Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv5472/celtic

Modified Files: button.lisp canvas.lisp celtic.lisp celtic.lpr frame.lisp textual.lisp widget-item.lisp Added Files: menu.lisp scrolling.lisp Log Message:

Date: Sun Jul 4 11:59:43 2004 Author: ktilton

Index: cell-cultures/celtic/button.lisp diff -u cell-cultures/celtic/button.lisp:1.3 cell-cultures/celtic/button.lisp:1.4 --- cell-cultures/celtic/button.lisp:1.3 Sun Jun 27 21:25:14 2004 +++ cell-cultures/celtic/button.lisp Sun Jul 4 11:59:43 2004 @@ -26,13 +26,14 @@ ;--------------------------------------------------------------------------

(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 nil) - -compound -default -height -overrelief -state -width)) + () + (-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 nil) + -compound -default -height -overrelief -state -width))

(defun test-button () (make-be 'button :text (format nil "Time is ~a" (get-internal-real-time)) @@ -45,6 +46,7 @@ ; http://tmml.sourceforge.net/doc/tk/checkbutton.html ; (def-widget checkbutton () + () (-activebackground -activeforeground -anchor -background -bitmap -borderwidth -cursor -disabledforeground -font -foreground -highlightbackground -highlightcolor @@ -62,6 +64,7 @@ (if new-value 1 0))))

(def-widget radiobutton () + () (-activebackground -activeforeground -anchor -background -bitmap -borderwidth -cursor -disabledforeground -font -foreground -highlightbackground -highlightcolor @@ -74,5 +77,6 @@ -tristatevalue (-tk-variable -variable) -width) (:default-initargs :command (lambda (self) - (setf (selection (upper self selector)) self)))) + (setf (selection (upper self selector)) + (value self)))))

Index: cell-cultures/celtic/canvas.lisp diff -u cell-cultures/celtic/canvas.lisp:1.1 cell-cultures/celtic/canvas.lisp:1.2 --- cell-cultures/celtic/canvas.lisp:1.1 Sat Jun 26 11:38:38 2004 +++ cell-cultures/celtic/canvas.lisp Sun Jul 4 11:59:43 2004 @@ -22,6 +22,7 @@ (in-package :celtic)

