[cells-cvs] CVS update: cell-cultures/celtic/menu.lisp cell-cultures/celtic/scrolling.lisp cell-cultures/celtic/button.lisp cell-cultures/celtic/canvas.lisp cell-cultures/celtic/celtic.lisp cell-cultures/celtic/celtic.lpr cell-cultures/celtic/frame.lisp cell-cultures/celtic/textual.lisp cell-cultures/celtic/widget-item.lisp
Kenny Tilton
ktilton at common-lisp.net
Sun Jul 4 18:59:44 UTC 2004
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 , at kids))))))
-
-(defmacro frame-stack ((&rest options) &rest kids)
- `(frame ,@(append options
- `(:layout (layout-stack)
- :kids (c? (list , at 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)))
- (, at slots)
+ (defmodel ,class (widget)
+ (,@(append std-slots slots))
, at 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)))))
- , at outputs)))))
+ , at outputs))))
+
+(defmacro pack-layout? (fmt$ &rest args)
+ `(c? (format nil "pack ~a ~?" (^path) ,fmt$ (list , at 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)
More information about the Cells-cvs
mailing list