[mcclim-devel] Poor man's CLIM text style selection dialog

[Paolo Amoroso]

As a CLIM learning exercise, and as a way of finally contributing back
something even remotely useful to the CLIM community, I have written
the attached text style selection dialog.  I have tested it with
McCLIM and CMUCL under Linux, but it should work with little or no
modification with other CLIM implementations.

The dialog provides the same features of the CLIM text style model.
See for example make-text-style in the specification.

To invoke the dialog, just compile the file and evaluate:

  (clim-user::select-text-style)

from a listener, or call it from your own code.  When you click on
"OK", the function returns a CLIM text style object, nil otherwise.

The usage of the dialog should be straightforward, except for a couple
of issues.  When you enter a numeric text size in the appropriate
field (try 2 or 60 for fun), hit ENTER to update the sample text.  The
family/face/size gadgets are not updated.

See the code for additional information or issues.  The main problem
is that I shouldn't have written it in the first place: CLIM provides
the powerful accepting-values macro for creating dialogs.  McCLIM,
however, supports only part of its functionality and can be used in
simple cases.  The bottom line is that my code is an example of how to
fake a value-returning modal dialog, provides an interim solution, and
gives an appreciation of the power and complexity of accepting-values.


Paolo
-- 
Lisp Propulsion Laboratory log - http://www.paoloamoroso.it/log

-------------- next part --------------
;;; -*- Mode: Lisp -*-

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

;;; Paolo Amoroso <amoroso at 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))))