(def-widget canvas () + () (-background -borderwidth -cursor -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -relief

Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.2 cell-cultures/celtic/celtic.lisp:1.3 --- cell-cultures/celtic/celtic.lisp:1.2 Sun Jun 27 16:54:28 2004 +++ cell-cultures/celtic/celtic.lisp Sun Jul 4 11:59:43 2004 @@ -84,11 +84,11 @@ ;;; start wish and set *w* (defun tk-start () #+:sbcl (setf *w* (do-execute "/usr/bin/wish" '("-name" "Cells-LTk"))) - #-:sbcl (setf *w* (do-execute "wish" '("-name" "Cells-LTk")))) + #-:sbcl (setf *w* (do-execute "wish84" '("-name" "Visual Apropos"))))

(defun tk-send (text) "send a string to wish" - (when *debug-tk* + (when nil ;; (search "pack " text) ;; *debug-tk* (format t "~&tk-send> ~A~%" text) (force-output)) (format *w* "~A~%" text) @@ -114,11 +114,14 @@

(defvar *callbacks* (make-hash-table :test #'equal))

-(defun register-callback(self callback-id fun - &aux (id (conc$ (path self) "." (down$ callback-id)))) - (format t "~&object ~a registering callback ~a: ~A" self id fun) +(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) @@ -126,18 +129,19 @@ (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))) - #+shhh (maphash (lambda (key func-self) + (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 func-self + (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 "after"))) + (tk-send (format nil "after ~a {puts -nonewline {("~A") };flush stdout}" + time (widget-callback-id self "after"))))

;; tool functions used by the objects

@@ -158,7 +162,7 @@ (defvar *tk-root*)

(defun mainloop() - (trc "mainloop !!! *w* is" *w*) + (trc nil "mainloop !!! *w* is" *w*) (let ((*exit-mainloop* nil) (*read-eval* nil)) ;;safety against malicious clients (loop @@ -167,22 +171,17 @@ (trc "sitting on mainloop read") (tk-read)))) (when (null msg) (return)) - (when t ;; *debug-tk* + (when *debug-tk* (format t "~&msg:~A<=~%" msg) (force-output))

(if (consp msg) (progn - (trc "dispatching callback" msg) + (trc nil "dispatching callback" msg) (dispatch-callback (first msg) (rest msg))) (let ((emsg (read-line *w* nil nil))) (trc "error msg:" msg emsg))) - #+not - (if (eql #( (elt msg 0)) - (let ((l (read-from-string msg))) - (trc "dispatching callback" l) - (dispatch-callback (first l) (rest l))) - (trc "mainloop gets tk error" msg)) + (when *exit-mainloop* (tk-send "exit") (return)))))) @@ -207,10 +206,8 @@ (tk-send (format nil "grid configure ~a -~a {~a}" (path widget) option value)))

(defun tk-test (fn) - (trc "input is" *standard-input* *standard-output*) - (trc "debug-io is" *debug-io*) - - (let ((*debug-tk* nil)) + (let ((*debug-tk* nil) + (*callbacks* (make-hash-table :test #'equal))) (cell-reset) (tk-start) (let ((*tk-root* (funcall fn)))

Index: cell-cultures/celtic/celtic.lpr diff -u cell-cultures/celtic/celtic.lpr:1.2 cell-cultures/celtic/celtic.lpr:1.3 --- cell-cultures/celtic/celtic.lpr:1.2 Sun Jun 27 16:54:28 2004 +++ cell-cultures/celtic/celtic.lpr Sun Jul 4 11:59:43 2004 @@ -11,9 +11,11 @@ (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 "button.lisp") + (make-instance 'module :name "menu.lisp") + (make-instance 'module :name "scrolling.lisp")) :projects (list (make-instance 'project-module :name - "c:\dvl\cells\cells")) + "..\cells\cells")) :libraries nil :distributed-files nil :project-package-name :celtic

Index: cell-cultures/celtic/frame.lisp diff -u cell-cultures/celtic/frame.lisp:1.3 cell-cultures/celtic/frame.lisp:1.4 --- cell-cultures/celtic/frame.lisp:1.3 Sun Jun 27 21:25:14 2004 +++ cell-cultures/celtic/frame.lisp Sun Jul 4 11:59:43 2004 @@ -21,95 +21,49 @@

(in-package :celtic)

-(def-widget frame () - (-borderwidth -cursor -highlightbackground -highlightcolor - -highlightthickness -padx -pady -relief - -takefocus -background (tk-class -class) - -colormap -container -height -visual -width)) +;--- group geometry -----------------------------------------

-(defun test-frame () - (make-be 'frame - :kids (loop repeat 2 - collecting (make-instance 'button - :text (format nil "Time is ~a" (floor (get-internal-real-time) 1000)) - :borderwidth 4 - :underline 2 - :cursor "hand2" - :font "Courier")))) - -;------------------------------------------------------- +(defmodel inline-mixin () + ((kids-layout :initarg :kids-layout :accessor kids-layout :initform nil) + (padx :initarg :padx :accessor padx :initform 0) + (pady :initarg :pady :accessor pady :initform 0) + (layout-side :initarg :layout-side :accessor layout-side :initform 'left) + (layout-anchor :initarg :layout-anchor :accessor layout-anchor :initform 'nw)) + (:default-initargs + :kid-slots (lambda (self) + (declare (ignore self)) + (list + (mk-kid-slot (layout :if-missing t) + nil))) ;; suppress default + :kids-layout (c? (format nil "pack~{ ~a~} -side ~a -anchor ~a -padx ~a -pady ~a" + (mapcar 'path (^kids)) + (down$ (^layout-side)) + (down$ (^layout-anchor)) + (^padx)(^pady)))))

-(def-widget labelframe () - (-borderwidth -cursor -highlightbackground -highlightcolor - -highlightthickness -padx -pady -relief - -takefocus -background (tk-class -class) -colormap -container -height -visual -width - -text -labelanchor -labelwidget)) +(def-c-output kids-layout () + (when new-value + (tk-send new-value)))

-(defmodel stack (frame) +(defmodel row-mixin (inline-mixin) () (:default-initargs - :kid-slots (lambda (self) - (declare (ignore self)) - (list - (mk-kid-slot (layout :if-missing t) - (c? (format nil "pack~{ ~a~} -side {top} -anchor nw" - (path self)))))))) -(defun stack (&rest init-args) - (apply 'make-instance 'stack init-args)) - - -(defun test-labelframe () - (make-be 'labelframe - :text "Considering" - :padx 16 - :pady 16 - :kids (loop repeat 2 - collecting (make-instance 'button - :text (format nil "Time is ~a" (floor (get-internal-real-time) 1000)) - :borderwidth 4 - :padx 8 - :underline 2 - :cursor "hand2" - :font "Courier")))) - -; ------------------------------------------------------------------ + :layout-side 'left))

-(defmodel labelframe-selector (selector labelframe)()) -(defun labelframe-selector (&rest init-args) - (apply 'make-instance 'labelframe-selector init-args)) - -;------------------------------------------------------- +(defmodel stack-mixin (inline-mixin) + () + (:default-initargs + :layout-side 'top))

-(defun layout-row () - (c? (format nil "pack ~a -side {left}; pack~{ ~a~} -side {left}" - (path self) (mapcar 'path (^kids))))) - -(defun layout-stack () - (c? (format nil "pack ~a -side {left}; pack~{ ~a~} -side {top} -anchor nw" - (path self) (mapcar 'path (^kids))))) - -(defmacro frame-row ((&rest options) &rest kids) - `(frame ,@(append options - `(:layout (layout-row) - :kids (c? (list ,@kids)))))) - -(defmacro frame-stack ((&rest options) &rest kids) - `(frame ,@(append options - `(:layout (layout-stack) - :kids (c? (list ,@kids))))))

;------------------------------------------------------

(defmodel selector () - ((selection :accessor selection :initarg :selection) - (initial-selection :initform nil :reader initial-selection - :initarg :initial-selection) - (tk-variable :cell nil :accessor tk-variable :initarg :tk-variable)) - (:default-initargs - :selection (c-in nil))) - -(def-c-output initial-selection () - (setf (selection self) new-value)) + ((selection :initform nil :accessor selection :initarg :selection) + (tk-variable :accessor tk-variable :initarg :tk-variable)) + (:default-initargs + :selection (c-in nil) + :tk-variable (c? (md-name self))))

(def-c-output selection () (when new-value @@ -117,14 +71,45 @@ (down$ (tk-variable self)) (down$ (md-name new-value))))))

-;--------------------------------------------------------- +;--- f r a m e --------------------------------------------------

-(defmodel radiogroup (selector) - ((tk-variable :accessor tk-variable :initarg :tk-variable)) - (:default-initargs - :tk-variable (c? (md-name self)))) +(def-widget frame () + () + (-borderwidth -cursor -highlightbackground -highlightcolor + -highlightthickness -padx -pady -relief + -takefocus -background (tk-class -class) + -colormap -container -height -visual -width)) + +(defmodel frame-selector (selector frame)()) +(defun 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) + (apply 'make-instance 'frame-stack init-args)) + +(defmodel frame-row (row-mixin frame-selector)()) +(defun frame-row (&rest init-args) + (apply 'make-instance 'frame-row init-args))

-(defmodel labelframe-radiogroup (radiogroup labelframe)()) -(defun labelframe-radiogroup (&rest init-args) - (apply 'make-instance 'labelframe-radiogroup init-args))

+;--- l a b e l f r a m e ---------------------------------------------- + +(def-widget labelframe () + () + (-borderwidth -cursor -highlightbackground -highlightcolor + -highlightthickness -padx -pady -relief + -takefocus -background (tk-class -class) -colormap -container -height -visual -width + -text -labelanchor -labelwidget)) + +(defmodel labelframe-selector (selector labelframe)()) +(defun 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) + (apply 'make-instance 'labelframe-stack init-args)) + +(defmodel labelframe-row (row-mixin labelframe-selector)()) +(defun labelframe-row (&rest init-args) + (apply 'make-instance 'labelframe-row init-args))

Index: cell-cultures/celtic/textual.lisp diff -u cell-cultures/celtic/textual.lisp:1.1 cell-cultures/celtic/textual.lisp:1.2 --- cell-cultures/celtic/textual.lisp:1.1 Sat Jun 26 11:38:38 2004 +++ cell-cultures/celtic/textual.lisp Sun Jul 4 11:59:43 2004 @@ -22,13 +22,14 @@ (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)) + () + (-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))

(defun test-label () (make-be 'label :text (format nil "Time is ~a" (get-internal-real-time)) @@ -39,6 +40,7 @@ ;--------------------------------------------------------------------------

(def-widget message () + () (-anchor -background -borderwidth -cursor -font -foreground -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief @@ -58,6 +60,7 @@ ;----------------------------------------------------------------------------

(def-widget entry () + ((text :initarg :text :accessor text :initform nil)) (-background -borderwidth -cursor -exportselection -font -foreground -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime @@ -66,4 +69,13 @@ -textvariable -xscrollcommand -disabledbackground -disabledforeground -invalidcommand -readonlybackground -show -state - -validate -validatecommand -width)) + -validate -validatecommand -width) + (:default-initargs + :textvariable (c? (md-name self)))) + +(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)))))

Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.2 cell-cultures/celtic/widget-item.lisp:1.3 --- cell-cultures/celtic/widget-item.lisp:1.2 Sun Jun 27 21:25:14 2004 +++ cell-cultures/celtic/widget-item.lisp Sun Jul 4 11:59:43 2004 @@ -26,7 +26,7 @@ (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self))

-;;; --- +;;; --- widget -----------------------------------------

(defmodel widget (family tk-object) ((name :initarg :name :accessor name @@ -35,29 +35,50 @@ :initform (c? (format nil "~a.~a" (if (fm-parent self) (path .parent) "") (name self)))) - (layout :reader layout :initarg :layout :initform nil) - (configurations :reader configurations :initarg :configurations :initform nil)) + (layout :reader layout :initarg :layout + :initform (c? (format nil "pack ~a" (path 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)))

+(defmethod not-to-be :after ((self widget)) + (trc "whacking true widget" self) + (tk-send (format nil "pack forget ~a" (^path)))) + (def-c-output command ((self widget)) - (let ((id (conc$ (path self) ".command"))) + (when (^command-is-callback) (register-callback self "command" new-value) (configure self "command" - (format nil "puts -nonewline {(~s)};flush stdout" id)))) + (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 configure ((self widget) option value) (tk-send (format nil "~A configure -~A {~A}" (path self) option value)))

-;;; --- layout -------------------- - (def-c-output layout ((self widget)) (when new-value (tk-send new-value)))

-(defmacro def-widget (class (&rest super-classes)(&rest tk-options) &rest defclass-options) - (let ((std-factory t)) - (flet ((de- (sym) (intern (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) (loop for tk-option-def in tk-options for slot-name = (de- (if (atom tk-option-def) @@ -71,12 +92,13 @@ (when new-value (configure self ,(down$ (de- (if (atom tk-option-def) tk-option-def (cadr tk-option-def)))) - (down$ new-value)))) + (if (stringp new-value) + new-value (down$ new-value))))) into outputs finally (return (values slot-defs outputs))) `(progn - (defmodel ,class (,@(append super-classes '(widget))) - (,@slots) + (defmodel ,class (widget) + (,@(append std-slots slots)) ,@defclass-options) (defun ,class (&rest inits) (apply 'make-instance ',class inits)) @@ -84,7 +106,10 @@ `(defmethod make-tk-instance ((self ,class)) (tk-send (format nil ,(concatenate 'string (down$ class) " ~A") (path self))))) - ,@outputs))))) + ,@outputs)))) + +(defmacro pack-layout? (fmt$ &rest args) + `(c? (format nil "pack ~a ~?" (^path) ,fmt$ (list ,@args))))

;;; --- items -----------------------------------------------------------------------

@@ -102,7 +127,7 @@

(defmethod make-tk-instance :after ((self item)) (setf (id-no self) (let ((msg (tk-read))) - ;;(trc "item msg" msg) + (trc "created item" self :id msg) (read-from-string msg))))

(defmethod configure ((self item) option value)