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