July 2004 - cells-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-cvs] CVS update: cell-cultures/clyde/visual-apropos/visual-apropos.lisp
by Kenny Tilton 21 Jul '04

21 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde/visual-apropos In directory common-lisp.net:/tmp/cvs-serv705/clyde/visual-apropos Modified Files: visual-apropos.lisp Log Message: Date: Wed Jul 21 04:49:40 2004 Author: ktilton Index: cell-cultures/clyde/visual-apropos/visual-apropos.lisp diff -u cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.4 cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.5 --- cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.4 Thu Jul 8 20:53:05 2004 +++ cell-cultures/clyde/visual-apropos/visual-apropos.lisp Wed Jul 21 04:49:39 2004 @@ -24,44 +24,42 @@ ;; ------------------- ;; to run, enter following in repl: ;; -;; (tk-test 'vis-apropos) +;; (tk-test 'visual-apropos) ;; -(defun vis-apropos () - (make-be 'visual-apropos - :sub-symbol (c-in 'padding))) - -(defmodel visual-apropos (frame-stack) +(defmodel visual-apropos (window) ((symbols :initarg :symbols :initform nil :accessor symbols) - (sub-symbol :initarg :sub-symbol :initform nil :accessor sub-symbol)) + (sub-symbol :initarg :sub-symbol :initform 'thread :accessor sub-symbol)) (:default-initargs :symbols (c-in nil) - :pady 2 - :padx 4 - :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") :kids (c? (list - (search-for-symbol) - (mk-frame-row - :padx 8 - :layout (pack-layout? "-side left -fill x") + (mk-frame-stack + :pady 2 + :padx 4 + :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") :kids (c? (list - (mk-frame-stack + (search-for-symbol) + (mk-frame-row + :padx 8 :kids (c? (list - (mk-checkbutton :md-name :exported-only - :text "Exported Only" - :underline 1 - :md-value (c-in nil) - :command (lambda (self) - (setf (^md-value) (not (^md-value))))) - (show-which-symbols)))) - (package-filtering)))) - (symbol-list))))) + (mk-frame-stack + :kids (c? (list + (mk-checkbutton :md-name :exported-only + :text "Exported Only" + :underline 1 + :md-value (c-in nil) + :command (c? (Tk-callback self 'cmd + (lambda (self key &rest args) + (declare (ignore key args)) + (setf (^md-value) (not (^md-value))))))) + (show-which-symbols)))) + (package-filtering)))) + (symbol-list)))))))) (defun search-for-symbol () (mk-frame-row :relief 'ridge :padx 8 - :layout (pack-layout? "-side left -fill x -anchor nw") :kids-layout (c? (format nil "pack ~a -side left; pack ~a -side left -expand 1 -fill x; pack ~a -side right" (path (kid1 self)) @@ -74,16 +72,18 @@ :width 64) (mk-button :text "Search" :underline 0 - :command (lambda (self) - (setf (symbols (upper self visual-apropos)) - (apropos-list (text (fm^ :search-string)))))))))) + :command (c? (Tk-callback self 'cmd + (lambda (self key &rest args) + (declare (ignore key args)) + (setf (symbols (upper self visual-apropos)) + (apropos-list (text (fm^ :search-string)))))))))))) ; --- symbol package filtering ------------------------------- (defun package-filtering () (mk-labelframe-row :text "Package(s) to Search" - :layout (pack-layout? "-side left -fill x -expand 1") + ;;:layout (pack-layout? "-side left -fill x -expand 1") :kids (c? (list (mk-checkbutton :md-name :all-pkgs :text "All" @@ -125,7 +125,7 @@ (defun symbol-list () (mk-frame-stack :md-name :symbol-list - :layout (pack-layout? "-side top -expand 1 -fill both") + ;;:layout (pack-layout? "-side top -expand 1 -fill both") :width 64 :background 'red :kids (c? (list @@ -208,13 +208,15 @@ (defmodel va-sorter (sort-button) ((sort-string-fn :initform 'string :initarg :sort-string-fn :accessor sort-string-fn)) (:default-initargs - :command (lambda (self) - (let* ((ss (fm^ :sym-sort))) - (if (eq self (or (md-value ss) (kid1 ss))) - (setf (sort-button-predicate self) - (if (eq (sort-button-predicate self) 'va-string<) - 'va-string> 'va-string<)) - (setf (md-value ss) self)))) + :command (c? (Tk-callback self 'cmd + (lambda (self key &rest args) + (declare (ignore key args)) + (let* ((ss (fm^ :sym-sort))) + (if (eq self (or (md-value ss) (kid1 ss))) + (setf (sort-button-predicate self) + (if (eq (sort-button-predicate self) 'va-string<) + 'va-string> 'va-string<)) + (setf (md-value ss) self)))))) :sort-button-predicate (c-in 'va-string<) :sort-button-key (c? (lambda (si) (funcall (^sort-string-fn)

1 0

[cells-cvs] CVS update: cell-cultures/utils-kt/strings.lisp
by Kenny Tilton 21 Jul '04

21 Jul '04

Update of /project/cells/cvsroot/cell-cultures/utils-kt In directory common-lisp.net:/tmp/cvs-serv705/utils-kt Modified Files: strings.lisp Log Message: Date: Wed Jul 21 04:49:40 2004 Author: ktilton Index: cell-cultures/utils-kt/strings.lisp diff -u cell-cultures/utils-kt/strings.lisp:1.1 cell-cultures/utils-kt/strings.lisp:1.2 --- cell-cultures/utils-kt/strings.lisp:1.1 Sat Jun 26 11:38:43 2004 +++ cell-cultures/utils-kt/strings.lisp Wed Jul 21 04:49:40 2004 @@ -159,11 +159,12 @@ (down$ s)) (defun down$ (s) - (etypecase s + (typecase s (null "") (string (string-downcase s)) (number (format nil "~a" s)) - (symbol (string-downcase (symbol-name s))))) + (symbol (string-downcase (symbol-name s))) + (cons (format nil "~{~(~a~)~^ ~}" s)))) (defun lower$ (s) (string-downcase s))

1 0

21 Jul '04

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

1 0

[cells-cvs] CVS update: cell-cultures/cells/defmodel.lisp cell-cultures/cells/defpackage.lisp cell-cultures/cells/model-object.lisp
by Kenny Tilton 21 Jul '04

21 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv705/cells Modified Files: defmodel.lisp defpackage.lisp model-object.lisp Log Message: Date: Wed Jul 21 04:49:37 2004 Author: ktilton Index: cell-cultures/cells/defmodel.lisp diff -u cell-cultures/cells/defmodel.lisp:1.1 cell-cultures/cells/defmodel.lisp:1.2 --- cell-cultures/cells/defmodel.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/defmodel.lisp Wed Jul 21 04:49:37 2004 @@ -80,6 +80,7 @@ (:metaclass ,(or (find :metaclass options :key #'car) 'standard-class))) + #-allegro-v6.2 (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs) (declare (ignore slot-names iargs)) ,(when (and directsupers (not (member 'model-object directsupers))) @@ -121,4 +122,5 @@ ) )) )) - slotspecs)))) \ No newline at end of file + slotspecs)))) + Index: cell-cultures/cells/defpackage.lisp diff -u cell-cultures/cells/defpackage.lisp:1.4 cell-cultures/cells/defpackage.lisp:1.5 --- cell-cultures/cells/defpackage.lisp:1.4 Sun Jul 4 11:59:41 2004 +++ cell-cultures/cells/defpackage.lisp Wed Jul 21 04:49:37 2004 @@ -47,7 +47,7 @@ #:with-integrity #:with-deference #:without-c-dependency #:self #:.cache #:c-lambda #:.cause #:defmodel #:c-awaken #:def-c-output #:def-c-unchanged-test - #:new-value #:old-value #:c... + #:new-value #:old-value #:old-value-boundp #:c... #:make-be #:mkpart #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids #:cell-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot Index: cell-cultures/cells/model-object.lisp diff -u cell-cultures/cells/model-object.lisp:1.3 cell-cultures/cells/model-object.lisp:1.4 --- cell-cultures/cells/model-object.lisp:1.3 Thu Jul 8 20:53:04 2004 +++ cell-cultures/cells/model-object.lisp Wed Jul 21 04:49:37 2004 @@ -154,7 +154,6 @@ (progn ;; next bit revised to avoid double-output of optimized cells (when (eql '.kids slot-name) (bwhen (sv (slot-value self '.kids)) - (trc "soon will output initial kids of" self) (md-kids-change self sv nil :md-awaken-slot))) (c-output-initially self slot-name)))))))

1 0

[cells-cvs] CVS update: cell-cultures/celtic/listbox.lisp cell-cultures/celtic/window.lisp cell-cultures/celtic/button.lisp cell-cultures/celtic/callback.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
by Kenny Tilton 17 Jul '04

17 Jul '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv19012/celtic Modified Files: button.lisp callback.lisp celtic.lisp celtic.lpr demos.lisp frame.lisp menu.lisp scrolling.lisp textual.lisp widget-item.lisp Added Files: listbox.lisp window.lisp Log Message: Date: Sat Jul 17 07:02:23 2004 Author: ktilton Index: cell-cultures/celtic/button.lisp diff -u cell-cultures/celtic/button.lisp:1.5 cell-cultures/celtic/button.lisp:1.6 --- cell-cultures/celtic/button.lisp:1.5 Thu Jul 8 20:53:05 2004 +++ cell-cultures/celtic/button.lisp Sat Jul 17 07:02:23 2004 @@ -30,8 +30,7 @@ -font -foreground -highlightbackground -highlightcolor -highlightthickness -image -justify -padx -pady -relief -repeatdelay -repeatinterval -takefocus -text -textvariable -underline -wraplength - (-command nil) - -compound -default -height -overrelief -state -width)) + -command -compound -default -height -overrelief -state -width)) (def-widget checkbutton () () @@ -41,16 +40,19 @@ -highlightthickness -image -justify -padx -pady -relief -takefocus -text -textvariable -underline -wraplength - (-command nil) - -height -indicatoron -offrelief -offvalue -onvalue + -command -height -indicatoron -offrelief -offvalue -onvalue -overrelief -selectcolor -selectimage -state -tristateimage -tristatevalue (-tk-variable -variable) -width) (:default-initargs - :command (lambda (self) - (setf (^md-value) (not (^md-value)))))) + :md-value (c-in nil) + :command (c? (tk-callback self 'toggle + (lambda (self id &rest args) + (declare (ignore id args)) + (eko ("toggling" self) + (setf (^md-value) (not (^md-value))))))))) (def-c-output .md-value ((self checkbutton)) - (tk-format "set ~a ~a" + (tk-send self "set ~a ~a" (down$ (md-name self)) (if new-value 1 0))) @@ -62,14 +64,15 @@ -highlightthickness -image -justify -padx -pady -relief -takefocus -text -textvariable -underline -wraplength - (-command nil) - -height -indicatoron -offrelief -value + -command -height -indicatoron -offrelief -value -overrelief -selectcolor -selectimage -state -tristateimage -tristatevalue (-tk-variable -variable) -width) (:default-initargs - :command (lambda (self) - (setf (selection (upper self selector)) - (value self))))) + :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 () () @@ -77,23 +80,26 @@ -font -foreground -highlightbackground -highlightcolor -highlightthickness -orient -relief -repeatdelay -repeatinterval -takefocus -troughcolor - -bigincrement (-command nil) -digits -from + -bigincrement -command -digits -from (-tk-label -label) (-tk-length -length) -resolution -showvalue -sliderlength -sliderrelief -state -tickinterval -to (-tk-variable -variable) -width) (:default-initargs :md-value (c-in nil) - :command (lambda (self) - (setf (^md-value) (tk-eval (format nil "~a get" (^path))))))) + :command (c? (tk-callback self 'radio-set + (lambda (self id &rest args) + (declare (ignore id)) + (eko ("scale now" self) + (setf (^md-value) (car args)))))))) (def-c-output .md-value ((self scale)) (when new-value (if (listp new-value) - (tk-format "set ~a {~{~a~^ ~}}" (^path) new-value) - (tk-format "~a set ~a" (^path) 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 @@ -103,20 +109,30 @@ -xscrollcommand -buttonbackground -buttoncursor -buttondownrelief -buttonuprelief - (-command nil) -disabledbackground -disabledforeground + -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 (lambda (self) - (setf (^md-value) - (eko ("spinbox value now" self) - (tk-eval-list (format nil "~a get" (^path)))))))) + :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-format "set ~a {~{~a~^ ~}}" (^path) new-value) - (tk-format "~a set ~a" (^path) 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))) Index: cell-cultures/celtic/callback.lisp diff -u cell-cultures/celtic/callback.lisp:1.1 cell-cultures/celtic/callback.lisp:1.2 --- cell-cultures/celtic/callback.lisp:1.1 Thu Jul 8 20:53:05 2004 +++ cell-cultures/celtic/callback.lisp Sat Jul 17 07:02:23 2004 @@ -19,21 +19,20 @@ |# -(in-package :celtic) -(defparameter *callbacks* (make-hash-table :test #'equal)) +(in-package :celtic) (defun register-callback (self callback-id fun) (let ((id (intern (string-upcase (format nil "~a.~a" (path self) callback-id))))) - (assert (not (gethash id *callbacks*))) + (assert (not (gethash id (callbacks .tkw)))) (trc "registering callback" self :id id) - (setf (gethash id *callbacks*) (cons fun self)) + (setf (gethash id (callbacks .tkw)) (cons fun self)) id)) -(defun dispatch-callback (callback) +(defun dispatch-callback (window callback) (destructuring-bind (callback-id &rest callback-args) callback - (let ((func-self (gethash callback-id *callbacks*))) + (let ((func-self (gethash callback-id (callbacks window)))) ;(format t "sym:~S fun:~A~%" sym func-self) ;(force-output) (when (not func-self) @@ -44,75 +43,52 @@ (declare (ignore func-self)) (format t "~&known callback key ~a, type ~a, pkg ~a" key (type-of key)(when (typep key 'symbol) (symbol-package key)))) - *callbacks*)) + (callbacks window))) (when (car func-self) - (apply (car func-self) (cdr func-self) callback-args))))) + (apply (car func-self) (cdr func-self) callback callback-args))))) (defun after (self time func) "Usage: (after self <time> <func>)) ...after <time> msec call function <func>" - (register-callback self "after" func) - (tk-format "after ~a {puts -nonewline {(\"~A\") };flush stdout}" - time (widget-callback-id self "after"))) + (tk-send self "after ~a {puts {callback ~a}}" + time (register-callback self 'after func))) - -(defmethod tk-eval (form$) - (car (tk-eval-list form$))) +(defun tk-eval (self form$) + (car (tk-eval-list self form$))) (defun peek-char-no-hang (stream) - (let ((c (read-char-no-hang stream nil :eof))) - (unless (eql c :eof) - (unread-char c stream) - c))) - -(defun tk-eval-list (form$) - ; - ; clear stdin - ; - (trc "attempting peek") - (loop while (peek-char-no-hang *w*) - do (trc "got peek") - (if (eql #$ (peek-char t *w*)) - (let ((msg (read *w*))) - (trc "tk-eval-list > buffer not empty" msg) - (when (eql 'callback (first msg)) - (dispatch-callback (rest msg)))) - (c-break "tk-eval-list error 1: ~a" (read-line *w*)))) - (trc "done peek") - ; - ; now evaluate form$ in Tk - ; - (tk-send - (format nil "puts -nonewline {(};puts -nonewline [~a];puts {)};flush stdout" - form$)) - ; - ; retrieve result - ; - (if (eql #\( (peek-char t *w* nil nil)) - (let ((*readtable* (copy-readtable))) - (trc "!!! got left parens" form$) - (set-macro-character #\} (get-macro-character #$)) - (set-macro-character #\{ - #'(lambda (s c1) - (declare (ignore c1)) - (read-delimited-list #\} s t))) - (return-from tk-eval-list (eko ("left par read") (read *w*)))) - (if (peek-char t *w* nil nil) - (c-break "tk-eval-list error 2: ~a" (read-line *w*)) - (trc "looks like wish exited")))) - -(def-c-output command ((self widget)) - (when (and new-value (^command-is-callback)) - (configure self "-command" - (format nil - "puts {(callback ~a)};flush stdout; list" ;; list cuz Tk feeds args to some - ; widgets' commands and list will consume syntax - (register-callback self "command" new-value))))) + (and (listen stream) (peek-char t stream))) + +(defun tk-eval-list (self form$) + (let* ((id (copy-symbol 'eval-list)) + result + (full-id (register-callback self id + (lambda (self id &rest args) + (trc "tk-eval-list" self id args) + (setf result args))))) + (tk-send self + (format nil + "puts -nonewline {callback ~a };puts [~a]" full-id form$)) + (tk-listen .tkw full-id) + result)) (def-c-output bindings () ;;; (w widget) event fun) (loop for binding in new-value for name = (create-name) do (destructuring-bind (event . fn) binding (declare (ignorable event)) - (tk-format "bind ~a ~a {puts {(callback ~a)};flush stdout}" + (tk-send self "bind ~a ~a {puts {callback ~a}}" (^path) event (register-callback self name fn))))) + +(defun tk-callback (self id-suffix fn &optional command) + (format nil + (or command + (if (tk-command-is-passed-args self) + "puts -nonewline {callback ~s }; puts" + "puts {callback ~s}")) + (register-callback self id-suffix fn))) + +(defmethod tk-command-is-passed-args ((other t)) nil) +(defmethod tk-command-is-passed-args ((self scale)) 1) + + Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.5 cell-cultures/celtic/celtic.lisp:1.6 --- cell-cultures/celtic/celtic.lisp:1.5 Thu Jul 8 20:53:05 2004 +++ cell-cultures/celtic/celtic.lisp Sat Jul 17 07:02:23 2004 @@ -35,10 +35,8 @@ "execute program with args a list containing the arguments passed to the program if wt is non-nil, the function will wait for the execution of the program to return. returns a two way stream connected to stdin/stdout of the program" - - (let ((fullstring program)) - (dolist (a args) - (setf fullstring (concatenate 'string fullstring " " a))) + (declare (ignorable args)) + (let ((fullstring (format nil "~a~{~^ ~a~}" program args))) #+:cmupty (let ((proc (run-program program args :input t :output t :wait wt :pty :stream :error :output))) (unless proc (error "Cannot create process.")) @@ -75,36 +73,6 @@ proc ))) - -;;; global var for holding the communication stream -(defvar *w* nil) - -;;; verbosity of debug messages, if true, then all communication -;;; with tk is echoed to stdout -(defparameter *debug-tk* nil) - -;;; start wish and set *w* -(defun tk-start () - (setf *w* (do-execute "wish" '("-name" "Visual Apropos")))) - -(defun tk-format (fmt$ &rest args) - (tk-send (apply 'format nil fmt$ args))) - -(defun tk-send (text) - "send a string to wish" - (when t ;(search "font-face" text) ;; *debug-tk* - (format t "~&tk-send> ~A~%" text) - (force-output)) - (format *w* "~A~%" text) - (force-output *w*)) - -;;; wrapper around read-line to compensate for slight differences between lisp versions -(defun tk-read () - (let ((c (read-line *w* nil nil))) - ;; (trc "tk-read> " c) - #+:lispworks (setf c (string-right-trim '(#\Newline #\Return #\Linefeed) c)) - c)) - (defun convert(from to) (close (do-execute "convert" (list from to) t))) @@ -112,6 +80,8 @@ ;; incremental counter to create unique numbers (let ((counter 1)) + (defun tk-names-reset() + (setf counter 1)) (defun get-counter() (incf counter))) @@ -120,31 +90,59 @@ (format nil "w~A" (get-counter))) ;;;; main event loop, runs until stream is closed by wish (wish exited) or -;;;; the variable *exit-mainloop* is set +;;;; the variable *exit-tk-listen* is set -(defvar *exit-mainloop* nil) +(defvar *exit-tk-listen* nil) -(defvar *tk-root*) +(defun tk-listen (window &optional exit-callback-id &aux (wish (wish window))) + (let ((*exit-tk-listen* nil) + (*read-eval* nil) ;;safety against malicious clients + (*readtable* (copy-readtable))) + (set-macro-character #\} (get-macro-character #\))) + (set-macro-character #\{ + #'(lambda (s c1) + (declare (ignore c1)) + (read-delimited-list #\} s t))) -(defun mainloop() - (trc nil "mainloop !!! *w* is" *w*) - (let ((*exit-mainloop* nil) - (*read-eval* nil)) ;;safety against malicious clients (loop - (let ((msg (read-preserving-whitespace *w* nil nil))) - (when (null msg) (return)) - - (if (consp msg) - (progn - (assert (eql 'callback (first msg))) - (trc "mainloop dispatching callback" msg) - (dispatch-callback (rest msg))) - (let ((emsg (read-line *w* nil nil))) - (trc "error msg:" msg emsg))) - - (when *exit-mainloop* - (tk-send "exit") - (return)))))) + (let ((msg$ (read-line #+not read-preserving-whitespace wish nil nil))) + (when (null msg$) + (return)) + (trc "tk-listen> read:" msg$) + (loop with start = 0 + and state = 'init + and func and self and callback-id and args + for (msg start-next) = (multiple-value-list + (read-from-string msg$ nil nil :start start)) + while msg + do (setf start start-next) + (ecase state + (init + (case msg + (callback (setf state 'get-callback-id)) + (otherwise (c-break "TKERR> " msg$)))) + (get-callback-id + (assert msg) + (let ((callback-info (gethash msg (callbacks window)))) + (assert callback-info () "No callback with ID ~a" msg) + (setf callback-id msg + func (car callback-info) + self (cdr callback-info) + state 'get-args))) + (get-args + (pushnew msg args))) + finally + (setf args (nreverse args)) + (apply func self callback-id args) + (cond + (*exit-tk-listen* + (tk-send window "exit") + (return)) + ((And exit-callback-id ;; play it safe + (or (trc "comparing callback id" callback-id exit-callback-id + (eql callback-id exit-callback-id)) + (eql callback-id exit-callback-id))) + (return-from tk-listen)))))))) ;; create pathname from master widget <master> and widget name <name> (defun create-path (master name) @@ -154,22 +152,17 @@ (format nil "~A.~A" master-path name))) (defgeneric grid-columnconfigure (w c o v)) -(defmethod grid-columnconfigure (widget column option value) - (tk-format "grid columnconfigure ~a ~a -~a {~a}" (path widget) column option value)) +(defmethod grid-columnconfigure (self column option value) + (tk-send self "grid columnconfigure ~a ~a -~a {~a}" (path self) column option value)) (defgeneric grid-rowconfigure (w r o v)) -(defmethod grid-rowconfigure (widget row option value) - (tk-format "grid rowconfigure ~a ~a -~a {~a}" (path widget) row option value)) +(defmethod grid-rowconfigure (self row option value) + (tk-send self "grid rowconfigure ~a ~a -~a {~a}" (path self) row option value)) (defgeneric grid-configure (w o v)) -(defmethod grid-configure (widget option value) - (tk-format "grid configure ~a -~a {~a}" (path widget) option value)) +(defmethod grid-configure (self option value) + (tk-send self "grid configure ~a -~a {~a}" (path self) option value)) + + -(defun tk-test (fn) - (let ((*debug-tk* nil) - (*callbacks* (make-hash-table))) - (cell-reset) - (tk-start) - (let ((*tk-root* (funcall fn))) - (mainloop)))) Index: cell-cultures/celtic/celtic.lpr diff -u cell-cultures/celtic/celtic.lpr:1.4 cell-cultures/celtic/celtic.lpr:1.5 --- cell-cultures/celtic/celtic.lpr:1.4 Thu Jul 8 20:53:05 2004 +++ cell-cultures/celtic/celtic.lpr Sat Jul 17 07:02:23 2004 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "6.2 [Windows] (May 12, 2004 22:13)"; common-graphics: "1.389.2.105.2.14"; -*- +;; -*- lisp-version: "6.2 [Windows] (Jul 16, 2004 8:32)"; common-graphics: "1.389.2.105.2.14"; -*- (in-package :common-graphics-user) @@ -8,14 +8,16 @@ :application-type (intern "Standard EXE" (find-package :keyword)) :modules (list (make-instance 'module :name "celtic.lisp") (make-instance 'module :name "widget-item.lisp") + (make-instance 'module :name "window.lisp") (make-instance 'module :name "frame.lisp") (make-instance 'module :name "canvas.lisp") (make-instance 'module :name "textual.lisp") (make-instance 'module :name "button.lisp") (make-instance 'module :name "menu.lisp") (make-instance 'module :name "scrolling.lisp") - (make-instance 'module :name "demos.lisp") - (make-instance 'module :name "callback.lisp")) + (make-instance 'module :name "callback.lisp") + (make-instance 'module :name "listbox.lisp") + (make-instance 'module :name "demos.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells")) :libraries nil Index: cell-cultures/celtic/demos.lisp diff -u cell-cultures/celtic/demos.lisp:1.1 cell-cultures/celtic/demos.lisp:1.2 --- cell-cultures/celtic/demos.lisp:1.1 Thu Jul 8 20:53:05 2004 +++ cell-cultures/celtic/demos.lisp Sat Jul 17 07:02:23 2004 @@ -21,32 +21,165 @@ (in-package :celtic) -(defun font-view () +(defun tk-test (root-class) + (cell-reset) + (tk-names-reset) + (tk-listen (make-be root-class))) + +(defun mk-font-view () (make-be 'font-view)) -(defmodel font-view (frame-stack) - ((symbols :initarg :symbols :initform nil :accessor symbols) - (sub-symbol :initarg :sub-symbol :initform nil :accessor sub-symbol)) +(defmodel all (window) + () (:default-initargs - :md-value (c? (let ((ff (eko ("fview ff") (tk-eval-list "font families")))) - (assert (consp ff)) - ff)) - :pady 2 :padx 4 - :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") - :kids (c? (list - (mk-spinbox :md-name :font-face - :md-value (c-in (car (^md-value))) - :tk-values (c? (md-value .parent))) - (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 ;; format nil "{{~{~a~^ ~}} ~a}" ;; eg, {{wp greek century} 24} - (md-value (fm^ :font-face)) - (md-value (fm^ :font-size))))))))) + :kids (c? (list + (demo-all-menubar) + (mk-frame-stack + :layout (pack-self) + :kids (c? (list + (mk-frame-row + :kids (c? (list + (mk-button :text "Press Me" + :layout nil + :command (tk-callback self 'hello + (lambda (self key &rest args) + (trc "hello world" self key args)))) + (mk-entry :text "Enter Me" + :layout nil)))) + (mk-frame-row + :kids (c? (list + (mk-checkbutton :md-name :check-me + :text "check Me" + :md-value (c-in t) + :layout nil) + (mk-radiobutton :text "yes" + :value 'yes + :layout nil) + (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") + :list-item-keys (list-all-packages) + :list-item-factory (lambda (pkg) + (make-instance 'listbox-item + :md-value pkg + :item-text (down$ (package-name pkg))))) + (mk-spinbox + :initial-value (c? (without-c-dependency + (when (^tk-values) + "celtic"))) + :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"))) + ))))))) + +(defun demo-all-menubar () + (mk-menubar + :kids (c? (list + (mk-menu-entry-cascade + :label "File" + :kids (c? (list + (mk-menu + :kids (c? (list + (mk-menu-entry-command :label "New" + :command "exit") + (mk-menu-entry-command :label "Open" + :command "exit") + (mk-menu-entry-command :label "Close" + :command "exit") + (mk-menu-entry-separator) + (mk-menu-entry-command :label "Quit" + :state (c? (if (md-value (fm^ :check-me)) + 'normal 'disabled)) + :command "exit"))))))) + (mk-menu-entry-cascade + :label "Edit" + :kids (c? (list + (mk-menu + :kids (c? (list + (mk-menu-entry-command :label "Undo" + :command (tk-callback .tkw 'undo + (lambda (self id &rest args) + (trc "edit menu undo" self id args)))) + (mk-menu-entry-separator) + (mk-menu-entry-command :label "Cut" + :command "exit") + (mk-menu-entry-command :label "Copy" + :command "exit") + (mk-menu-entry-command :label "Paste" + :command "exit") + (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-entry-separator) + (mk-menu-entry-cascade + :label "Font Size" + :menu (c? (path (kid1 self))) + :kids (c? (list + (mk-menu + :kids (c? (list + (mk-menu-entry-radiobutton + :label "9" :value 9 + :tk-variable "fontsize" + :command nil) + (mk-menu-entry-radiobutton + :label "12" :value 12 + :tk-variable "fontsize" + :command nil) + (mk-menu-entry-radiobutton + :label "14" :value 14 + :tk-variable "fontsize" + :command nil))))))) + (mk-menu-entry-separator) + (mk-menu-entry-checkbutton :label "Italic" + :command nil) + (mk-menu-entry-checkbutton :label "Bold" + :command nil) + )))))))))) +(defmodel font-view (window) + () + (:default-initargs + :title$ "Font View" + :kids (c? (list (mk-frame-stack + :md-value (c? (tk-eval-list self "font families")) + :pady 2 :padx 4 + :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") + :kids (c?(list + (mk-spinbox :md-name :font-face + :md-value (c-in (car (^md-value))) + :tk-values (c? (md-value .parent))) + (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 ;; format nil "{{~{~a~^ ~}} ~a}" ;; eg, {{wp greek century} 24} + (md-value (fm^ :font-face)) + (md-value (fm^ :font-size)))))))))))) (defun font-view-2 () (make-be 'font-view-2)) @@ -57,3 +190,33 @@ :orient 'vertical :kids (c? (loop repeat 2 collecting (make-instance 'font-view))))) + +;;; ---- toplevel -------------------------------- + +(defmodel tl-popper (frame-stack) + () + (:default-initargs + :pady 2 :padx 4 + :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") + :kids (c? (list + (mk-button :text "Open" + :underline 0 + :command (lambda (self) + (declare (ignore self)) + (make-be 'file-open))))))) + + +(defmodel file-open (toplevel) + () + (:default-initargs + :md-value (c? (directory "\\windows\\fonts\\*.ttf")) + :pady 2 :padx 4 + :kids (c? (list + (mk-spinbox :md-name :font-face + :md-value (c-in (car (^md-value))) + :tk-values (c? (mapcar 'pathname-name (md-value .parent)))) + (mk-button :text "Open" + :underline 0 + :command (lambda (self) + (tk-send self "destroy ~a" (path (upper self toplevel))) + (not-to-be (upper self toplevel)))))))) \ No newline at end of file Index: cell-cultures/celtic/frame.lisp diff -u cell-cultures/celtic/frame.lisp:1.5 cell-cultures/celtic/frame.lisp:1.6 --- cell-cultures/celtic/frame.lisp:1.5 Thu Jul 8 20:53:05 2004 +++ cell-cultures/celtic/frame.lisp Sat Jul 17 07:02:23 2004 @@ -43,7 +43,7 @@ (def-c-output kids-layout () (when new-value - (tk-send new-value))) + (tk-send self new-value))) (defmodel row-mixin (inline-mixin) () @@ -67,7 +67,7 @@ (def-c-output selection () (when new-value - (tk-format "set ~a ~a" + (tk-send self "set ~a ~a" (down$ (tk-variable self)) (down$ (md-name new-value))))) @@ -113,33 +113,4 @@ (defmodel labelframe-row (row-mixin labelframe-selector)()) (defun mk-labelframe-row (&rest init-args) (apply 'make-instance 'labelframe-row init-args)) - -;---- panedwindow ----------------------------------- - -(def-widget panedwindow (:std-factory nil) - () - (-background -borderwidth -cursor -height - -orient -relief -width - -handlepad - -handlesize - -opaqueresize - -sashcursor - -sashpad - -sashrelief - -sashwidth - -showhandle) - (:default-initargs - :layout nil)) - -(defmethod make-tk-instance ((self panedwindow)) - (tk-format "panedwindow ~a -orient ~(~a~)" - (^path) (or (orient self) "vertical")) - (tk-format "pack ~a -expand yes -fill both" (^path))) - -(defmethod parent-path ((self panedwindow)) (^path)) - -(defmethod md-awaken :after ((self panedwindow)) - (with-integrity (:panedwindow :finalize self) - (loop for k in (^kids) - do (tk-format "~a add ~a" (^path) (path k))))) Index: cell-cultures/celtic/menu.lisp diff -u cell-cultures/celtic/menu.lisp:1.3 cell-cultures/celtic/menu.lisp:1.4 --- cell-cultures/celtic/menu.lisp:1.3 Thu Jul 8 20:53:05 2004 +++ cell-cultures/celtic/menu.lisp Sat Jul 17 07:02:23 2004 @@ -21,64 +21,151 @@ (in-package :celtic) -(def-widget menu () - () +#| do list + +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)) (-activebackground -activeborderwidth -activeforeground -background -borderwidth -cursor -disabledforeground -font -foreground -relief -takefocus -postcommand -selectcolor -tearoff -tearoffcommand - -title (-tk-type -type))) + (-title nil) (-tk-type -type))) + +(defmethod make-tk-instance ((self menu)) + (trc "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)))) + +;;; --- menu bars ----------------------------------- + +(defmodel menubar (menu)()) +(defun mk-menubar (&rest inits) (apply 'make-instance 'menubar inits)) + +(defmethod make-tk-instance ((self menubar)) + (tk-send self (format nil "menu ~a -tearoff 0 -type menubar" (^path))) + (tk-send self (format nil ". configure -menu ~a" (^path)))) + +;;; --- menu entries ------------------------------------ + +(defmodel menu-entry (tk-object) + ((index :initarg :index :accessor index + :initform (c? (kid-no self))) + (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 not-to-be :after ((self menu-entry)) + (trc nil "whacking menu-entry" self) + (tk-send self "~a delete ~a" (path .parent) (index self))) + +(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))) + +(defmacro def-menu-entry (class + (&optional (superclasses '(menu-entry))) + (&rest std-slots) + (&rest tk-options) + &rest defclass-options + &aux (std-factory t)) + (multiple-value-bind (slots outputs) + (loop for tk-option-def in tk-options + for slot-name = (intern (de- (if (atom tk-option-def) + tk-option-def (car tk-option-def)))) + collecting `(,slot-name :initform nil + :initarg ,(intern (string slot-name) :keyword) + :accessor ,slot-name) + into slot-defs + when (or (atom tk-option-def) + (cadr tk-option-def)) + collecting `(def-c-output ,slot-name ((self ,class)) + (when new-value + (configure self ,(string (if (atom tk-option-def) + tk-option-def (cadr tk-option-def))) + new-value))) + + into outputs + finally (return (values slot-defs outputs))) + `(progn + (defmodel ,class (,@superclasses) + (,@(append std-slots slots)) + ,@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-widget menubutton () +(def-menu-entry menu-entry-separator () () - (-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)) - -;--------------------------------------------------- - -(def-widget listbox () - () - (-activestyle -background -borderwidth -cursor - -disabledforeground -exportselection -font -foreground - -height -highlightbackground -highlightcolor -highlightthickness - -relief -selectbackground -selectborderwidth -selectforeground - -setgrid -state -takefocus -width - -xscrollcommand -yscrollcommand - -listvariable -selectmode) + (-columnbreak) (:default-initargs - :bindings (c? (when (selector self) - (list (cons "<<ListboxSelect>>" - (lambda (self) - (setf (selection (selector self)) - (car (listbox-get-selection self)))))))))) - -(defmodel listbox-item (tk-object) - ((item-text :initarg :item-text :accessor item-text - :initform (c? (format nil "~a" (^md-value)))))) - -(defmethod make-tk-instance ((self listbox-item)) - (tk-format "~A insert end ~s" - (path .parent) - (^item-text))) - -(def-c-output .kids ((self listbox)) - (when old-value - (tk-format "~A delete ~a ~a" - (^path) - 0 (1- (length old-value))))) - -(defmethod listbox-get-selection ((l listbox)) - (tk-send - (format nil "puts -nonewline {(};puts -nonewline [~a curselection];puts {)};flush stdout" - (path l))) - (read *w*)) + :entry-type 'separator)) + +(def-menu-entry menu-entry-usable () + () + (-activebackground -activeforeground -accelerator -background + -bitmap -columnbreak + -compound -font -foreground -hidemargin + -image -label -state -underline)) + +(def-menu-entry menu-entry-cascade ((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))) +(def-menu-entry menu-entry-command ((menu-entry-usable)) + () + (-command) + (:default-initargs + :entry-type 'command)) + +(def-menu-entry menu-entry-button ((menu-entry-command)) + () + ((-tk-variable -variable) -selectcolor -selectimage -indicatoron)) + +(def-menu-entry menu-entry-checkbutton ((menu-entry-button)) + () + (-offvalue -onvalue) + (:default-initargs + :entry-type 'checkbutton)) + +(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)) Index: cell-cultures/celtic/scrolling.lisp diff -u cell-cultures/celtic/scrolling.lisp:1.3 cell-cultures/celtic/scrolling.lisp:1.4 --- cell-cultures/celtic/scrolling.lisp:1.3 Thu Jul 8 20:53:05 2004 +++ cell-cultures/celtic/scrolling.lisp Sat Jul 17 07:02:23 2004 @@ -29,7 +29,7 @@ -takefocus -troughcolor -activerelief -command -elementborderwidth -width)) -(defmodel scrolled-list (frame-row) +(defmodel scrolled-list (frame-selector) ((list-item-keys :initarg :list-item-keys :accessor list-item-keys :initform nil) (list-item-factory :initarg :list-item-factory :accessor list-item-factory :initform nil) (list-height :initarg :list-height :accessor list-height :initform nil)) @@ -47,8 +47,7 @@ (format nil "~a set" (path (nsib)))))) (mk-scrollbar :md-name :vscroll :layout (c? (format nil "pack ~a -side right -fill y" (^path))) - :command (c? (format nil "~a yview" (path (psib)))) - :command-is-callback nil))))) + :command (c? (format nil "~a yview" (path (psib))))))))) (defun mk-scrolled-list (&rest inits) (apply 'make-instance 'scrolled-list inits)) Index: cell-cultures/celtic/textual.lisp diff -u cell-cultures/celtic/textual.lisp:1.3 cell-cultures/celtic/textual.lisp:1.4 --- cell-cultures/celtic/textual.lisp:1.3 Thu Jul 8 20:53:05 2004 +++ cell-cultures/celtic/textual.lisp Sat Jul 17 07:02:23 2004 @@ -55,10 +55,10 @@ -invalidcommand -readonlybackground -show -state -validate -validatecommand -width) (:default-initargs - :textvariable (c? (md-name self)))) + :textvariable (c? (^path)))) (def-c-output text ((self entry)) (when new-value - (tk-format "set ~a ~s" + (tk-send self "set ~a ~s" (down$ (textvariable self)) new-value))) Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.6 cell-cultures/celtic/widget-item.lisp:1.7 --- cell-cultures/celtic/widget-item.lisp:1.6 Thu Jul 8 20:53:05 2004 +++ cell-cultures/celtic/widget-item.lisp Sat Jul 17 07:02:23 2004 @@ -39,42 +39,43 @@ (parent-path (fm-parent self)) (name self)))) (layout :reader layout :initarg :layout - :initform (c? (format nil "pack ~a" (path self)))) + :initform nil #+not (pack-self)) (enabled :reader enabled :initarg :enabled :initform t) - (command-is-callback :reader command-is-callback :initarg :command-is-callback - :initform t) (bindings :reader bindings :initarg :bindings :initform nil) (selector :reader selector :initarg :selector :initform (c? (upper self selector)))) (:default-initargs :md-name (create-name))) +(defun pack-self () + (c? (format nil "pack ~a" (path self)))) + (defmethod not-to-be :after ((self widget)) (trc "not-to-be tk-forgetting true widget" self) - (tk-format "pack forget ~a" (^path)) - (tk-format "destroy ~a" (^path))) + (tk-send self "pack forget ~a" (^path)) + (tk-send self "destroy ~a" (^path))) (defmethod parent-path ((nada null)) "") (defmethod parent-path ((self t)) (^path)) (defmethod configure ((self widget) option value) - (tk-format "~A configure ~(~a~) ~a" (path self) option (tk-format-value value))) + (tk-send self "~A configure ~(~a~) ~a" (path self) option (tk-send-value value))) -(defmethod tk-format-value ((s string)) - (format nil "{~a}" s)) +(defmethod tk-send-value ((s string)) + (format nil "~s" #+not "{~a}" s)) -(defmethod tk-format-value (other) +(defmethod tk-send-value (other) (format nil "~a" other)) -(defmethod tk-format-value ((s symbol)) +(defmethod tk-send-value ((s symbol)) (down$ s)) -(defmethod tk-format-value ((values list)) - (format nil "{~{~a~^ ~}}" (mapcar 'tk-format-value values))) +(defmethod tk-send-value ((values list)) + (format nil "{~{~a~^ ~}}" (mapcar 'tk-send-value values))) (def-c-output layout ((self widget)) (when (and new-value (not (typep .parent 'panedwindow))) - (tk-send new-value))) + (tk-send self new-value))) (defun de- (sym) (remove #\- (symbol-name sym) :end 1)) @@ -111,7 +112,8 @@ ,(when std-factory `(defmethod make-tk-instance ((self ,class)) (trc nil "!!! tk-creating" self) - (tk-format ,(format nil "~(~a~) ~~a" class) (path self)))) + (setf (gethash (^path) (dictionary .tkw)) self) + (tk-send self ,(format nil "~(~a~) ~~a" class) (path self)))) ,@outputs))) @@ -139,16 +141,16 @@ (defmethod not-to-be :after ((self item)) (trc nil "whacking item" self) - (tk-format "~a delete ~a" (path (upper self widget)) (id-no self))) + (tk-send self "~a delete ~a" (path (upper self widget)) (id-no self))) (defmethod make-tk-instance :after ((self item)) - (setf (id-no self) (let ((msg (tk-read))) + (setf (id-no self) (let ((msg (tk-read self))) (trc "created item" self :id msg) (read-from-string msg)))) (defmethod configure ((self item) option value) (assert (id-no self) () "cannot configure item until instantiated and id obtained") - (tk-format "~A itemconfigure ~a ~a {~a}" (path .parent) (id-no self) option value)) + (tk-send self "~A itemconfigure ~a ~a {~a}" (path .parent) (id-no self) option value)) (defmacro def-item (class (&rest tk-options)) (multiple-value-bind (slots outputs) @@ -174,12 +176,12 @@ (defun ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) (apply 'make-instance ',class inits)) (defmethod make-tk-instance ((self ,class)) - (tk-format "puts [~a create ~a ~{ ~a~}]" + (tk-send self "puts [~a create ~a ~{ ~a~}]" (path .parent) ,(down$ class) (coords self))) ,@outputs))) (def-c-output coords () (when (and (id-no self) new-value) - (tk-format "~a coords ~a ~{ ~a~}" + (tk-send self "~a coords ~a ~{ ~a~}" (path .parent) (id-no self) new-value)))

1 0

[cells-cvs] CVS update: cell-cultures/cello/jans.lisp
by Kenny Tilton 15 Jul '04

15 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv12754/cello Removed Files: jans.lisp Log Message: Date: Thu Jul 15 03:28:35 2004 Author: ktilton

1 0

[cells-cvs] CVS update: cell-cultures/install-notes.txt
by Kenny Tilton 09 Jul '04

09 Jul '04

Update of /project/cells/cvsroot/cell-cultures In directory common-lisp.net:/tmp/cvs-serv14181 Modified Files: install-notes.txt Log Message: Date: Thu Jul 8 20:53:05 2004 Author: ktilton Index: cell-cultures/install-notes.txt diff -u cell-cultures/install-notes.txt:1.1 cell-cultures/install-notes.txt:1.2 --- cell-cultures/install-notes.txt:1.1 Sat Jun 26 11:38:32 2004 +++ cell-cultures/install-notes.txt Thu Jul 8 20:53:05 2004 @@ -1,137 +1,26 @@ -PortaCello4 (this release) was meant to be a maintenance release. Instead, here is what is new: +Kenny Tilton +July 6, 20004 -- destudlification: I wrote a program to assist in a semi-automatic conversion of all studlyCap occurrences to studly-cap. But it was also semi-manual, so do not fall over dead if something snuck through. It at least seems as if I did not introduce any bugs doing this. +This CVS release inaugurates the collection of all my Cells-related code under one CVS project (./cells/cell-cultures), in turn under one common-lisp.net project, Cells. From now on the Cello project under common-lisp.net is quiesced, tho the web page is still informative and fun screen shots can be found in the FTP area. -- OpenAL: Play back wav files in 3D. Not sure if other formats are accessible. The bindings are in cl-openal, and Cello has a very rough framework to make it easier to easily associate sounds with the action. But that is really awful, just enough to get the app to make sound. Sometimes. When it works. +This release also introduces two significant new code releases. First, a substantial reworking of Cell internals known informally as Cells II. Second, Celtic, a derived work of Peter Herth's LTk project marrying Common Lisp and TCl/Tk. Celtic adds Cells to the mix (and deviates wildly from LTk so cannot be combined with that. -- zoom zoom zoom: Cello now makes maximum use of OpenGL display list optimizations, and I am seeing roughly 400% higher frame rates as a result. Every node inthe visual framework gets its own display list. These get refreshed bottom up when any element needs to change how it gets drawn, so a parent, when it comes time to redraw itself, can simply call the display list of its children. Later on, if a child changes, that is the only display list which needs to be redefined to OpenGL; when the parent renders, the new definition of the child display list gets picked up. In the end, the most complex window can be redrawn with nothing more than one gl-call-list call, on the window's display list. +A third subproject (a directory, in fact), Clyde (derived from "CL IDE") currently just contains a GUI wrapper for the CL apropos-list function, but could soon see a port of ClouCell, currently a Cello-based graphical object inspector. -- FTGL problems: unfortunately, the display list stuff has created some problems. I would fix them but I have to drop Cello for a couple of weeks and I did not want to hold up the release. Various issues: +Several other subprojects offer utilities required by most Cell projects. ASDF-ACLPROJ is Thomas Burdick's creation, which teaches ASDF about AllegroCL project files (their home-brewed defsystem). I use AllegroCL and cannot be trusted to keep parallel ASDF definition files current with the ACL project files. UTILS-KT is just what it looks like, very low-level stuff I use everywhere. FFI-EXTENDER makes it easier for me to whip up FFI bindings using UFFI (which, btw, you will also need). ---- Select the shape called "Cello" in the light panel demo, which shows the word "Cello" in extruded type. Ahem. It actually shows "ello". +Pure binding subprojects are functional as far as they go, but are usually incomplete because I punt when they get hard, until I need the challenging bindings. These include: ---- Clicking on different shapes in the light panel demo, individual letters start disappearing from words in that list and the "Backdrops" list!! +cl-opengl -- OpenGL. +cl-openal -- bindings to OpenAL. Think "OpenGL for audio". +cl-ftgl -- FTGL, FreeType for OpenGL +cl-magick -- ImageMagick, for image files such as JPG, and vector or bitmapped graphics. ---- Select the ft-jpg test. It runs at like one frame per second. resize the window one pixel and it jumps to 40-50 fps. Go figure. +That just leaves Cello, the OpenGL/Freeglut-based CL GUI. Where LTk and Celtic offer simpler, higher-level (but still powerful), and native GUIs, Cello is Lisp all the way down and offers terrific graphical power thx to direct OpenGL capabilities accelerated by hardware GPUs. ---- Select the ftgl-test demo. Better yet, don't. It will take forever to open, and then be almost completely unresponsive. resize the window and frame rates climb at least to 8-10fps. +Installing +---------- +1. A rough first attempt has been made at making various pathnames used by the code easy to live with. CONFIG.LISP at the top level of the CELL-CULTURES hierarchy has a single *devel-root* global to be configured to your install location. The subdirectory CONFIG contains other *-config.lisp files you might need to visit, especially if you tackle a Cello install. Celtik is blessedly more simple in this as well as other regards. ---- resizing works because I force all display lists to be regenerated on a resize. This makes resizing a window pretty slow, since it causes a ton of work to be done every frame as the mouse is dragged around. So why resize? That does not change the way most things need to be drawn. Answer: OpenGL clipping does not play well with display lists, because unlike the rest of OpenGL clipping gets recorded in global coordinates. It's a long story. I have a fix in mind, tho. RSN. +2. Other than that, each subdirectory has its own AllegroCL project and ASD files. Go for it, and holler if something will not build. -;----------------------------------------------------------------- - -Portacello3 was a first, rough stab at a livable directory structure for Cello. -But it is rough, and will not get less so until a few people try to install -and report back to the cello-devel list with problems and/or suggestions. That said, I have had good luck relocating the project on my own system and rebuilding with no more than a change to "cello-devel-root* in configure.lisp. - -The objective I have is to separate configuration from the source tree, -so you could tweak them once to fit your environment and then forget them even -after grabbing a new distro. But I also wanted to keep application code inside -the source tree to simplify future revisions. - -It turned out a little weird: a root configuration.lisp file -sets the *cello-config-directory*. Application source such as cl-magick.lisp -uses *cello-config-directory* to load cl-magick-config.lisp once the cl-magick -package has been defined. A simpler approach was tried but seemed icky. We -will see. - -This release is a phat one to set the environment, but future releases will be -of just the Cello directory. I /think/ I built in enough flexibility so that you can -tweak once for a different directory structure and then not worry about redoing -that every time there is a new release. - -This release contains asdf.lisp as well as UFFI. You may already have those. If -so, they are fine, the ones here are vanilla. - ------------- ALERT ------------------------------------------------------------ -This distro contains the Cells source. Use this version, not anything you might -have from the Cells project. Not sure yet, but I am leaning towards merging the -two projects. If I do, it will still be possible to grab just Cells. -------------------------------------------------------------------------------- - ------------- THANKS ----------------------------------------------------------- -...to David Steuber for mandelbrot3.gif, which looks smashing when used as a -texture for just about anything. -------------------------------------------------------------------------------- - ------------- LINUX ------------------------------------------------------------ -I think I pulled in Frank's code for the Linux port, but I just featured it out -and went with the configuration.lisp-based stuff for ACL/win32. I have suggested -Frank's fine job of loading cooperating .SOs be contributed to UFFI so Cello code -can just say "load-library". Stay tuned. -------------------------------------------------------------------------------- - ------------- WARNING ---------------------------------------------------------- -ASDF files are suspect for anything other than a full build. In some places I -cured this by bogusly declaring each file dependent on its predecessor. In other -places you may find that modifying files at random, then exiting and coming back -in will cause compiler errors when ASDF tries recompiling just the changed files. -Unfortunately, at this point I do not use ASDF for day to day work, so they do -not get much attention, and when porting to Lispworks/win32 (where I do use ASDF) -I just set d-force to t to force full builds if I have any such problems. --------------------------------------------------------------------------------- - ------------ BIG PROBLEM -------------------------------------------------------- -Libraries. For win32, the PC4 release includes the DLLs I use (well, except those you should find in /windows/system32). Linux/Mac OS X really have their work cut out for them. Building Freeglut and ImageMagick (and FreeType) may just work for you as typical Linux installs, but FTGL as I have done it requires to build with the included FTGLFromC.cpp and a modified FTGLExtrdFont.h built into the library .SO. -------------------------------------------------------------------------------- - - -Step #1 -------- -Unzip into any directory. The distro includes win32 DLLs, -so Linux folk can skip those. - -Step #2 -------- -Edit configure.lisp, tweak as necessary - -Step #3 -------- -Open build.lisp. - -Get ASDF (if necessary) and build-sys-kt.lisp loaded. - -Work your way down the top-level forms evaluating them in turn. Comment out the line about -UFFI if you already have that. - -lesson-14 is optional, but will let you know if you have the Glut and -OpenGL working, including callbacks from C into Lisp. - -Step #4 -------- -Cello-test. Hope it works. If so, the FTGL test takes a long time to come up, -maybe six seconds on my 3ghz screamer, because it is loading every TTF font on -my system (150?) and building a widget for it. - -The light panel is the fun one. The cone is the best place to see photographic textures, -and the torus is a good one, too. Play with the lighting controls to see what they do. -And as you change from shape to shape, play with the options for each, such as -"slices" and "stacks". The torus is a lot of fun for that. To understand what -is going on, set "wireframe" on. - -The prettiest pictures come from "sphere","repeat", and one of the photographic textures. -The torus and "Cello" shapes are good here. - -If you see one you like, hit the "snapshot" button on the "just shoot me" widget. -It will write out a PNG in the "out" directory. I have no -idea where I left things on the "record" button. It will probably crash. - -If sound is working, you will hear a short riff when the window opens, a little bleep when you operate any of the color controls, and with luck a cool sound if you hit ESCAPE to close a window (worked under AllegroCL, not Lispworks). - -Crashing --------- -Lisp is hard to kill, and so can be the Glut. It seems to have gotten better under AllegroCL. The old nightmare is described next. Now I can click debug and/or abort, tho the Cello window will not go away until it I move the mouse over it. On Lispworks it does not go away. I can run again and get a second window, but the third or fourth time Lispworks gets upset. I spent exactly zero seconds trying to figure out how to fix this, so hopefully anyone wanting to use Lispworks in anger will be able to figure something out. - -Old nightmare: "Under AllegroCL on win32, when I get a -backtrace I can not always just click debug or abort. I have learned to click first on -any IDE window, and /then/ debug or abort. In the worst cases I have to get to the -listener and evaluate (c-stop t), then try again to abort, and sometimes it takes a few -aborts. In the very worst case I have to kill AllegroCL, but fortunately this does not -happen very often. On Lispworks I had worse luck keeping LW going in the face of -backtraces, but I imagine that with a little elbow grease (and LW expertise, which -I lack utterly) the problem could be resolved." - - Needless to say, I do view anything interfering with iterative Lisp developemtn as a show-stopper, so if anyone gets serious about Cello under a different implementation I'll help with what I know to get crashing under control. - -kenny -4/17/2004 \ No newline at end of file

1 0

[cells-cvs] CVS update: cell-cultures/cells/integrity.lisp cell-cultures/cells/model-object.lisp
by Kenny Tilton 09 Jul '04

09 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv14181/cells Modified Files: integrity.lisp model-object.lisp Log Message: Date: Thu Jul 8 20:53:04 2004 Author: ktilton Index: cell-cultures/cells/integrity.lisp diff -u cell-cultures/cells/integrity.lisp:1.3 cell-cultures/cells/integrity.lisp:1.4 --- cell-cultures/cells/integrity.lisp:1.3 Tue Jul 6 18:25:40 2004 +++ cell-cultures/cells/integrity.lisp Thu Jul 8 20:53:04 2004 @@ -51,8 +51,8 @@ `(let ((*deference-acknowledged* t)) ,@body)) -(defmacro with-integrity ((key &rest defer-info) &rest body) - `(call-with-integrity ,key (list ,@defer-info) +(defmacro with-integrity ((debug-key &rest defer-info) &rest body) + `(call-with-integrity ,debug-key (list ,@defer-info) (lambda () ,@body))) (defun ufb-queue (opcode) @@ -61,7 +61,7 @@ (defun ufb-add (opcode continuation) (fifo-add (ufb-queue opcode) continuation)) -(defconstant-once *ufb-opcodes* '(:user-notify :output :setf :makunbound)) +(defconstant-once *ufb-opcodes* '(:user-notify :output :setf :makunbound :finalize)) (define-condition c-opcode-deferred (c-enabling) ((defer-info :initarg :defer-info :reader defer-info)) @@ -72,8 +72,8 @@ (defparameter *ufb-needed* nil) -(defun call-with-integrity (key defer-info action &aux (opcode (car defer-info))) - (declare (ignorable key)) +(defun call-with-integrity (debug-key defer-info action &aux (opcode (car defer-info))) + (declare (ignorable debug-key)) (assert (or (null opcode) (member opcode *ufb-opcodes*))) (trc nil "call-with-integrity entry *unfinished-business*" *unfinished-business*) (if *unfinished-business* @@ -91,7 +91,7 @@ (mapcar (lambda (opcode) (cons opcode (make-fifo-queue))) *ufb-opcodes*))) - (trc nil "!!!!!!!!!! started new *unfinished-business*" key defer-info) + (trc nil "!!!!!!!!!! started new *unfinished-business*" debug-key defer-info) (when (or (zerop *data-pulse-id*) (member opcode '(:setf :makunbound))) (data-pulse-next (cons opcode defer-info)) @@ -145,4 +145,12 @@ (push c setfs) (data-pulse-next (list :finbiz c new-value)) (funcall task-fn)))) + (go notify-users)) + + ; --- do finalizations ------------------------ + (setf task (fifo-pop (ufb-queue :finalize))) + (when task + (destructuring-bind ((self) . task-fn) task + (trc "finbiz: deferred finalize!!!!" self) + (funcall task-fn)) (go notify-users)))) Index: cell-cultures/cells/model-object.lisp diff -u cell-cultures/cells/model-object.lisp:1.2 cell-cultures/cells/model-object.lisp:1.3 --- cell-cultures/cells/model-object.lisp:1.2 Sun Jul 4 11:59:41 2004 +++ cell-cultures/cells/model-object.lisp Thu Jul 8 20:53:04 2004 @@ -154,7 +154,7 @@ (progn ;; next bit revised to avoid double-output of optimized cells (when (eql '.kids slot-name) (bwhen (sv (slot-value self '.kids)) - (trc nil "soon will output initial kids of" self) + (trc "soon will output initial kids of" self) (md-kids-change self sv nil :md-awaken-slot))) (c-output-initially self slot-name)))))))

1 0

[cells-cvs] CVS update: cell-cultures/celtic/callback.lisp cell-cultures/celtic/demos.lisp cell-cultures/celtic/button.lisp cell-cultures/celtic/celtic.lisp cell-cultures/celtic/celtic.lpr 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
by Kenny Tilton 09 Jul '04

09 Jul '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv14181/celtic Modified Files: button.lisp celtic.lisp celtic.lpr frame.lisp menu.lisp scrolling.lisp textual.lisp widget-item.lisp Added Files: callback.lisp demos.lisp Log Message: Date: Thu Jul 8 20:53:05 2004 Author: ktilton Index: cell-cultures/celtic/button.lisp diff -u cell-cultures/celtic/button.lisp:1.4 cell-cultures/celtic/button.lisp:1.5 --- cell-cultures/celtic/button.lisp:1.4 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/button.lisp Thu Jul 8 20:53:05 2004 @@ -21,8 +21,6 @@ (in-package :celtic) - - ;-------------------------------------------------------------------------- (def-widget button () @@ -35,16 +33,6 @@ (-command nil) -compound -default -height -overrelief -state -width)) -(defun test-button () - (make-be 'button :text (format nil "Time is ~a" (get-internal-real-time)) - :width 48 - :borderwidth 4 - :underline 2 - :font "Courier")) - -; --------------------------------------------------- -; http://tmml.sourceforge.net/doc/tk/checkbutton.html -; (def-widget checkbutton () () (-activebackground -activeforeground -anchor -background @@ -56,12 +44,15 @@ (-command nil) -height -indicatoron -offrelief -offvalue -onvalue -overrelief -selectcolor -selectimage -state -tristateimage - -tristatevalue (-tk-variable -variable) -width)) + -tristatevalue (-tk-variable -variable) -width) + (:default-initargs + :command (lambda (self) + (setf (^md-value) (not (^md-value)))))) (def-c-output .md-value ((self checkbutton)) - (tk-send (format nil "set ~a ~a" - (down$ (md-name self)) - (if new-value 1 0)))) + (tk-format "set ~a ~a" + (down$ (md-name self)) + (if new-value 1 0))) (def-widget radiobutton () () @@ -79,4 +70,53 @@ :command (lambda (self) (setf (selection (upper self selector)) (value self))))) + +(def-widget scale () + () + (-activebackground -background -borderwidth -cursor + -font -foreground -highlightbackground -highlightcolor + -highlightthickness -orient -relief -repeatdelay + -repeatinterval -takefocus -troughcolor + -bigincrement (-command nil) -digits -from + (-tk-label -label) (-tk-length -length) -resolution + -showvalue -sliderlength -sliderrelief + -state -tickinterval -to (-tk-variable -variable) -width) + (:default-initargs + :md-value (c-in nil) + :command (lambda (self) + (setf (^md-value) (tk-eval (format nil "~a get" (^path))))))) + +(def-c-output .md-value ((self scale)) + (when new-value + (if (listp new-value) + (tk-format "set ~a {~{~a~^ ~}}" (^path) new-value) + (tk-format "~a set ~a" (^path) new-value)))) + +(def-widget spinbox () + () + (-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 nil) -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 (lambda (self) + (setf (^md-value) + (eko ("spinbox value now" self) + (tk-eval-list (format nil "~a get" (^path)))))))) + +(def-c-output .md-value ((self spinbox)) + (when new-value + (if (listp new-value) + (tk-format "set ~a {~{~a~^ ~}}" (^path) new-value) + (tk-format "~a set ~a" (^path) new-value)))) Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.4 cell-cultures/celtic/celtic.lisp:1.5 --- cell-cultures/celtic/celtic.lisp:1.4 Mon Jul 5 12:29:30 2004 +++ cell-cultures/celtic/celtic.lisp Thu Jul 8 20:53:05 2004 @@ -87,9 +87,12 @@ (defun tk-start () (setf *w* (do-execute "wish" '("-name" "Visual Apropos")))) +(defun tk-format (fmt$ &rest args) + (tk-send (apply 'format nil fmt$ args))) + (defun tk-send (text) "send a string to wish" - (when nil ;; (search "pack " text) ;; *debug-tk* + (when t ;(search "font-face" text) ;; *debug-tk* (format t "~&tk-send> ~A~%" text) (force-output)) (format *w* "~A~%" text) @@ -102,48 +105,9 @@ #+:lispworks (setf c (string-right-trim '(#\Newline #\Return #\Linefeed) c)) c)) - -;;; tcl -> lisp: puts "$x" mit \ und " escaped -;;; puts [regsub {"} [regsub {\\} $x {\\\\}] {\"}] - -;;; call to convert untility (defun convert(from to) (close (do-execute "convert" (list from to) t))) -;;; table used for callback every callback consists of a name of a widget and -;;; a function to call - -(defvar *callbacks* (make-hash-table :test #'equal)) - -(defun register-callback (self callback-id fun - &aux (id (widget-callback-id self callback-id))) - ;;(format t "~&object ~a registering callback ~a: ~A" self :id id) - (setf (gethash id *callbacks*) (cons fun self))) - -(defun widget-callback-id (self callback-id) - (conc$ (path self) "." (down$ callback-id))) - -(defun dispatch-callback(sym args) - (let ((func-self (gethash sym *callbacks*))) - ;(format t "sym:~S fun:~A~%" sym func-self) - (force-output) - (when (not func-self) - (format t "~&callback ~a, type ~a, pkg ~a, not found. known callbacks:" - sym (type-of sym) (when (typep sym 'symbol) (symbol-package sym))) - (maphash (lambda (key func-self) - (declare (ignore func-self)) - (format t "~&known callback key ~a, type ~a, pkg ~a" - key (type-of key)(when (typep key 'symbol) (symbol-package key)))) - *callbacks*)) - (when (car func-self) - (apply (car func-self) (cdr func-self) args)))) - -(defun after (self time func) - "Usage: (after self <time> <func>)) ...after <time> msec call function <func>" - (register-callback self "after" func) - (tk-send (format nil "after ~a {puts -nonewline {(\"~A\") };flush stdout}" - time (widget-callback-id self "after")))) - ;; tool functions used by the objects ;; incremental counter to create unique numbers @@ -167,19 +131,14 @@ (let ((*exit-mainloop* nil) (*read-eval* nil)) ;;safety against malicious clients (loop - (let ((msg (read-preserving-whitespace *w* nil nil) - #+not (progn - (trc "sitting on mainloop read") - (tk-read)))) + (let ((msg (read-preserving-whitespace *w* nil nil))) (when (null msg) (return)) - (when *debug-tk* - (format t "~&msg:~A<=~%" msg) - (force-output)) (if (consp msg) (progn - (trc nil "dispatching callback" msg) - (dispatch-callback (first msg) (rest msg))) + (assert (eql 'callback (first msg))) + (trc "mainloop dispatching callback" msg) + (dispatch-callback (rest msg))) (let ((emsg (read-line *w* nil nil))) (trc "error msg:" msg emsg))) @@ -196,19 +155,19 @@ (defgeneric grid-columnconfigure (w c o v)) (defmethod grid-columnconfigure (widget column option value) - (tk-send (format nil "grid columnconfigure ~a ~a -~a {~a}" (path widget) column option value))) + (tk-format "grid columnconfigure ~a ~a -~a {~a}" (path widget) column option value)) (defgeneric grid-rowconfigure (w r o v)) (defmethod grid-rowconfigure (widget row option value) - (tk-send (format nil "grid rowconfigure ~a ~a -~a {~a}" (path widget) row option value))) + (tk-format "grid rowconfigure ~a ~a -~a {~a}" (path widget) row option value)) (defgeneric grid-configure (w o v)) (defmethod grid-configure (widget option value) - (tk-send (format nil "grid configure ~a -~a {~a}" (path widget) option value))) + (tk-format "grid configure ~a -~a {~a}" (path widget) option value)) (defun tk-test (fn) (let ((*debug-tk* nil) - (*callbacks* (make-hash-table :test #'equal))) + (*callbacks* (make-hash-table))) (cell-reset) (tk-start) (let ((*tk-root* (funcall fn))) Index: cell-cultures/celtic/celtic.lpr diff -u cell-cultures/celtic/celtic.lpr:1.3 cell-cultures/celtic/celtic.lpr:1.4 --- cell-cultures/celtic/celtic.lpr:1.3 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/celtic.lpr Thu Jul 8 20:53:05 2004 @@ -13,7 +13,9 @@ (make-instance 'module :name "textual.lisp") (make-instance 'module :name "button.lisp") (make-instance 'module :name "menu.lisp") - (make-instance 'module :name "scrolling.lisp")) + (make-instance 'module :name "scrolling.lisp") + (make-instance 'module :name "demos.lisp") + (make-instance 'module :name "callback.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells")) :libraries nil Index: cell-cultures/celtic/frame.lisp diff -u cell-cultures/celtic/frame.lisp:1.4 cell-cultures/celtic/frame.lisp:1.5 --- cell-cultures/celtic/frame.lisp:1.4 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/frame.lisp Thu Jul 8 20:53:05 2004 @@ -67,9 +67,9 @@ (def-c-output selection () (when new-value - (tk-send (format nil "set ~a ~a" - (down$ (tk-variable self)) - (down$ (md-name new-value)))))) + (tk-format "set ~a ~a" + (down$ (tk-variable self)) + (down$ (md-name new-value))))) ;--- f r a m e -------------------------------------------------- @@ -81,15 +81,15 @@ -colormap -container -height -visual -width)) (defmodel frame-selector (selector frame)()) -(defun frame-selector (&rest init-args) +(defun mk-frame-selector (&rest init-args) (apply 'make-instance 'frame-selector init-args)) (defmodel frame-stack (stack-mixin frame-selector)()) -(defun frame-stack (&rest init-args) +(defun mk-frame-stack (&rest init-args) (apply 'make-instance 'frame-stack init-args)) (defmodel frame-row (row-mixin frame-selector)()) -(defun frame-row (&rest init-args) +(defun mk-frame-row (&rest init-args) (apply 'make-instance 'frame-row init-args)) @@ -103,13 +103,43 @@ -text -labelanchor -labelwidget)) (defmodel labelframe-selector (selector labelframe)()) -(defun labelframe-selector (&rest init-args) +(defun mk-labelframe-selector (&rest init-args) (apply 'make-instance 'labelframe-selector init-args)) (defmodel labelframe-stack (stack-mixin labelframe-selector)()) -(defun labelframe-stack (&rest init-args) +(defun mk-labelframe-stack (&rest init-args) (apply 'make-instance 'labelframe-stack init-args)) (defmodel labelframe-row (row-mixin labelframe-selector)()) -(defun labelframe-row (&rest init-args) +(defun mk-labelframe-row (&rest init-args) (apply 'make-instance 'labelframe-row init-args)) + +;---- panedwindow ----------------------------------- + +(def-widget panedwindow (:std-factory nil) + () + (-background -borderwidth -cursor -height + -orient -relief -width + -handlepad + -handlesize + -opaqueresize + -sashcursor + -sashpad + -sashrelief + -sashwidth + -showhandle) + (:default-initargs + :layout nil)) + +(defmethod make-tk-instance ((self panedwindow)) + (tk-format "panedwindow ~a -orient ~(~a~)" + (^path) (or (orient self) "vertical")) + (tk-format "pack ~a -expand yes -fill both" (^path))) + +(defmethod parent-path ((self panedwindow)) (^path)) + +(defmethod md-awaken :after ((self panedwindow)) + (with-integrity (:panedwindow :finalize self) + (loop for k in (^kids) + do (tk-format "~a add ~a" (^path) (path k))))) + Index: cell-cultures/celtic/menu.lisp diff -u cell-cultures/celtic/menu.lisp:1.2 cell-cultures/celtic/menu.lisp:1.3 --- cell-cultures/celtic/menu.lisp:1.2 Tue Jul 6 18:25:41 2004 +++ cell-cultures/celtic/menu.lisp Thu Jul 8 20:53:05 2004 @@ -63,29 +63,21 @@ :initform (c? (format nil "~a" (^md-value)))))) (defmethod make-tk-instance ((self listbox-item)) - (tk-send (format nil "~A insert end ~s" - (path .parent) - (^item-text)))) + (tk-format "~A insert end ~s" + (path .parent) + (^item-text))) (def-c-output .kids ((self listbox)) (when old-value - (tk-send (format nil "~A delete ~a ~a" - (^path) - 0 (1- (length old-value)))))) + (tk-format "~A delete ~a ~a" + (^path) + 0 (1- (length old-value))))) (defmethod listbox-get-selection ((l listbox)) (tk-send (format nil "puts -nonewline {(};puts -nonewline [~a curselection];puts {)};flush stdout" (path l))) (read *w*)) - -(defmethod tk-eval (form$) - (tk-send - (format nil "puts -nonewline {(};puts -nonewline [~a];puts {)};flush stdout" - form$)) - (loop for value = (read *w* nil :eof) - While (not (eq value :eof)) - collecting value)) Index: cell-cultures/celtic/scrolling.lisp diff -u cell-cultures/celtic/scrolling.lisp:1.2 cell-cultures/celtic/scrolling.lisp:1.3 --- cell-cultures/celtic/scrolling.lisp:1.2 Tue Jul 6 18:25:41 2004 +++ cell-cultures/celtic/scrolling.lisp Thu Jul 8 20:53:05 2004 @@ -36,19 +36,19 @@ (:default-initargs :list-height (c? (max 1 (length (^list-item-keys)))) :kids (c? (the-kids - (listbox :md-name :list + (mk-listbox :md-name :list :kids (c? (mapcar (list-item-factory .parent) (list-item-keys .parent))) - :font "courier 9" + :font '(courier 9) :state (c? (if (enabled .parent) 'normal 'disabled)) :height (c? (list-height .parent)) :layout (c? (format nil "pack ~a -side left -fill both -expand 1" (^path))) :yscrollcommand (c? (when (enabled .parent) (format nil "~a set" (path (nsib)))))) - (scrollbar :md-name :vscroll + (mk-scrollbar :md-name :vscroll :layout (c? (format nil "pack ~a -side right -fill y" (^path))) :command (c? (format nil "~a yview" (path (psib)))) :command-is-callback nil))))) -(defun scrolled-list (&rest inits) +(defun mk-scrolled-list (&rest inits) (apply 'make-instance 'scrolled-list inits)) Index: cell-cultures/celtic/textual.lisp diff -u cell-cultures/celtic/textual.lisp:1.2 cell-cultures/celtic/textual.lisp:1.3 --- cell-cultures/celtic/textual.lisp:1.2 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/textual.lisp Thu Jul 8 20:53:05 2004 @@ -31,12 +31,6 @@ -textvariable -underline -wraplength -compound -height -state -width)) -(defun test-label () - (make-be 'label :text (format nil "Time is ~a" (get-internal-real-time)) - :borderwidth 4 - :relief "ridge" - :font "Courier")) - ;-------------------------------------------------------------------------- (def-widget message () @@ -47,16 +41,6 @@ -takefocus -text -textvariable -width -aspect -justify)) -(defun test-message () - (make-be 'message - :text "four score and seven years ago our fathers brought forth on this continent -a new nation, conceived in liberty, and dedicated to the proposition that all men -are created equal." - :borderwidth 4 - :underline 2 - :justify :center - :font "Times")) - ;---------------------------------------------------------------------------- (def-widget entry () @@ -75,7 +59,6 @@ (def-c-output text ((self entry)) (when new-value - (tk-send (eko ("entry sets text var" self new-value) - (format nil "set ~a ~s" - (down$ (textvariable self)) - new-value))))) + (tk-format "set ~a ~s" + (down$ (textvariable self)) + new-value))) Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.5 cell-cultures/celtic/widget-item.lisp:1.6 --- cell-cultures/celtic/widget-item.lisp:1.5 Tue Jul 6 18:25:41 2004 +++ cell-cultures/celtic/widget-item.lisp Thu Jul 8 20:53:05 2004 @@ -26,14 +26,17 @@ (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) + + ;;; --- widget ----------------------------------------- + (defmodel widget (family tk-object) ((name :initarg :name :accessor name :initform (c? (down$ (md-name self)))) (path :accessor path :initarg :path :initform (c? (format nil "~a.~a" - (if (fm-parent self) (path .parent) "") + (parent-path (fm-parent self)) (name self)))) (layout :reader layout :initarg :layout :initform (c? (format nil "pack ~a" (path self)))) @@ -48,42 +51,43 @@ (defmethod not-to-be :after ((self widget)) (trc "not-to-be tk-forgetting true widget" self) - (tk-send (format nil "pack forget ~a" (^path))) - (tk-send (format nil "destroy ~a" (^path)))) + (tk-format "pack forget ~a" (^path)) + (tk-format "destroy ~a" (^path))) -(def-c-output command ((self widget)) - (when (^command-is-callback) - (register-callback self "command" new-value) - (configure self "command" - (format nil "puts -nonewline {(~s)};flush stdout" - (widget-callback-id self "command"))))) - -(def-c-output bindings () ;;; (w widget) event fun) - (loop for binding in new-value - for name = (create-name) - do (destructuring-bind (event . fn) binding - (declare (ignorable event)) - (register-callback self name fn) - (tk-send (format nil "bind ~a ~a {puts -nonewline {(\"~A\")};flush stdout}" - (^path) event (widget-callback-id self name)))))) +(defmethod parent-path ((nada null)) "") +(defmethod parent-path ((self t)) (^path)) (defmethod configure ((self widget) option value) - (tk-send (format nil "~A configure -~A {~A}" (path self) option value))) + (tk-format "~A configure ~(~a~) ~a" (path self) option (tk-format-value value))) + +(defmethod tk-format-value ((s string)) + (format nil "{~a}" s)) + +(defmethod tk-format-value (other) + (format nil "~a" other)) + +(defmethod tk-format-value ((s symbol)) + (down$ s)) + +(defmethod tk-format-value ((values list)) + (format nil "{~{~a~^ ~}}" (mapcar 'tk-format-value values))) (def-c-output layout ((self widget)) - (when new-value + (when (and new-value (not (typep .parent 'panedwindow))) (tk-send new-value))) +(defun de- (sym) + (remove #\- (symbol-name sym) :end 1)) + ;;; --- widget -------------------- (defmacro def-widget (class (&key (std-factory t)) (&rest std-slots) (&rest tk-options) &rest defclass-options) - (flet ((de- (sym) (intern (remove #\- (symbol-name sym) :end 1)))) - (multiple-value-bind (slots outputs) + (multiple-value-bind (slots outputs) (loop for tk-option-def in tk-options - for slot-name = (de- (if (atom tk-option-def) - tk-option-def (car tk-option-def))) + for slot-name = (intern (de- (if (atom tk-option-def) + tk-option-def (car tk-option-def)))) collecting `(,slot-name :initform nil :initarg ,(intern (string slot-name) :keyword) :accessor ,slot-name) @@ -92,28 +96,37 @@ (cadr tk-option-def)) collecting `(def-c-output ,slot-name ((self ,class)) (when new-value - (configure self ,(down$ (de- (if (atom tk-option-def) - tk-option-def (cadr tk-option-def)))) - (if (stringp new-value) - new-value (down$ new-value))))) + (configure self ,(string (if (atom tk-option-def) + tk-option-def (cadr tk-option-def))) + new-value))) + into outputs finally (return (values slot-defs outputs))) `(progn (defmodel ,class (widget) (,@(append std-slots slots)) ,@defclass-options) - (defun ,class (&rest inits) + (defun ,(intern (format nil "MK-~a" class)) (&rest inits) (apply 'make-instance ',class inits)) ,(when std-factory `(defmethod make-tk-instance ((self ,class)) (trc nil "!!! tk-creating" self) - (tk-send (format nil ,(concatenate 'string - (down$ class) " ~A") (path self))))) - ,@outputs)))) + (tk-format ,(format nil "~(~a~) ~~a" class) (path self)))) + ,@outputs))) + (defmacro pack-layout? (fmt$ &rest args) `(c? (format nil "pack ~a ~?" (^path) ,fmt$ (list ,@args)))) +(defmethod tk-down$ (other) (down$ other)) +(defmethod tk-down$ ((s string)) s) +(defmethod tk-down$ ((list list)) + (conc$ + (apply 'conc$ "{" (tk-down$ (car list)) + (mapcar (lambda (v) + (conc$ " " (tk-down$ v))) + (cdr list))) "}")) + ;;; --- items ----------------------------------------------------------------------- (defmodel item (tk-object) @@ -126,7 +139,7 @@ (defmethod not-to-be :after ((self item)) (trc nil "whacking item" self) - (tk-send (format nil "~a delete ~a" (path (upper self widget)) (id-no self)))) + (tk-format "~a delete ~a" (path (upper self widget)) (id-no self))) (defmethod make-tk-instance :after ((self item)) (setf (id-no self) (let ((msg (tk-read))) @@ -135,39 +148,38 @@ (defmethod configure ((self item) option value) (assert (id-no self) () "cannot configure item until instantiated and id obtained") - (tk-send (format nil "~A itemconfigure ~a -~A {~A}" (path .parent) (id-no self) option value))) + (tk-format "~A itemconfigure ~a ~a {~a}" (path .parent) (id-no self) option value)) (defmacro def-item (class (&rest tk-options)) - (flet ((de- (sym) (intern (remove #\- (symbol-name sym) :end 1)))) - (multiple-value-bind (slots outputs) - (loop for tk-option-def in tk-options - for tk-option = (if (atom tk-option-def) - tk-option-def (cadr tk-option-def)) - for slot-name = (de- (if (atom tk-option-def) - tk-option-def (car tk-option-def))) - collecting `(,slot-name :initform nil - :initarg ,(intern (string slot-name) :keyword) - :accessor ,slot-name) - into slot-defs - collecting `(def-c-output ,slot-name ((self ,class)) - (when (and (id-no self) new-value) - (configure self - ,(down$ (de- tk-option)) - (down$ new-value)))) - into outputs - finally (return (values slot-defs outputs))) - `(progn - (defmodel ,class (item) - (,@slots)) - (defun ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) - (apply 'make-instance ',class inits)) - (defmethod make-tk-instance ((self ,class)) - (tk-send (format nil "puts [~a create ~a ~{ ~a~}]" - (path .parent) ,(down$ class) (coords self)))) - ,@outputs)))) + (multiple-value-bind (slots outputs) + (loop for tk-option-def in tk-options + for tk-option = (if (atom tk-option-def) + tk-option-def (cadr tk-option-def)) + for slot-name = (intern (de- (if (atom tk-option-def) + tk-option-def (car tk-option-def)))) + collecting `(,slot-name :initform nil + :initarg ,(intern (string slot-name) :keyword) + :accessor ,slot-name) + into slot-defs + collecting `(def-c-output ,slot-name ((self ,class)) + (when (and (id-no self) new-value) + (configure self + ,(string tk-option) + (down$ new-value)))) + into outputs + finally (return (values slot-defs outputs))) + `(progn + (defmodel ,class (item) + (,@slots)) + (defun ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) + (apply 'make-instance ',class inits)) + (defmethod make-tk-instance ((self ,class)) + (tk-format "puts [~a create ~a ~{ ~a~}]" + (path .parent) ,(down$ class) (coords self))) + ,@outputs))) (def-c-output coords () (when (and (id-no self) new-value) - (tk-send (format nil "~a coords ~a ~{ ~a~}" - (path .parent) (id-no self) new-value)))) + (tk-format "~a coords ~a ~{ ~a~}" + (path .parent) (id-no self) new-value)))

1 0

[cells-cvs] CVS update: cell-cultures/clyde/visual-apropos/visual-apropos.lisp
by Kenny Tilton 09 Jul '04

09 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde/visual-apropos In directory common-lisp.net:/tmp/cvs-serv14181/clyde/visual-apropos Modified Files: visual-apropos.lisp Log Message: Date: Thu Jul 8 20:53:05 2004 Author: ktilton Index: cell-cultures/clyde/visual-apropos/visual-apropos.lisp diff -u cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.3 cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.4 --- cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.3 Tue Jul 6 18:25:41 2004 +++ cell-cultures/clyde/visual-apropos/visual-apropos.lisp Thu Jul 8 20:53:05 2004 @@ -41,13 +41,13 @@ :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") :kids (c? (list (search-for-symbol) - (frame-row + (mk-frame-row :padx 8 :layout (pack-layout? "-side left -fill x") :kids (c? (list - (frame-stack + (mk-frame-stack :kids (c? (list - (checkbutton :md-name :exported-only + (mk-checkbutton :md-name :exported-only :text "Exported Only" :underline 1 :md-value (c-in nil) @@ -58,7 +58,7 @@ (symbol-list))))) (defun search-for-symbol () - (frame-row + (mk-frame-row :relief 'ridge :padx 8 :layout (pack-layout? "-side left -fill x -anchor nw") @@ -67,12 +67,12 @@ (path (kid1 self)) (path (second (^kids))) (path (third (^kids))))) - :kids (c? (list (label :text "String:" + :kids (c? (list (mk-label :text "String:" :underline 4) - (entry :md-name :search-string + (mk-entry :md-name :search-string :text (c? (symbol-name (sub-symbol (upper self visual-apropos)))) :width 64) - (button :text "Search" + (mk-button :text "Search" :underline 0 :command (lambda (self) (setf (symbols (upper self visual-apropos)) @@ -81,17 +81,15 @@ ; --- symbol package filtering ------------------------------- (defun package-filtering () - (labelframe-row - :text " Package(s) to Search " + (mk-labelframe-row + :text "Package(s) to Search" :layout (pack-layout? "-side left -fill x -expand 1") :kids (c? (list - (checkbutton :md-name :all-pkgs + (mk-checkbutton :md-name :all-pkgs :text "All" :underline 1 - :md-value (c-in t) - :command (lambda (self) - (setf (^md-value) (not (^md-value))))) - (scrolled-list + :md-value (c-in t)) + (mk-scrolled-list :md-name :in-package :list-height 4 :layout (pack-layout? "-side left -fill x -expand 1") @@ -106,9 +104,9 @@ ; --- symbol binding filtering --------------------------------------- (defun show-which-symbols () - (labelframe-selector + (mk-labelframe-selector :md-name :which-symbols - :text " With bindings " + :text "With bindings to" :tk-variable 'which-symbols :layout (c? (format nil "pack ~a -side {left}~:{; grid ~a -column ~d -row ~d -sticky w~}" (path self) (mapcar (lambda (k) @@ -117,7 +115,7 @@ (^kids)))) :selection (c-in :any) :kids (c? (flet ((rb (n) - (radiobutton :md-name n + (mk-radiobutton :md-name n :text (string-capitalize (string n)) :tk-variable (tk-variable self) :value n @@ -126,12 +124,12 @@ (list (rb :any)(rb :functions)(rb :variables)(rb :classes)))))) (defun symbol-list () - (frame-stack :md-name :symbol-list + (mk-frame-stack :md-name :symbol-list :layout (pack-layout? "-side top -expand 1 -fill both") :width 64 :background 'red :kids (c? (list - (frame-row + (mk-frame-row :md-name :sym-sort :md-value (c-in nil) :relief 'groove @@ -151,7 +149,7 @@ (va-button :layout nil :text "Var" :padx 5) (va-button :layout nil :text "Class") (va-button :layout nil :text "Exp"))))) - (scrolled-list + (mk-scrolled-list :layout (pack-layout? "-side top -expand 1 -fill both") :width 64 :list-height nil

1 0