September 2004 - cells-cvs@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