;;; -*- Mode: Lisp -*-

;;; CLIM text style selection dialog. Call with:
;;;
;;;   (clim-user::select-text-style)
;;;
;;; It returns a CLIM text style

;;; Paolo Amoroso <amoroso@mclink.it> - July 24, 2005


;;; No dedicated package because it's a hack. However, it might one day be part
;;; of a collection of portable CLIM utilities...

(in-package :clim-user)


;;; Utilities

(defun familyp (family)
  (first (member family '(:fix :serif :sans-serif))))

(defun facep (face)
  (first (member face '(:roman :bold :italic (:bold :italic)) :test #'equal)))

(defun sizep (size)
  (or (first (member size '(:tiny :very-small :small :normal :large :very-large
                            :huge :larger :smaller)))
      (and (numberp size) size)))

(defun style-component-to-style-spec (component)
  "Return a text style specifier from one of its COMPONENTs.
E.g. if COMPONENT is `:roman', returns (nil :roman nil)."
  (list (familyp component) (facep component) (sizep component)))

(defun dismiss-dialog-callback (gadget)
  "Set frame's `dismiss-value' slot and dismiss dialog.
Assumes that the application frame has a `dismiss-value' slot and that the push
button has a meaningful ID, i.e. t for OK, nil for Cancel, and possibly other
application-specific values."
  (setf (dismiss-value *application-frame*) (gadget-id gadget))
  (frame-exit *application-frame*))


;;; Callbacks

;;; Value changed and activate callbacks have different lambda lists:
;;;
;;;   activate      : <gadget>
;;;   value changed : <gadget> <value>
;;;
;;; We use a single function for both callbacks by ignoring the <value> argument
;;; when not needed, and selecting the appropriate gadget ID based on the kind
;;; of gadget (radio box or push button)

(defun style-change-callback (gadget &optional (value nil providedp))
  (setf (sample-style *application-frame*)
        (merge-text-styles (style-component-to-style-spec (if providedp
                                                              (gadget-id value)
                                                              (gadget-id gadget)))
                           (sample-style *application-frame*)))
  (redisplay-frame-pane *application-frame*
                        (get-frame-pane *application-frame* 'sample)
                        :force-p t))

;;; FIXME: should handle real numbers for text style point sizes, not just
;;; integers. See `make-text-style' in the CLIM 2 specification

(defun points-callback (gadget)
  (let ((new-value (parse-integer (gadget-value gadget) :junk-allowed t)))
    (when (numberp new-value)
      (setf (sample-style *application-frame*)
            (merge-text-styles (style-component-to-style-spec new-value)
                               (sample-style *application-frame*)))
      (redisplay-frame-pane *application-frame*
                            (get-frame-pane *application-frame* 'sample)
                            :force-p t))))


;;; Application frame

(define-application-frame text-style-selection ()
  ((dismiss-value :initarg :dismiss-value :accessor dismiss-value :initform nil)
   (sample-style :initarg :sample-style :accessor sample-style
                 :initform (make-text-style :fix :roman :normal)))
  (:menu-bar nil)
  (:panes
   (family (with-radio-box (:orientation :vertical
                                         :value-changed-callback 'style-change-callback)
             (radio-box-current-selection
              (make-pane 'toggle-button :id :fix :label "Fix"))
             (make-pane 'toggle-button :id :serif :label "Serif")
             (make-pane 'toggle-button :id :sans-serif :label "Sans Serif")))
   (face (with-radio-box (:orientation :vertical
                                       :value-changed-callback 'style-change-callback)
           (radio-box-current-selection
            (make-pane 'toggle-button :id :roman :label "Roman"))
           (make-pane 'toggle-button :id :bold :label "Bold")
           (make-pane 'toggle-button :id :italic :label "Italic")
           (make-pane 'toggle-button :id '(:bold :italic) :label "Bold Italic")))
   (size (with-radio-box (:orientation :vertical
                                       :value-changed-callback 'style-change-callback)
           (make-pane 'toggle-button :id :tiny :label "Tiny")
           (make-pane 'toggle-button :id :very-small :label "Very small")
           (make-pane 'toggle-button :id :small :label "Small")
           (radio-box-current-selection
            (make-pane 'toggle-button :id :normal :label "Normal"))
           (make-pane 'toggle-button :id :large :label "Large")
           (make-pane 'toggle-button :id :very-large :label "Very large")
           (make-pane 'toggle-button :id :huge :label "Huge")))
   (smaller :push-button :id :smaller :label "Smaller"
            :activate-callback 'style-change-callback)
   (larger :push-button :id :larger :label "Larger"
           :activate-callback 'style-change-callback)
   ;; Incremental redisplay would be possible, but probably overkill
   (sample :application
           :display-function 'display-sample-text
           :display-time nil
           :text-style (sample-style *application-frame*)
           :width 400 :height 100
           :scroll-bars t
           :end-of-line-action :wrap)
   (points :text-field :value "10" :activate-callback 'points-callback)
   (ok-button :push-button :id t :label "  OK  "
              :activate-callback 'dismiss-dialog-callback)
   (cancel-button :push-button :id nil :label "Cancel"
                  :activate-callback 'dismiss-dialog-callback))
  (:layouts
   (default
       (labelling (:label "Select Text Style" :align-x :center
                          :text-style (make-text-style :sans-serif :roman :huge))
         (vertically (:equalize-width t)
           (horizontally ()
             +fill+
             (labelling (:label "Family" :align-x :center) family)
             (labelling (:label "Face" :align-x :center) face)
             (labelling (:label "Size" :align-x :center)
               (horizontally (:equalize-height t)
                 size 10 (vertically (:equalize-width t)
                           +fill+ smaller larger +fill+ points +fill+)))
             +fill+)
           10
           sample
           10
           (horizontally (:equalize-width t)
             +fill+ ok-button +fill+ cancel-button +fill+))))))

(defmethod display-sample-text ((frame text-style-selection) stream)
  (window-clear stream)
  (with-text-style (stream (sample-style *application-frame*))
    (write-string "This is some sample text" stream)))

;;; FIXME: at dialog startup, family/face/size gadgets should be updated based
;;; on the default style supplied by the caller. Currently, only the text sample
;;; is updated. Use a :before method on `run-frame-top-level'?

(defun select-text-style (&optional (default (make-text-style :fix :roman :normal)))
  "Return a text style interactively selected by the user, nil otherwise."
  (let ((frame (make-application-frame 'text-style-selection
                                       :sample-style default
                                       ;; If you don't use a CLIM implementation
                                       ;; compatible with Franz's or McCLIM, you
                                       ;; may need to remove the following
                                       ;; argument. It's required to properly
                                       ;; refresh the calling frame while the
                                       ;; dialog is open
                                       :calling-frame *application-frame*)))
    (run-frame-top-level frame)
    (when (dismiss-value frame)
      (sample-style frame))))