home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Environments / AllegroCL11 / Library / pop-up-dialogs.Lisp < prev    next >
Encoding:
Text File  |  1987-10-27  |  8.6 KB  |  201 lines  |  [TEXT/CCL ]
  1. #|
  2. pop-up dialogs
  3.  
  4. copyright © 1987 Coral Software Corp.
  5.  
  6. this file creates a new class of dialog objects which can be used for easily
  7. popping up options in front of the user.  It illustrates Dialogs, objects,
  8. the init-list-default function, and the nfunction special form.
  9.  
  10. pop-up dialogs contain a single table.  When the user clicks in a the table,
  11. an action is run.  pop-up dialog can be modal or modeless.
  12.  
  13. The function POP-UP is used to create pop-up dialogs.
  14.  
  15. POP-UP accepts any even number of arguments.  The arguments should alternate
  16. between keywords and values (like the argument to oneof).  POP-UP accepts the
  17. standard window init-list options, but you usually don't need to supply these
  18. (except perhaps for :window-title).  In addition, POP-UP accepts the following
  19. pseudo-keyword arguments:
  20.  
  21. :item-list           A list of items to display in the pop-up dialog.
  22.  
  23. :dispatch-function   The action to call when the user clicks on a cell
  24.  
  25.                      If :dispatch-function is a function, it will be funcalled
  26.                      with the contents of the clicked cell as the argument.
  27.  
  28.                      If :dispatch-function is the keyword :ask-item, then
  29.                      each item can have its own action.  The :item-list must be
  30.                      an alist.  The car of each pair will be displayed
  31.                      in the table.  The cdr of each pair should be a function
  32.                      or form.  This function or form provides the action for
  33.                      the corresponding item.  If it is a function
  34.                      it will be funcalled (with no arguments).  If it is not a
  35.                      function, it will be eval'ed.  You only need to use the
  36.                      :ask-item option when each item does something very
  37.                      different.
  38.  
  39. :modal               If :modal is non-nil (the default), then POP-UP displays
  40.                      the dialog as a modal dialog.  After the user clicks, the
  41.                      return-from-modal-dialog is called.  The value returned by
  42.                      the action is returned by the call to POP-UP.
  43.  
  44.                      If :modal is nil, POP-UP simply displays the dialog window
  45.                      as a modeless dialog.  The dialog will remain visible, even
  46.                      after the user clicks.
  47.  
  48. :table-width         The height of a pop-up dialog is computed automatically.
  49.                      The width, however, will always be the same unless it is
  50.                      specified by the user.  This is because calculating the
  51.                      width can be very computationally intensive.  If the user
  52.                      wishes to specify a non-default width, :table-width may
  53.                      be given.  It should be an integer giving a number of
  54.                      pixels.
  55. |#
  56.  
  57.  
  58. ;;make a sub-class of sequence-dialog-items used for displaying a-lists
  59. (defobject *alist-dialog-item* *sequence-dialog-item*)
  60.  
  61. (defobfun (cell-contents *alist-dialog-item*) (cell)
  62.    (car (usual-cell-contents cell)))
  63.  
  64. (defobfun (full-cell-contents *alist-dialog-item*) (cell)
  65.   (elt (table-sequence) (cell-to-index cell)))
  66.  
  67. (defobfun (value-cell-contents *alist-dialog-item*) (cell)
  68.   (cdr (full-cell-contents cell)))
  69.  
  70.  
  71. ;here's the class of pop-up dialogs
  72. (defobject *pop-up-dialog* *dialog*)
  73.  
  74. ;this is where most of the work is done
  75. (defobfun (exist *pop-up-dialog*) (init-list)
  76.   (let* ((item-list (getf init-list :item-list ()))
  77.          (list-length (length item-list))
  78.          (table-height (min (- *screen-height* 75)
  79.                             (* 18 list-length)))
  80.          (table-width (getf init-list :table-width 120))
  81.          (dispatch-function (getf init-list :dispatch-function ()))
  82.          (modal-p (getf init-list :modal t))
  83.          (the-table (oneof (if (eq dispatch-function :ask-item)
  84.                              *alist-dialog-item*
  85.                              *sequence-dialog-item*)
  86.                            :dialog-item-size (make-point table-width
  87.                                                          table-height)
  88.                            :dialog-item-position #@(2 2)
  89.                            :cell-size (make-point (- table-width 15)
  90.                                                   16)
  91.                            :table-sequence item-list
  92.                            :table-hscrollp nil
  93.                            :table-dimensions (make-point 1 list-length)
  94.                            :dialog-item-action
  95.                            (if (eq dispatch-function :ask-item)
  96.                              ;we use nfunction so that we can call usual
  97.                              (nfunction
  98.                               dialog-item-action
  99.                               (lambda ()
  100.                                 (when (selected-cells)
  101.                                   (let*
  102.                                     ((the-cell (car (selected-cells)))
  103.                                      (the-action (value-cell-contents the-cell))
  104.                                      (returned-value
  105.                                       (if (functionp the-action)
  106.                                         (funcall the-action)
  107.                                         (eval the-action))))
  108.                                     (if modal-p
  109.                                       (return-from-modal-dialog returned-value)
  110.                                       (usual-dialog-item-action))))))
  111.                              (nfunction
  112.                               dialog-item-action
  113.                               (lambda ()
  114.                                 (when (selected-cells)
  115.                                   (let*
  116.                                     ((returned-value
  117.                                       (funcall dispatch-function
  118.                                                (cell-contents
  119.                                                 (car (selected-cells))))))
  120.                                     (if modal-p
  121.                                       (return-from-modal-dialog returned-value)
  122.                                       (usual-dialog-item-action))))))))))
  123.     (usual-exist
  124.      (init-list-default init-list
  125.                         :window-type (if modal-p :double-edge-box
  126.                                          :document)
  127.                         :window-size (make-point (+ 5 table-width)
  128.                                                  (+ 10 table-height))
  129.                         :window-position #@(350 40)
  130.                         :window-show nil
  131.                         :window-title (getf init-list
  132.                                             :window-title "Pop Up")
  133.                         :dialog-items (list the-table)))))
  134.  
  135.  
  136. (defun pop-up (&rest args)
  137.   (let ((the-pop-up
  138.          (apply #'oneof *pop-up-dialog* args)))
  139.     (if (getf args :modal t)
  140.       (modal-dialog the-pop-up)
  141.       (ask the-pop-up (window-show)))))
  142.  
  143.  
  144. (provide 'pop-up-dialogs)
  145. (pushnew :pop-up-dialogs *features*)
  146.  
  147.  
  148. #|
  149. example calls to POP-UP
  150.  
  151.  
  152. (pop-up :item-list '(1 2 3 4 5 1 2 3 4 5
  153.                      1 2 3 1 2 3 1 2 3 1
  154.                      3 2 1 3 2 1 1 2 3 1)
  155.         :table-width 50
  156.         :dispatch-function #'(lambda (n)
  157.                                (dotimes (x n)
  158.                                  (ed-beep))
  159.                                n))
  160.  
  161. (pop-up :item-list '(1 2 3 4 5 6 7 8 9 10)
  162.         :modal nil
  163.         :window-title "peep"
  164.         :dispatch-function #'(lambda (n)
  165.                                (dotimes (x n)
  166.                                  (ed-beep))
  167.                                n))
  168.  
  169. (pop-up :item-list '("abc" "def" "ghi" "jkl" "mno" "pqr" "stu" "vwx" "yza")
  170.         :dispatch-function #'(lambda (a-string)
  171.                                (print a-string))
  172.         :window-title "Print String"
  173.         :modal nil)
  174.  
  175.  
  176. (pop-up :item-list '(1 'two "three" (4) 5 6 7 8)
  177.         :dispatch-function #'(lambda (form)
  178.                                (inspect form))
  179.         :window-title "Inspect"
  180.         :modal nil)
  181.  
  182.  
  183. (pop-up :item-list '(("Beep" . (ed-beep))
  184.                      ("Beep Twice" . (progn (ed-beep) (ed-beep)))
  185.                      ("Say Hello" . (print "Hello"))
  186.                      ("Emacs Mode Off" . (setq *emacs-mode* nil)))
  187.         :table-width 150
  188.         :dispatch-function :ask-item)
  189.  
  190.  
  191. (pop-up :item-list `(("Beep" . ed-beep)
  192.                      ("Beep Twice" . ,#'(lambda () (ed-beep) (ed-beep)))
  193.                      ("Inspect Type-in" . ,#'(lambda ()
  194.                                               (inspect
  195.                                                (read-from-string
  196.                                                 (get-string-from-user
  197.                                                  "Type in for inspect"))))))
  198.         :dispatch-function :ask-item
  199.         :modal nil
  200.         :table-width 140)
  201. |#