menu.lisp

   1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
   2 #|
   3
   4     Celtk -- Cells, Tcl, and Tk
   5
   6 Copyright (C) 2006 by Kenneth Tilton
   7
   8 This library is free software; you can redistribute it and/or
   9 modify it under the terms of the Lisp Lesser GNU Public License
  10  (http://opensource.franz.com/preamble.html), known as the LLGPL.
  11
  12 This library is distributed  WITHOUT ANY WARRANTY; without even
  13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15 See the Lisp Lesser GNU Public License for more details.
  16
  17 |#
  18
  19 (in-package :Celtk)
  20
  21 #| do list
  22
  23 tear-off
  24 dynamic add/remove
  25
  26 |#
  27
  28 ;;; --- menu bars -----------------------------------
  29
  30 (defmodel menubar (menu)())
  31 (defun mk-menubar (&rest inits)
  32   (apply 'make-instance 'menubar
  33     :fm-parent *parent*
  34     inits))
  35
  36 (defmethod make-tk-instance ((self menubar))
  37   (tk-format `(:make-tk ,self) "menu ~a -tearoff 0 -type menubar ~{~(~a~) ~a~^ ~}" (^path) (tk-configurations self))
  38
  39 ;;;  (let ((opts (tk-class-options self))
  40 ;;;        (figs (tk-configurations self)))
  41 ;;;    (trc (background self) " menu-figs!!!!!!!!!!!!" figs :opts opts)
  42 ;;;    (tk-format `(:make-tk ,self) "menu ~a ~{~(~a~) ~a~^ ~}" ;; call to this GF now integrity-wrapped by caller
  43 ;;;      (path self) figs))
  44   (tk-format `(:configure ,self) ". configure -menu ~a" (^path)))
  45
  46 ;;; --- menus -------------------------------------------
  47
  48 (deftk menu (widget)
  49   ((label :initarg :label :initform nil :accessor label))
  50   (:tk-spec menu -activebackground -activeborderwidth -activeforeground -background
  51     -borderwidth -cursor -disabledforeground (tkfont -font)
  52     -foreground -relief -takefocus
  53     -postcommand -selectcolor -tearoff -tearoffcommand
  54     (-title nil) (-tk-type -type))
  55   (:default-initargs
  56       :id (gentemp "MNU")))
  57
  58
  59 (defmethod make-tk-instance ((self menu))
  60   (trc nil "maketkinstance menu" self :parent .parent (type-of .parent)
  61     :grandpar (fm-parent .parent) (type-of (fm-parent .parent)))
  62   (tk-format `(:make-tk ,self) "menu ~a -tearoff 0" (^path)))
  63
  64 (defmacro mk-menu-ex (&rest submenus)
  65   `(mk-menu :kids (c? (the-kids ,@submenus))))
  66
  67 (defmethod make-tk-instance :after ((self menu))
  68   (trc nil "make-tk-instance > traversing menu" self)
  69   (fm-menu-traverse self
  70     (lambda (entry &aux (menu self))
  71       (assert (typep entry 'menu-entry))
  72       (trc nil "make-tk-instance visiting menu entry" (path menu) entry)
  73       (tk-format `(:post-make-tk ,self) "~(~a~) add ~(~a~) ~{~(~a~) ~a~^ ~}"
  74         (path menu)
  75         (tk-class entry)
  76         (tk-configurations entry)))))
  77
  78 ;;; --- menu entries ------------------------------------
  79 ;;;   these get created a lot diff than widgets and items, and the path is
  80 ;;;   specified diff, so we start a new object hierarchy for them
  81 ;;;
  82
  83 (defmodel menu-entry (tk-object)
  84   ((idx :cell nil :initarg :idx :accessor idx :initform nil))
  85   (:documentation "e.g, New, Open, Save in a File menu"))
  86
  87 (defmethod idx :around ((self menu-entry))
  88   (or (call-next-method)
  89     (setf (idx self)
  90       (block count-to-self
  91         (let ((i -1)
  92               (menu (upper self menu)))
  93           (fm-menu-traverse menu
  94             (lambda (entry)
  95               (assert (typep entry 'menu-entry))
  96               (incf i)
  97               (when (eq entry self)
  98                 (return-from count-to-self i)))))))))
  99
 100 (defmethod make-tk-instance ((self menu-entry))
 101   "Parent has to do this to get them in the right order"
 102   (setf (gethash (path-idx self) (dictionary .tkw)) self))
 103
 104 (defmethod parent-path ((self menu-entry))
 105   (path .parent))
 106
 107 (defmethod path-idx ((self menu-entry))
 108   "This method hopefully gets used only internally and not given to Tcl qua thing name, which will not recognize it"
 109   (assert (idx self))
 110   (format nil "~a.~a" (path (upper self menu))(idx self)))
 111
 112 (defun fm-menu-traverse (family fn)
 113   "Traverse family arbitrarily deep as need to reach all menu-entries
 114 without recursively penetrating nested menu (in which case menu-entries
 115 encountered would belong to that menu, versus the one on which fm-menu-traverse
 116 was implicitly invoked (which is why menu is not passed to callback fn))."
 117   (loop for k in (kids family)
 118       do (typecase k
 119            (menu-entry (funcall fn k))
 120            (menu (c-break "not stopped at cascade?"))
 121            (family (fm-menu-traverse k fn)))))
 122
 123
 124 (defmethod not-to-be :after ((self menu-entry))
 125   (unless (find .tkw *windows-destroyed*)
 126     (trc nil "whacking menu-entry" (path-idx self))
 127     (tk-format `(:destroy ,self) "~a delete ~a" (path (upper self menu)) (idx self))))
 128
 129 (defmethod tk-configure ((self menu-entry) option value)
 130   (assert (>= (idx self) 0) () "cannot configure menu-entry ~a until instantiated and index decided" self)
 131   (tk-format `(:configure ,self) "~A entryconfigure ~a ~(~a~) ~a"
 132     (path (upper self menu)) (idx self) option (tk-send-value value)))
 133
 134 (deftk menu-entry-separator (menu-entry)
 135   ()
 136   (:tk-spec separator -columnbreak))
 137
 138 (deftk menu-entry-usable (menu-entry)
 139   ()
 140   (:tk-spec menu -activebackground -activeforeground -accelerator -background
 141     -bitmap -columnbreak -command
 142     -compound (tkfont -font) -foreground -hidemargin
 143     -image -label -state -underline))
 144
 145 (defobserver accelerator :around ((self menu-entry-usable))
 146   (call-next-method)
 147   (with-integrity (:client '(:bind nil))
 148     (when new-value
 149       (tk-format-now "bind . <~a> {~a invoke ~a}" new-value (path (upper self menu)) (idx self)))))
 150
 151
 152 (deftk menu-entry-cascade (tk-selector family menu-entry-usable)
 153   ()
 154   (:tk-spec cascade
 155     -menu)
 156   (:default-initargs
 157       :menu (c? (path (kid1 self)))))
 158
 159 (defmacro mk-menu-entry-cascade-ex ((&rest initargs) &rest submenus)
 160   `(mk-menu-entry-cascade
 161     ,@initargs
 162     :kids (c? (the-kids (mk-menu :kids (c? (the-kids ,@submenus)))))))
 163
 164 (defmethod path ((self menu-entry-cascade))
 165   (format nil "~(~a.~a~)" (path .parent) (md-name self)))
 166
 167 (defmethod tk-output-selection ((self menu-entry-cascade) new-value old-value old-value-boundp)
 168   (declare (ignorable old-value old-value-boundp))
 169   (when (and new-value #+not (not old-value-boundp))
 170     (tk-format `(:selection ,self)
 171       (if (listp new-value) "set ~(~a~) {~{~a~^ ~}}" "set ~(~a~) ~s")
 172       (^path) new-value)))
 173
 174 (deftk menu-entry-command (menu-entry-usable)
 175   ()
 176   (:tk-spec command -command)
 177   (:default-initargs
 178       :command (c? (format nil "do-on-command ~a" (path-idx self)))))
 179
 180 (defmacro mk-menu-entry-command-ex ((&rest menu-command-initargs) lbl callback-body)
 181   `(mk-menu-entry-command
 182     ,@menu-command-initargs
 183     :label ,lbl
 184     :on-command (lambda (self)
 185                   (declare (ignorable self))
 186                   ,callback-body)))
 187
 188 (deftk menu-entry-button (menu-entry-command)
 189   ()
 190   (:tk-spec command
 191     (tk-variable nil) -selectcolor -selectimage -indicatoron))
 192
 193 ; --- menu check button -----------------------------------
 194
 195 (deftk menu-entry-checkbutton (menu-entry-command)
 196   ()
 197   (:tk-spec checkbutton
 198     (tk-variable -variable)
 199     -offvalue
 200     -onvalue)
 201   (:default-initargs
 202     :value (c-in nil)
 203     :tk-variable (c? (format nil "~a.~(~a~)" (path .parent)(md-name self)))
 204     :on-command  (lambda (self)
 205                    (setf (^value) (not (^value))))))
 206
 207 (defobserver .value ((self menu-entry-checkbutton))
 208   (trc nil "defobserver value menu-entry-checkbutton" self new-value old-value-boundp)
 209   (when (and new-value (not old-value-boundp))
 210     (tk-format `(:variable ,self) "set ~a ~a" (^tk-variable) (if new-value 1 0))))
 211
 212 ; --- menu radio button -----------------------------------
 213
 214 (deftk menu-entry-radiobutton (menu-entry-command)
 215   ()
 216   (:tk-spec radiobutton
 217     (tk-variable -variable)
 218     -value)
 219   (:default-initargs
 220     :tk-variable (c? (down$ (path (upper self tk-selector))))
 221     :on-command  (lambda (self)
 222                    (declare (ignore key args))
 223                    (trc "menu radio button command firing" self (^value) (upper self tk-selector))
 224                    (setf (selection (upper self tk-selector)) (^value)))))
 225
 226 (defmodel menu-radio-group (tk-selector family)
 227   ((.md-name :cell nil :initform (gentemp "RG") :initarg :id))
 228   (:documentation "Sits in Celtk menu tree managing radio buttons but has no Tk correlate"))
 229
 230 (defmethod path ((self menu-radio-group))
 231   (format nil "~(~a.~a~)" (path .parent) (md-name self)))
 232
 233 (defun mk-menu-radio-group (&rest inits)
 234   (apply 'make-instance 'menu-radio-group
 235     :fm-parent *parent*
 236     inits))
 237
 238 (defmethod parent-path ((self menu-radio-group))
 239   (path .parent))
 240
 241 (defmethod tk-output-selection ((self menu-radio-group) new-value old-value old-value-boundp)
 242   (declare (ignorable old-value old-value-boundp))
 243   (trc nil "selection output for radio group" self new-value old-value old-value-boundp (^path))
 244   (unless old-value-boundp ;; just needed for initialization; Tk manages variable afterwards
 245     (tk-format `(:variable ,self) "set ~(~a~) ~a" (^path) (tk-send-value new-value))))
 246
 247 (deftk menubutton (widget)
 248   ((menu-values :initarg :menu-values :accessor menu-values :initform nil))
 249   (:tk-spec menubutton -activebackground -activeforeground -anchor -background
 250     -bitmap -borderwidth -cursor -disabledforeground
 251     (tkfont -font) -foreground -highlightbackground -highlightcolor
 252     -highlightthickness -image (tk-justify -justify) -padx
 253     -pady -relief -takefocus -text
 254     -textvariable -underline -wraplength
 255     -compound -direction -height -indicatoron
 256     (-tk-menu -menu) -state -width))
 257
 258 (defmethod make-tk-instance ((self menubutton))
 259   (setf (gethash (^path) (dictionary .tkw)) self)
 260   (when (tk-class self)
 261     (tk-format `(:make-tk ,self) "~(~a~) ~a ~{~(~a~) ~a~^ ~}"
 262       (tk-class self) (path self)(tk-configurations self)) :stdfctry))
 263
 264 (deftk popup-menubutton (tk-selector menubutton)
 265   ((initial-value :initarg :initial-value :initform nil :accessor initial-value)
 266    (entry-values :initarg :entry-values :initform nil :accessor entry-values))
 267   (:tk-spec menubutton)
 268   (:default-initargs
 269       :tk-menu (c? (path (kid1 self)))
 270     ;;:text (c? (tk-send-value (or (^selection) "unselected")))
 271     :textvariable (c? (^path))
 272     :relief 'raised
 273     :indicatoron 1
 274     :kids (c? (the-kids
 275                (mk-menu
 276                 :kids (c? (the-kids ;; don't worry, this flattens
 277                            (loop for v in (entry-values .parent)
 278                                collecting
 279                                  (mk-menu-entry-radiobutton
 280                                     :label (down$ v)
 281                                     :value v)))))))))
 282
 283 (defobserver initial-value ((self popup-menubutton))
 284   (when new-value
 285     (with-integrity (:change self)
 286       (setf (selection self) new-value))))
 287
 288 (defmethod tk-output-selection ((self popup-menubutton) new-value old-value old-value-boundp)
 289   (declare (ignorable old-value old-value-boundp))
 290   (when new-value
 291     (with-integrity (:client `(:selection ,self))
 292       (tk-format-now
 293        (if (listp new-value) "set ~(~a~) {~{~a~^ ~}}" "set ~(~a~) ~s")
 294        (^path) new-value))))