- cells-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-cvs] CVS update: cell-cultures/celtic/callback.lisp cell-cultures/celtic/demos.lisp
by Kenny Tilton 29 Sep '04

29 Sep '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv14617 Modified Files: callback.lisp demos.lisp Log Message: Not sure what I did! There is still a problem with text edit items, tho. Date: Wed Sep 29 05:09:59 2004 Author: ktilton Index: cell-cultures/celtic/callback.lisp diff -u cell-cultures/celtic/callback.lisp:1.3 cell-cultures/celtic/callback.lisp:1.4 --- cell-cultures/celtic/callback.lisp:1.3 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/callback.lisp Wed Sep 29 05:09:59 2004 @@ -61,6 +61,53 @@ (defun peek-char-no-hang (stream) (and (listen stream) (peek-char t stream))) +;;;<<<<<<< callback.lisp +;;;(defun peek-char-no-hang (stream) +;;; (and (listen stream) (peek-char nil stream))) +;;; +;;;(defun tk-eval-list (form$) +;;; ; +;;; ; clear stdin +;;; ; +;;; (trc "tk-eval-list > entry w eval form:" form$) +;;; (loop while (peek-char-no-hang *w*) +;;; do (if (eql #$ (peek-char t *w*)) +;;; (let ((msg (read *w*))) +;;; (trc "tk-eval-list > buffer not empty:" msg) +;;; (when (eql 'callback (first msg)) +;;; (trc "tk-eval-list > tending to callback:" (rest msg)) +;;; (dispatch-callback (rest msg)))) +;;; (c-break "tk-eval-list error 1: ~a" (read-line *w*)))) +;;; ; +;;; (trc "tk-eval-list > buffer clear, now evaluating (in Tk):" form$) +;;; ; +;;; (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))) +;;; (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 ("tk-eval-list > result:") +;;; (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))))) + (defun tk-eval-list (self form$) (let* ((id (copy-symbol 'eval-list)) result Index: cell-cultures/celtic/demos.lisp diff -u cell-cultures/celtic/demos.lisp:1.4 cell-cultures/celtic/demos.lisp:1.5 --- cell-cultures/celtic/demos.lisp:1.4 Thu Sep 2 05:19:16 2004 +++ cell-cultures/celtic/demos.lisp Wed Sep 29 05:09:59 2004 @@ -33,6 +33,27 @@ (defmodel all (window) () (:default-initargs +;;;<<<<<<< demos.lisp +;;; :md-value (c? (let ((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)

1 0

[cells-cvs] CVS update: cell-cultures/cells/constructors.lisp cell-cultures/cells/defmodel.lisp cell-cultures/cells/initialize.lisp cell-cultures/cells/md-slot-value.lisp cell-cultures/cells/model-object.lisp cell-cultures/cells/propagate.lisp cell-cultures/cells/synapse-types.lisp cell-cultures/cells/synapse.lisp
by Kenny Tilton 29 Sep '04

29 Sep '04

Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv13558/cells Modified Files: constructors.lisp defmodel.lisp initialize.lisp md-slot-value.lisp model-object.lisp propagate.lisp synapse-types.lisp synapse.lisp Log Message: Resolve problems with FTGL. Texture fonts will require upcoming fix in FTGL 2.1 currently in testing Date: Wed Sep 29 04:50:18 2004 Author: ktilton Index: cell-cultures/cells/constructors.lisp diff -u cell-cultures/cells/constructors.lisp:1.2 cell-cultures/cells/constructors.lisp:1.3 --- cell-cultures/cells/constructors.lisp:1.2 Sun Jul 4 20:59:41 2004 +++ cell-cultures/cells/constructors.lisp Wed Sep 29 04:50:13 2004 @@ -82,7 +82,7 @@ ,result)))))) (defmacro c-formula ((&rest keys &key lazy) &body forms) - (declare (ignore lazy)) + (assert (member lazy '(nil t :once-asked :until-asked :always))) `(make-c-dependent :code ',forms :value-state :unevaluated Index: cell-cultures/cells/defmodel.lisp diff -u cell-cultures/cells/defmodel.lisp:1.2 cell-cultures/cells/defmodel.lisp:1.3 --- cell-cultures/cells/defmodel.lisp:1.2 Wed Jul 21 13:49:37 2004 +++ cell-cultures/cells/defmodel.lisp Wed Sep 29 04:50:13 2004 @@ -80,8 +80,7 @@ (:metaclass ,(or (find :metaclass options :key #'car) 'standard-class))) - #-allegro-v6.2 - (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs) + (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key) (declare (ignore slot-names iargs)) ,(when (and directsupers (not (member 'model-object directsupers))) `(unless (typep self 'model-object) Index: cell-cultures/cells/initialize.lisp diff -u cell-cultures/cells/initialize.lisp:1.1 cell-cultures/cells/initialize.lisp:1.2 --- cell-cultures/cells/initialize.lisp:1.1 Sat Jun 26 20:38:36 2004 +++ cell-cultures/cells/initialize.lisp Wed Sep 29 04:50:13 2004 @@ -70,13 +70,6 @@ (c-ephemeral-reset c))) (defmethod c-awaken-cell ((c c-ruled)) - ; - ; ^svuc (with askers supplied) calls c-awaken, and now we call ^svuc crucially without askers - ; this oddity comes from an incident in which an asker-free invocation of ^svuc - ; successfully calculated when the call passing askers failed, i guess because askers not - ; actually to be consulted given the algorithm still were detected as self-referential - ; since the self-ref detector could not anticipate the algorithm's branching. - ; (let (*c-calculators*) (trc "c-awaken-cell c-ruled clearing *c-calculators*" c) (c-calculate-and-set c))) Index: cell-cultures/cells/md-slot-value.lisp diff -u cell-cultures/cells/md-slot-value.lisp:1.3 cell-cultures/cells/md-slot-value.lisp:1.4 --- cell-cultures/cells/md-slot-value.lisp:1.3 Wed Jul 7 03:25:40 2004 +++ cell-cultures/cells/md-slot-value.lisp Wed Sep 29 04:50:13 2004 @@ -84,7 +84,7 @@ (let ((raw-value (progn (let ((*c-calculators* (cons c *c-calculators*))) - (trc nil "c-calculate-and-set> just added to *c-calculators*:" + (trc nil "c-calculate-and-set> new *c-calculators*:" *c-calculators*) (c-assert (c-model c)) (funcall (cr-rule c) c))))) Index: cell-cultures/cells/model-object.lisp diff -u cell-cultures/cells/model-object.lisp:1.4 cell-cultures/cells/model-object.lisp:1.5 --- cell-cultures/cells/model-object.lisp:1.4 Wed Jul 21 13:49:37 2004 +++ cell-cultures/cells/model-object.lisp Wed Sep 29 04:50:13 2004 @@ -136,26 +136,26 @@ (setf (md-state self) :awakening) (dolist (esd (class-slots (class-of self))) (when (md-slot-cell-type (type-of self) (slot-definition-name esd)) - (let ((slot-name (slot-definition-name esd))) - (let ((c (md-slot-cell self slot-name))) - (when *c-debug* - (bwhen (sv (and (slot-boundp self slot-name) - (slot-value self slot-name))) - (when (typep sv 'cell) - (c-break "md-awaken ~a found cell ~a in slot ~a" self sv esd)))) + (let* ((slot-name (slot-definition-name esd)) + (c (md-slot-cell self slot-name))) + (when *c-debug* + (bwhen (sv (and (slot-boundp self slot-name) + (slot-value self slot-name))) + (when (typep sv 'cell) + (c-break "md-awaken ~a found cell ~a in slot ~a" self sv esd)))) - (if c - (cond - ((c-lazy c) - (trc nil "md-awaken deferring c-awaken since lazy" - self esd)) - ((eq :nascent (c-state c)) (c-awaken c))) + (if c + (cond + ((find (c-lazy c) '(:until-asked :always t)) + (trc nil "md-awaken deferring c-awaken since lazy" + self esd)) + ((eq :nascent (c-state c)) (c-awaken c))) - (progn ;; next bit revised to avoid double-output of optimized cells - (when (eql '.kids slot-name) - (bwhen (sv (slot-value self '.kids)) - (md-kids-change self sv nil :md-awaken-slot))) - (c-output-initially self slot-name))))))) + (progn + (when (eql '.kids slot-name) + (bwhen (sv (slot-value self '.kids)) + (md-kids-change self sv nil :md-awaken-slot))) + (c-output-slot nil slot-name self (bd-slot-value self slot-name) nil nil)))))) (setf (md-state self) :awake) self) Index: cell-cultures/cells/propagate.lisp diff -u cell-cultures/cells/propagate.lisp:1.3 cell-cultures/cells/propagate.lisp:1.4 --- cell-cultures/cells/propagate.lisp:1.3 Wed Jul 7 03:25:40 2004 +++ cell-cultures/cells/propagate.lisp Wed Sep 29 04:50:13 2004 @@ -60,13 +60,15 @@ (trc nil "c-propagate-to-users > queueing" c :cause *causation*) (let ((causation (cons c *causation*))) ;; in case deferred (with-integrity (:user-notify :user-notify c) + (assert (null *c-calculators*)) (let ((*causation* causation)) (trc nil "c-propagate-to-users > notifying users of" c) (dolist (user (c-users c)) (bwhen (dead (catch :mdead (trc nil "c-propagate-to-users> *data-pulse-id*, user, c:" *data-pulse-id* user c) (when (c-user-cares user) - (c-value-ensure-current user)))) + (c-value-ensure-current user)) + nil)) (when (eq dead (c-model c)) (trc nil "!!! aborting further user prop of dead" dead) (return-from c-propagate-to-users)) @@ -74,23 +76,10 @@ (defun c-user-cares (c) (not (or (c-currentp c) - (cr-lazy c)))) + (member (cr-lazy c) '(t :always :once-asked))))) (defun c-output-defined (slot-name) (getf (symbol-plist slot-name) :output-defined)) - -(defun c-output-initially (self slot-name) - "call during instance init to force initial output." - (trc nil "c-output-initially" self slot-name - (c-output-defined slot-name) - (md-slot-cell self slot-name)) - (bif (c (md-slot-cell self slot-name)) - (cond - ((c-lazy c)) - ((c-inputp c) - (c-propagate c nil nil)) - (t (md-slot-value self slot-name))) ;; this will output after calculating if not nil - (c-output-slot nil slot-name self (bd-slot-value self slot-name) nil nil))) (defun c-output-slot (c slot-name self new-value prior-value prior-value-supplied) (let ((causation *causation*)) ;; in case deferred Index: cell-cultures/cells/synapse-types.lisp diff -u cell-cultures/cells/synapse-types.lisp:1.1 cell-cultures/cells/synapse-types.lisp:1.2 --- cell-cultures/cells/synapse-types.lisp:1.1 Sat Jun 26 20:38:36 2004 +++ cell-cultures/cells/synapse-types.lisp Wed Sep 29 04:50:13 2004 @@ -26,7 +26,7 @@ `(with-synapse ((prior-fire-value) :fire-p (lambda (syn new-value) (declare (ignorable syn)) - (trc "f-sensitivity fire-p decides" prior-fire-value ,sensitivity) + (trc nil "f-sensitivity fire-p decides" prior-fire-value ,sensitivity) (or (xor prior-fire-value new-value) (eko (nil "fire-p decides" new-value prior-fire-value ,sensitivity) (delta-greater-or-equal Index: cell-cultures/cells/synapse.lisp diff -u cell-cultures/cells/synapse.lisp:1.2 cell-cultures/cells/synapse.lisp:1.3 --- cell-cultures/cells/synapse.lisp:1.2 Sun Jul 4 20:59:41 2004 +++ cell-cultures/cells/synapse.lisp Wed Sep 29 04:50:13 2004 @@ -36,8 +36,7 @@ ,@body))) (cd-synapses (car *c-calculators*))))))) - (progn ;;let ((*c-calculators* (cons synapse *c-calculators*))) - (c-value-ensure-current synapse))))) + (c-value-ensure-current synapse)))) (defmacro make-synaptic-ruled (syn-user (fire-p fire-value) &body body) (let ((new-value (gensym))

1 0

[cells-cvs] CVS update: cell-cultures/cellodemo/cellodemo.lpr cell-cultures/cellodemo/demo-window.lisp cell-cultures/cellodemo/hedron-decoration.lisp cell-cultures/cellodemo/hedron-render.lisp cell-cultures/cellodemo/light-panel.lisp
by Kenny Tilton 29 Sep '04

29 Sep '04

Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv13558/cellodemo Modified Files: cellodemo.lpr demo-window.lisp hedron-decoration.lisp hedron-render.lisp light-panel.lisp Log Message: Resolve problems with FTGL. Texture fonts will require upcoming fix in FTGL 2.1 currently in testing Date: Wed Sep 29 04:50:11 2004 Author: ktilton Index: cell-cultures/cellodemo/cellodemo.lpr diff -u cell-cultures/cellodemo/cellodemo.lpr:1.2 cell-cultures/cellodemo/cellodemo.lpr:1.3 --- cell-cultures/cellodemo/cellodemo.lpr:1.2 Sun Jul 4 20:59:40 2004 +++ cell-cultures/cellodemo/cellodemo.lpr Wed Sep 29 04:50:11 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] (Sep 3, 2004 12:04)"; common-graphics: "1.389.2.105.2.14"; -*- (in-package :common-graphics-user) Index: cell-cultures/cellodemo/demo-window.lisp diff -u cell-cultures/cellodemo/demo-window.lisp:1.1 cell-cultures/cellodemo/demo-window.lisp:1.2 --- cell-cultures/cellodemo/demo-window.lisp:1.1 Sat Jun 26 20:38:35 2004 +++ cell-cultures/cellodemo/demo-window.lisp Wed Sep 29 04:50:11 2004 @@ -28,7 +28,7 @@ (run-stylish-demos '(light-panel ft-jpg tu-geo ftgl-test demo-scroller) 'light-panel :skin (c? (wand-ensure-typed 'wand-texture - (car (md-value (fm-other :texture-picker))))) + (car (md-value (fm-other :texture-picker))))) :focus (c-in nil) :display-continuous (c-in nil) :clear-rgba (list 0 0 0 1) @@ -85,18 +85,28 @@ (make-instance 'gui-style-ftgl :id :button :face *gui-style-button-face* - :sizes '(14 14 14 14 14) + :sizes '(12 12 12 12 12) :text-color +white+) (make-instance 'gui-style-ftgl :id :label :face *gui-style-button-face* - :sizes '(14 14 16 14 14) + :sizes '(14 14 14 14 14) + :text-color +white+) + (make-instance 'gui-style-ftgl + :id :unique + :face *gui-style-button-face* + :sizes '(24 24 24 24 24) + :text-color +white+) + (make-instance 'gui-style-ftgl + :id :unique2 + :face *gui-style-button-face* + :sizes '(18 18 18 18 18) :text-color +white+) (make-instance 'gui-style-ftgl :id :default :mode :texture :face *gui-style-button-face* - :sizes '(14 9 16 12 14) + :sizes '(14 9 14 14 14) :text-color +green+)) (apply 'run-demos demo-names start-at iargs))) @@ -125,8 +135,7 @@ :pos (make-ff-array :float 200 (downs 300) (farther 500) 1) :ambient *dusk* :diffuse *dim* - :specular *bright*) - ) + :specular *bright*)) :recording nil #+not (c? (when (md-value (fm-other :record)) (make-recording :wand (magick-wand-template) @@ -236,7 +245,7 @@ (a-stack (:spacing (u16ths 1)) (texture-picker) (demo-picker)) - (a-stack (:spacing (u96ths 6) + #+nah (a-stack (:spacing (u96ths 6) :justify :center :outset (u96ths 6) :visible (c? (not (snapshot-release-id .w.))) Index: cell-cultures/cellodemo/hedron-decoration.lisp diff -u cell-cultures/cellodemo/hedron-decoration.lisp:1.1 cell-cultures/cellodemo/hedron-decoration.lisp:1.2 --- cell-cultures/cellodemo/hedron-decoration.lisp:1.1 Sat Jun 26 20:38:35 2004 +++ cell-cultures/cellodemo/hedron-decoration.lisp Wed Sep 29 04:50:11 2004 @@ -97,7 +97,7 @@ :resizeable nil :content (c? (mk-part :shape (ix-stack) :pre-layer (with-layers +white+ :fill) - :md-value (c-in (list 'cube)) + :md-value (c-in (list 'cello)) :kids (c? (loop for shape in '(cube 4 8 12 rhombic-dodecahedron 20 cylinder cone sphere torus sierpinski-sponge teapot cello) Index: cell-cultures/cellodemo/hedron-render.lisp diff -u cell-cultures/cellodemo/hedron-render.lisp:1.1 cell-cultures/cellodemo/hedron-render.lisp:1.2 --- cell-cultures/cellodemo/hedron-render.lisp:1.1 Sat Jun 26 20:38:35 2004 +++ cell-cultures/cellodemo/hedron-render.lisp Wed Sep 29 04:50:11 2004 @@ -35,17 +35,19 @@ (glut-ftgl-cello font gl_fill)) (defun glut-wire-cello (font) - (trc "string width" - (font-string-width 96 font "Cello")) + (trc nil "string width" + (font-string-width 96 font + "2Cel2lo")) (glut-ftgl-cello font gl_line)) (defun glut-ftgl-cello (font poly-style) - (gl-polygon-mode gl_front_and_back poly-style) - ; (gl-rotatef g_rot 1.0f0 0.5f0 0.0f0) - (gl-scalef .05 .05 .05) - ;(gl-Scalef .1 .1 .1) - ;(gl-Translatef -20 -20 0) - (ftgl-render font "Cello")) + (gl-polygon-mode gl_front_and_back poly-style) + ; (gl-rotatef g_rot 1.0f0 0.5f0 0.0f0) + (gl-scalef .05 .05 .05) + ;(gl-Scalef .1 .1 .1) + ;(gl-Translatef -20 -20 0) + + (ftgl-render font "Cello")) (defparameter *sponge-offset* (loop with fv = (fgn-alloc 'gldouble 3 :sponge) for n below 3 Index: cell-cultures/cellodemo/light-panel.lisp diff -u cell-cultures/cellodemo/light-panel.lisp:1.1 cell-cultures/cellodemo/light-panel.lisp:1.2 --- cell-cultures/cellodemo/light-panel.lisp:1.1 Sat Jun 26 20:38:35 2004 +++ cell-cultures/cellodemo/light-panel.lisp Wed Sep 29 04:50:11 2004 @@ -34,7 +34,7 @@ (mat-emission :initform nil :initarg :mat-emission :reader mat-emission)) (:default-initargs :lighting :on - :text-font (ftgl-make :extruded *gui-style-default-face* 36 96 18) + :text-font (ftgl-make :extruded *gui-style-default-face* 18 96 9) :rotation (let ((rx 0)(ry 0)(rz 0)) (c? (let ((spinning (md-value (fm-other :spinning)))) (macrolet ((radj (axis ixid) @@ -47,6 +47,9 @@ (radj ry :roty) (radj rz :rotz))))))))) +(defmethod display-text$ ((self Hedron)) + "quick dirty to satisfy ix-styled ogl-disp-list-prep" + "2Cel2lo") (defmodel rgba-mixer (ix-stack) ((red :cell nil :initarg :red :initform nil)

1 0

[cells-cvs] CVS update: cell-cultures/cello/cello-ftgl.lisp cell-cultures/cello/image.lisp cell-cultures/cello/ix-render.lisp cell-cultures/cello/ix-styled.lisp cell-cultures/cello/ix-text.lisp cell-cultures/cello/mouse-click.lisp cell-cultures/cello/slider.lisp cell-cultures/cello/window-callbacks.lisp cell-cultures/cello/window.lisp
by Kenny Tilton 29 Sep '04

29 Sep '04

Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv13558/cello Modified Files: cello-ftgl.lisp image.lisp ix-render.lisp ix-styled.lisp ix-text.lisp mouse-click.lisp slider.lisp window-callbacks.lisp window.lisp Log Message: Resolve problems with FTGL. Texture fonts will require upcoming fix in FTGL 2.1 currently in testing Date: Wed Sep 29 04:50:09 2004 Author: ktilton Index: cell-cultures/cello/cello-ftgl.lisp diff -u cell-cultures/cello/cello-ftgl.lisp:1.1 cell-cultures/cello/cello-ftgl.lisp:1.2 --- cell-cultures/cello/cello-ftgl.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/cello-ftgl.lisp Wed Sep 29 04:50:09 2004 @@ -77,10 +77,72 @@ (defmethod make-style-font ((style gui-style-ftgl)) (font-ftgl-ensure (mode style) (face style) (gui-style-size style))) -(defmethod ogl-dsp-list-prep progn ((self ftgl)) - "Do stuff needed before render but not needed/wanted in display list" - (ftgl::ftgl-get-display-font self)) - +(defun ftgl-debug () + (let (*w*) + (with-styles ( + (make-instance 'gui-style-ftgl + :id :button + :face *gui-style-button-face* + :sizes '(12 12 12 12 12) + :text-color +white+) + (make-instance 'gui-style-ftgl + :id :label + :face *gui-style-button-face* + :sizes '(14 14 14 14 14) + :text-color +white+) + (make-instance 'gui-style-ftgl + :id :unique + :face *gui-style-button-face* + :sizes '(24 24 24 24 24) + :text-color +white+) + (make-instance 'gui-style-ftgl + :id :unique2 + :face *gui-style-button-face* + :sizes '(18 18 18 18 18) + :text-color +white+) + (make-instance 'gui-style-ftgl + :id :default + :mode :texture + :face *gui-style-button-face* + :sizes '(14 9 14 14 14) + :text-color +green+)) + (run-window (make-instance 'ftgl-window) + (lambda () + ;;; -- not sure how much of this new reset stuff is necessary --- + (cl-opengl-init) + (cl-ftgl-reset) + (cl-ftgl-init)))))) + +(defmodel ftgl-window (window) + () + (:default-initargs + :idler nil + :display-continuous t + :ll 0 :lt 0 + :lr (c-in (scr2log 900)) + :lb (c-in (scr2log -900)) + :md-name :ftgl-w + :title$ "Hello, ftgl" + :skin nil + :lighting :off + :clear-rgba (list 0 0 0 1) + :pre-layer (c? (with-layers +blue+ :off)) + :clipped nil + :kids (c? (the-kids + (a-stack (:md-name :ftgl-debug :spacing (upts 10) :px 0 :py (downs (uin 1)) + :justify :left + :outset (u8ths 1)) + (loop for s in (list "hell" ;;"hlwr" ;;"hlwr 1212" + "hi2" + "hello, world 222" "1212" + ) + for n upfrom 0 + collecting (mk-part :sample (ix-text) + :lighting :off + :text$ s + :style-id :unique + :pre-layer (c? (with-layers (:rgba (if (^mouse-over-p) + +red+ +blue+))))))))))) (defun ftgl-test () @@ -185,6 +247,9 @@ (trc nil "ix-render-in-font ftgl-texture" :pxy (pxy self) (l-rect self) t$) (gl-enable gl_texture_2d) + (trc "(gl-is-enabled gl_texture_2d)!!!!!!!" (gl-is-enabled gl_texture_2d) + (ogl-get-boolean gl_texture_2d)) + ;;(assert (ogl-get-boolean gl_texture_2d)) (gl-disable gl_lighting) (gl-enable gl_blend) (gl-blend-func gl_src_alpha gl_one_minus_src_alpha) Index: cell-cultures/cello/image.lisp diff -u cell-cultures/cello/image.lisp:1.2 cell-cultures/cello/image.lisp:1.3 --- cell-cultures/cello/image.lisp:1.2 Sun Jul 4 20:59:40 2004 +++ cell-cultures/cello/image.lisp Wed Sep 29 04:50:09 2004 @@ -38,22 +38,24 @@ (defmodel ogl-node () ((dsp-list :initarg :dsp-list :accessor dsp-list - :initform (c? (ogl-dsp-list-prep self) - (when (every 'dsp-list (kids self)) - (let ((display-list-name (or .cache (gl-gen-lists 1))) - (*window-rendering* (nearest self window))) - - (assert (not *ogl-listing-p*)) - (gl-new-list display-list-name gl_compile) - (let ((*ogl-listing-p* self) - *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) - (with-metrics (nil nil "(funcall renderer)" self) - (ix-paint self))) - (gl-end-list) - (setf (redisplayp *window-rendering*) t) - #+nah (when (typep self 'window) - (c-break "got display list for ~a" self)) - display-list-name)))) + :initform (c-formula (:lazy :until-asked) + (assert *w*) + (assert (not *ogl-listing-p*)) + (ogl-dsp-list-prep self) + (when (every 'dsp-list (kids self)) + (let ((display-list-name (or .cache (gl-gen-lists 1))) + (*window-rendering* (nearest self window))) + (trc nil "display-list-name" display-list-name self) + + (gl-new-list display-list-name gl_compile) + + (let ((*ogl-listing-p* self) + *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) + (with-metrics (nil nil "(funcall renderer)" self) + (ix-paint self))) + (gl-end-list) + (setf (redisplayp *window-rendering*) t) + display-list-name)))) (gl-name :initarg :gl-name :initform nil :accessor gl-name) (renderer :initarg :renderer :initform nil :accessor renderer))) Index: cell-cultures/cello/ix-render.lisp diff -u cell-cultures/cello/ix-render.lisp:1.1 cell-cultures/cello/ix-render.lisp:1.2 --- cell-cultures/cello/ix-render.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-render.lisp Wed Sep 29 04:50:09 2004 @@ -47,10 +47,7 @@ (when (and (not lights) (emergency-lighting self)) (trc nil "emergency lighting" self) (dolist (e-light (emergency-lighting self)) - (ix-render-light e-light)))) - - ) - + (ix-render-light e-light))))) (defmethod ix-paint :after ((self family)) (dolist (k (kids self)) @@ -63,7 +60,9 @@ (unless (typep k 'window) ;; GLUT gives subwindows their own display callback (count-it :call-list) - (gl-call-list (dsp-list k))))) + (if (dsp-list k) + (gl-call-list (dsp-list k)) + (ix-paint k))))) (defun rpchk (id pfail psucc &optional self) (declare (ignorable pfail)) @@ -86,7 +85,7 @@ (ogl-pen-move (px self) (py self)) ; /// combine former in here? (when n - (trc "gl-name" self n) + (trc nil "gl-name" self n) (gl-push-name n)) (rpchk 'ix-paint t nil self) Index: cell-cultures/cello/ix-styled.lisp diff -u cell-cultures/cello/ix-styled.lisp:1.1 cell-cultures/cello/ix-styled.lisp:1.2 --- cell-cultures/cello/ix-styled.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-styled.lisp Wed Sep 29 04:50:09 2004 @@ -73,7 +73,8 @@ (when style ;;(print `(gui-style ,style ,(styles-default))) (or (find style (styles-default) :key 'id) - (find :default (styles-default) :key 'id)))) + (find :default (styles-default) :key 'id) + (break "gui-style cannot find requested style ~a" style)))) (defmodel ix-styled () ((style-id :initarg :style-id @@ -81,6 +82,7 @@ :reader style-id) (style :initform (c? (gui-style (^style-id))) + :initarg :style :reader style) (text-font :reader text-font :initarg :text-font @@ -100,8 +102,27 @@ (with-layers (:rgba (^text-color))))))) -(defmethod ogl-dsp-list-prep progn ((self ix-styled)) - (ogl-dsp-list-prep (text-font self))) +(defmethod ogl-dsp-list-prep progn ((self ix-styled) &aux (font (text-font self))) + (assert (not *ogl-listing-p*)) + (trc nil "ogl-dsp-list-prep sub-prepping font" font) + (typecase font + (ftgl-extruded + (unless (ftgl::ftgl-disp-ready-p font) + (fgc-set-face-size (ftgl::ftgl-get-metrics-font font) + (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) + (ix-string-width self (^display-text$))) + (ftgl-texture + #+not (loop with x for c across (^display-text$) + do (pushnew (fgc-char-texture (ftgl::ftgl-get-metrics-font font)(char-code c)) x) + finally (trc "font,string,textures" font (^display-text$) x)) + #+no? (unless (ftgl::ftgl-disp-ready-p font) + (trc "setting face size" font) + (fgc-set-face-size (ftgl::ftgl-get-metrics-font font) + (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) + ;;(trc (eql 12 (ftgl::ftgl-size font)) "forcing glyphs" (ftgl::ftgl-face font) (^display-text$)) + #+not (ix-string-width self (^display-text$))) + ) + (ftgl::ftgl-get-display-font font)) (defmethod make-style-font ((style gui-style-glut-stroke)) (make-font-glut-stroke Index: cell-cultures/cello/ix-text.lisp diff -u cell-cultures/cello/ix-text.lisp:1.1 cell-cultures/cello/ix-text.lisp:1.2 --- cell-cultures/cello/ix-text.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-text.lisp Wed Sep 29 04:50:09 2004 @@ -154,6 +154,11 @@ :initform (c? (cons (now)(frame-ct .w.))))) (:default-initargs :style-id :button + :style (make-instance 'gui-style-ftgl + :id :button + :face *gui-style-button-face* + :sizes '(16 16 16 16 16) + :text-color +white+) :inset (mkv2 (upts 2)(upts 0)) ;;:lt 15 :lb -5 :char-mask "999" Index: cell-cultures/cello/mouse-click.lisp diff -u cell-cultures/cello/mouse-click.lisp:1.1 cell-cultures/cello/mouse-click.lisp:1.2 --- cell-cultures/cello/mouse-click.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/mouse-click.lisp Wed Sep 29 04:50:09 2004 @@ -74,14 +74,7 @@ (focus-navigate (focus (click-window self)) (clickee self)))) (to-be self) ;; unnecessary? 2301kt just moved this from after next line - (trc "echo click set self clickee" self (clickee self)) - (bwhen (c (cells::md-slot-cell (clickee self) 'click-evt)) - (trc "echo click-evt cell" c) - (dolist (u (cells::c-users c)) - (trc "echo click-evt cell user" c u)) - (if (c-debug c) - (trace ctl-notify-mouse-click) - (untrace ctl-notify-mouse-click))) + (trc nil "echo click set self clickee" self (clickee self)) (when (clickee self) (setf (click-evt (clickee self)) self))) Index: cell-cultures/cello/slider.lisp diff -u cell-cultures/cello/slider.lisp:1.1 cell-cultures/cello/slider.lisp:1.2 --- cell-cultures/cello/slider.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/slider.lisp Wed Sep 29 04:50:09 2004 @@ -91,7 +91,7 @@ (def-c-output tracked-pct () (when new-value - (trc "tracked-pct output sets slider" self) + (trc nil "tracked-pct output sets slider" self) (slider-set self new-value))) (defun make-slider (md-name &key (md-value-fn 'identity) @@ -104,5 +104,5 @@ (defun slider-set (self value) (assert (typep self 'ix-slider)) - (trc "slider set") + (trc nil "slider set") (setf (drag-pct (second (kids self))) value)) Index: cell-cultures/cello/window-callbacks.lisp diff -u cell-cultures/cello/window-callbacks.lisp:1.1 cell-cultures/cello/window-callbacks.lisp:1.2 --- cell-cultures/cello/window-callbacks.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/window-callbacks.lisp Wed Sep 29 04:50:09 2004 @@ -51,33 +51,6 @@ (w-post-redisplay *w*))) (apply callback args)))))) -;;;(defmacro def-Window-callback (fn-name args &body body) -;;; `(ff-defun-callable :cdecl :void ,fn-name ,args -;;; (window-callback fn-name (lambda ,args ,@body)))) -;;; -;;;(defun window-callback (fn-name callback) -;;; (unless (c-stopped) -;;; ;; -;;; ;; this next bit makes sense because no cell rule evaluation could -;;; ;; depend on something touched during a callback, but then no cell -;;; ;; rule should dynamically encompass a callback, so...why reset -;;; ;; the calculators (dependents) global? it is necessary -;;; ;; because, when an error occurs, error-handling can cause -;;; ;; re-entrance and, if a cell rule was being evaluated, suddenly -;;; ;; the programmer is looking at an error about "too many dependencies" -;;; ;; instead of the original error. there is probably a better way to handle -;;; ;; all this, but for now... 2003-04-05kwt -;;; ;; -;;; (let* (cells::*c-calculators* -;;; (*w* (mg-window-current))) -;;; (if *w* -;;; (prog2 -;;; (setf (redisplayp *w*) nil) -;;; (progn ,@body) -;;; (when (redisplayp *w*) -;;; (w-post-redisplay *w*))) -;;; (progn ,@body)))))) - (def-window-callback mgwkey (k x y) (trc "mgwkey" k x y (glutgetwindow)) (bwhen (w *w*) @@ -111,14 +84,25 @@ (bwhen (w (mg-window-current)) (ix-idle w)))) +#+bzzzt +(defun dnr (n) + (locally (declare (special %displaying%)) + (print `(dnr ,n)) + (unless (and (boundp '%displaying%) %displaying%) + (let ((%displaying% t)) + (when (< n 2) + (dnr (1+ n))))))) + + (def-window-callback mg-glut-display () - (unless (or (c-stopped) (null *w*)) + (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox + (c-stopped) (null *w*)) (with-metrics (nil nil "mg-glut-display") - (trc nil "mg-glut-display > about to render w " *w* (glutgetwindow)) + (trc nil "mg-glut-display > about to render w " *w* (glutgetwindow)) (window-display *w*)))) (defmethod window-display ((self window)) - (gl-call-list (dsp-list self)) + (ix-paint self) ;; (gl-call-list (dsp-list self)) (glut-swap-buffers) (incf (frame-ct self)) Index: cell-cultures/cello/window.lisp diff -u cell-cultures/cello/window.lisp:1.1 cell-cultures/cello/window.lisp:1.2 --- cell-cultures/cello/window.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/window.lisp Wed Sep 29 04:50:09 2004 @@ -384,12 +384,12 @@ (glut-destroy-window (glutw self))))) (defmethod mg-window-reshape (self width height) - (trc "mg-window-reshape" self width height) + (trc nil "mg-window-reshape" self width height) (gl-viewport 0 0 width height) (gl-matrix-mode gl_projection) (gl-load-identity) - (trc "mg-window-reshape ortho" 0 width (- height) 0 *mgw-near* *mgw-far*) + (trc nil "mg-window-reshape ortho" 0 width (- height) 0 *mgw-near* *mgw-far*) (gl-ortho 0 width (- height) 0 *mgw-near* *mgw-far*) (gl-load-identity) (trc nil "mg-window-reshape > new window wid,hei:" self width height) @@ -403,7 +403,8 @@ (when run-init-func (funcall run-init-func)) (let ((ogl::*gl-stop* nil) - (ogl::*gl-begun* nil)) ;;/// wrap these two in a macro? + (ogl::*gl-begun* nil) ;;/// wrap these two in a macro? + *w* *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (setf cello::*sys* nil) (cello-reset 'mg-system)

1 0

[cells-cvs] CVS update: cell-cultures/celtic/canvas.lisp cell-cultures/celtic/celtic.lisp cell-cultures/celtic/celtic.lpr cell-cultures/celtic/demos.lisp cell-cultures/celtic/widget-item.lisp cell-cultures/celtic/window.lisp
by Kenny Tilton 02 Sep '04

02 Sep '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv28119/celtic Modified Files: canvas.lisp celtic.lisp celtic.lpr demos.lisp widget-item.lisp window.lisp Log Message: Now supporting all Tk menu types, all Tk widgets, and all Tk canvas items except image and window Date: Thu Sep 2 05:19:17 2004 Author: ktilton Index: cell-cultures/celtic/canvas.lisp diff -u cell-cultures/celtic/canvas.lisp:1.3 cell-cultures/celtic/canvas.lisp:1.4 --- cell-cultures/celtic/canvas.lisp:1.3 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/canvas.lisp Thu Sep 2 05:19:16 2004 @@ -32,29 +32,8 @@ -closeenough -confine -height -scrollregion -width -xscrollincrement -yscrollincrement)) -(def-item rectangle - (-dash - -activedash - -disableddash - -dashoffset - (tk-fill -fill) - -activefill - -disabledfill - -offset - -outline - -activeoutline - -disabledoutline - -outlinestipple - -activeoutlinestipple - -disabledoutlinestipple - -stipple - -activestipple - -disabledstipple - -state - -tags - -width - -activewidth - -disabledwidth)) +(def-item rectangle (standard-item)()) +(def-item oval (standard-item)()) (defun test-rectangle () (make-be 'canvas @@ -62,65 +41,41 @@ :coords (list 10 10 100 60) :tk-fill "red")))) -(def-item text - ((tk-fill -fill) - -activefill - -disabledfill - -stipple - -activestipple - -disabledstipple - -state - -tags - -anchor +(def-item text (standard-item) + (-anchor -font -justify -text -width)) +(def-item arc (standard-item) + (-extent -start -style)) -#| +(def-item bitmap (standard-item) + (-anchor + -background + -activebackground + -disabledbackground + -bitmap + -activebitmap + -disabledbitmap + -foreground + -activeforeground + -disabledforeground)) + +(def-item image (standard-item) + (-anchor + -image + -activeimage + -disabledimage)) -ARC ITEMS +(def-item line (standard-item) + (-arrow -arrowshape -capstyle -joinstyle -smooth -splinesteps)) -Items of type arc appear on the display as arc-shaped regions. An arc is a section of an oval delimited by two angles (specified by the -start and -extent options) and displayed in one of several ways (specified by the -style option). Arcs are created with widget commands of the following form: +(def-item polygon (standard-item) + (-joinstyle -smooth -splinesteps)) -pathName create arc x1 y1 x2 y2 ?option value option value ...? -pathName create arc coordList ?option value option value ...? - -The arguments x1, y1, x2, and y2 or coordList give the coordinates of two diagonally opposite corners of a rectangular region enclosing the oval that defines the arc. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option-value pairs may be used in itemconfigure widget commands to change the item's configuration. -The following standard options are supported by arcs: - --dash --activedash --disableddash --dashoffset --fill --activefill --disabledfill --offset --outline --activeoutline --disabledoutline --outlinestipple --activeoutlinestipple --disabledoutlinestipple --stipple --activestipple --disabledstipple --state --tags --width --activewidth --disabledwidth - -The following extra options are supported for arcs: - --extent degrees - Specifies the size of the angular range occupied by the arc. The arc's range extends for degrees degrees counter-clockwise from the starting angle given by the -start option. Degrees may be negative. If it is greater than 360 or less than -360, then degrees modulo 360 is used as the extent. --start degrees - Specifies the beginning of the angular range occupied by the arc. Degrees is given in units of degrees measured counter-clockwise from the 3-o'clock position; it may be either positive or negative. --style type - Specifies how to draw the arc. If type is pieslice (the default) then the arc's region is defined by a section of the oval's perimeter plus two line segments, one between the center of the oval and each end of the perimeter section. If type is chord then the arc's region is defined by a section of the oval's perimeter plus a single line segment connecting the two end points of the perimeter section. If type is arc then the arc's region consists of a section of the perimeter alone. In this last case the -fill option is ignored. +|# BITMAP ITEMS @@ -173,47 +128,6 @@ -activeimage name -disabledimage name Specifies the name of the images to display in the item in is normal, active and disabled states. This image must have been created previously with the image create command. - -LINE ITEMS - -Items of type line appear on the display as one or more connected line segments or curves. Line items support coordinate indexing operations using the canvas widget commands: dchars, index, insert. Lines are created with widget commands of the following form: - -pathName create line x1 y1... xn yn ?option value option value ...? -pathName create line coordList ?option value option value ...? - -The arguments x1 through yn or coordList give the coordinates for a series of two or more points that describe a series of connected line segments. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option-value pairs may be used in itemconfigure widget commands to change the item's configuration. -The following standard options are supported by lines: - --dash --activedash --disableddash --dashoffset --fill --activefill --disabledfill --stipple --activestipple --disabledstipple --state --tags --width --activewidth --disabledwidth - -The following extra options are supported for lines: - --arrow where - Indicates whether or not arrowheads are to be drawn at one or both ends of the line. Where must have one of the values none (for no arrowheads), first (for an arrowhead at the first point of the line), last (for an arrowhead at the last point of the line), or both (for arrowheads at both ends). This option defaults to none. --arrowshape shape - This option indicates how to draw arrowheads. The shape argument must be a list with three elements, each specifying a distance in any of the forms described in the COORDINATES section above. The first element of the list gives the distance along the line from the neck of the arrowhead to its tip. The second element gives the distance along the line from the trailing points of the arrowhead to the tip, and the third element gives the distance from the outside edge of the line to the trailing points. If this option isn't specified then Tk picks a ``reasonable'' shape. --capstyle style - Specifies the ways in which caps are to be drawn at the endpoints of the line. Style may have any of the forms accepted by Tk_GetCapStyle (butt, projecting, or round). If this option isn't specified then it defaults to butt. Where arrowheads are drawn the cap style is ignored. --joinstyle style - Specifies the ways in which joints are to be drawn at the vertices of the line. Style may have any of the forms accepted by Tk_GetCapStyle (bevel, miter, or round). If this option isn't specified then it defaults to miter. If the line only contains two points then this option is irrelevant. --smooth smoothMethod - smoothMethod must have one of the forms accepted by Tk_GetBoolean or a line smoothing method. Only bezier is supported in the core, but more can be added at runtime. If a boolean false value or empty string is given, no smoothing is applied. A boolean truth value assume bezier smoothing. It indicates whether or not the line should be drawn as a curve. If so, the line is rendered as a set of parabolic splines: one spline is drawn for the first and second line segments, one for the second and third, and so on. Straight-line segments can be generated within a curve by duplicating the end-points of the desired line segment. --splinesteps number - Specifies the degree of smoothness desired for curves: each spline will be approximated with number line segments. This option is ignored unless the -smooth option is true. OVAL ITEMS Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.7 cell-cultures/celtic/celtic.lisp:1.8 --- cell-cultures/celtic/celtic.lisp:1.7 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/celtic.lisp Thu Sep 2 05:19:16 2004 @@ -19,6 +19,9 @@ |# +(eval-when (compile load) + (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) + (defpackage :celtic (:nicknames :ctk) (:use #:common-lisp #:utils-kt #:cells @@ -31,6 +34,8 @@ ;communication with wish ;;; this is the only function one needs to adapt to other lisps +(defparameter *ewish* nil) + (defun do-execute (program args &optional (wt nil)) "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. @@ -63,106 +68,22 @@ (process-output proc) (process-input proc)) ) - #+:lispworks (system:open-pipe fullstring :direction :io) - #+allegro (let ((proc (excl:run-shell-command - #+mswindows fullstring - #-mswindows (apply #'vector program program args) - :input :stream :output :stream :wait wt))) - (unless proc - (error "Cannot create process.")) - proc - ))) - -(defun convert(from to) - (close (do-execute "convert" (list from to) t))) - -;; tool functions used by the objects - -;; incremental counter to create unique numbers -(let ((counter 1)) - (defun tk-names-reset() - (setf counter 1)) - (defun get-counter() - (incf counter))) - -;; create unique widget name, append unique number to "w" -(defun create-name () - (format nil "w~A" (get-counter))) - -;;;; main event loop, runs until stream is closed by wish (wish exited) or -;;;; the variable *exit-tk-listen* is set - -(defvar *exit-tk-listen* nil) - -(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))) - - (loop - (let ((msg$ (read-line #+not read-preserving-whitespace wish nil nil))) - (when (null msg$) - (return)) - (trc nil "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) - (let ((master-path (if master - (path master) - ""))) - (format nil "~A.~A" master-path name))) - -(defgeneric grid-columnconfigure (w c o v)) -(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 (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 (self option value) - (tk-send self "grid configure ~a -~a {~a}" (path self) option value)) + #+:lispworks (system:open-pipe fullstring :direction :io) + #+allegro (multiple-value-bind (stream error-stream process-id) + (excl:run-shell-command + #+mswindows fullstring + #-mswindows (apply #'vector program program args) + :input :stream :output :stream + :error-output :stream + :wait wt) + (declare (ignorable dummy error-stream process-id)) + (trc "doexec!!!> " stream error-stream process-id) + (if stream + (progn + (setf *ewish* error-stream) + stream) + (error "Cannot create WISH process."))))) Index: cell-cultures/celtic/celtic.lpr diff -u cell-cultures/celtic/celtic.lpr:1.6 cell-cultures/celtic/celtic.lpr:1.7 --- cell-cultures/celtic/celtic.lpr:1.6 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/celtic.lpr Thu Sep 2 05:19:16 2004 @@ -7,6 +7,7 @@ (define-project :name :celtic :application-type (intern "Standard EXE" (find-package :keyword)) :modules (list (make-instance 'module :name "celtic.lisp") + (make-instance 'module :name "celtic2.lisp") (make-instance 'module :name "widget-item.lisp") (make-instance 'module :name "window.lisp") (make-instance 'module :name "frame.lisp") @@ -47,7 +48,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'nowtest + :on-initialization 'celtic::tk-test-all :on-restart 'do-default-restart) ;; End of Project Definition Index: cell-cultures/celtic/demos.lisp diff -u cell-cultures/celtic/demos.lisp:1.3 cell-cultures/celtic/demos.lisp:1.4 --- cell-cultures/celtic/demos.lisp:1.3 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/demos.lisp Thu Sep 2 05:19:16 2004 @@ -26,6 +26,7 @@ (tk-names-reset) (tk-listen (make-be root-class))) +(defun tk-test-all ()(tk-test 'all)) (defun mk-font-view () (make-be 'font-view)) @@ -38,6 +39,37 @@ (mk-frame-stack :layout (pack-self) :kids (c? (list + (mk-canvas + :kids (c? (list + (mk-rectangle + :coords (list 10 10 100 60) + :tk-fill "red") + (mk-text + :coords (list 100 80) + :text "i am an item" + :tk-fill 'blue) + (mk-arc + :coords (list 10 100 100 160) + :start 45 + :tk-fill "white") + (mk-line + :width 8 + :smooth 'bezier + :joinstyle 'miter + :coords (list 250 10 300 40 250 70 400 100) + :arrow 'both) + (mk-oval + :coords (list 10 200 100 260) + :tk-fill "yellow") + (mk-polygon + :width 4 + :tk-fill 'green + :smooth 'bezier + :joinstyle 'miter + :coords (list 250 210 300 220 340 200 260 180)) + (mk-bitmap + :coords (list 40 300) + :bitmap "@\\temp\\gsl.xbm")))) (mk-labelframe-row :text "Style by Edit Menu" ;;:layout (pack-layout? "-side left -fill x -expand 1") @@ -116,6 +148,26 @@ (selection (fm^ :font-face)) (md-value (fm^ :font-size))))))))) +#| +-defaultextension + Specifies a string that will be appended to the filename if the user enters a filename without an extension. The defaut value is the empty string, which means no extension will be appended to the filename in any case. This option is ignored on the Macintosh platform, which does not require extensions to filenames, and the UNIX implementation guesses reasonable values for this from the -filetypes option when this is not supplied. +-filetypes filePatternList + If a File types listbox exists in the file dialog on the particular platform, this option gives the filetypes in this listbox. When the user choose a filetype in the listbox, only the files of that type are listed. If this option is unspecified, or if it is set to the empty list, or if the File types listbox is not supported by the particular platform then all files are listed regardless of their types. See the section SPECIFYING FILE PATTERNS below for a discussion on the contents of filePatternList. +-initialdir directory + Specifies that the files in directory should be displayed when the dialog pops up. If this parameter is not specified, then the files in the current working directory are displayed. If the parameter specifies a relative path, the return value will convert the relative path to an absolute path. This option may not always work on the Macintosh. This is not a bug. Rather, the General Controls control panel on the Mac allows the end user to override the application default directory. +-initialfile filename + Specifies a filename to be displayed in the dialog when it pops up. This option is ignored on the Macintosh platform. +-multiple + Allows the user to choose multiple files from the Open dialog. On the Macintosh, this is only available when Navigation Services are installed. +-message string + Specifies a message to include in the client area of the dialog. This is only available on the Macintosh, and only when Navigation Services are installed. +-parent window + Makes window the logical parent of the file dialog. The file dialog is displayed on top of its parent window. +-title titleString + Specifies a string to display as the title of the dialog box. If this option is not specified, then a default title is displayed. + +|# + (defun demo-all-menubar () (mk-menubar :kids (c? (list @@ -127,12 +179,12 @@ (mk-menu-entry-command :label "New" :command "exit") (mk-menu-entry-command :label "Open" - :command "exit") + :command "tk_getOpenFile") (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)) + :state (c? (if t ;; (md-value (fm^ :check-me)) 'normal 'disabled)) :command "exit"))))))) (mk-menu-entry-cascade Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.8 cell-cultures/celtic/widget-item.lisp:1.9 --- cell-cultures/celtic/widget-item.lisp:1.8 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/widget-item.lisp Thu Sep 2 05:19:16 2004 @@ -178,7 +178,7 @@ (coords :initarg :coords :initform nil)) (:documentation "not full blown widgets, but decorations thereof") (:default-initargs - :name (c-in nil) ;; assigned by Tk upon creation + ;;:name (c-in nil) ;; assigned by Tk upon creation )) (defmethod not-to-be :after ((self item)) @@ -187,14 +187,16 @@ (defmethod make-tk-instance :after ((self item)) (setf (id-no self) (let ((msg (tk-read self))) + (unless (parse-integer msg) + (break "Error creating item ~a : ~a" self msg)) (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-send self "~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) (down$ option) value)) -(defmacro def-item (class (&rest tk-options)) +(defmacro def-item (class (&rest superclasses)(&rest tk-options)) (multiple-value-bind (slots outputs) (loop for tk-option-def in tk-options for tk-option = (if (atom tk-option-def) @@ -213,7 +215,7 @@ into outputs finally (return (values slot-defs outputs))) `(progn - (defmodel ,class (item) + (defmodel ,class ,(or superclasses '(item)) (,@slots)) (defun ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) (apply 'make-instance ',class inits)) @@ -227,3 +229,28 @@ (when (and (id-no self) new-value) (tk-send self "~a coords ~a ~{ ~a~}" (path .parent) (id-no self) new-value))) + + +(def-item standard-item () + (-dash + -activedash + -disableddash + -dashoffset + (tk-fill -fill) + -activefill + -disabledfill + -offset + -outline + -activeoutline + -disabledoutline + -outlinestipple + -activeoutlinestipple + -disabledoutlinestipple + -stipple + -activestipple + -disabledstipple + -state + -tags + -width + -activewidth + -disabledwidth)) \ No newline at end of file Index: cell-cultures/celtic/window.lisp diff -u cell-cultures/celtic/window.lisp:1.2 cell-cultures/celtic/window.lisp:1.3 --- cell-cultures/celtic/window.lisp:1.2 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/window.lisp Thu Sep 2 05:19:16 2004 @@ -66,10 +66,14 @@ ; -------------------------------------------------------- + + (defmodel window (family) ((wish :initarg :wish :accessor wish - :initform (c? (do-execute "wish" - (list (format nil "-name ~s" (title$ self)))))) + :initform (c? (do-execute "wish84" + nil #+not (list (format nil "-name ~s" (title$ self)))))) + (ewish :initarg :ewish :accessor ewish + :initform nil :cell nil) (title$ :initarg :title$ :accessor title$ :initform (c? (string (class-name (class-of self))))) (dictionary :initarg :dictionary :initform (make-hash-table) :accessor dictionary) @@ -86,7 +90,7 @@ "send a string to wish" (let ((text (apply 'format nil fmt$ args))) (when (find-if (lambda (s) (search s text)) - '(".font-size" )) ;; *debug-tk* + '("100" )) ;; *debug-tk* (format t "~&tk-send> ~A~%" text)) (format (wish .tkw) "~A~%" text) #+needed? (force-output (wish .tkw))))

1 0

[cells-cvs] CVS update: cell-cultures/utils-kt/strings.lisp
by Kenny Tilton 21 Jul '04

21 Jul '04

Update of /project/cells/cvsroot/cell-cultures/utils-kt In directory common-lisp.net:/tmp/cvs-serv705/utils-kt Modified Files: strings.lisp Log Message: Date: Wed Jul 21 04:49:40 2004 Author: ktilton Index: cell-cultures/utils-kt/strings.lisp diff -u cell-cultures/utils-kt/strings.lisp:1.1 cell-cultures/utils-kt/strings.lisp:1.2 --- cell-cultures/utils-kt/strings.lisp:1.1 Sat Jun 26 11:38:43 2004 +++ cell-cultures/utils-kt/strings.lisp Wed Jul 21 04:49:40 2004 @@ -159,11 +159,12 @@ (down$ s)) (defun down$ (s) - (etypecase s + (typecase s (null "") (string (string-downcase s)) (number (format nil "~a" s)) - (symbol (string-downcase (symbol-name s))))) + (symbol (string-downcase (symbol-name s))) + (cons (format nil "~{~(~a~)~^ ~}" s)))) (defun lower$ (s) (string-downcase s))

1 0

[cells-cvs] CVS update: cell-cultures/clyde/visual-apropos/visual-apropos.lisp
by Kenny Tilton 21 Jul '04

21 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde/visual-apropos In directory common-lisp.net:/tmp/cvs-serv705/clyde/visual-apropos Modified Files: visual-apropos.lisp Log Message: Date: Wed Jul 21 04:49:40 2004 Author: ktilton Index: cell-cultures/clyde/visual-apropos/visual-apropos.lisp diff -u cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.4 cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.5 --- cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.4 Thu Jul 8 20:53:05 2004 +++ cell-cultures/clyde/visual-apropos/visual-apropos.lisp Wed Jul 21 04:49:39 2004 @@ -24,44 +24,42 @@ ;; ------------------- ;; to run, enter following in repl: ;; -;; (tk-test 'vis-apropos) +;; (tk-test 'visual-apropos) ;; -(defun vis-apropos () - (make-be 'visual-apropos - :sub-symbol (c-in 'padding))) - -(defmodel visual-apropos (frame-stack) +(defmodel visual-apropos (window) ((symbols :initarg :symbols :initform nil :accessor symbols) - (sub-symbol :initarg :sub-symbol :initform nil :accessor sub-symbol)) + (sub-symbol :initarg :sub-symbol :initform 'thread :accessor sub-symbol)) (:default-initargs :symbols (c-in nil) - :pady 2 - :padx 4 - :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") :kids (c? (list - (search-for-symbol) - (mk-frame-row - :padx 8 - :layout (pack-layout? "-side left -fill x") + (mk-frame-stack + :pady 2 + :padx 4 + :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") :kids (c? (list - (mk-frame-stack + (search-for-symbol) + (mk-frame-row + :padx 8 :kids (c? (list - (mk-checkbutton :md-name :exported-only - :text "Exported Only" - :underline 1 - :md-value (c-in nil) - :command (lambda (self) - (setf (^md-value) (not (^md-value))))) - (show-which-symbols)))) - (package-filtering)))) - (symbol-list))))) + (mk-frame-stack + :kids (c? (list + (mk-checkbutton :md-name :exported-only + :text "Exported Only" + :underline 1 + :md-value (c-in nil) + :command (c? (Tk-callback self 'cmd + (lambda (self key &rest args) + (declare (ignore key args)) + (setf (^md-value) (not (^md-value))))))) + (show-which-symbols)))) + (package-filtering)))) + (symbol-list)))))))) (defun search-for-symbol () (mk-frame-row :relief 'ridge :padx 8 - :layout (pack-layout? "-side left -fill x -anchor nw") :kids-layout (c? (format nil "pack ~a -side left; pack ~a -side left -expand 1 -fill x; pack ~a -side right" (path (kid1 self)) @@ -74,16 +72,18 @@ :width 64) (mk-button :text "Search" :underline 0 - :command (lambda (self) - (setf (symbols (upper self visual-apropos)) - (apropos-list (text (fm^ :search-string)))))))))) + :command (c? (Tk-callback self 'cmd + (lambda (self key &rest args) + (declare (ignore key args)) + (setf (symbols (upper self visual-apropos)) + (apropos-list (text (fm^ :search-string)))))))))))) ; --- symbol package filtering ------------------------------- (defun package-filtering () (mk-labelframe-row :text "Package(s) to Search" - :layout (pack-layout? "-side left -fill x -expand 1") + ;;:layout (pack-layout? "-side left -fill x -expand 1") :kids (c? (list (mk-checkbutton :md-name :all-pkgs :text "All" @@ -125,7 +125,7 @@ (defun symbol-list () (mk-frame-stack :md-name :symbol-list - :layout (pack-layout? "-side top -expand 1 -fill both") + ;;:layout (pack-layout? "-side top -expand 1 -fill both") :width 64 :background 'red :kids (c? (list @@ -208,13 +208,15 @@ (defmodel va-sorter (sort-button) ((sort-string-fn :initform 'string :initarg :sort-string-fn :accessor sort-string-fn)) (:default-initargs - :command (lambda (self) - (let* ((ss (fm^ :sym-sort))) - (if (eq self (or (md-value ss) (kid1 ss))) - (setf (sort-button-predicate self) - (if (eq (sort-button-predicate self) 'va-string<) - 'va-string> 'va-string<)) - (setf (md-value ss) self)))) + :command (c? (Tk-callback self 'cmd + (lambda (self key &rest args) + (declare (ignore key args)) + (let* ((ss (fm^ :sym-sort))) + (if (eq self (or (md-value ss) (kid1 ss))) + (setf (sort-button-predicate self) + (if (eq (sort-button-predicate self) 'va-string<) + 'va-string> 'va-string<)) + (setf (md-value ss) self)))))) :sort-button-predicate (c-in 'va-string<) :sort-button-key (c? (lambda (si) (funcall (^sort-string-fn)

1 0

21 Jul '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv705/celtic Modified Files: button.lisp callback.lisp canvas.lisp celtic.lisp celtic.lpr demos.lisp frame.lisp menu.lisp scrolling.lisp textual.lisp widget-item.lisp window.lisp Added Files: choice.lisp Removed Files: listbox.lisp Log Message: Date: Wed Jul 21 04:49:38 2004 Author: ktilton Index: cell-cultures/celtic/button.lisp diff -u cell-cultures/celtic/button.lisp:1.6 cell-cultures/celtic/button.lisp:1.7 --- cell-cultures/celtic/button.lisp:1.6 Sat Jul 17 07:02:23 2004 +++ cell-cultures/celtic/button.lisp Wed Jul 21 04:49:38 2004 @@ -23,26 +23,19 @@ ;-------------------------------------------------------------------------- -(def-widget button () - () - (-activebackground -activeforeground -anchor -background - -bitmap -borderwidth -cursor -disabledforeground - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -image -justify -padx -pady -relief -repeatdelay - -repeatinterval -takefocus -text -textvariable -underline -wraplength - -command -compound -default -height -overrelief -state -width)) - -(def-widget checkbutton () - () - (-activebackground -activeforeground -anchor -background - -bitmap -borderwidth -cursor -disabledforeground - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -image -justify -padx - -pady -relief -takefocus -text - -textvariable -underline -wraplength - -command -height -indicatoron -offrelief -offvalue -onvalue +(def-widget button (standard-widget) + ()() + (-command -compound -default -height -overrelief -state -width)) + +(def-widget radiocheck (standard-widget) + ()() + (-command -height -indicatoron -offrelief -overrelief -selectcolor -selectimage -state -tristateimage - -tristatevalue (-tk-variable -variable) -width) + -tristatevalue (-tk-variable -variable) -width)) + +(def-widget checkbutton (radiocheck) + ()() + (-offvalue -onvalue) (:default-initargs :md-value (c-in nil) :command (c? (tk-callback self 'toggle @@ -56,83 +49,36 @@ (down$ (md-name self)) (if new-value 1 0))) -(def-widget radiobutton () +(def-widget radiobutton (radiocheck) () - (-activebackground -activeforeground -anchor -background - -bitmap -borderwidth -cursor -disabledforeground - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -image -justify -padx - -pady -relief -takefocus -text - -textvariable -underline -wraplength - -command -height -indicatoron -offrelief -value - -overrelief -selectcolor -selectimage -state -tristateimage - -tristatevalue (-tk-variable -variable) -width) + () + (-value) (:default-initargs + :tk-variable (c? (path (upper self selector))) :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 () +(def-widget scale (standard-widget) + () () - (-activebackground -background -borderwidth -cursor - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -orient -relief -repeatdelay - -repeatinterval -takefocus -troughcolor + ( -orient -repeatdelay + -repeatinterval -bigincrement -command -digits -from (-tk-label -label) (-tk-length -length) -resolution -showvalue -sliderlength -sliderrelief - -state -tickinterval -to (-tk-variable -variable) -width) + -state -tickinterval -to (-tk-variable nil) -width) (:default-initargs :md-value (c-in nil) - :command (c? (tk-callback self 'radio-set + :tk-variable nil ;;(c? (^path)) + :command (c? (tk-callback self 'scale-set (lambda (self id &rest args) (declare (ignore id)) - (eko ("scale now" self) - (setf (^md-value) (car args)))))))) + (setf (^md-value) (car args))))))) -(def-c-output .md-value ((self scale)) - (when new-value - (if (listp 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 - -insertofftime -insertontime -insertwidth -justify - -relief -repeatdelay -repeatinterval -selectbackground - -selectborderwidth -selectforeground -takefocus -textvariable - -xscrollcommand - -buttonbackground -buttoncursor -buttondownrelief - -buttonuprelief - -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 (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-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))) +(defmethod make-tk-instance :after ((self scale)) + (when (^md-value) + (tk-send self "~a set ~a" (^path) (^md-value)))) Index: cell-cultures/celtic/callback.lisp diff -u cell-cultures/celtic/callback.lisp:1.2 cell-cultures/celtic/callback.lisp:1.3 --- cell-cultures/celtic/callback.lisp:1.2 Sat Jul 17 07:02:23 2004 +++ cell-cultures/celtic/callback.lisp Wed Jul 21 04:49:38 2004 @@ -24,12 +24,15 @@ (defun register-callback (self callback-id fun) (let ((id (intern (string-upcase - (format nil "~a.~a" (path self) callback-id))))) + (format nil "~a.~a" (path-index self) callback-id))))) (assert (not (gethash id (callbacks .tkw)))) - (trc "registering callback" self :id id) + (trc nil "registering callback" self :id id) (setf (gethash id (callbacks .tkw)) (cons fun self)) id)) +(defmethod path-index (self) (^path)) + + (defun dispatch-callback (window callback) (destructuring-bind (callback-id &rest callback-args) callback (let ((func-self (gethash callback-id (callbacks window)))) @@ -63,7 +66,8 @@ result (full-id (register-callback self id (lambda (self id &rest args) - (trc "tk-eval-list" self id args) + (declare (ignorable self id)) + (trc nil "tk-eval-list" self id args) (setf result args))))) (tk-send self (format nil Index: cell-cultures/celtic/canvas.lisp diff -u cell-cultures/celtic/canvas.lisp:1.2 cell-cultures/celtic/canvas.lisp:1.3 --- cell-cultures/celtic/canvas.lisp:1.2 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/canvas.lisp Wed Jul 21 04:49:38 2004 @@ -23,11 +23,12 @@ (def-widget canvas () () - (-background -borderwidth -cursor -highlightbackground - -highlightcolor -highlightthickness -insertbackground -insertborderwidth - -insertofftime -insertontime -insertwidth -relief - -selectbackground -selectborderwidth -selectforeground -state - -takefocus -xscrollcommand -yscrollcommand + () + (-background -borderwidth -cursor -highlightbackground + -highlightcolor -highlightthickness -insertbackground -insertborderwidth + -insertofftime -insertontime -insertwidth -relief + -selectbackground -selectborderwidth -selectforeground -state + -takefocus -xscrollcommand -yscrollcommand -closeenough -confine -height -scrollregion -width -xscrollincrement -yscrollincrement)) Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.6 cell-cultures/celtic/celtic.lisp:1.7 --- cell-cultures/celtic/celtic.lisp:1.6 Sat Jul 17 07:02:23 2004 +++ cell-cultures/celtic/celtic.lisp Wed Jul 21 04:49:38 2004 @@ -108,7 +108,7 @@ (let ((msg$ (read-line #+not read-preserving-whitespace wish nil nil))) (when (null msg$) (return)) - (trc "tk-listen> read:" msg$) + (trc nil "tk-listen> read:" msg$) (loop with start = 0 and state = 'init and func and self and callback-id and args Index: cell-cultures/celtic/celtic.lpr diff -u cell-cultures/celtic/celtic.lpr:1.5 cell-cultures/celtic/celtic.lpr:1.6 --- cell-cultures/celtic/celtic.lpr:1.5 Sat Jul 17 07:02:23 2004 +++ cell-cultures/celtic/celtic.lpr Wed Jul 21 04:49:38 2004 @@ -16,7 +16,7 @@ (make-instance 'module :name "menu.lisp") (make-instance 'module :name "scrolling.lisp") (make-instance 'module :name "callback.lisp") - (make-instance 'module :name "listbox.lisp") + (make-instance 'module :name "choice.lisp") (make-instance 'module :name "demos.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells")) Index: cell-cultures/celtic/demos.lisp diff -u cell-cultures/celtic/demos.lisp:1.2 cell-cultures/celtic/demos.lisp:1.3 --- cell-cultures/celtic/demos.lisp:1.2 Sat Jul 17 07:02:23 2004 +++ cell-cultures/celtic/demos.lisp Wed Jul 21 04:49:38 2004 @@ -34,9 +34,23 @@ (:default-initargs :kids (c? (list (demo-all-menubar) + (mk-frame-stack :layout (pack-self) :kids (c? (list + (mk-labelframe-row + :text "Style by Edit Menu" + ;;:layout (pack-layout? "-side left -fill x -expand 1") + :kids (c? (list + (mk-label :text "Four score and seven years ago today" + :wraplength 600 + :font (c? (list + (selection (fm^ :app-font-face)) + (selection (fm^ :app-font-size)) + (if (md-value (fm^ :app-font-italic)) + 'italic 'roman) + (if (md-value (fm^ :app-font-bold)) + 'bold 'normal))))))) (mk-frame-row :kids (c? (list (mk-button :text "Press Me" @@ -47,6 +61,7 @@ (mk-entry :text "Enter Me" :layout nil)))) (mk-frame-row + :selection (c-in 'yes) :kids (c? (list (mk-checkbutton :md-name :check-me :text "check Me" @@ -58,11 +73,6 @@ (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") @@ -78,10 +88,33 @@ :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"))) - ))))))) + (style-by-widgets)))))))) + +(defun style-by-widgets () + (mk-labelframe-stack + :text "Style by Widgets" + ;;:layout (pack-layout? "-side left -fill x -expand 1") + :kids (c? (list + (mk-frame-row + :layout-anchor 'sw + :kids (c? (list + (mk-popup-menubutton + :md-name :font-face + :initial-value (c? (down$ (car (^entry-values)))) + :entry-values (c? (tk-eval-list self "font families"))) + + (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 + (selection (fm^ :font-face)) + (md-value (fm^ :font-size))))))))) (defun demo-all-menubar () (mk-menubar @@ -103,9 +136,11 @@ 'normal 'disabled)) :command "exit"))))))) (mk-menu-entry-cascade + :md-name 'editcascade :label "Edit" :kids (c? (list (mk-menu + :md-name 'editmenu :kids (c? (list (mk-menu-entry-command :label "Undo" :command (tk-callback .tkw 'undo @@ -121,42 +156,40 @@ (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-radio-group :md-name :app-font-face + :selection (c-in "courier") + :kids (c? (list + (mk-menu-entry-radiobutton + :label "Times" :value "times") + (mk-menu-entry-radiobutton + :label "Courier" :value "courier") + (mk-menu-entry-radiobutton + :label "Helvetica" :value "helvetica")))) (mk-menu-entry-separator) (mk-menu-entry-cascade + :md-name :app-font-size :label "Font Size" :menu (c? (path (kid1 self))) + :selection (c-in 12) :kids (c? (list (mk-menu + :tearoff 1 + :last-index 0 :kids (c? (list (mk-menu-entry-radiobutton - :label "9" :value 9 - :tk-variable "fontsize" - :command nil) + :label "9" :value 9) (mk-menu-entry-radiobutton - :label "12" :value 12 - :tk-variable "fontsize" - :command nil) + :label "12" :value 12) (mk-menu-entry-radiobutton - :label "14" :value 14 - :tk-variable "fontsize" - :command nil))))))) + :label "14" :value 14))))))) (mk-menu-entry-separator) - (mk-menu-entry-checkbutton :label "Italic" - :command nil) - (mk-menu-entry-checkbutton :label "Bold" - :command nil) + (mk-menu-entry-checkbutton + :md-name :app-font-italic + :label "Italic") + (mk-menu-entry-checkbutton + :md-name :app-font-bold + :label "Bold" + :md-value (c-in t)) )))))))))) (defmodel font-view (window) () Index: cell-cultures/celtic/frame.lisp diff -u cell-cultures/celtic/frame.lisp:1.6 cell-cultures/celtic/frame.lisp:1.7 --- cell-cultures/celtic/frame.lisp:1.6 Sat Jul 17 07:02:23 2004 +++ cell-cultures/celtic/frame.lisp Wed Jul 21 04:49:38 2004 @@ -63,18 +63,20 @@ (tk-variable :accessor tk-variable :initarg :tk-variable)) (:default-initargs :selection (c-in nil) - :tk-variable (c? (md-name self)))) + :tk-variable (c? (^path)))) (def-c-output selection () (when new-value + (trc nil "def-c-output selection" (type-of new-value) (md-name new-value) new-value) (tk-send self "set ~a ~a" (down$ (tk-variable self)) - (down$ (md-name new-value))))) + (tk-down$ (md-name new-value))))) ;--- f r a m e -------------------------------------------------- (def-widget frame () () + () (-borderwidth -cursor -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -background (tk-class -class) @@ -96,6 +98,7 @@ ;--- l a b e l f r a m e ---------------------------------------------- (def-widget labelframe () + () () (-borderwidth -cursor -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief Index: cell-cultures/celtic/menu.lisp diff -u cell-cultures/celtic/menu.lisp:1.4 cell-cultures/celtic/menu.lisp:1.5 --- cell-cultures/celtic/menu.lisp:1.4 Sat Jul 17 07:02:23 2004 +++ cell-cultures/celtic/menu.lisp Wed Jul 21 04:49:38 2004 @@ -25,14 +25,15 @@ 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)) +(def-widget menu () + (:std-factory nil) + ((last-index :cell nil :initarg :last-index :initform -1 :accessor last-index) + (label :initarg :label :initform nil :accessor label)) (-activebackground -activeborderwidth -activeforeground -background -borderwidth -cursor -disabledforeground -font -foreground -relief -takefocus @@ -40,10 +41,19 @@ (-title nil) (-tk-type -type))) (defmethod make-tk-instance ((self menu)) - (trc "make-tk-instance menu" self :parent .parent (type-of .parent) + (trc nil "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)))) +(defmethod make-tk-instance :after ((self menu)) + (fm-menu-traverse self + (lambda (entry &aux (menu self)) + (assert (typep entry 'menu-entry)) + (setf (index entry) (incf (last-index menu))) + (tk-send menu + (format nil "~(~a~) add ~(~a~)" + (path menu)(entry-type entry)))))) + ;;; --- menu bars ----------------------------------- (defmodel menubar (menu)()) @@ -55,15 +65,27 @@ ;;; --- menu entries ------------------------------------ -(defmodel menu-entry (tk-object) - ((index :initarg :index :accessor index - :initform (c? (kid-no self))) +(defmodel menu-entry (model) + ((index :cell nil :initarg :index :accessor index :initform nil) (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 path-index ((self menu-entry)) + (format nil "~a.~a" (path (upper self menu))(index self))) + +(defun fm-menu-traverse (family fn) + "Traverse family arbitrarily deep as need to reach all menu-entries +without recursively penetrating nested menu (in which case menu-entries +encountered would belong to that menu, versus the one on which fm-menu-traverse +was implicitly invoked (which is why menu is not passed to callback fn))." + (loop for k in (kids family) + do (typecase k + (menu-entry (funcall fn k)) + (menu (c-break "not stopped at cascase?")) + (family (fm-menu-traverse k fn))))) (defmethod not-to-be :after ((self menu-entry)) (trc nil "whacking menu-entry" self) @@ -72,14 +94,13 @@ (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))) + (path (upper self menu)) (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)) + &rest defclass-options) (multiple-value-bind (slots outputs) (loop for tk-option-def in tk-options for slot-name = (intern (de- (if (atom tk-option-def) @@ -104,11 +125,6 @@ ,@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-menu-entry menu-entry-separator () @@ -124,16 +140,21 @@ -compound -font -foreground -hidemargin -image -label -state -underline)) -(def-menu-entry menu-entry-cascade ((family menu-entry-usable)) +(def-menu-entry menu-entry-cascade ((selector 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))) +(defmethod path ((self menu-entry-cascade)) + (format nil "~a.~(~a~)" (path .parent) (md-name self))) + +(def-c-output selection ((self menu-entry-cascade)) + (when (and new-value (not old-value-boundp)) + (if (listp new-value) + (tk-send self "set ~(~a~) {~{~a~^ ~}}" (^path) new-value) + (tk-send self "set ~(~a~) ~s" (^path) new-value)))) (def-menu-entry menu-entry-command ((menu-entry-usable)) () @@ -149,23 +170,92 @@ () (-offvalue -onvalue) (:default-initargs - :entry-type 'checkbutton)) + :entry-type 'checkbutton + :md-value (c-in nil) + :tk-variable (c? (format nil "~a.~(~a~)" (path .parent)(md-name self))) + :command (c? (tk-callback self 'cmd + (lambda (self key &rest args) + (declare (ignore key args)) + (setf (^md-value) (not (^md-value)))))))) + +(def-c-output .md-value ((self menu-entry-checkbutton)) + (trc nil "def-c-output md-value menu-entry-checkbutton" self new-value old-value-boundp) + (when (and new-value (not old-value-boundp)) + (if (listp new-value) + (tk-send self "set ~a {~{~a~^ ~}}" (^tk-variable) (if new-value 1 0)) + (tk-send self "set ~a ~s" (^tk-variable) (if new-value 1 0))))) (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)) - + :entry-type 'radiobutton + :tk-variable (c? (down$ (path (upper self selector)))) + :command (c? (tk-callback self 'cmd + (lambda (self key &rest args) + (declare (ignore key args)) + (setf (selection (upper self selector)) + (^value))))))) + +(defmodel menu-radio-group (selector family) + () + (:documentation "md-name becomes Tk variable")) + +(defmethod path ((self menu-radio-group)) + (format nil "~a.~(~a~)" (path .parent) (md-name self))) + +(defun mk-menu-radio-group (&rest inits) + (apply 'make-instance 'menu-radio-group inits)) +(defmethod parent-path ((self menu-radio-group)) + (path .parent)) +(def-c-output selection ((self menu-radio-group)) + (unless old-value-boundp ;; just needed for initialization; Tk manages variable afterwards + (tk-send self "set ~a ~a" (down$ (md-name self)) new-value))) + +(def-widget menubutton () + () + ((menu-values :initarg :menu-values :accessor menu-values :initform nil)) + (-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)) + +(defmodel popup-menubutton (selector menubutton) + ((initial-value :initarg :initial-value :initform nil :accessor initial-value) + (entry-values :initarg :entry-values :initform nil :accessor entry-values)) + (:default-initargs + :tk-menu (c? (path (kid1 self))) + :text (c? (tk-down$ (or (^selection) "unselected"))) + :textvariable (c? (^path)) + :relief 'raised + :indicatoron 1 + :kids (c? (list + (mk-menu + :kids (c? (loop for v in (entry-values .parent) + collecting + (progn + ;(trc "radio label" v (down$ v)) + (mk-menu-entry-radiobutton + :label (down$ v) + :value v))))))))) + +(defun mk-popup-menubutton (&rest inits) + (apply 'make-instance 'popup-menubutton inits)) + +(def-c-output initial-value ((self popup-menubutton)) + (when new-value + (setf (selection self) new-value) + (if (listp new-value) + (tk-send self "set ~(~a~) {~{~a~^ ~}}" (^path) new-value) + (tk-send self "set ~(~a~) ~s" (^path) new-value)))) + +;;;(def-c-output selection ((self popup-menubutton)) +;;; (when new-value +;;; (if (listp new-value) +;;; (tk-send self "set ~(~a~) {~{~a~^ ~}}" (md-name self) new-value) +;;; (tk-send self "set ~(~a~) ~s" (md-name self) new-value)))) Index: cell-cultures/celtic/scrolling.lisp diff -u cell-cultures/celtic/scrolling.lisp:1.4 cell-cultures/celtic/scrolling.lisp:1.5 --- cell-cultures/celtic/scrolling.lisp:1.4 Sat Jul 17 07:02:23 2004 +++ cell-cultures/celtic/scrolling.lisp Wed Jul 21 04:49:38 2004 @@ -21,12 +21,10 @@ (in-package :celtic) -(def-widget scrollbar () +(def-widget scrollbar (standard-widget) () - (-activebackground -background -borderwidth -cursor - -highlightbackground -highlightcolor -highlightthickness -jump - -orient -relief -repeatdelay -repeatinterval - -takefocus -troughcolor + () + ( -jump -orient -troughcolor -activerelief -command -elementborderwidth -width)) (defmodel scrolled-list (frame-selector) Index: cell-cultures/celtic/textual.lisp diff -u cell-cultures/celtic/textual.lisp:1.4 cell-cultures/celtic/textual.lisp:1.5 --- cell-cultures/celtic/textual.lisp:1.4 Sat Jul 17 07:02:23 2004 +++ cell-cultures/celtic/textual.lisp Wed Jul 21 04:49:38 2004 @@ -21,38 +21,22 @@ (in-package :celtic) -(def-widget label () - () - (-activebackground -activeforeground -anchor -background - -bitmap -borderwidth -cursor -disabledforeground - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -image -justify -padx - -pady -relief -takefocus -text - -textvariable -underline -wraplength - -compound -height -state -width)) +(def-widget label (standard-widget) + ()() + (-compound -height -state -width)) ;-------------------------------------------------------------------------- -(def-widget message () - () - (-anchor -background -borderwidth -cursor - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -padx -pady -relief - -takefocus -text -textvariable -width - -aspect -justify)) +(def-widget message (standard-widget) + ()() + (-width -aspect -justify)) ;---------------------------------------------------------------------------- -(def-widget entry () +(def-widget entry (standard-widget) + () ((text :initarg :text :accessor text :initform nil)) - (-background -borderwidth -cursor -exportselection - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -insertbackground -insertborderwidth -insertofftime - -insertontime -insertwidth -justify -relief - -selectbackground -selectborderwidth -selectforeground -takefocus - -textvariable -xscrollcommand - -disabledbackground -disabledforeground - -invalidcommand -readonlybackground -show -state + (-invalidcommand -readonlybackground -show -state -validate -validatecommand -width) (:default-initargs :textvariable (c? (^path)))) Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.7 cell-cultures/celtic/widget-item.lisp:1.8 --- cell-cultures/celtic/widget-item.lisp:1.7 Sat Jul 17 07:02:23 2004 +++ cell-cultures/celtic/widget-item.lisp Wed Jul 21 04:49:38 2004 @@ -33,7 +33,7 @@ (defmodel widget (family tk-object) ((name :initarg :name :accessor name - :initform (c? (down$ (md-name self)))) + :initform (c? (eko ("name" (type-of self))(down$ (md-name self))))) (path :accessor path :initarg :path :initform (c? (format nil "~a.~a" (parent-path (fm-parent self)) @@ -82,7 +82,9 @@ ;;; --- widget -------------------- -(defmacro def-widget (class (&key (std-factory t)) +(defmacro def-widget (class + superclasses + (&key (std-factory t)) (&rest std-slots) (&rest tk-options) &rest defclass-options) (multiple-value-bind (slots outputs) @@ -104,7 +106,7 @@ into outputs finally (return (values slot-defs outputs))) `(progn - (defmodel ,class (widget) + (defmodel ,class ,(or superclasses '(widget)) (,@(append std-slots slots)) ,@defclass-options) (defun ,(intern (format nil "MK-~a" class)) (&rest inits) @@ -128,6 +130,46 @@ (mapcar (lambda (v) (conc$ " " (tk-down$ v))) (cdr list))) "}")) + +;;; --- vehicle for standard options ----------------------------------------- + +(def-widget standard-widget () + ()() + (-activebackground -activeborderwidth -activeforeground -anchor + -background -bitmap -borderwidth -cursor + -disabledforeground -disabledbackground -exportselection -font -foreground + -highlightbackground -highlightcolor -highlightthickness -image + -insertbackground -insertborderwidth -insertofftime -insertontime + -insertwidth -jump -justify -orient + -padx -pady -relief -repeatdelay + -repeatinterval -selectbackground -selectborderwidth -selectforeground + -setgrid -takefocus -text -textvariable + -troughcolor -underline -wraplength -xscrollcommand -yscrollcommand)) + +;;; --- variable mirror widget mixin ----------------------------------------- + +(defmodel tk-variable-mirror (model) + ((initial-value :initarg :initial-value :initform nil :accessor initial-value)) + (:default-initargs + :md-value (c-in nil) + :command (c? (format nil "puts {callback ~s %s %d}" + (register-callback self 'cmd + (lambda (self id &rest args) + (declare (ignore id)) + (destructuring-bind (new-value up-down) args + (declare (ignore up-down)) + (setf (^md-value) (down$ new-value))))))))) + +(def-c-output .md-value ((self tk-variable-mirror)) + (when (and new-value (not old-value-boundp)) + (trc "tk-variable-mirror value" (type-of new-value) new-value) + (if (listp new-value) + (tk-send self "set ~a {~{~a~^ ~}}" (^path) new-value) + (tk-send self "set ~a ~s" (^path) new-value)))) + +(def-c-output initial-value ((self tk-variable-mirror)) + (when new-value + (setf (^md-value) new-value))) ;;; --- items ----------------------------------------------------------------------- Index: cell-cultures/celtic/window.lisp diff -u cell-cultures/celtic/window.lisp:1.1 cell-cultures/celtic/window.lisp:1.2 --- cell-cultures/celtic/window.lisp:1.1 Sat Jul 17 07:02:23 2004 +++ cell-cultures/celtic/window.lisp Wed Jul 21 04:49:38 2004 @@ -21,10 +21,13 @@ (in-package :celtic) +(define-symbol-macro .tkw (nearest self window)) + ;;; --- toplevel --------------------------------------------- (def-widget toplevel () () + () (-borderwidth -cursor -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -background -tk-class -colormap @@ -33,7 +36,8 @@ ;; --- panedwindow ----------------------------------------- -(def-widget panedwindow (:std-factory nil) +(def-widget panedwindow () + (:std-factory nil) () (-background -borderwidth -cursor -height -orient -relief -width @@ -76,14 +80,13 @@ (defmethod path ((self window)) ".") (defmethod parent-path ((self window)) "") -(define-symbol-macro .tkw (nearest self window)) - ; --- (defun tk-send (self fmt$ &rest args) "send a string to wish" (let ((text (apply 'format nil fmt$ args))) - (when (search "pack " text) ;; *debug-tk* + (when (find-if (lambda (s) (search s text)) + '(".font-size" )) ;; *debug-tk* (format t "~&tk-send> ~A~%" text)) (format (wish .tkw) "~A~%" text) #+needed? (force-output (wish .tkw))))

1 0

[cells-cvs] CVS update: cell-cultures/cells/defmodel.lisp cell-cultures/cells/defpackage.lisp cell-cultures/cells/model-object.lisp
by Kenny Tilton 21 Jul '04

21 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv705/cells Modified Files: defmodel.lisp defpackage.lisp model-object.lisp Log Message: Date: Wed Jul 21 04:49:37 2004 Author: ktilton Index: cell-cultures/cells/defmodel.lisp diff -u cell-cultures/cells/defmodel.lisp:1.1 cell-cultures/cells/defmodel.lisp:1.2 --- cell-cultures/cells/defmodel.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/defmodel.lisp Wed Jul 21 04:49:37 2004 @@ -80,6 +80,7 @@ (:metaclass ,(or (find :metaclass options :key #'car) 'standard-class))) + #-allegro-v6.2 (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs) (declare (ignore slot-names iargs)) ,(when (and directsupers (not (member 'model-object directsupers))) @@ -121,4 +122,5 @@ ) )) )) - slotspecs)))) \ No newline at end of file + slotspecs)))) + Index: cell-cultures/cells/defpackage.lisp diff -u cell-cultures/cells/defpackage.lisp:1.4 cell-cultures/cells/defpackage.lisp:1.5 --- cell-cultures/cells/defpackage.lisp:1.4 Sun Jul 4 11:59:41 2004 +++ cell-cultures/cells/defpackage.lisp Wed Jul 21 04:49:37 2004 @@ -47,7 +47,7 @@ #:with-integrity #:with-deference #:without-c-dependency #:self #:.cache #:c-lambda #:.cause #:defmodel #:c-awaken #:def-c-output #:def-c-unchanged-test - #:new-value #:old-value #:c... + #:new-value #:old-value #:old-value-boundp #:c... #:make-be #:mkpart #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids #:cell-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot Index: cell-cultures/cells/model-object.lisp diff -u cell-cultures/cells/model-object.lisp:1.3 cell-cultures/cells/model-object.lisp:1.4 --- cell-cultures/cells/model-object.lisp:1.3 Thu Jul 8 20:53:04 2004 +++ cell-cultures/cells/model-object.lisp Wed Jul 21 04:49:37 2004 @@ -154,7 +154,6 @@ (progn ;; next bit revised to avoid double-output of optimized cells (when (eql '.kids slot-name) (bwhen (sv (slot-value self '.kids)) - (trc "soon will output initial kids of" self) (md-kids-change self sv nil :md-awaken-slot))) (c-output-initially self slot-name)))))))

1 0

[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
by Kenny Tilton 17 Jul '04

17 Jul '04

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

1 0