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