home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1991: Code Warrior / bincue / Code Warrior.bin / Development Platforms (Moof!) / LISP Related / Goal-Plan-Code Editor / library / ken-objects.lisp < prev    next >
Encoding:
Text File  |  1990-07-06  |  18.1 KB  |  433 lines  |  [TEXT/CCL ]
  1.  
  2. ;=====================================================================
  3. ; 
  4. ;  GPC Editor
  5. ;
  6. ;  Name: ken-objects.lisp
  7. ;  
  8. ;  Various objects used in the GPC Editor.
  9. ;
  10. ;---------------------------------------------------------------------
  11. ; Date        Name  Comments   
  12. ;---------------------------------------------------------------------
  13. ; 10/13/88    lhh   Initial Documentation
  14. ;=====================================================================
  15.  
  16. ;;; load this file into the objects available for the system. 
  17. ;;; ???
  18. ;;; Why is the statement 'in-package' needed
  19. ;;;???
  20.  
  21. (provide "ken-objects")
  22. (in-package "ken-objects")
  23.  
  24. ;;; Shadow nothing.
  25. (export '(*alist-dialog-item* cell-contents full-cell-contents value-cell-contents
  26.           *pane* *paned-window* 
  27.           *selection-dialog* ))
  28.  
  29. ;;; Require nothing.
  30. (use 'ccl)
  31. ;;; Import nothing.
  32.  
  33.  
  34. ;;;;****************************************************************************
  35. ;;;; The Actual Contents
  36. ;;;;****************************************************************************
  37.  
  38. ;;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  39. ;;;; *alist-dialog-item*
  40. ;;;; A kind of *sequence-dialog-item* that supports displaying alists.
  41. ;;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  42.  
  43. (defobject *alist-dialog-item* *sequence-dialog-item*)
  44.  
  45. (defobfun (cell-contents *alist-dialog-item*) (cell)
  46.    (car (usual-cell-contents cell)))
  47.  
  48. (defobfun (full-cell-contents *alist-dialog-item*) (cell)
  49.   (elt (table-sequence) (cell-to-index cell)))
  50.  
  51. (defobfun (value-cell-contents *alist-dialog-item*) (cell)
  52.   (cdr (full-cell-contents cell)))
  53.  
  54. #| 11/13/87 unfinished
  55. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  56. ;+++ *size-it-window* - UNFINISHED AS OF 11/13/87
  57. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  58. #|
  59. size-it-window is a subclass of *window* which allows the user to size and
  60. position the window on creation (NOT appearance) with the mouse.  When asked
  61. to exist if
  62.    option-key is depressed             then use user mouse input to position
  63.                                        and size the window
  64.    command-key is depressed            then use user mouse input to position
  65.                                        and size the window and store these
  66.                                        globally for this class of window
  67. otherwise if
  68.    size and/or position is given       use these
  69. otherwise if
  70.    global defaults (see command-key)   use these
  71.       for this class are given
  72. otherwise                              use *window* defaults
  73.  
  74. The work of maintaining the global list of defaults is done by function exist.
  75. |#
  76.  
  77. (setq *size-it-defaults* '())
  78.  
  79. (defobject *size-it-window* *window*)
  80.  
  81. (defobfun (exist *size-it-window*) (&rest init-list)
  82.   (let* ((window-type (getf init-list :window-type :document))
  83.          (given-pos (getf init-list :window-pos '()))
  84.          (given-size (getf init-list :window-size '()))
  85.          (class-defaults (assoc (ask (car (object-parents (self))) object-name) 
  86.                                 *size-it-defaults*))
  87.          (global-defaults '(#@(6 44) #@(502 150)))
  88.          (defaults (list (cond (given-pos)
  89.                                ((car class-defaults))
  90.                                (t (car global-defaults)))
  91.                          (cond (given-size)
  92.                                ((cadr class-defaults))
  93.                                (t (cadr global-defaults)))))
  94.          (settings (cond ((option-key-p) (get-settings defaults window-type))
  95.                          ((command-key-p) (set-class-defaults
  96.                                            (get-settings defaults window-type)))
  97.                          (t defaults))))
  98.     (usual-exist
  99.      (init-list-default init-list 
  100.                         :window-position (car settings)
  101.                         :window-size (cadr settings)))))
  102.  
  103. (defobfun (get-settings *size-it-window*) (defaults window-type)
  104.   (with-cursor 2
  105.     (let ((default-pos (car defaults))
  106.           (default-size (cadr defaults))
  107.           (start (loop (when (mouse-down-p)
  108.                          (return (local-to-global 
  109.                                   (ask (front-window) 
  110.                                     (window-mouse-position)))))))
  111.           (end (loop (when (not (mouse-down-p)) 
  112.                        (return (local-to-global
  113.                                 (ask (front-window) 
  114.                                   (window-mouse-position))))))))
  115.       (if (double-click-spacing-p start end)
  116.         (adjust-window-settings (list (start default-size))
  117.                                 window-type)
  118.         (adjust-window-settings (list (start (subtract-points end start)))
  119.                                 window-type)))))
  120.  
  121. (setq w (oneof *size-it-window*))
  122. |# 11/13/87 unfinished
  123.  
  124.  
  125. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  126. ;+++ *paned-window*
  127. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  128. #|
  129. Paned windows organize a set of windows so that all may be activated, deactivated,
  130. selected, and closed at once.  Panes can be any window object but :document-with-
  131. grow and :document-with-zoom, since changing the size of a pane is not yet
  132. supported.  Also, overlapping of panes is not checked yet either, so WATCH OUT!
  133.  
  134. |#
  135.  
  136. (defobject *pane* *window*)
  137. (defobfun (exist *pane*) (init-list)
  138.   (declare (special *paned-window*))
  139.   (let ((my-window (getf init-list :my-window nil))
  140.         (window-type (getf init-list :window-type :document)))
  141.     (cond ((equal window-type :document-with-zoom)
  142.            (error "Panes may not be of type :document-with-zoom."))
  143.           ((equal window-type :document-with-grow)
  144.            (error "Panes may not be of type :document-with-grow."))
  145.           ((and my-window (not (typep my-window *paned-window*)))
  146.            (error ":my-window ~a must be a *paned-window*." my-window))
  147.           (t (have 'my-window my-window)
  148.              (usual-exist 
  149.               (init-list-default init-list
  150.                                  :window-show nil))))))
  151. (defobfun (window-select-event-handler *pane*) ()
  152.   (if (null my-window)
  153.     (usual-window-select-event-handler)
  154.     (ask my-window (window-select-event-handler))))
  155. (defobfun (window-close *pane*) ()
  156.   (if (null my-window)
  157.     (usual-window-close)
  158.     (ask my-window (window-close))))
  159. (defobfun (window-deactivate-event-handler *pane*) ()
  160.   (if (null my-window)
  161.     (usual-window-deactivate-event-handler)
  162.     (ask my-window (window-deactivate-event-handler))))
  163. (defobfun (window-activate-event-handler *pane*) ()
  164.   (if (null my-window)
  165.     (usual-window-activate-event-handler)
  166.     (ask my-window (window-activate-event-handler))))
  167.           
  168.  
  169. (defobject *paned-window* *window*)
  170. (defobfun (exist *paned-window*) (init-list)
  171.   (declare (special *pane*))
  172.   (let ((panes (getf init-list :panes '())))
  173.     (have 'panes (cond
  174.                   ((null panes) '())
  175.                   ((notevery #'(lambda (thing) (typep thing *pane*)) panes)
  176.                    (error "All panes must inherit from ~a." *pane*))
  177.                   (t (muliple-value-bind 
  178.                       (check msg)
  179.                       (ok-regions-p 
  180.                        (mapcar #'(lambda (p)
  181.                                    (ask p
  182.                                      (unless (ownp 'wptr)
  183.                                        (exist))))
  184.                                panes))
  185.                       (if check panes (error msg))))))
  186.     (usual-exist 
  187.      (init-list-default init-list
  188.                         :window-show nil))))
  189. (defobfun (add-panes *paned-window*) (&rest the-panes)
  190.   (declare (special *pane*))
  191.   (let ((w (self)))
  192.     (if (and (mapc #'(lambda (p) (typep p *pane*)) the-panes)
  193.              (ok-regions-p (append (mapcar #'(lambda (p)
  194.                                                (ask p
  195.                                                  (unless (ownp 'wptr)
  196.                                                    (exist))))
  197.                                            the-panes) 
  198.                                    panes)))
  199.       (mapcar #'(lambda (p) 
  200.                   (ask p (setf my-window w))
  201.                   (ask w (pushnew p panes)))
  202.               the-panes)
  203.       (error "All panes, even ~a, must inherit from ~a."
  204.              p
  205.              *pane*))))
  206.  
  207.  
  208. ;;; window-select-event-handler shadows the default handler, which would
  209. ;;;   deactivate all the panes.  This version activates all the panes and
  210. ;;;   moves them as a block to the front of the window list.
  211. ;
  212. (defobfun (window-select-event-handler *paned-window*) ()
  213.   (unless (find (front-window) panes)
  214.     (ask (front-window) (window-deactivate-event-handler))
  215.     (window-activate-event-handler)))
  216.  
  217. ;;; window-activate-event-handler shadows the default handler, which would
  218. ;;;   ignore the window panes.  This version activates all panes as well.
  219. ;
  220. (defobfun (window-activate-event-handler *paned-window*) ()
  221.   (do ((counter 0 (1+ counter)))
  222.       ((= (length panes) counter) 
  223.        (progn
  224.          (_hilitewindow :ptr wptr :word #xFFFF)
  225.          (usual-window-activate-event-handler)))
  226.     (ask (nth counter panes)
  227.       (_hilitewindow :ptr wptr :word #xFFFF)
  228.       (usual-window-activate-event-handler)
  229.       (set-window-layer counter))))
  230.  
  231. ;;; window-deactivate-event-handler shadows the default handler, which would
  232. ;;;   ignore the window panes.  This version deactivates all panes as well.
  233. ;
  234. (defobfun (window-deactivate-event-handler *paned-window*) ()
  235.   (do ((counter (length panes) (1- counter)))
  236.       ((= 0 counter) (usual-window-deactivate-event-handler))
  237.     (ask (nth counter panes)
  238.       (usual-window-deactivate-event-handler))))
  239.  
  240. ;;; window-close shadows the default window-close, which would
  241. ;;;   ignore the window panes.  This version closes all panes as well.
  242. ;
  243. (defobfun (window-close *paned-window*) ()
  244.   (do ((counter (length panes) (1- counter)))
  245.       ((= 0 counter) (usual-window-close))
  246.     (ask (nth counter panes)
  247.       (usual-window-close))))
  248.  
  249. ;;; make-paned-window takes a window and a list of panes.  It remakes (if nec.)
  250. ;;;   the window as a *paned-window* with the given list of panes (also remade
  251. ;;;   as *pane*'s, if nec.) as its panes, checking that the rectangles of all
  252. ;;;   of the panes do not overlap, and the union of all the rectangles lies
  253. ;;;   within the window's content region.
  254. ;
  255. (defobfun (ok-regions-p *window*) (panes)
  256.   (let ((scratch-region (new-region))
  257.         (the-union (new-region)))
  258.     (set-empty-region the-union)
  259.     (do ((counter (1- (length panes)) (1- counter)))
  260.         ((= -1 counter) 
  261.          (if (empty-region-p
  262.               (difference-region the-union
  263.                                  (rref wptr window.contrgn)
  264.                                  scratch-region))
  265.            (progn
  266.              (dispose-region scratch-region)
  267.              (dispose-region the-union)
  268.              (values t nil)
  269.            (progn
  270.              (dispose-region scratch-region)
  271.              (dispose-region the-union)
  272.              (values nil
  273.                      (format nil 
  274.                              "The panes must all be within ~a's content region." 
  275.                              (self)))))))
  276.       (ask (nth counter panes)
  277.         (if (not 
  278.              (empty-region-p 
  279.               (intersect-region the-union 
  280.                                 (rref wptr window.strucrgn) 
  281.                                 scratch-region)))
  282.           (progn
  283.            (dispose-region scratch-region)
  284.            (dispose-region the-union)
  285.            (values nil "The panes may not overlap."))
  286.           (copy-region 
  287.            (union-region the-union 
  288.                          (rref wptr window.strucrgn)
  289.                          scratch-region)
  290.            the-union))))))
  291.  
  292. (defun make-paned-window (window &rest panes)
  293.   (declare (special *paned-window*))
  294.   (when (ask window (ok-regions-p panes))
  295.     (ask
  296.       (unless (typep window *paned-window*)
  297.         (apply #'remake-object window
  298.                *paned-window* 
  299.                (object-parents window)))
  300.       (have 'panes
  301.             (mapcar #'(lambda (w) (make-pane w window)) panes)))
  302.     window))
  303.           
  304.  
  305. #|
  306. *selection-dialog*
  307.  
  308. Selection dialogs contain a prompt, a table, an ok-button, and a cancel-button.
  309.  
  310. The function GET-SELECTION is used to create selection dialogs.  The user makes 
  311. a selection in the table and presses either button.  If ok-button is pressed, 
  312. then the selection is returned.  If cancel-button is pressed, then :cancel is 
  313. returned.
  314.  
  315. Selection dialogs are always modal.  Therefore, if cancel-button is pressed,
  316. a throw to :cancel will be made, with :cancel returned.  Unless GET-SELECTION
  317. is called from withing a catch form, the throw will continue to the Listener.
  318.  
  319. GET-SELECTION accepts any even number of arguments.  The arguments should
  320. alternate between keywords and values (like the argument to oneof).  GET-
  321. SELECTION accepts the standard window init-list options, but you usually
  322. need supply only :window-title.  In addition, GET-SELECTION accepts the
  323. following pseudo-keyword arguments:
  324.  
  325. :prompt             The prompt string to display in the dialog.
  326.  
  327. :item-list          A list of items to display in the dialog.
  328.  
  329. :table-height       The height of the selection table defaults to 4
  330.                     unless this keyword and value are given.  The value
  331.                     should be an integer number of CELLS.
  332.  
  333. :dialog-width       The width of the dialog is not computed automatically.
  334.                     The default width is 200 pixels.  Specify a different 
  335.                     width using :dialog-width.  It should be an integer 
  336.                     number of PIXELS.
  337.  
  338. :position           The upper right corner of the dialog defaults to #@(100 50).
  339.                     unless this keyword and value are given.  The value
  340.                     should be a POINT, ie of the form #@(... ...).
  341.  
  342. :|#
  343.  
  344. (defobject *selection-dialog* *dialog*)
  345.  
  346. (defobfun (exist *selection-dialog*) (&rest init-list)
  347.   (declare (special *screen-height* *screen-width*)
  348.            (special *button-dialog-item* *sequence-dialog-item*
  349.                     *static-text-dialog-item*))
  350.   (let* ((item-list (getf init-list :item-list ()))
  351.          (list-length (length item-list))
  352.          (table-height (* 16 (min (- *screen-height* 122)
  353.                                   (getf init-list :table-height 4))))
  354.          (dialog-height (+ 56 table-height))
  355.          (dialog-width (max 150 (getf init-list :dialog-width 150)))
  356.          (dialog-position (getf init-list :position #@(100 50)))
  357.          (prompt (getf init-list :prompt "Select one and press OK:"))
  358.          (the-prompt (oneof *static-text-dialog-item*
  359.                             :dialog-item-position #@(1 1) 
  360.                             :dialog-item-text prompt))
  361.          (ok-button (oneof *button-dialog-item*
  362.                            :dialog-item-position (make-point 
  363.                                                   (- dialog-width 39)
  364.                                                   (- dialog-height 20))
  365.                            :dialog-item-text " OK "
  366.                            :dialog-item-enabled-p nil))
  367.          (the-table (oneof *sequence-dialog-item*
  368.                            :dialog-item-position #@(1 19) 
  369.                            :table-sequence item-list
  370.                            :table-vscrollp t
  371.                            :table-hscrollp nil
  372.                            :dialog-item-size (make-point 
  373.                                               (- dialog-width 2)
  374.                                               table-height)
  375.                            :cell-size (make-point
  376.                                        (- dialog-width 19)
  377.                                        16)
  378.                            :dialog-item-action
  379.                            (nfunction
  380.                             dialog-item-action
  381.                             (lambda ()
  382.                               (ask ok-button 
  383.                                 (unless (dialog-item-enabled-p)
  384.                                   (dialog-item-enable)))
  385.                               (ask my-dialog (set-default-button ok-button))
  386.                               (usual-dialog-item-action)))))
  387.          (cancel-button (oneof *button-dialog-item*
  388.                                :dialog-item-position (make-point 
  389.                                                       4 
  390.                                                       (- dialog-height 20))
  391.                                :dialog-item-text " Cancel "
  392.                                :dialog-item-action 
  393.                                (nfunction
  394.                                 dialog-item-action
  395.                                 (lambda ()
  396.                                   (usual-dialog-item-action)
  397.                                   (return-from-modal-dialog :cancel))))))
  398.     (ask ok-button (fhave 'dialog-item-action
  399.                           (nfunction 
  400.                            dialog-item-action
  401.                            (lambda ()
  402.                              (usual-dialog-item-action)
  403.                              (return-from-modal-dialog
  404.                               (ask the-table 
  405.                                 (cell-contents (car (selected-cells)))))))))
  406.     (usual-exist
  407.      (init-list-default init-list
  408.                         :window-type :double-edge-box
  409.                         :window-size (make-point dialog-width dialog-height)
  410.                         :window-position dialog-position 
  411.                         :window-show t
  412.                         :window-title (getf init-list
  413.                                             :window-title "Select")
  414.                         :dialog-items (list the-table the-prompt cancel-button
  415.                                             ok-button)))))
  416.  
  417. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  418. ;+++ get-object-descendants
  419. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  420. ;
  421. ; This function recursively finds the descendants of its argument.
  422. ; Of course it only works for hierarchies created using defobject.
  423. ;
  424. (defun get-object-descendants (thing)
  425.   (let ((kids (ask thing object-children)))
  426.     (when kids
  427.       (nconc (mapcar '(lambda (thing)
  428.                          (ask thing object-name))
  429.                       kids)
  430.               (apply #'nconc
  431.                      (mapcar #'get-object-descendants
  432.                              kids))))))
  433.