home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Environments / AllegroCL11 / Library / icon-dialog-items.lisp < prev    next >
Encoding:
Text File  |  1987-10-27  |  8.3 KB  |  236 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;icons-dialog-items.lisp
  3. ;;copyright 1987 Coral Software Corp.
  4. ;;
  5. ;;
  6. ;;  this file defines icon-dialog-items which work like buttons.
  7. ;;  it is written to run in Allegro CL 1.1
  8. ;;
  9. ;;
  10.  
  11.  
  12. (eval-when (eval compile)
  13.   (require 'traps))
  14.  
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. ;;
  18. ;;first a couple of functions for reading icons from resources
  19. ;;  displaying them in a window
  20. ;;
  21.  
  22.  
  23.  
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. ;;get-icon
  26. ;;
  27. ;;given an the number of an icon resource, it attempts to permanently load
  28. ;; the icon.  If it succeeds, it returns the icon, otherwise it returns nil.
  29. ;;
  30.  
  31. (defun get-icon (icon-number)
  32.   (without-interrupts
  33.    (let ((icon-holder (_geticon :word icon-number :ptr)))
  34.                                              ;try to get the icon
  35.     (and icon-holder                         ;if we got it
  36.          (_detachresource :ptr icon-holder)) ;make it unpurgeable
  37.      icon-holder)))                          ;and return it
  38.  
  39.  
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41. ;;plot-icon
  42. ;;
  43. ;;an object function defined for windows
  44. ;;
  45. ;;given an icon and a point, it draws the icon at that point
  46. ;;
  47. ;;icons are always drawn at the standard 32 by 32 size, though the
  48. ;;  the toolbox allow scaling to arbitrary sizes.
  49. ;;
  50.  
  51. (defobfun (plot-icon *window*) (icon point)
  52.   (declare (object-variable wptr))
  53.   (let ((rtop (point-v point)) (rleft (point-h point)))
  54.     (without-interrupts
  55.      (with-port wptr
  56.        (rlet ((r rect                         ;allocate a rectangle
  57.                  :top rtop
  58.                  :left rleft
  59.                  :bottom (+ rtop 32)
  60.                  :right (+ rleft 32)))
  61.          (_ploticon :ptr r :ptr icon))))))
  62.  
  63.  
  64. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65. ;;
  66. ;;read in the three icons from system file and bind them to global variables.
  67. ;;
  68.  
  69. (defvar *stop-icon* (get-icon 0))
  70. (defvar *note-icon* (get-icon 1))
  71. (defvar *warn-icon* (get-icon 2))
  72.  
  73.  
  74. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76. ;;
  77. ;;*icon-dialog-item*
  78. ;;
  79. ;;here we define the icon-dialog-item-class
  80. ;;
  81.  
  82.  
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84. ;;
  85. ;;*icon-dialog-item*
  86. ;;
  87. ;;the new class inherits from *user-dialog-item*
  88. ;;
  89. ;;
  90.  
  91. (defobject *icon-dialog-item* *user-dialog-item*)
  92.  
  93.  
  94. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  95. ;;
  96. ;;exist
  97. ;;
  98. ;;an added init-list option :icon allows the caller specify which icon to use.
  99. ;;  the default is to use the note icon
  100. ;;
  101. ;;the size of the item is always 32 by 32
  102. ;;
  103.  
  104. (defobfun (exist *icon-dialog-item*) (init-list)
  105.   (have 'my-icon (getf init-list :icon *note-icon*))
  106.                                              ;get the icon from the init-list
  107.                                              ; or use the default
  108.   (usual-exist
  109.    (init-list-default init-list              ;usual-exist with default size
  110.                       :dialog-item-size #@(32 32))))
  111.  
  112. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  113. ;;
  114. ;;dialog-item-draw
  115. ;;
  116. ;;this is the function called by the system whenever it needs to draw the item
  117. ;;
  118. ;;
  119.  
  120. (defobfun (dialog-item-draw *icon-dialog-item*) ()
  121.   (declare (object-variable my-icon my-dialog))
  122.   (let* ((icon my-icon)                      ;rebind some instance variables
  123.          (pos (dialog-item-position)))       ; to lexical variables so they
  124.                                              ; can be passed to another object.
  125.     (ask my-dialog (plot-icon icon pos))))   ;ask the owning dialog window
  126.                                              ;to plot the icon.
  127.  
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129. ;;
  130. ;;dialog-item-click-event-handler
  131. ;;
  132. ;;  <<will be exported in release 1.1>>
  133. ;;
  134. ;;  this function is called whenever the user clicks in the dialog item.  It
  135. ;;  is called on mouse-down, not on mouse-up.
  136. ;;
  137. ;;  the version defined below tracks the mouse, inverting the icon as long
  138. ;;  as the mouse is over it.  If the user releases the mouse-button while the
  139. ;;  the mouse is over the icon, the icon's dialog-item-action is called.
  140. ;;
  141. ;;
  142.  
  143. (defobfun (dialog-item-click-event-handler *icon-dialog-item*) (where)
  144.   (declare (object-variable my-dialog wptr)
  145.            (ignore where))
  146.   (let* ((pos (dialog-item-position))        ;position of the item
  147.          (mtop (point-v pos))                ;the four rectangle
  148.          (mleft (point-h pos))               ;  coordinates of the
  149.          (mbottom (+ mtop 32))               ;  item
  150.          (mright (+ mleft 32))               ;
  151.          (inverted-p nil)                    ;used to track whether the icon
  152.                                              ;  is inverted. will only be true
  153.                                              ;  when the mouse is over the icon
  154.          (item (self)))                      ;the icon object.
  155.     (ask my-dialog                           ;the dialog does all the tracking.
  156.       (with-port wptr                        ;draw in the dialog's grafport.
  157.         (rlet ((temp-rect rect               ;temporarily allocate a rectangle
  158.                           :top mtop          ;
  159.                           :left mleft        ;
  160.                           :bottom mbottom    ;
  161.                           :right mright))    ;
  162.           (without-interrupts                ;without interrupts for speed.
  163.            (_inverrect :ptr temp-rect)       ;initially invert the icon.
  164.            (setq inverted-p t)               ;
  165.              (loop                           ;loop until the button is released
  166.                (unless (mouse-down-p)        ;
  167.                  (when inverted-p            ;if button released with mouse
  168.                                              ;  over the icon, run the action
  169.                    (ask item (dialog-item-action)))
  170.                  (return-from dialog-item-click-event-handler))
  171.                (if (logbitp 8 (_PtInRect     ;
  172.                                :long (window-mouse-position)
  173.                                :ptr temp-rect
  174.                                :word))       ;is mouse over the icon's rect?
  175.                    (unless inverted-p        ;yes, make sure it's inverted.
  176.                      (_inverrect :ptr temp-rect)
  177.                      (setq inverted-p t))    ;
  178.                    (when inverted-p          ;no, make sure it's not inverted.
  179.                      (_inverrect :ptr temp-rect)
  180.                      (setq inverted-p nil))))))))))
  181.  
  182.  
  183. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  184. ;;
  185. ;;dialog-item-action
  186. ;;
  187. ;;  when the user releases the mouse with the cursor over the icon,
  188. ;;  dialog-item-click-event-handler leaves the icon high-lighted and calls
  189. ;;  dialog-item-action.  For this reason, the usual-dialog-item-action
  190. ;;  redraws the icon to un-invert it.
  191. ;;
  192.  
  193. (defobfun (dialog-item-action *icon-dialog-item*) ()
  194.   (dialog-item-draw))
  195.  
  196.  
  197. (provide 'icon-dialog-items)
  198. (pushnew :icon-dialog-items *features*)
  199.  
  200.  
  201. #|
  202. ;;a sample call
  203.  
  204. (oneof *dialog*
  205.        :window-size #@(115 43)
  206.        :window-title "Icons"
  207.        :window-position #@(150 125)
  208.        :window-type :document
  209.        :dialog-items
  210.        (list
  211.         (oneof *icon-dialog-item*
  212.                :dialog-item-action '(progn
  213.                                       (print "please note")
  214.                                       (ed-beep)
  215.                                       (usual-dialog-item-action)))
  216.         (oneof *icon-dialog-item*
  217.                :icon *stop-icon*
  218.                :dialog-item-action '(progn
  219.                                       (print "please stop")
  220.                                       (ed-beep)
  221.                                       (ed-beep)
  222.                                       (usual-dialog-item-action)))
  223.         (oneof *icon-dialog-item*
  224.                :icon *warn-icon*
  225.                :dialog-item-action '(progn
  226.                                       (print "warning!  warning!"
  227.                                              *error-output*)
  228.                                       (ed-beep)
  229.                                       (ed-beep)
  230.                                       (ed-beep)
  231.                                       (usual-dialog-item-action)))))
  232.  
  233.  
  234.  
  235. |#
  236.