[cells-cvs] CVS update: cell-cultures/celtic/listbox.lisp cell-cultures/celtic/window.lisp cell-cultures/celtic/button.lisp cell-cultures/celtic/callback.lisp cell-cultures/celtic/celtic.lisp cell-cultures/celtic/celtic.lpr cell-cultures/celtic/demos.lisp 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
Sat Jul 17 14:02:24 UTC 2004
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 (, at superclasses)
+ (,@(append std-slots slots))
+ , at 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)))))
+ , at 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))))
, at 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)))
, at 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)))
More information about the Cells-cvs
mailing list