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 @@ ,@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))))) ,@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)) ,@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))))