[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
Kenny Tilton
ktilton at common-lisp.net
Fri Jul 9 03:53:05 UTC 2004
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))
, at 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)))))
- , at outputs))))
+ (tk-format ,(format nil "~(~a~) ~~a" class) (path self))))
+ , at outputs)))
+
(defmacro pack-layout? (fmt$ &rest args)
`(c? (format nil "pack ~a ~?" (^path) ,fmt$ (list , at 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)
- (, at 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))))
- , at 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)
+ (, at 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)))
+ , at 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)))
More information about the Cells-cvs
mailing list