[cells-cvs] CVS update: cell-cultures/celtic/choice.lisp cell-cultures/celtic/button.lisp cell-cultures/celtic/callback.lisp cell-cultures/celtic/canvas.lisp cell-cultures/celtic/celtic.lisp cell-cultures/celtic/celtic.lpr cell-cultures/celtic/demos.lisp cell-cultures/celtic/frame.lisp cell-cultures/celtic/menu.lisp cell-cultures/celtic/scrolling.lisp cell-cultures/celtic/textual.lisp cell-cultures/celtic/widget-item.lisp cell-cultures/celtic/window.lisp cell-cultures/celtic/listbox.lisp
Kenny Tilton
ktilton at common-lisp.net
Wed Jul 21 11:49:39 UTC 2004
Update of /project/cells/cvsroot/cell-cultures/celtic
In directory common-lisp.net:/tmp/cvs-serv705/celtic
Modified Files:
button.lisp callback.lisp canvas.lisp celtic.lisp celtic.lpr
demos.lisp frame.lisp menu.lisp scrolling.lisp textual.lisp
widget-item.lisp window.lisp
Added Files:
choice.lisp
Removed Files:
listbox.lisp
Log Message:
Date: Wed Jul 21 04:49:38 2004
Author: ktilton
Index: cell-cultures/celtic/button.lisp
diff -u cell-cultures/celtic/button.lisp:1.6 cell-cultures/celtic/button.lisp:1.7
--- cell-cultures/celtic/button.lisp:1.6 Sat Jul 17 07:02:23 2004
+++ cell-cultures/celtic/button.lisp Wed Jul 21 04:49:38 2004
@@ -23,26 +23,19 @@
;--------------------------------------------------------------------------
-(def-widget button ()
- ()
- (-activebackground -activeforeground -anchor -background
- -bitmap -borderwidth -cursor -disabledforeground
- -font -foreground -highlightbackground -highlightcolor
- -highlightthickness -image -justify -padx -pady -relief -repeatdelay
- -repeatinterval -takefocus -text -textvariable -underline -wraplength
- -command -compound -default -height -overrelief -state -width))
-
-(def-widget checkbutton ()
- ()
- (-activebackground -activeforeground -anchor -background
- -bitmap -borderwidth -cursor -disabledforeground
- -font -foreground -highlightbackground -highlightcolor
- -highlightthickness -image -justify -padx
- -pady -relief -takefocus -text
- -textvariable -underline -wraplength
- -command -height -indicatoron -offrelief -offvalue -onvalue
+(def-widget button (standard-widget)
+ ()()
+ (-command -compound -default -height -overrelief -state -width))
+
+(def-widget radiocheck (standard-widget)
+ ()()
+ (-command -height -indicatoron -offrelief
-overrelief -selectcolor -selectimage -state -tristateimage
- -tristatevalue (-tk-variable -variable) -width)
+ -tristatevalue (-tk-variable -variable) -width))
+
+(def-widget checkbutton (radiocheck)
+ ()()
+ (-offvalue -onvalue)
(:default-initargs
:md-value (c-in nil)
:command (c? (tk-callback self 'toggle
@@ -56,83 +49,36 @@
(down$ (md-name self))
(if new-value 1 0)))
-(def-widget radiobutton ()
+(def-widget radiobutton (radiocheck)
()
- (-activebackground -activeforeground -anchor -background
- -bitmap -borderwidth -cursor -disabledforeground
- -font -foreground -highlightbackground -highlightcolor
- -highlightthickness -image -justify -padx
- -pady -relief -takefocus -text
- -textvariable -underline -wraplength
- -command -height -indicatoron -offrelief -value
- -overrelief -selectcolor -selectimage -state -tristateimage
- -tristatevalue (-tk-variable -variable) -width)
+ ()
+ (-value)
(:default-initargs
+ :tk-variable (c? (path (upper self selector)))
:command (c? (tk-callback self 'radio-set
(lambda (self id &rest args)
(declare (ignore id args))
(setf (selection (upper self selector))
(value self)))))))
-(def-widget scale ()
+(def-widget scale (standard-widget)
+ ()
()
- (-activebackground -background -borderwidth -cursor
- -font -foreground -highlightbackground -highlightcolor
- -highlightthickness -orient -relief -repeatdelay
- -repeatinterval -takefocus -troughcolor
+ ( -orient -repeatdelay
+ -repeatinterval
-bigincrement -command -digits -from
(-tk-label -label) (-tk-length -length) -resolution
-showvalue -sliderlength -sliderrelief
- -state -tickinterval -to (-tk-variable -variable) -width)
+ -state -tickinterval -to (-tk-variable nil) -width)
(:default-initargs
:md-value (c-in nil)
- :command (c? (tk-callback self 'radio-set
+ :tk-variable nil ;;(c? (^path))
+ :command (c? (tk-callback self 'scale-set
(lambda (self id &rest args)
(declare (ignore id))
- (eko ("scale now" self)
- (setf (^md-value) (car args))))))))
+ (setf (^md-value) (car args)))))))
-(def-c-output .md-value ((self scale))
- (when new-value
- (if (listp new-value)
- (tk-send self "set ~a {~{~a~^ ~}}" (^path) new-value)
- (tk-send self "~a set ~a" (^path) new-value))))
-
-(def-widget spinbox ()
- ((initial-value :initarg :initial-value :initform nil :accessor initial-value))
- (-activebackground -background -borderwidth -cursor
- -exportselection -font -foreground -highlightbackground
- -highlightcolor -highlightthickness -insertbackground -insertborderwidth
- -insertofftime -insertontime -insertwidth -justify
- -relief -repeatdelay -repeatinterval -selectbackground
- -selectborderwidth -selectforeground -takefocus -textvariable
- -xscrollcommand
- -buttonbackground -buttoncursor -buttondownrelief
- -buttonuprelief
- -command -disabledbackground -disabledforeground
- (-spinbox-format -format) -from -invalidcommand -increment
- -readonlybackground -state -to -validate
- -validatecommand (-tk-values -values) -width -wrap)
- (:default-initargs
- :md-value (c-in nil)
- :command (c? (format nil
- "puts {callback ~s %s %d}"
- (register-callback self 'cmd
- (lambda (self id &rest args)
- (destructuring-bind (new-value up-down) args
- (setf (^md-value)
- (eko ("spinbox value now" self id :up-down up-down)
- (down$ new-value)
- #+not (tk-eval-list self (format nil "~a get" (^path))))))))))))
-
-(def-c-output .md-value ((self spinbox))
- (when new-value
- (trc "spinbox value" (type-of new-value) new-value)
- (if (listp new-value)
- (tk-send self "set ~a {~{~a~^ ~}}" (^path) new-value)
- (tk-send self "~a set ~s" (^path) new-value))))
-
-(def-c-output initial-value ((self spinbox))
- (when new-value
- (setf (^md-value) new-value)))
+(defmethod make-tk-instance :after ((self scale))
+ (when (^md-value)
+ (tk-send self "~a set ~a" (^path) (^md-value))))
Index: cell-cultures/celtic/callback.lisp
diff -u cell-cultures/celtic/callback.lisp:1.2 cell-cultures/celtic/callback.lisp:1.3
--- cell-cultures/celtic/callback.lisp:1.2 Sat Jul 17 07:02:23 2004
+++ cell-cultures/celtic/callback.lisp Wed Jul 21 04:49:38 2004
@@ -24,12 +24,15 @@
(defun register-callback (self callback-id fun)
(let ((id (intern (string-upcase
- (format nil "~a.~a" (path self) callback-id)))))
+ (format nil "~a.~a" (path-index self) callback-id)))))
(assert (not (gethash id (callbacks .tkw))))
- (trc "registering callback" self :id id)
+ (trc nil "registering callback" self :id id)
(setf (gethash id (callbacks .tkw)) (cons fun self))
id))
+(defmethod path-index (self) (^path))
+
+
(defun dispatch-callback (window callback)
(destructuring-bind (callback-id &rest callback-args) callback
(let ((func-self (gethash callback-id (callbacks window))))
@@ -63,7 +66,8 @@
result
(full-id (register-callback self id
(lambda (self id &rest args)
- (trc "tk-eval-list" self id args)
+ (declare (ignorable self id))
+ (trc nil "tk-eval-list" self id args)
(setf result args)))))
(tk-send self
(format nil
Index: cell-cultures/celtic/canvas.lisp
diff -u cell-cultures/celtic/canvas.lisp:1.2 cell-cultures/celtic/canvas.lisp:1.3
--- cell-cultures/celtic/canvas.lisp:1.2 Sun Jul 4 11:59:43 2004
+++ cell-cultures/celtic/canvas.lisp Wed Jul 21 04:49:38 2004
@@ -23,11 +23,12 @@
(def-widget canvas ()
()
- (-background -borderwidth -cursor -highlightbackground
- -highlightcolor -highlightthickness -insertbackground -insertborderwidth
- -insertofftime -insertontime -insertwidth -relief
- -selectbackground -selectborderwidth -selectforeground -state
- -takefocus -xscrollcommand -yscrollcommand
+ ()
+ (-background -borderwidth -cursor -highlightbackground
+ -highlightcolor -highlightthickness -insertbackground -insertborderwidth
+ -insertofftime -insertontime -insertwidth -relief
+ -selectbackground -selectborderwidth -selectforeground -state
+ -takefocus -xscrollcommand -yscrollcommand
-closeenough -confine -height -scrollregion -width
-xscrollincrement -yscrollincrement))
Index: cell-cultures/celtic/celtic.lisp
diff -u cell-cultures/celtic/celtic.lisp:1.6 cell-cultures/celtic/celtic.lisp:1.7
--- cell-cultures/celtic/celtic.lisp:1.6 Sat Jul 17 07:02:23 2004
+++ cell-cultures/celtic/celtic.lisp Wed Jul 21 04:49:38 2004
@@ -108,7 +108,7 @@
(let ((msg$ (read-line #+not read-preserving-whitespace wish nil nil)))
(when (null msg$)
(return))
- (trc "tk-listen> read:" msg$)
+ (trc nil "tk-listen> read:" msg$)
(loop with start = 0
and state = 'init
and func and self and callback-id and args
Index: cell-cultures/celtic/celtic.lpr
diff -u cell-cultures/celtic/celtic.lpr:1.5 cell-cultures/celtic/celtic.lpr:1.6
--- cell-cultures/celtic/celtic.lpr:1.5 Sat Jul 17 07:02:23 2004
+++ cell-cultures/celtic/celtic.lpr Wed Jul 21 04:49:38 2004
@@ -16,7 +16,7 @@
(make-instance 'module :name "menu.lisp")
(make-instance 'module :name "scrolling.lisp")
(make-instance 'module :name "callback.lisp")
- (make-instance 'module :name "listbox.lisp")
+ (make-instance 'module :name "choice.lisp")
(make-instance 'module :name "demos.lisp"))
:projects (list (make-instance 'project-module :name
"..\\cells\\cells"))
Index: cell-cultures/celtic/demos.lisp
diff -u cell-cultures/celtic/demos.lisp:1.2 cell-cultures/celtic/demos.lisp:1.3
--- cell-cultures/celtic/demos.lisp:1.2 Sat Jul 17 07:02:23 2004
+++ cell-cultures/celtic/demos.lisp Wed Jul 21 04:49:38 2004
@@ -34,9 +34,23 @@
(:default-initargs
:kids (c? (list
(demo-all-menubar)
+
(mk-frame-stack
:layout (pack-self)
:kids (c? (list
+ (mk-labelframe-row
+ :text "Style by Edit Menu"
+ ;;:layout (pack-layout? "-side left -fill x -expand 1")
+ :kids (c? (list
+ (mk-label :text "Four score and seven years ago today"
+ :wraplength 600
+ :font (c? (list
+ (selection (fm^ :app-font-face))
+ (selection (fm^ :app-font-size))
+ (if (md-value (fm^ :app-font-italic))
+ 'italic 'roman)
+ (if (md-value (fm^ :app-font-bold))
+ 'bold 'normal)))))))
(mk-frame-row
:kids (c? (list
(mk-button :text "Press Me"
@@ -47,6 +61,7 @@
(mk-entry :text "Enter Me"
:layout nil))))
(mk-frame-row
+ :selection (c-in 'yes)
:kids (c? (list
(mk-checkbutton :md-name :check-me
:text "check Me"
@@ -58,11 +73,6 @@
(mk-radiobutton :text "no"
:value 'no
:layout nil))))
- (mk-scale :md-name :font-size
- :md-value (c-in 14)
- :tk-label "Font Size"
- :from 7 :to 24
- :orient 'horizontal)
(mk-scrolled-list
:list-height 6
:layout nil ;;(pack-layout? "-side left -fill x -expand 1")
@@ -78,10 +88,33 @@
:tk-values (mapcar 'down$
(mapcar 'package-name
(list-all-packages))))
- (mk-spinbox
- :initial-value (c? (down$ (car (^tk-values))))
- :tk-values (c? (tk-eval-list self "font families")))
- )))))))
+ (style-by-widgets))))))))
+
+(defun style-by-widgets ()
+ (mk-labelframe-stack
+ :text "Style by Widgets"
+ ;;:layout (pack-layout? "-side left -fill x -expand 1")
+ :kids (c? (list
+ (mk-frame-row
+ :layout-anchor 'sw
+ :kids (c? (list
+ (mk-popup-menubutton
+ :md-name :font-face
+ :initial-value (c? (down$ (car (^entry-values))))
+ :entry-values (c? (tk-eval-list self "font families")))
+
+ (mk-scale :md-name :font-size
+ :md-value (c-in 14)
+ :tk-label "Font Size"
+ :from 7 :to 24
+ :orient 'horizontal))))
+
+
+ (mk-label :text "Four score and seven years ago today"
+ :wraplength 600
+ :font (c? (list
+ (selection (fm^ :font-face))
+ (md-value (fm^ :font-size)))))))))
(defun demo-all-menubar ()
(mk-menubar
@@ -103,9 +136,11 @@
'normal 'disabled))
:command "exit")))))))
(mk-menu-entry-cascade
+ :md-name 'editcascade
:label "Edit"
:kids (c? (list
(mk-menu
+ :md-name 'editmenu
:kids (c? (list
(mk-menu-entry-command :label "Undo"
:command (tk-callback .tkw 'undo
@@ -121,42 +156,40 @@
(mk-menu-entry-command :label "Clear"
:command "exit")
(mk-menu-entry-separator)
- (mk-menu-entry-radiobutton
- :label "Times" :value "times"
- :tk-variable "fontface"
- :command nil)
- (mk-menu-entry-radiobutton
- :label "Courier" :value "courier"
- :tk-variable "fontface"
- :command nil)
- (mk-menu-entry-radiobutton
- :label "Helvetica" :value "helvetica"
- :tk-variable "fontface"
- :command nil)
+ (mk-menu-radio-group :md-name :app-font-face
+ :selection (c-in "courier")
+ :kids (c? (list
+ (mk-menu-entry-radiobutton
+ :label "Times" :value "times")
+ (mk-menu-entry-radiobutton
+ :label "Courier" :value "courier")
+ (mk-menu-entry-radiobutton
+ :label "Helvetica" :value "helvetica"))))
(mk-menu-entry-separator)
(mk-menu-entry-cascade
+ :md-name :app-font-size
:label "Font Size"
:menu (c? (path (kid1 self)))
+ :selection (c-in 12)
:kids (c? (list
(mk-menu
+ :tearoff 1
+ :last-index 0
:kids (c? (list
(mk-menu-entry-radiobutton
- :label "9" :value 9
- :tk-variable "fontsize"
- :command nil)
+ :label "9" :value 9)
(mk-menu-entry-radiobutton
- :label "12" :value 12
- :tk-variable "fontsize"
- :command nil)
+ :label "12" :value 12)
(mk-menu-entry-radiobutton
- :label "14" :value 14
- :tk-variable "fontsize"
- :command nil)))))))
+ :label "14" :value 14)))))))
(mk-menu-entry-separator)
- (mk-menu-entry-checkbutton :label "Italic"
- :command nil)
- (mk-menu-entry-checkbutton :label "Bold"
- :command nil)
+ (mk-menu-entry-checkbutton
+ :md-name :app-font-italic
+ :label "Italic")
+ (mk-menu-entry-checkbutton
+ :md-name :app-font-bold
+ :label "Bold"
+ :md-value (c-in t))
))))))))))
(defmodel font-view (window)
()
Index: cell-cultures/celtic/frame.lisp
diff -u cell-cultures/celtic/frame.lisp:1.6 cell-cultures/celtic/frame.lisp:1.7
--- cell-cultures/celtic/frame.lisp:1.6 Sat Jul 17 07:02:23 2004
+++ cell-cultures/celtic/frame.lisp Wed Jul 21 04:49:38 2004
@@ -63,18 +63,20 @@
(tk-variable :accessor tk-variable :initarg :tk-variable))
(:default-initargs
:selection (c-in nil)
- :tk-variable (c? (md-name self))))
+ :tk-variable (c? (^path))))
(def-c-output selection ()
(when new-value
+ (trc nil "def-c-output selection" (type-of new-value) (md-name new-value) new-value)
(tk-send self "set ~a ~a"
(down$ (tk-variable self))
- (down$ (md-name new-value)))))
+ (tk-down$ (md-name new-value)))))
;--- f r a m e --------------------------------------------------
(def-widget frame ()
()
+ ()
(-borderwidth -cursor -highlightbackground -highlightcolor
-highlightthickness -padx -pady -relief
-takefocus -background (tk-class -class)
@@ -96,6 +98,7 @@
;--- l a b e l f r a m e ----------------------------------------------
(def-widget labelframe ()
+ ()
()
(-borderwidth -cursor -highlightbackground -highlightcolor
-highlightthickness -padx -pady -relief
Index: cell-cultures/celtic/menu.lisp
diff -u cell-cultures/celtic/menu.lisp:1.4 cell-cultures/celtic/menu.lisp:1.5
--- cell-cultures/celtic/menu.lisp:1.4 Sat Jul 17 07:02:23 2004
+++ cell-cultures/celtic/menu.lisp Wed Jul 21 04:49:38 2004
@@ -25,14 +25,15 @@
initialize check/radio entries to non-nil
mirror check/radios into app model
-cascade
tear-off
dynamic add/remove
|#
-(def-widget menu (:std-factory nil)
- ((label :initarg :label :initform nil :accessor label))
+(def-widget menu ()
+ (:std-factory nil)
+ ((last-index :cell nil :initarg :last-index :initform -1 :accessor last-index)
+ (label :initarg :label :initform nil :accessor label))
(-activebackground -activeborderwidth -activeforeground -background
-borderwidth -cursor -disabledforeground -font
-foreground -relief -takefocus
@@ -40,10 +41,19 @@
(-title nil) (-tk-type -type)))
(defmethod make-tk-instance ((self menu))
- (trc "make-tk-instance menu" self :parent .parent (type-of .parent)
+ (trc nil "make-tk-instance menu" self :parent .parent (type-of .parent)
:grandpar (fm-parent .parent) (type-of (fm-parent .parent)))
(tk-send self (format nil "menu ~a -tearoff 0" (^path))))
+(defmethod make-tk-instance :after ((self menu))
+ (fm-menu-traverse self
+ (lambda (entry &aux (menu self))
+ (assert (typep entry 'menu-entry))
+ (setf (index entry) (incf (last-index menu)))
+ (tk-send menu
+ (format nil "~(~a~) add ~(~a~)"
+ (path menu)(entry-type entry))))))
+
;;; --- menu bars -----------------------------------
(defmodel menubar (menu)())
@@ -55,15 +65,27 @@
;;; --- menu entries ------------------------------------
-(defmodel menu-entry (tk-object)
- ((index :initarg :index :accessor index
- :initform (c? (kid-no self)))
+(defmodel menu-entry (model)
+ ((index :cell nil :initarg :index :accessor index :initform nil)
(entry-type :cell nil :initarg :entry-type :accessor entry-type :initform nil
:documentation "Command, cascade, radiobutton, checkbutton, or separator"))
(:documentation "e.g, New, Open, Save in a File menu"))
(defmethod parent-path ((self menu-entry))
(path .parent))
+(defmethod path-index ((self menu-entry))
+ (format nil "~a.~a" (path (upper self menu))(index self)))
+
+(defun fm-menu-traverse (family fn)
+ "Traverse family arbitrarily deep as need to reach all menu-entries
+without recursively penetrating nested menu (in which case menu-entries
+encountered would belong to that menu, versus the one on which fm-menu-traverse
+was implicitly invoked (which is why menu is not passed to callback fn))."
+ (loop for k in (kids family)
+ do (typecase k
+ (menu-entry (funcall fn k))
+ (menu (c-break "not stopped at cascase?"))
+ (family (fm-menu-traverse k fn)))))
(defmethod not-to-be :after ((self menu-entry))
(trc nil "whacking menu-entry" self)
@@ -72,14 +94,13 @@
(defmethod configure ((self menu-entry) option value)
(assert (>= (index self) 0) () "cannot configure menu-entry until instantiated and index decided")
(tk-send self "~A entryconfigure ~a ~(~a~) {~a}"
- (path .parent) (index self) option (tk-down$ value)))
+ (path (upper self menu)) (index self) option (tk-down$ value)))
(defmacro def-menu-entry (class
(&optional (superclasses '(menu-entry)))
(&rest std-slots)
(&rest tk-options)
- &rest defclass-options
- &aux (std-factory t))
+ &rest defclass-options)
(multiple-value-bind (slots outputs)
(loop for tk-option-def in tk-options
for slot-name = (intern (de- (if (atom tk-option-def)
@@ -104,11 +125,6 @@
, at defclass-options)
(defun ,(intern (format nil "MK-~a" class)) (&rest inits)
(apply 'make-instance ',class inits))
- ,(when std-factory
- `(defmethod make-tk-instance ((self ,class))
- (tk-send self
- (format nil "~(~a~) add ~(~a~)"
- (path .parent)(entry-type self)))))
, at outputs)))
(def-menu-entry menu-entry-separator ()
@@ -124,16 +140,21 @@
-compound -font -foreground -hidemargin
-image -label -state -underline))
-(def-menu-entry menu-entry-cascade ((family menu-entry-usable))
+(def-menu-entry menu-entry-cascade ((selector family menu-entry-usable))
()
(-menu)
(:default-initargs
:menu (c? (path (kid1 self)))
:entry-type 'cascade))
-#+save
-(tk-send self (format nil "~A add cascade -label {~A} -menu ~a"
- (path (nearest .parent widget)) (^label) (^path)))
+(defmethod path ((self menu-entry-cascade))
+ (format nil "~a.~(~a~)" (path .parent) (md-name self)))
+
+(def-c-output selection ((self menu-entry-cascade))
+ (when (and new-value (not old-value-boundp))
+ (if (listp new-value)
+ (tk-send self "set ~(~a~) {~{~a~^ ~}}" (^path) new-value)
+ (tk-send self "set ~(~a~) ~s" (^path) new-value))))
(def-menu-entry menu-entry-command ((menu-entry-usable))
()
@@ -149,23 +170,92 @@
()
(-offvalue -onvalue)
(:default-initargs
- :entry-type 'checkbutton))
+ :entry-type 'checkbutton
+ :md-value (c-in nil)
+ :tk-variable (c? (format nil "~a.~(~a~)" (path .parent)(md-name self)))
+ :command (c? (tk-callback self 'cmd
+ (lambda (self key &rest args)
+ (declare (ignore key args))
+ (setf (^md-value) (not (^md-value))))))))
+
+(def-c-output .md-value ((self menu-entry-checkbutton))
+ (trc nil "def-c-output md-value menu-entry-checkbutton" self new-value old-value-boundp)
+ (when (and new-value (not old-value-boundp))
+ (if (listp new-value)
+ (tk-send self "set ~a {~{~a~^ ~}}" (^tk-variable) (if new-value 1 0))
+ (tk-send self "set ~a ~s" (^tk-variable) (if new-value 1 0)))))
(def-menu-entry menu-entry-radiobutton ((menu-entry-button))
()
(-value)
(:default-initargs
- :entry-type 'radiobutton))
-
-;;;(def-widget menubutton (:std-factory nil) ;; abstract class
-;;; ((label :initarg :label :initform nil :accessor label))
-;;; (-activebackground -activeforeground -anchor -background
-;;; -bitmap -borderwidth -cursor -disabledforeground
-;;; -font -foreground -highlightbackground -highlightcolor
-;;; -highlightthickness -image -justify -padx
-;;; -pady -relief -takefocus -text
-;;; -textvariable -underline -wraplength
-;;; -compound -direction -height -indicatoron
-;;; (-tk-menu -menu) -state -width))
-
+ :entry-type 'radiobutton
+ :tk-variable (c? (down$ (path (upper self selector))))
+ :command (c? (tk-callback self 'cmd
+ (lambda (self key &rest args)
+ (declare (ignore key args))
+ (setf (selection (upper self selector))
+ (^value)))))))
+
+(defmodel menu-radio-group (selector family)
+ ()
+ (:documentation "md-name becomes Tk variable"))
+
+(defmethod path ((self menu-radio-group))
+ (format nil "~a.~(~a~)" (path .parent) (md-name self)))
+
+(defun mk-menu-radio-group (&rest inits)
+ (apply 'make-instance 'menu-radio-group inits))
+(defmethod parent-path ((self menu-radio-group))
+ (path .parent))
+(def-c-output selection ((self menu-radio-group))
+ (unless old-value-boundp ;; just needed for initialization; Tk manages variable afterwards
+ (tk-send self "set ~a ~a" (down$ (md-name self)) new-value)))
+
+(def-widget menubutton ()
+ ()
+ ((menu-values :initarg :menu-values :accessor menu-values :initform nil))
+ (-activebackground -activeforeground -anchor -background
+ -bitmap -borderwidth -cursor -disabledforeground
+ -font -foreground -highlightbackground -highlightcolor
+ -highlightthickness -image -justify -padx
+ -pady -relief -takefocus -text
+ -textvariable -underline -wraplength
+ -compound -direction -height -indicatoron
+ (-tk-menu -menu) -state -width))
+
+(defmodel popup-menubutton (selector menubutton)
+ ((initial-value :initarg :initial-value :initform nil :accessor initial-value)
+ (entry-values :initarg :entry-values :initform nil :accessor entry-values))
+ (:default-initargs
+ :tk-menu (c? (path (kid1 self)))
+ :text (c? (tk-down$ (or (^selection) "unselected")))
+ :textvariable (c? (^path))
+ :relief 'raised
+ :indicatoron 1
+ :kids (c? (list
+ (mk-menu
+ :kids (c? (loop for v in (entry-values .parent)
+ collecting
+ (progn
+ ;(trc "radio label" v (down$ v))
+ (mk-menu-entry-radiobutton
+ :label (down$ v)
+ :value v)))))))))
+
+(defun mk-popup-menubutton (&rest inits)
+ (apply 'make-instance 'popup-menubutton inits))
+
+(def-c-output initial-value ((self popup-menubutton))
+ (when new-value
+ (setf (selection self) new-value)
+ (if (listp new-value)
+ (tk-send self "set ~(~a~) {~{~a~^ ~}}" (^path) new-value)
+ (tk-send self "set ~(~a~) ~s" (^path) new-value))))
+
+;;;(def-c-output selection ((self popup-menubutton))
+;;; (when new-value
+;;; (if (listp new-value)
+;;; (tk-send self "set ~(~a~) {~{~a~^ ~}}" (md-name self) new-value)
+;;; (tk-send self "set ~(~a~) ~s" (md-name self) new-value))))
Index: cell-cultures/celtic/scrolling.lisp
diff -u cell-cultures/celtic/scrolling.lisp:1.4 cell-cultures/celtic/scrolling.lisp:1.5
--- cell-cultures/celtic/scrolling.lisp:1.4 Sat Jul 17 07:02:23 2004
+++ cell-cultures/celtic/scrolling.lisp Wed Jul 21 04:49:38 2004
@@ -21,12 +21,10 @@
(in-package :celtic)
-(def-widget scrollbar ()
+(def-widget scrollbar (standard-widget)
()
- (-activebackground -background -borderwidth -cursor
- -highlightbackground -highlightcolor -highlightthickness -jump
- -orient -relief -repeatdelay -repeatinterval
- -takefocus -troughcolor
+ ()
+ ( -jump -orient -troughcolor
-activerelief -command -elementborderwidth -width))
(defmodel scrolled-list (frame-selector)
Index: cell-cultures/celtic/textual.lisp
diff -u cell-cultures/celtic/textual.lisp:1.4 cell-cultures/celtic/textual.lisp:1.5
--- cell-cultures/celtic/textual.lisp:1.4 Sat Jul 17 07:02:23 2004
+++ cell-cultures/celtic/textual.lisp Wed Jul 21 04:49:38 2004
@@ -21,38 +21,22 @@
(in-package :celtic)
-(def-widget label ()
- ()
- (-activebackground -activeforeground -anchor -background
- -bitmap -borderwidth -cursor -disabledforeground
- -font -foreground -highlightbackground -highlightcolor
- -highlightthickness -image -justify -padx
- -pady -relief -takefocus -text
- -textvariable -underline -wraplength
- -compound -height -state -width))
+(def-widget label (standard-widget)
+ ()()
+ (-compound -height -state -width))
;--------------------------------------------------------------------------
-(def-widget message ()
- ()
- (-anchor -background -borderwidth -cursor
- -font -foreground -highlightbackground -highlightcolor
- -highlightthickness -padx -pady -relief
- -takefocus -text -textvariable -width
- -aspect -justify))
+(def-widget message (standard-widget)
+ ()()
+ (-width -aspect -justify))
;----------------------------------------------------------------------------
-(def-widget entry ()
+(def-widget entry (standard-widget)
+ ()
((text :initarg :text :accessor text :initform nil))
- (-background -borderwidth -cursor -exportselection
- -font -foreground -highlightbackground -highlightcolor
- -highlightthickness -insertbackground -insertborderwidth -insertofftime
- -insertontime -insertwidth -justify -relief
- -selectbackground -selectborderwidth -selectforeground -takefocus
- -textvariable -xscrollcommand
- -disabledbackground -disabledforeground
- -invalidcommand -readonlybackground -show -state
+ (-invalidcommand -readonlybackground -show -state
-validate -validatecommand -width)
(:default-initargs
:textvariable (c? (^path))))
Index: cell-cultures/celtic/widget-item.lisp
diff -u cell-cultures/celtic/widget-item.lisp:1.7 cell-cultures/celtic/widget-item.lisp:1.8
--- cell-cultures/celtic/widget-item.lisp:1.7 Sat Jul 17 07:02:23 2004
+++ cell-cultures/celtic/widget-item.lisp Wed Jul 21 04:49:38 2004
@@ -33,7 +33,7 @@
(defmodel widget (family tk-object)
((name :initarg :name :accessor name
- :initform (c? (down$ (md-name self))))
+ :initform (c? (eko ("name" (type-of self))(down$ (md-name self)))))
(path :accessor path :initarg :path
:initform (c? (format nil "~a.~a"
(parent-path (fm-parent self))
@@ -82,7 +82,9 @@
;;; --- widget --------------------
-(defmacro def-widget (class (&key (std-factory t))
+(defmacro def-widget (class
+ superclasses
+ (&key (std-factory t))
(&rest std-slots)
(&rest tk-options) &rest defclass-options)
(multiple-value-bind (slots outputs)
@@ -104,7 +106,7 @@
into outputs
finally (return (values slot-defs outputs)))
`(progn
- (defmodel ,class (widget)
+ (defmodel ,class ,(or superclasses '(widget))
(,@(append std-slots slots))
, at defclass-options)
(defun ,(intern (format nil "MK-~a" class)) (&rest inits)
@@ -128,6 +130,46 @@
(mapcar (lambda (v)
(conc$ " " (tk-down$ v)))
(cdr list))) "}"))
+
+;;; --- vehicle for standard options -----------------------------------------
+
+(def-widget standard-widget ()
+ ()()
+ (-activebackground -activeborderwidth -activeforeground -anchor
+ -background -bitmap -borderwidth -cursor
+ -disabledforeground -disabledbackground -exportselection -font -foreground
+ -highlightbackground -highlightcolor -highlightthickness -image
+ -insertbackground -insertborderwidth -insertofftime -insertontime
+ -insertwidth -jump -justify -orient
+ -padx -pady -relief -repeatdelay
+ -repeatinterval -selectbackground -selectborderwidth -selectforeground
+ -setgrid -takefocus -text -textvariable
+ -troughcolor -underline -wraplength -xscrollcommand -yscrollcommand))
+
+;;; --- variable mirror widget mixin -----------------------------------------
+
+(defmodel tk-variable-mirror (model)
+ ((initial-value :initarg :initial-value :initform nil :accessor initial-value))
+ (:default-initargs
+ :md-value (c-in nil)
+ :command (c? (format nil "puts {callback ~s %s %d}"
+ (register-callback self 'cmd
+ (lambda (self id &rest args)
+ (declare (ignore id))
+ (destructuring-bind (new-value up-down) args
+ (declare (ignore up-down))
+ (setf (^md-value) (down$ new-value)))))))))
+
+(def-c-output .md-value ((self tk-variable-mirror))
+ (when (and new-value (not old-value-boundp))
+ (trc "tk-variable-mirror value" (type-of new-value) new-value)
+ (if (listp new-value)
+ (tk-send self "set ~a {~{~a~^ ~}}" (^path) new-value)
+ (tk-send self "set ~a ~s" (^path) new-value))))
+
+(def-c-output initial-value ((self tk-variable-mirror))
+ (when new-value
+ (setf (^md-value) new-value)))
;;; --- items -----------------------------------------------------------------------
Index: cell-cultures/celtic/window.lisp
diff -u cell-cultures/celtic/window.lisp:1.1 cell-cultures/celtic/window.lisp:1.2
--- cell-cultures/celtic/window.lisp:1.1 Sat Jul 17 07:02:23 2004
+++ cell-cultures/celtic/window.lisp Wed Jul 21 04:49:38 2004
@@ -21,10 +21,13 @@
(in-package :celtic)
+(define-symbol-macro .tkw (nearest self window))
+
;;; --- toplevel ---------------------------------------------
(def-widget toplevel ()
()
+ ()
(-borderwidth -cursor -highlightbackground -highlightcolor
-highlightthickness -padx -pady -relief
-takefocus -background -tk-class -colormap
@@ -33,7 +36,8 @@
;; --- panedwindow -----------------------------------------
-(def-widget panedwindow (:std-factory nil)
+(def-widget panedwindow ()
+ (:std-factory nil)
()
(-background -borderwidth -cursor -height
-orient -relief -width
@@ -76,14 +80,13 @@
(defmethod path ((self window)) ".")
(defmethod parent-path ((self window)) "")
-(define-symbol-macro .tkw (nearest self window))
-
; ---
(defun tk-send (self fmt$ &rest args)
"send a string to wish"
(let ((text (apply 'format nil fmt$ args)))
- (when (search "pack " text) ;; *debug-tk*
+ (when (find-if (lambda (s) (search s text))
+ '(".font-size" )) ;; *debug-tk*
(format t "~&tk-send> ~A~%" text))
(format (wish .tkw) "~A~%" text)
#+needed? (force-output (wish .tkw))))
More information about the Cells-cvs
mailing list