/[mcclim]/mcclim/menu.lisp
ViewVC logotype

Diff of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.31 by moore, Thu May 27 08:46:41 2004 UTC revision 1.32 by hefner1, Mon Oct 18 06:24:57 2004 UTC
# Line 125  Line 125 
125           (command-table-name (slot-value sub-menu 'command-table))           (command-table-name (slot-value sub-menu 'command-table))
126           (items (mapcar #'(lambda (item)           (items (mapcar #'(lambda (item)
127                              (make-menu-button-from-menu-item                              (make-menu-button-from-menu-item
128                               item client :command-table command-table-name))                               item client :command-table command-table-name :vertical t))
129                          (slot-value (find-command-table command-table-name)                          (slot-value (find-command-table command-table-name)
130                                      'menu)))                                      'menu)))
131           (rack (make-pane-1 manager frame 'vrack-pane           (rack (make-pane-1 manager frame 'vrack-pane
# Line 164  Line 164 
164            (mapc #'destroy-substructure (menu-children client))            (mapc #'destroy-substructure (menu-children client))
165            (create-substructure sub-menu sub-menu)))            (create-substructure sub-menu sub-menu)))
166      (arm-menu sub-menu)))      (arm-menu sub-menu)))
167    
168  (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))  (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
169    (destroy-substructure (menu-root pane)))    (destroy-substructure (menu-root pane)))
170    
171  ;; Menu creation from command tables  ;;; menu-button-vertical-submenu-pane
172    (defclass menu-button-vertical-submenu-pane (menu-button-submenu-pane) ())
173    
174    (let* ((left-padding 10)
175           (widget-size  5)
176           (right-padding 4)
177           (widget-width widget-size)
178           (widget-height (* 2 widget-size))
179           (total-width (+ left-padding widget-width right-padding))
180           (total-height widget-height))
181    
182      (defmethod compose-space ((gadget menu-button-vertical-submenu-pane) &key width height)
183        (declare (ignorable width height))
184        (multiple-value-bind (width min-width max-width height min-height max-height)
185            (space-requirement-components (call-next-method))
186          (declare (ignorable max-width))
187          (make-space-requirement :min-width (+ min-width total-width)
188                                  :width (+ width total-width)
189                                  :max-width +fill+
190                                  :min-height (max min-height total-height)
191                                  :height (max height total-height)
192                                  :max-height (if (zerop max-height) ; make-space-requirements default maximums are zero..
193                                                  0
194                                                  (max max-height total-height)))))
195    
196      (defmethod handle-repaint ((pane menu-button-vertical-submenu-pane) region)
197        (call-next-method)
198        (multiple-value-bind (x1 y1 x2 y2)
199            (bounding-rectangle* (sheet-region pane))
200          (when (and (> (- x2 x1) total-width)
201                     (> (- y2 y1) total-height))
202            (let* ((center (/ (+ y1 y2) 2))
203                   (vbase (- center (/ widget-height 2)))
204                   (hbase (+ (- x2 total-width) left-padding))
205                   (shape (list hbase vbase
206                                (+ hbase widget-size) (+ vbase widget-size)
207                                hbase (+ vbase (* 2 widget-size)))))
208              (draw-polygon* pane shape :ink +black+))))))
209    
210    ;;; menu-divider-leaf-pane
211    
212    (defclass menu-divider-leaf-pane (standard-gadget)
213      ((label :initform nil :initarg :label)))
214    
215    (defparameter *labelled-divider-text-style* (make-text-style :sans-serif :roman :small))
216    
217    (defmethod destroy-substructure ((object menu-divider-leaf-pane)))
218    (defmethod arm-menu ((object menu-divider-leaf-pane)))
219    (defmethod disarm-menu ((object menu-divider-leaf-pane)))
220    
221    (defmethod compose-space ((gadget menu-divider-leaf-pane) &key width height)
222      (declare (ignorable width height))
223      (flet ((make-sr (w h)
224               (make-space-requirement :min-width w   :width w
225                                       :min-height h  :height h :max-height h)))
226        (let ((label (slot-value gadget 'label)))
227          (if label
228              (multiple-value-bind (width height fx fy baseline)
229                  (text-size gadget label :text-style *labelled-divider-text-style*)
230                (declare (ignore fx fy height baseline))
231                (make-sr width (+ 0
232                                  (text-style-ascent *labelled-divider-text-style* gadget)
233                                  (text-style-descent *labelled-divider-text-style* gadget))))
234              (make-sr 0 4)))))
235    
236    
237    (defmethod handle-repaint ((pane menu-divider-leaf-pane) region)
238      (let ((label (slot-value pane 'label)))
239        (multiple-value-bind (x1 y1 x2 y2)
240            (bounding-rectangle* (sheet-region pane))
241          (declare (ignore y2))
242          (if label
243              (multiple-value-bind (width height fx fy baseline)
244                  (text-size pane label :text-style *labelled-divider-text-style*)
245                (declare (ignore height fx fy))
246                (let ((tx0 (+ x1 (/ (- (- x2 x1) width) 2)))
247                      (ty0 (+ 1 y1 baseline)))
248                (draw-line* pane tx0 (1+ ty0) (+ tx0 width) (1+ ty0) :ink *3d-dark-color*)
249                (draw-text* pane label tx0 ty0
250                            :text-style *labelled-divider-text-style*)))
251              (progn
252                (draw-line* pane x1 (1+ y1) x2 (1+ y1) :ink *3d-dark-color*)
253                (draw-line* pane x1 (+ 2 y1) x2 (+ 2 y1) :ink *3d-light-color*))))))
254    
255    
256    ;;; Menu creation from command tables
257    
258  ;; for now, accept only types :command and :menu, and only  ;; for now, accept only types :command and :menu, and only
259  ;; command names as values of :command  ;; command names as values of :command
260    
261  (defparameter *disabled-text-style* (make-text-style :fix :italic :normal))  (defparameter *enabled-text-style*  (make-text-style :sans-serif :roman :normal))
262    (defparameter *disabled-text-style* (make-text-style :sans-serif :roman :normal))
263    
264  (defun make-menu-button-from-menu-item (item client  (defun make-menu-button-from-menu-item (item client
265                                          &key (bottomp nil)                                          &key (bottomp nil)
266                                            (vertical nil)
267                                          command-table                                          command-table
268                                          (presentation-type 'menu-item))                                          (presentation-type 'menu-item))
269    (declare (ignore command-table))    (declare (ignore command-table))
# Line 185  Line 272 
272          (value (command-menu-item-value item))          (value (command-menu-item-value item))
273          (frame *application-frame*)          (frame *application-frame*)
274          (manager (frame-manager *application-frame*)))          (manager (frame-manager *application-frame*)))
275      (if (eq type :command)      (case type
276          (if (command-enabled (if (consp value) (car value) value) frame)        (:command
277              (make-pane-1 manager frame 'menu-button-leaf-pane         (let ((command-name (if (consp value) (car value) value)))
278                           :label name           (if (command-enabled command-name frame)
279                           :client client               (make-pane-1 manager frame 'menu-button-leaf-pane
280                           :value-changed-callback                            :label name
281                           #'(lambda (gadget val)                            :text-style *enabled-text-style*
282                               (declare (ignore gadget val))                            :client client
283                               (throw-object-ptype item presentation-type)))                            :value-changed-callback
284              (make-pane-1 manager frame 'menu-button-leaf-pane                            #'(lambda (gadget val)
285                           :label name                                (declare (ignore gadget val))
286                           :text-style *disabled-text-style*                                (throw-object-ptype item presentation-type)))
287                           :client client               (let ((pane (make-pane-1 manager frame 'menu-button-leaf-pane
288                           :value-changed-callback                              :label name
289                           #'(lambda (gadget val)                              :text-style *disabled-text-style*
290                               (declare (ignore gadget val))                              :client client
291                               nil)))                              :value-changed-callback
292          (make-pane-1 manager frame 'menu-button-submenu-pane                              #'(lambda (gadget val)
293                                    (declare (ignore gadget val))
294                                    nil))))
295                   (deactivate-gadget pane)
296                   pane))))
297          (:function
298            (make-pane-1 manager frame 'menu-button-leaf-pane
299                         :label name
300                         :text-style *enabled-text-style*
301                         :client client
302                         :value-changed-callback
303                         #'(lambda (gadget val)
304                             (declare (ignore gadget val))
305                             ;; FIXME: the spec requires us to pass a gesture to the
306                             ;; function, but value-changed-callback doesn't provide
307                             ;; one, so we pass NIL for now.
308                             ;; FIXME: We don't have a numeric argument, either.
309                             (let ((command (funcall item nil nil)))
310                               (throw-object-ptype command presentation-type)))))
311          (:divider
312           (make-pane-1 manager frame 'menu-divider-leaf-pane
313                        :label name
314                        :client client))
315          (:menu
316            (make-pane-1 manager frame (if vertical
317                                           'menu-button-vertical-submenu-pane
318                                           'menu-button-submenu-pane)
319                       :label name                       :label name
320                       :client client                       :client client
321                       :frame-manager manager                       :frame-manager manager
322                       :command-table value                       :command-table value
323                       :bottomp bottomp))))                       :bottomp bottomp))
324          (otherwise (error "Don't know how to create a menu button for ~W" type)))))
325    
326  ;;  ;;
327  ;; MENU-BAR  ;; MENU-BAR
# Line 265  Line 379 
379                            (make-menu-button-from-menu-item                            (make-menu-button-from-menu-item
380                             item nil                             item nil
381                             :bottomp t                             :bottomp t
382                               :vertical nil
383                             :command-table command-table))                             :command-table command-table))
384                      (list +fill+))))))                      (list +fill+))))))

Legend:
Removed from v.1.31  
changed lines
  Added in v.1.32

  ViewVC Help
Powered by ViewVC 1.1.5