From ktilton at common-lisp.net Mon May 1 20:23:14 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 1 May 2006 16:23:14 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20060501202314.A95E371035@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv30537 Modified Files: cells.lisp cells.lpr constructors.lisp defpackage.lisp family.lisp fm-utilities.lisp initialize.lisp integrity.lisp md-slot-value.lisp Log Message: Mainly remove WITH-INTEGRITY wrapper from (setf md-slot-value). Big change, that. --- /project/cells/cvsroot/cells/cells.lisp 2006/03/16 05:28:28 1.7 +++ /project/cells/cvsroot/cells/cells.lisp 2006/05/01 20:23:14 1.8 @@ -141,7 +141,7 @@ (unless *stop* (c-stop args) (format t "c-break > stopping > ~a" args) - (apply #'error args))) + (apply 'break args))) --- /project/cells/cvsroot/cells/cells.lpr 2006/03/22 04:08:34 1.9 +++ /project/cells/cvsroot/cells/cells.lpr 2006/05/01 20:23:14 1.10 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 19, 2006 10:49)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Apr 21, 2006 10:24)"; cg: "1.81"; -*- (in-package :cg-user) @@ -49,7 +49,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'cells::go-deep + :on-initialization 'cells::test :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/cells/constructors.lisp 2006/03/16 05:28:28 1.4 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/05/01 20:23:14 1.5 @@ -57,9 +57,6 @@ :value-state :unevaluated :rule (c-lambda (without-c-dependency , at body)))) - - - (defmacro c?dbg (&body body) `(make-c-dependent :code ',body @@ -74,6 +71,14 @@ :lazy t :rule (c-lambda , at body))) +(defmacro c_? (&body body) + "Lazy until asked, then eagerly propagating" + `(make-c-dependent + :code ',body + :value-state :unevaluated + :lazy :until-asked + :rule (c-lambda , at body))) + (defmacro c?? ((&key (tagp nil) (in nil) (out t))&body body) (let ((result (copy-symbol 'result)) (thetag (gensym))) --- /project/cells/cvsroot/cells/defpackage.lisp 2006/03/22 04:08:34 1.5 +++ /project/cells/cvsroot/cells/defpackage.lisp 2006/05/01 20:23:14 1.6 @@ -41,11 +41,11 @@ #:class-precedence-list #-(and mcl (not openmcl-partial-mop)) #:class-slots - #-clisp #:slot-definition-name + #:slot-definition-name ) (:export #:cell #:.md-name #:c-input #:c-in #:c-in8 - #:c-formula #:c? #:c?8 #:c?_ #:c?? + #:c-formula #:c? #:c_? #:c?8 #:c?_ #:c?? #:with-integrity #:without-c-dependency #:self #:*parent* #:.cache #:.with-c-cache #:c-lambda #:defmodel #:defobserver #:slot-value-observe #:def-c-unchanged-test --- /project/cells/cvsroot/cells/family.lisp 2006/04/01 21:47:00 1.5 +++ /project/cells/cvsroot/cells/family.lisp 2006/05/01 20:23:14 1.6 @@ -36,7 +36,8 @@ nil) (defmethod print-object ((self model) s) - (format s "~a" (or (md-name self) (type-of self)))) + (format s "~a" (type-of self)) + #+shhh (format s "~a" (or (md-name self) (type-of self)))) (define-symbol-macro .parent (fm-parent self)) @@ -143,7 +144,7 @@ (defobserver .kids ((self family) new-kids old-kids) (declare (ignorable usage)) - (c-assert (listp new-kids)) + (c-assert (listp new-kids) () "New kids value for ~a not listp: ~a ~a" self (type-of new-kids) new-kids) (c-assert (listp old-kids)) (c-assert (not (member nil old-kids))) (c-assert (not (member nil new-kids))) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/03/26 14:05:49 1.5 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/05/01 20:23:14 1.6 @@ -525,7 +525,7 @@ (count-it :fm-find-one) (flet ((matcher (fm) (when diag - (trc "fm-find-one matcher sees" md-name fm (md-name fm))) + (trc "fm-find-one matcher sees name" (md-name fm) :ofthing fm :seeking md-name)) (when (and (eql (name-root md-name)(md-name fm)) (or (null (name-subscript md-name)) (eql (name-subscript md-name) (fm-pos fm))) @@ -541,7 +541,7 @@ :skip-tree skip-tree :global-search global-search)))) (when (and must-find (null match)) - (trc "fm-find-one > erroring fm-not-found" family md-name must-find global-search) + (trc "fm-find-one > erroring fm-not-found, in family: " family :seeking md-name :global? global-search) ;;(inspect family) (setq diag t must-find nil) (fm-traverse family #'matcher --- /project/cells/cvsroot/cells/initialize.lisp 2006/03/18 00:15:40 1.3 +++ /project/cells/cvsroot/cells/initialize.lisp 2006/05/01 20:23:14 1.4 @@ -34,10 +34,6 @@ (defmethod c-awaken-cell ((c cell)) (assert (c-inputp c)) - #+goforit(when (and (c-ephemeral-p c) - (c-value c)) - (c-break "Feature not yet supported: initializing ephemeral to other than nil: [~a]" - (c-value c))) ; ; nothing to calculate, but every cellular slot should be output ; --- /project/cells/cvsroot/cells/integrity.lisp 2006/03/18 00:15:40 1.6 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/05/01 20:23:14 1.7 @@ -41,19 +41,36 @@ (when *stop* (return-from call-with-integrity)) (if *within-integrity* - (if opcode - (ufb-add opcode (cons defer-info action)) - (funcall action)) + (if opcode + (ufb-add opcode (cons defer-info action)) + (funcall action)) (let ((*within-integrity* t) - *unfinished-business*) + *unfinished-business* + *defer-changes*) (when (or (zerop *data-pulse-id*) - (eq opcode :change)) + (eq opcode :change) + ) (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) (data-pulse-next (cons opcode defer-info)))) (prog1 (funcall action) (finish-business))))) +(defmacro without-integrity ((&optional dbg-info) &rest body) + "Whimsical name for launching a self-contained, dynamic integrity chunk, as with +string-to-mx in the math-paper project, where everything is fully isolated from the +outside computation." + `(call-without-integrity ,dbg-info (lambda () , at body))) + +(defun call-without-integrity (dbg-info action) + (declare (ignorable dbg-info)) + (let ((*within-integrity* nil) + *unfinished-business* + *defer-changes* + *c-calculators* + (*data-pulse-id* 0)) + (funcall action))) + (defun ufb-queue (opcode) (assert (find opcode *ufb-opcodes*)) (cdr (assoc opcode *unfinished-business*))) @@ -131,7 +148,7 @@ ;--- do deferred state changes ----------------------- ; (bwhen (task-info (fifo-pop (ufb-queue :change))) - (trc nil "!!!!!!!!!!!!!!!!!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change))) + (trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change))) (destructuring-bind (defer-info . task-fn) task-info (trc nil "finbiz: deferred state change" defer-info) (data-pulse-next (list :finbiz defer-info)) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/03/16 05:28:28 1.11 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/05/01 20:23:14 1.12 @@ -162,10 +162,25 @@ (when *defer-changes* (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c)) - (with-integrity (:change) + (progn ;; with-integrity (:change) + ;; + ;; ok, we had a weird bug to find caused by a SETF being deferred unexpectedly. + ;; This was the gears Togl demo, setf-ing a display-list in the create callback. It got + ;; called within the dynamic scope of the ufb queue handler doing the :make-tk items. + ;; When contemplating a fix, it occurred to me that I had no idea what to return from + ;; (setf md-slot-value) if the core setf behavior got deferred. I concluded one could not + ;; sensibly impose integrity automatically here, as slick as that might seem. So callers + ;; will have to provide the with-integrity (:change... wrapper. Since SETF happens mostly + ;; in event handling callbacks, hopefully this will not be necesssary at all. A quck check + ;; of Celtk confirms this pattern. + ;; (md-slot-value-assume c new-value nil)) - new-value) + ;; new-value + ;; above line commented out 2006-05-01. It seems to me we want the value assumed by the slot + ;; not the value setf'ed (on rare occasions they diverge, or at least used to for delta slots) + ;; anyway, if they no longer diverge the question of which to return is moot + ) (defmethod md-slot-value-assume (c raw-value propagation-code) (assert c) From ktilton at common-lisp.net Mon May 1 20:23:14 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 1 May 2006 16:23:14 -0400 (EDT) Subject: [cells-cvs] CVS cells/doc Message-ID: <20060501202314.E1AC075027@common-lisp.net> Update of /project/cells/cvsroot/cells/doc In directory clnet:/tmp/cvs-serv30537/doc Modified Files: 01-Cell-basics.lisp Log Message: Mainly remove WITH-INTEGRITY wrapper from (setf md-slot-value). Big change, that. --- /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2006/03/16 05:24:41 1.2 +++ /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2006/05/01 20:23:14 1.3 @@ -111,9 +111,6 @@ (in-package :cells) -(cells-reset) - - (defmodel stone () ((accel :cell t :initarg :accel :initform 0 :accessor accel) (time-elapsed :cell t :initarg :time-elapsed @@ -210,9 +207,11 @@ #+evaluatethis -(defparameter *s2* (make-instance 'stone - :accel 32 ;; (constant) feet per second per second - :time-elapsed (c-in 0))) +(progn + (cells-reset) + (defparameter *s2* (make-instance 'stone + :accel 32 ;; (constant) feet per second per second + :time-elapsed (c-in 0)))) #| From ktilton at common-lisp.net Mon May 1 20:23:15 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 1 May 2006 16:23:15 -0400 (EDT) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20060501202315.28436D007@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv30537/utils-kt Modified Files: debug.lisp utils-kt.lpr Log Message: Mainly remove WITH-INTEGRITY wrapper from (setf md-slot-value). Big change, that. --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/03/16 05:26:47 1.6 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/05/01 20:23:14 1.7 @@ -32,7 +32,8 @@ (setf *count* nil *stop* nil *dbg* nil - *trcdepth* 0)) + *trcdepth* 0) + (print "----------UTILSRESET----------------------------------")) ;----------- trc ------------------------------------------- --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/03/23 04:22:56 1.6 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/05/01 20:23:14 1.7 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 19, 2006 10:49)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Apr 10, 2006 23:36)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Tue May 2 12:48:05 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 2 May 2006 08:48:05 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060502124805.AC5631A000@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv25230 Modified Files: gears.lisp Added Files: multichoice.lisp run.lisp scroll.lisp text-item.lisp timer.lisp tk-interp.lisp tk-object.lisp togl.lisp widget.lisp Log Message: Missing pieces from last night's incomplete update. --- /project/cells/cvsroot/Celtk/gears.lisp 2006/05/02 06:57:22 1.1 +++ /project/cells/cvsroot/Celtk/gears.lisp 2006/05/02 12:48:05 1.2 @@ -1,6 +1,68 @@ (in-package :celtk) +(in-package :celtk) + +(defparameter *startx* nil) +(defparameter *starty* nil) +(defparameter *xangle0* nil) +(defparameter *yangle0* nil) +(defparameter *xangle* 0.0) +(defparameter *yangle* 0.0) + +(defparameter *vTime* 100) + +(defun gears () ;; ACL project manager needs a zero-argument function, in project package + (test-window 'gears-demo)) + + +(defmodel gears-demo (window) + ((gear-ct :initform (c-in 1) :accessor gear-ct :initarg :gear-ct) + (scale :initform (c-in 1) :accessor scale :initarg :scale)) + (:default-initargs + :title$ "Rotating Gear Widget Test" + :kids (c? (the-kids + (mk-stack (:packing (c?pack-self)) + (mk-label :text "Click and drag to rotate image") + #+tki (mk-row () + (mk-button-ex (" Add " (incf (gear-ct .tkw)))) + (mk-button-ex ("Remove" (when (plusp (gear-ct .tkw)) + (decf (gear-ct .tkw))))) + (mk-entry :id :vtime + :md-value (c-in "100")) + (mk-button-ex (" Quit " (progn)))) + (make-instance 'gears + :fm-parent *parent* + :width 400 + :height 400 + :timer-interval nil #+tki (c? (or .cache ;; comment out just ".cache" for some fun + (eko ("vtime is") + (md-value (fm-other :vtime))))) + :double "yes" + :bindings nil #+wait (c? (list + (list "" + (lambda (event) + (RotStart self + (event-root-x event) + (event-root-y event)))) + (list "" + (lambda (event) + (RotMove self + (event-root-x event) + (event-root-y event))) ))))))))) + +(defun RotStart (self x y) + (setf *startx* x) + (setf *starty* y) + (let ((vPos (tk-eval-list "~a position" (^path)))) ;; this fails for me -- command not recognized, it seems + (trc "got vpos" vpos) + (setf *xangle0* (read-from-string (nth 0 vpos))) + (setf *yangle0* (read-from-string (nth 1 vpos))))) + +(defun RotMove (self x y) + (setf *xangle* (+ *xangle0* (- x *startx*))) + (setf *yangle* (+ *yangle0* (- y *starty*))) + (tk-format-now "~a rotate ~a ~a" (^path) *xangle* *yangle*)) (defconstant +pif+ (coerce pi 'single-float)) (defmodel gears (togl) --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/02 12:48:05 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- ;;; ;;; Copyright (c) 2006 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. ; --- scale ---------------------------------------------- (in-package :Celtk) (deftk scale (commander widget) () (:tk-spec scale -activestyle -background -borderwidth -cursor -font -foreground -highlightbackground -highlightcolor -highlightthickness -relief -state -takefocus -troughcolor -width -xscrollcommand -yscrollcommand -orient -repeatdelay -repeatinterval -bigincrement -command -digits -from (-tk-label -label) (-tk-length -length) -resolution -showvalue -sliderlength -sliderrelief -tickinterval -to (-tk-variable nil)) (:default-initargs :id (gentemp "SCL") :md-value (c-in nil) :tk-variable nil ;;(c? (^path)) :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :on-command (lambda (self value) (setf (^md-value) value)))) (defmethod make-tk-instance :after ((self scale)) "Still necessary?" (when (^md-value) (tk-format `(:variable ,self) "~a set ~a" (^path) (^md-value)))) ; --- listbox -------------------------------------------------------------- (deftk listbox (widget) () (:tk-spec listbox -activestyle -background -borderwidth -cursor -disabledforeground -exportselection -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -listvariable -relief -selectmode -selectbackground -selectborderwidth -selectforeground -setgrid -state -takefocus -width -xscrollcommand -yscrollcommand) (:default-initargs :id (gentemp "LBX") :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :bindings (c? (assert (selector self)) (when (selector self) ;; if not? Figure out how listbox tracks own selection (list (list "<>" (format nil "{callbackval ~~a [~a curselection]}" (^path)) (lambda (selection) (trc nil "listbox callback firing" self selection) (setf (selection (selector self)) (md-value (elt (^kids) selection)))))))))) (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 `(:post-make-tk ,self) "~A insert end ~s" (path .parent) (^item-text))) (defobserver .kids ((self listbox)) (when old-value (tk-format `(:destroy ,self) "~A delete ~a ~a" (^path) 0 (1- (length old-value))))) ; --- spinbox --------------------------------------------- (deftk spinbox (widget) ((initial-value :initform nil :initarg :initial-value :reader initial-value)) (:tk-spec spinbox -activebackground -background -borderwidth -cursor -buttonbackground -buttoncursor -buttondownrelief -buttonuprelief -disabledforeground -disabledbackground -exportselection -font (spin-format -format) -foreground -from -command -invalidcommand -increment -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -jump -justify -orient -padx -pady -relief -repeatdelay -repeatinterval -selectbackground -selectborderwidth -selectforeground -readonlybackground -state -to -takefocus -text -textvariable -troughcolor -underline -xscrollcommand -validate -validatecommand (tk-values -values) -width -wrap) (:default-initargs :md-value (c-in nil) :id (gentemp "SPN") :textVariable (c? (^path)) :xscrollcommand (c-in nil) :on-command (lambda (self text) (eko (nil "variable mirror command fired !!!!!!!" text) (setf (^md-value) text))))) (defobserver .md-value ((self spinbox)) (when new-value (tk-format `(:variable ,self) "set ~a ~a" (^path) (tk-send-value new-value)))) (defobserver initial-value ((self spinbox)) (when new-value (with-integrity (:change) (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) (setf (^md-value) new-value)))) --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/02 12:48:05 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- ;;; ;;; Copyright (c) 2006 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :Celtk) ;;; --- running a Celtk application (window class, actually) -------------------------------------- (eval-when (compile load eval) (export '(tk-scaling run-window test-window))) (defun run-window (root-class) (declare (ignorable root-class)) (setf *tkw* nil) (cells-reset 'tk-user-queue-handler) (tk-interp-init-ensure) (setf *tki* (Tcl_CreateInterp)) (tk-app-init *tki*) (tk-togl-init *tki*) #+soon (tk-format-now "proc trc2 {cb n1 n2 op} {puts \"(:callback \\\"$cb\\\" :name1 $n1 :name2 \\\"$n2\\\" :op $op)\"}") (tk-format-now "set tk-events {}") (tk-format-now "proc call-back {w args} { global tk-events lappend tk-events [concat do-on-command $w $args]}") ;; deadly (takes down ACL) -> (tk-format-now "bind . exit") (with-integrity () (setf *tkw* (make-instance root-class))) (tk-format `(:fini) "wm deiconify .") ;; one or the other of... ;; hangs on win close now, but probably easy to fix, just needs to know when ;; to stop looping: -> (tcl-do-one-event-loop) (tcl-do-one-event-loop) ) ;; Our own event loop ! - Use this if it is desirable to do something ;; else between events (defun tcl-do-one-event-loop () (loop with start-time = (get-internal-real-time) while (> 10 (floor (- (get-internal-real-time) start-time) internal-time-units-per-second)) do (bif (events (prog1 (tk-eval-list "set tk-events") (tk-eval "set tk-events {}"))) (loop ;; with x = (trc "no events") for e in events do (setf start-time (get-internal-real-time)) (tk-process-event e)) (sleep .05)) ;;*event-loop-delay*)) (loop until (zerop (Tcl_DoOneEvent 2))))) (defun tk-process-event (event) (trc "event string:" event) (destructuring-bind (fn w-name &rest args) (read-from-string (conc$ "(" event ")")) (let ((id (symbol-name w-name))) (bif (w (gethash id (dictionary *tkw*))) (progn (trc "funcalling" fn w) (apply fn w args)) (progn (loop for k being the hash-keys of (dictionary *tkw*) do (trc "known key" k (type-of k))) (break "bad id ~a in event ~a" id event)))))) (defmethod do-on-command :around (self &rest args) (trc "on command!!!" self) (bwhen (ocb (on-command self)) (apply ocb self args))) (defun test-window (root-class) "nails existing window as a convenience in iterative development" (declare (ignorable root-class)) #+tki (when (and *tkw* (open-stream-p *tkw*)) (format *tkw* "wm withdraw .~%") (force-output *tkw*) (format *tkw* "destroy .%") (force-output *tkw*) (setf *tkw* nil)) (run-window root-class))--- /project/cells/cvsroot/Celtk/scroll.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/scroll.lisp 2006/05/02 12:48:05 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- ;;; ;;; Copyright (c) 2006 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :Celtk) ; --- scroll bars ---------------------------------------- (deftk scrollbar (widget) () (:tk-spec scrollbar -activebackground -activerelief -background -borderwidth -command -cursor -elementborderwidth -highlightbackground -highlightcolor -highlightthickness -jump -orient -relief -repeatdelay -repeatinterval -takefocus -troughcolor -width) (:default-initargs :id (gentemp "SBAR"))) (deftk scrolled-list (row-mixin 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)) (:default-initargs :list-height (c? (max 1 (length (^list-item-keys)))) :kids-packing nil :kids (c? (the-kids (mk-listbox :id :list-me :kids (c? (the-kids (mapcar (list-item-factory .parent) (list-item-keys .parent)))) :font '(courier 9) :state (c? (if (enabled .parent) 'normal 'disabled)) :takefocus (c? (if (enabled .parent) 1 0)) :height (c? (list-height .parent)) :packing (c? (format nil "pack ~a -side left -fill both -expand 1" (^path))) :yscrollcommand (c? (when (enabled .parent) (format nil "~a set" (path (nsib)))))) (mk-scrollbar :id :vscroll :packing (c?pack-self "-side right -fill y") :command (c? (format nil "~a yview" (path (psib))))))))) (defmethod tk-output-selection :after ((self scrolled-list) new-value old-value old-value-boundp) (declare (ignorable old-value old-value-boundp)) (trc nil "scrolled-list selection output" self new-value) (when new-value (let ((lb (car (^kids))) (item-no (position new-value (^list-item-keys) :test 'equal))) (if item-no (tk-format `(:selection ,self) "~(~a~) selection set ~a" (path lb) item-no) (break "~&scrolled-list ~a selection ~a not found in item keys ~a" self new-value (^list-item-keys)))))) ;--- scroller (of canvas; need to generalize this) ---------- (defmodel scroller (grid-manager frame) ((canvas :initarg :canvas :accessor canvas :initform nil)) (:default-initargs :id :cv-scroller :kids-packing nil :gridding '(:columns ("-weight {1}" "-weight {0}") :rows ("-weight {1}" "-weight {0}")) :kids (c? (the-kids (^canvas) (mk-scrollbar :id :hscroll :orient "horizontal" :gridding "-row 1 -column 0 -sticky we" :command (c? (format nil "~a xview" (path (kid1 .parent))))) [19 lines skipped] --- /project/cells/cvsroot/Celtk/text-item.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/text-item.lisp 2006/05/02 12:48:05 1.1 [65 lines skipped] --- /project/cells/cvsroot/Celtk/timer.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/05/02 12:48:05 1.1 [170 lines skipped] --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/02 12:48:05 1.1 [666 lines skipped] --- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/05/02 12:48:05 1.1 [774 lines skipped] --- /project/cells/cvsroot/Celtk/togl.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/05/02 12:48:05 1.1 [922 lines skipped] --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/02 12:48:05 1.1 [1155 lines skipped] From ktilton at common-lisp.net Tue May 2 12:52:47 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 2 May 2006 08:52:47 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060502125247.5F5451E005@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv25417 Modified Files: Celtk.asd Log Message: --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/24 03:46:25 1.3 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/02 12:52:47 1.4 @@ -5,7 +5,7 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))) (asdf:defsystem :celtk - :name "celtk" + :name "celtk" :author "Kenny Tilton " :version "2.0" :maintainer "Kenny Tilton " @@ -15,12 +15,28 @@ :depends-on (:ltk :cells) :serial t :components ((:file "Celtk") - (:file "tk-format") + (:file "tk-interp") + (:file "tk-object") + (:file "widget") + (:file "font") + (:file "layout") + (:file "timer") (:file "menu") - (:file "textual") - (:file "widgets") + (:file "label") + (:file "entry") + (:file "button") + (:file "multichoice") + (:file "scroll") (:file "canvas") + (:file "text-item") + (:file "item-pictorial") + (:file "item-shaped") (:file "composites") + (:file "frame") + (:file "load-cl-opengl") + (:file "togl") + (:file "run") (:file "demos") + (:file "gears-demo") + (:file "gears") (:file "ltktest-cells-inside"))) - From ktilton at common-lisp.net Tue May 2 13:03:37 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 2 May 2006 09:03:37 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060502130337.DA7922200B@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27105 Modified Files: widget.lisp Log Message: --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/02 12:48:05 1.1 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/02 13:03:37 1.2 @@ -47,6 +47,7 @@ (:default-initargs :command (c? (format nil "call-back ~(~a~)" (^path))))) + (defun widget-menu (self key) (or (find key (^menus) :key 'md-name) (break "The only menus I see are~{ ~a,~} not requested ~a" (mapcar 'md-name (^menus)) key))) From ktilton at common-lisp.net Tue May 2 13:13:00 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 2 May 2006 09:13:00 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060502131300.3AF072E1AE@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27400 Modified Files: CELTK.lpr Celtk.asd Log Message: --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/02 06:57:22 1.5 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/02 13:13:00 1.6 @@ -28,7 +28,6 @@ (make-instance 'module :name "togl.lisp") (make-instance 'module :name "run.lisp") (make-instance 'module :name "demos.lisp") - (make-instance 'module :name "gears-demo.lisp") (make-instance 'module :name "gears.lisp") (make-instance 'module :name "ltktest-cells-inside.lisp")) --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/02 12:52:47 1.4 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/02 13:13:00 1.5 @@ -6,12 +6,12 @@ (asdf:defsystem :celtk :name "celtk" - :author "Kenny Tilton " + :author "Kenny Tilton " :version "2.0" - :maintainer "Kenny Tilton " + :maintainer "Kenny Tilton " :licence "MIT Style" - :description "Tk via LTk with Cells Inside(tm)" - :long-description "A Cells-driven portable GUI built atop the LTk core, ultimately implmented by Tk" + :description "Tcl/Tk with Cells Inside(tm)" + :long-description "A Cells-driven portable GUI, ultimately implmented by Tk" :depends-on (:ltk :cells) :serial t :components ((:file "Celtk") From ktilton at common-lisp.net Wed May 3 08:22:16 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 3 May 2006 04:22:16 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20060503082216.2859D6D157@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv12351 Modified Files: integrity.lisp Log Message: --- /project/cells/cvsroot/cells/integrity.lisp 2006/05/01 20:23:14 1.7 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/05/03 08:22:15 1.8 @@ -47,6 +47,7 @@ (let ((*within-integrity* t) *unfinished-business* *defer-changes*) + (trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info) (when (or (zerop *data-pulse-id*) (eq opcode :change) ) @@ -82,11 +83,13 @@ (defun ufb-add (opcode continuation) (assert (find opcode *ufb-opcodes*)) + (trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation))) (fifo-add (ufb-queue-ensure opcode) continuation)) (defun just-do-it (op-or-q &aux (q (if (keywordp op-or-q) (ufb-queue op-or-q) op-or-q))) + (trc nil "just do it doing" op-or-q) (loop for (nil . task) = (fifo-pop q) while task do (trc nil "unfin task is" opcode task) @@ -123,11 +126,15 @@ ; (when *stop* (return-from finish-business)) + handle-clients (bwhen (clientq (ufb-queue :client)) (if *client-queue-handler* (funcall *client-queue-handler* clientq) ;; might be empty/not exist, so handlers must check - (just-do-it clientq))) - + (just-do-it clientq)) + (when (fifo-peek (ufb-queue :client)) + #+shhh (ukt::fifo-browse (ufb-queue :client) (lambda (entry) + (trc "surprise client" entry))) + (go handle-clients))) ;--- now we can reset ephemerals -------------------- ; ; one might be wondering when the observers got notified. That happens From ktilton at common-lisp.net Wed May 3 08:22:16 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 3 May 2006 04:22:16 -0400 (EDT) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20060503082216.4DB276D19E@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv12351/utils-kt Modified Files: detritus.lisp utils-kt.lpr Log Message: --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/04/01 21:47:00 1.4 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/05/03 08:22:16 1.5 @@ -62,6 +62,9 @@ (defun fifo-length (q) (length (fifo-data q))) (defun fifo-peek (q) (car (fifo-data q))) +(defun fifo-browse (q fn) + (map nil fn (fifo-data q))) + (defun fifo-add (q new) (if (car q) (let ((last (cdr q)) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/05/01 20:23:14 1.7 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/05/03 08:22:16 1.8 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Apr 10, 2006 23:36)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Apr 21, 2006 10:24)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Wed May 3 08:46:56 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 3 May 2006 04:46:56 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060503084656.25DD51E005@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv19334 Modified Files: Celtk.lisp ltktest-cells-inside.lisp run.lisp Log Message: --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/03 08:20:49 1.14 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/03 08:46:56 1.15 @@ -124,15 +124,15 @@ ; ; --- debug stuff --- ; - (let ((yes '("popup" "menu" "bkg-pop")) - (no '("menu"))) + (let ((yes '("pop" "menu" "mnu")) + (no '("tk-events"))) (declare (ignorable yes no)) (bwhen (st (search "\"Alt Q\"" tk$)) (break "Hey, fix this.") (replace tk$ "{Alt Q}" :start1 st)) - (when t #+not (and (find-if (lambda (s) (search s tk$)) yes) + (when (and (find-if (lambda (s) (search s tk$)) yes) (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/05/03 08:20:49 1.14 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/05/03 08:46:56 1.15 @@ -214,7 +214,7 @@ (with-integrity (:change self) (progn (trc "setting moire-spin" self (fm^ :moire-1)) - (setf (moire-spin (fm^ :moire-1)) 10))))))) + (setf (moire-spin (fm^ :moire-1)) 100))))))) ; ; Cells initiata will be surprised to learn the above works twice even if the button is ; clicked twice in a row; Cells is about managing state change, and the second time through @@ -339,7 +339,7 @@ ; :bindings (c? (list (list '|<1>| (lambda (self event root-x root-y) - (declare (ignore event)) + (declare (ignorable event root-x root-y)) ; ; Stolen from the original. It means "when the left button is @@ -353,7 +353,7 @@ ; via the client queue. ; (pop-up (^widget-menu :bkg-pop) root-x root-y)) - "%X %Y"))) + "%x %y"))) :menus (c? (the-kids ; --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/03 08:20:49 1.2 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/03 08:46:56 1.3 @@ -80,7 +80,7 @@ (defun tcl-do-one-event-loop () (loop with start-time = (get-internal-real-time) - while (> 1 (floor (- (get-internal-real-time) start-time) internal-time-units-per-second)) + while (> 10 (floor (- (get-internal-real-time) start-time) internal-time-units-per-second)) do (bif (events (prog1 (tk-eval-list "set tk-events") From ktilton at common-lisp.net Wed May 3 17:18:29 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 3 May 2006 13:18:29 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060503171829.D4DBC5B006@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv22166 Modified Files: run.lisp Log Message: latest --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/03 08:46:56 1.3 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/03 17:18:29 1.4 @@ -35,14 +35,6 @@ (tk-format `(:bind ,self) "bind ~a ~a {call-back-event %W ~:*\"~a\" ~a}" (^path) binding-key (or desired-event-info ""))) -#+reference -(defun bind (self event-type handler &optional (desired-event-info "") - &aux (binding-key (intern (symbol-name event-type)))) ;; lookup on rebound will have been read in this package - (trc "bind registering" self binding-key) - (setf (gethash binding-key (event-handlers self)) handler) - (tk-format `(:bind ,self) "bind ~a ~a {call-back-event %W ~:*\"~a\" ~a}" - (^path) binding-key (or desired-event-info ""))) - (defun run-window (root-class) (declare (ignorable root-class)) (setf *tkw* nil) From ktilton at common-lisp.net Wed May 3 17:34:58 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 3 May 2006 13:34:58 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060503173458.BCC757020D@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv23986 Modified Files: ltktest-cells-inside.lisp menu.lisp Log Message: simple popup bugs fixed, but only pops up once per IDE run --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/05/03 08:46:56 1.15 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/05/03 17:34:58 1.16 @@ -353,7 +353,7 @@ ; via the client queue. ; (pop-up (^widget-menu :bkg-pop) root-x root-y)) - "%x %y"))) + "%X %Y"))) :menus (c? (the-kids ; --- /project/cells/cvsroot/Celtk/menu.lisp 2006/05/03 08:20:49 1.8 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/05/03 17:34:58 1.9 @@ -218,8 +218,8 @@ :on-command (lambda (self) (declare (ignore key args)) (trc nil "menu radio button command firing" self (^value) (upper self selector)) - (setf (selection (upper self selector)) - (^value))))) + (with-integrity (:change) + (setf (selection (upper self selector)) (^value)))))) (defmodel menu-radio-group (selector family) ((.md-name :cell nil :initform (gentemp "RG") :initarg :id)) From ktilton at common-lisp.net Wed May 3 20:02:36 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 3 May 2006 16:02:36 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060503200236.45C33200B@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv8947 Modified Files: Celtk.lisp run.lisp tk-interp.lisp Log Message: use tk_getnummainwindows to figure out when to stop looping on tcl_dooneevent --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/03 08:46:56 1.15 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/03 20:02:36 1.16 @@ -124,7 +124,7 @@ ; ; --- debug stuff --- ; - (let ((yes '("pop" "menu" "mnu")) + (let ((yes '("bind" "pop" "menu" "mnu")) (no '("tk-events"))) (declare (ignorable yes no)) --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/03 17:18:29 1.4 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/03 20:02:36 1.5 @@ -72,7 +72,8 @@ (defun tcl-do-one-event-loop () (loop with start-time = (get-internal-real-time) - while (> 10 (floor (- (get-internal-real-time) start-time) internal-time-units-per-second)) + while (and (plusp (tk-get-num-main-windows)) + (> 10 (floor (- (get-internal-real-time) start-time) internal-time-units-per-second))) do (bif (events (prog1 (tk-eval-list "set tk-events") @@ -80,6 +81,7 @@ (progn #+shhh (loop for e in events do (trc "event preview" e)) + (trc "main windows count =" (tk-get-num-main-windows)) (loop for e in events do (setf start-time (get-internal-real-time)) (tk-process-event e))) --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/03 08:20:49 1.2 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/03 20:02:36 1.3 @@ -165,6 +165,8 @@ (defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string (interp :pointer)) + + (defcfun ("Tk_GetNumMainWindows" tk-get-num-main-windows) :int) (defun Tcl_Eval (interp script) (with-foreign-string (script-cstr script) @@ -388,11 +390,11 @@ (trc "tk-eval result:" (tk-eval "tk scaling")) (trc "tk-eval-list result:" (tk-eval-list "font families")))) -(defun exec-main () - (main "\\0devtools\\frgotk\\psu-rc-gui.tcl")) - -#+test -(exec-main) +;;;(defun exec-main () +;;; (main "\\0devtools\\frgotk\\psu-rc-gui.tcl")) +;;; +;;;#+test +;;;(exec-main) ;;; Togl stuff From ktilton at common-lisp.net Thu May 4 06:11:10 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 4 May 2006 02:11:10 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060504061110.B01D94507B@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27622 Modified Files: CELTK.lpr Celtk.lisp demos.lisp gears.lisp menu.lisp run.lisp tk-interp.lisp tk-object.lisp togl.lisp Log Message: Resurrected Gears Lite -- hopefully last stamp with faux events --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/02 13:13:00 1.6 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/04 06:11:10 1.7 @@ -24,17 +24,18 @@ (make-instance 'module :name "item-shaped.lisp") (make-instance 'module :name "composites.lisp") (make-instance 'module :name "frame.lisp") - (make-instance 'module :name "load-cl-opengl.lisp") (make-instance 'module :name "togl.lisp") (make-instance 'module :name "run.lisp") (make-instance 'module :name "demos.lisp") - (make-instance 'module :name "gears.lisp") (make-instance 'module :name - "ltktest-cells-inside.lisp")) + "ltktest-cells-inside.lisp") + (make-instance 'module :name "gears.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells") (make-instance 'project-module :name - "C:\\0devtools\\cffi\\cffi")) + "C:\\0devtools\\cffi\\cffi") + (make-instance 'project-module :name + "C:\\0devtools\\cl-opengl\\glu")) :libraries nil :distributed-files nil :internally-loaded-files nil --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/03 20:02:36 1.16 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/04 06:11:10 1.17 @@ -52,6 +52,8 @@ (in-package :Celtk) +(defvar *tki* nil) + (defparameter *tk-last* nil "Debug aid. Last recorded command send to Tk") (defparameter *tkw* nil) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/03 08:20:49 1.8 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/04 06:11:10 1.9 @@ -25,7 +25,7 @@ (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package ;;(test-window 'one-button) - (test-window 'ltktest-cells-inside) + (test-window 'gears-demo) ) (defmodel one-button (window) --- /project/cells/cvsroot/Celtk/gears.lisp 2006/05/03 08:20:49 1.3 +++ /project/cells/cvsroot/Celtk/gears.lisp 2006/05/04 06:11:10 1.4 @@ -1,7 +1,6 @@ -(in-package :celtk) +(in-package :celtk-user) -(in-package :celtk) (defparameter *startx* nil) (defparameter *starty* nil) @@ -13,8 +12,13 @@ (defparameter *vTime* 100) (defun gears () ;; ACL project manager needs a zero-argument function, in project package - (test-window 'gears-demo)) - + (let ((*startx* nil) + (*starty* nil) + (*xangle0* nil) + (*yangle0* nil) + (*xangle* 0.0) + (*yangle* 0.0)) + (test-window 'gears-demo))) (defmodel gears-demo (window) ((gear-ct :initform (c-in 1) :accessor gear-ct :initarg :gear-ct) @@ -40,35 +44,39 @@ (md-value (fm-other :vtime))))) :double "yes" :bindings (c? (list - (list '|| - (lambda (self event root-x root-y) - (declare (ignore event)) - (RotStart self root-x root-y)) + (list '|<1>| (lambda (self event root-x root-y) + (declare (ignorable self event root-x root-y)) + (RotStart self root-x root-y) + 0) "%X %Y") (list '|| (lambda (self event root-x root-y) (declare (ignore event)) - (RotMove self root-x root-y)) + (with-integrity (:change) + (RotMove self root-x root-y)) + 0) "%X %Y"))))))))) (defun RotStart (self x y) + ;(trc "Rotstart!!!" self x y) (setf *startx* x) (setf *starty* y) - (let ((vPos (tk-eval-list "~a position" (^path)))) ;; this fails for me -- command not recognized, it seems - (trc "got vpos" vpos) - (setf *xangle0* (read-from-string (nth 0 vpos))) - (setf *yangle0* (read-from-string (nth 1 vpos))))) + (setf *xangle0* (rotx self)) + (setf *yangle0* (roty self))) (defun RotMove (self x y) + ;(trc "RotMove!!!!" self x y) (setf *xangle* (+ *xangle0* (- x *startx*))) (setf *yangle* (+ *yangle0* (- y *starty*))) - (tk-format-now "~a rotate ~a ~a" (^path) *xangle* *yangle*)) + (setf (rotx self) *xangle*) + (setf (roty self) *yangle*)) + (defconstant +pif+ (coerce pi 'single-float)) (defmodel gears (togl) - ((view-rotx :initform (c-in 20.0) :accessor view-rotx :initarg :view-rotx) - (view-roty :initform (c-in 30.0) :accessor view-roty :initarg :view-roty) - (view-rotz :initform (c-in 0.0) :accessor view-rotz :initarg :view-rotz) + ((rotx :initform (c-in 0.0) :accessor rotx :initarg :rotx) + (roty :initform (c-in 0.0) :accessor roty :initarg :roty) + (rotz :initform (c-in 0.0) :accessor rotz :initarg :rotz) (gear1 :accessor gear1 :initform (c-in nil)) (gear2 :accessor gear2 :initform (c-in nil)) (gear3 :accessor gear3 :initform (c-in nil)) @@ -81,32 +89,35 @@ (defmethod togl-timer-using-class ((self gears)) (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time)) - (incf (^angle) 2.0) - (Togl_PostRedisplay (togl-ptr self))) - -(defmethod togl-reshape-using-class ((self gears) width height) - (trc "enter gear reshape" self width :height (type-of height) :voila height) - (gl:viewport 0 0 width height) - (gl:matrix-mode :projection) - (gl:load-identity) - (let ((h (/ height width))) - (gl:frustum -1 1 (- h) h 5 60)) - (gl:matrix-mode :modelview) - (gl:load-identity) - (gl:translate 0 0 -40)) + (with-integrity (:change) + (incf (^angle) 2.0) + (Togl_PostRedisplay (togl-ptr self)))) + +(defmethod togl-reshape-using-class ((self gears)) + (let ((width (Togl_width (togl-ptr self))) + (height (Togl_height (togl-ptr self)))) + (trc "enter gear reshape" self width :height (type-of height) :voila height) + (gl:viewport 0 0 width height) + (gl:matrix-mode :projection) + (gl:load-identity) + (let ((h (/ height width))) + (gl:frustum -1 1 (- h) h 5 60)) + (gl:matrix-mode :modelview) + (gl:load-identity) + (gl:translate 0 0 -40))) (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo)))) (declare (ignorable scale)) - (with-slots (view-rotx view-roty view-rotz angle gear1 gear2 gear3) + (with-slots (rotx roty rotz angle gear1 gear2 gear3) self - (trc nil "in gear display" self (togl-ptr self)gear1 gear2 gear3 scale) + (gl:clear-color 0 0 0 1) (gl:clear :color-buffer-bit :depth-buffer-bit) (gl:with-pushed-matrix - (gl:rotate (incf view-rotx) 1 0 0) - (gl:rotate view-roty 0 1 0) - (gl:rotate view-rotz 0 0 1) + (gl:rotate rotx 1 0 0) + (gl:rotate roty 0 1 0) + (gl:rotate rotz 0 0 1) (gl:with-pushed-matrix ; gear1 (gl:translate -3 -2 0) @@ -125,21 +136,7 @@ (Togl_SwapBuffers (togl-ptr self)) - (print-frame-rate self))) - -(defun print-frame-rate (window) - (with-slots (frame-count t0) window - (incf frame-count) - (let ((time (get-internal-real-time))) - (when (= t0 0) - (setq t0 time)) - (when (>= (- time t0) (* 1 internal-time-units-per-second)) - (let* ((seconds (/ (- time t0) internal-time-units-per-second)) - (fps (/ frame-count seconds))) - (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%" - frame-count seconds fps)) - (setq t0 time) - (setq frame-count 0))))) + #+shhh (print-frame-rate self))) (defmethod togl-create-using-class ((self gears)) (gl:light :light0 :position #(5.0 5.0 10.0 0.0)) @@ -265,3 +262,18 @@ (gl:normal (- (cos angle)) (- (sin angle)) 0.0) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* (- width) 0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))))))) + +(defun print-frame-rate (window) + (with-slots (frame-count t0) window + (incf frame-count) + (let ((time (get-internal-real-time))) + (when (= t0 0) + (setq t0 time)) + (when (>= (- time t0) (* 5 internal-time-units-per-second)) + (let* ((seconds (/ (- time t0) internal-time-units-per-second)) + (fps (/ frame-count seconds))) + (declare (ignorable fps)) + #+shh (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%" + frame-count seconds fps)) + (setq t0 time) + (setq frame-count 0))))) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/05/03 17:34:58 1.9 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/05/04 06:11:10 1.10 @@ -79,12 +79,12 @@ ;;; (defmodel menu-entry (tk-object) - ((index :cell nil :initarg :index :accessor index :initform nil)) + ((idx :cell nil :initarg :idx :accessor idx :initform nil)) (:documentation "e.g, New, Open, Save in a File menu")) -(defmethod index :around ((self menu-entry)) +(defmethod idx :around ((self menu-entry)) (or (call-next-method) - (setf (index self) + (setf (idx self) (block count-to-self (let ((i -1) (menu (upper self menu))) @@ -97,15 +97,15 @@ (defmethod make-tk-instance ((self menu-entry)) "Parent has to do this to get them in the right order" - (setf (gethash (path-index self) (dictionary .tkw)) self)) + (setf (gethash (path-idx self) (dictionary .tkw)) self)) (defmethod parent-path ((self menu-entry)) (path .parent)) -(defmethod path-index ((self menu-entry)) +(defmethod path-idx ((self menu-entry)) "This method hopefully gets used only internally and not given to Tcl qua thing name, which will not recognize it" - (assert (index self)) - (format nil "~a.~a" (path (upper self menu))(index self))) + (assert (idx self)) + (format nil "~a.~a" (path (upper self menu))(idx self))) (defun fm-menu-traverse (family fn) "Traverse family arbitrarily deep as need to reach all menu-entries @@ -121,12 +121,12 @@ (defmethod not-to-be :after ((self menu-entry)) (trc nil "whacking menu-entry" self) - (tk-format `(:destroy ,self) "~a delete ~a" (path .parent) (index self))) + (tk-format `(:destroy ,self) "~a delete ~a" (path .parent) (idx self))) (defmethod tk-configure ((self menu-entry) option value) - (assert (>= (index self) 0) () "cannot configure menu-entry ~a until instantiated and index decided" self) + (assert (>= (idx self) 0) () "cannot configure menu-entry ~a until instantiated and index decided" self) (tk-format `(:configure ,self) "~A entryconfigure ~a ~(~a~) ~a" - (path (upper self menu)) (index self) option (tk-send-value value))) + (path (upper self menu)) (idx self) option (tk-send-value value))) (deftk menu-entry-separator (menu-entry) () @@ -143,7 +143,7 @@ (call-next-method) (with-integrity (:client '(:bind nil)) (when new-value - (tk-format-now "bind . <~a> {~a invoke ~a}" new-value (path (upper self menu)) (index self))))) + (tk-format-now "bind . <~a> {~a invoke ~a}" new-value (path (upper self menu)) (idx self))))) (deftk menu-entry-cascade (selector family menu-entry-usable) @@ -172,7 +172,7 @@ () (:tk-spec command -command) (:default-initargs - :command (c? (format nil "call-back ~(~a~)" (path-index self))))) + :command (c? (format nil "call-back ~(~a~)" (path-idx self))))) (defmacro mk-menu-entry-command-ex ((&rest menu-command-initargs) lbl callback-body) `(mk-menu-entry-command --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/03 20:02:36 1.5 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/04 06:11:10 1.6 @@ -52,14 +52,10 @@ ;; (tk-format-now "bind . {call-back-event %W :type :time %t}") (with-integrity () - (setf *tkw* (make-instance root-class)) - (bind *tkw* '|| - (lambda (self &rest args) - (trc "better event handler!!!!" self args)) - ":time %t")) + (setf *tkw* (make-instance root-class))) (tk-format `(:fini) "wm deiconify .") - + (tk-format-now "bind . {destroy .}") ;; one or the other of... (tcl-do-one-event-loop) #+either-or (Tk_MainLoop) @@ -70,24 +66,29 @@ (defparameter *event-loop-delay* 0.08 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)") -(defun tcl-do-one-event-loop () - (loop with start-time = (get-internal-real-time) - while (and (plusp (tk-get-num-main-windows)) - (> 10 (floor (- (get-internal-real-time) start-time) internal-time-units-per-second))) - do - (bif (events (prog1 +(let ((last-check nil) + (check-interval (floor internal-time-units-per-second 100))) + (defun check-faux-events () + (let ((now (get-internal-real-time))) + (when (or (null last-check) (> (- now last-check) check-interval)) + (setf last-check now) + (bwhen (events (prog2 (trc nil "tcl-do-one-event-loop checking for events" (get-internal-real-time)) (tk-eval-list "set tk-events") (tk-eval "set tk-events {}"))) - (progn - #+shhh (loop for e in events - do (trc "event preview" e)) - (trc "main windows count =" (tk-get-num-main-windows)) - (loop for e in events - do (setf start-time (get-internal-real-time)) - (tk-process-event e))) - (sleep *event-loop-delay*)) - (loop until (zerop (Tcl_DoOneEvent 2))) - finally (trc "tcl-do-one-event-loop has left the building"))) + (loop for e in events + do (tk-process-event e)))) + (progn + (trc nil "tcl-do-one-event-loop sees no events" (get-internal-real-time)) + #+iwantmyide (sleep *event-loop-delay*))))) + +(defun tcl-do-one-event-loop () + (loop while (plusp (tk-get-num-main-windows)) + do (check-faux-events) + (loop until (zerop (Tcl_DoOneEvent 2))) ;; 2== TCL_DONT_WAIT + finally ;;(tk-eval "exit") + (tcl-delete-interp *tki*) + (setf *tki* nil) + (trc "tcl-do-one-event-loop has left the building"))) (defun tk-process-event (event) (destructuring-bind (fn w-name &rest args) @@ -103,7 +104,7 @@ (defmethod do-on-event (self event-type$ &rest args &aux (event-type (intern event-type$))) (assert (symbolp event-type)) - (trc "on event!!!" self event-type args) + (trc nil "on event!!!" self event-type args) (bif (ecb (gethash event-type (event-handlers self))) (apply ecb self event-type args) (progn --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/03 20:02:36 1.3 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/04 06:11:10 1.4 @@ -5,7 +5,6 @@ ;;------------------------------------------------------------------------------ -(defvar *tki* nil) ;;------------------------------------------------------------------------------ ;; External LIBRARIES ;;------------------------------------------------------------------------------ @@ -116,7 +115,7 @@ ;; Togl Initialization - (Togl_Init interp) + ;;(Togl_Init interp) ;; Say hello @@ -143,10 +142,13 @@ ;; Tcl_CreateInterp (defcfun ("Tcl_CreateInterp" %Tcl_CreateInterp) :pointer) - (defun Tcl_CreateInterp () (%Tcl_CreateInterp)) + (defcfun ("Tcl_DeleteInterp" tcl-delete-interp) + :void + (interp :pointer)) + ;; Tcl_EvalFile (defcfun ("Tcl_EvalFile" %Tcl_EvalFile) tcl-retcode @@ -335,9 +337,8 @@ (use-foreign-library Tcl) (use-foreign-library Tk) (use-foreign-library Togl) - (prog1 - (Tcl_FindExecutable) - (set-initialized)))) + (Tcl_FindExecutable) + (set-initialized))) ;; Send a script to a piven Tcl/Tk interpreter --- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/05/03 08:20:49 1.2 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/05/04 06:11:10 1.3 @@ -35,8 +35,7 @@ (:documentation "Root class for widgets and (canvas) items")) (defmethod md-awaken :before ((self tk-object)) - (progn ;; sorry, some next need more granularity in client queueso no: with-integrity (:client `(:make-tk ,self)) - (make-tk-instance self))) + (make-tk-instance self)) ;;; --- deftk -------------------- --- /project/cells/cvsroot/Celtk/togl.lisp 2006/05/02 12:48:05 1.1 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/05/04 06:11:10 1.2 @@ -28,7 +28,10 @@ ;;;(defcfun ("Togl_Init" togl-init) tcl-retcode ;;; (interp :pointer)) - +(eval-when (compile load eval) + (export '(togl_swapbuffers togl_postredisplay togl-ptr togl-reshape-func + togl togl-timer-using-class Togl_PostRedisplay togl-reshape-using-class + togl-display-using-class togl_width togl_height togl-create-using-class))) ;; --- gotta call this bad boy during initialization, I guess any time after we have an interpreter ;; @@ -121,28 +124,20 @@ (defvar *togl*) (defvar *togls*) + (def-togl-callback create (setf (togl-ptr *togl*) togl) (push (cons togl *togl*) *togls*)) (def-togl-callback display) - -#+nah (def-togl-callback reshape) -(progn (defcfun ("Togl_ReshapeFunc" togl-reshape-func) :void (callback :pointer)) - (defcallback togl-reshape :void ((togl :pointer)) - (trc "reshape cb sees" togl) - (togl-reshape-using-class (cdr (assoc togl *togls*)) 400 400)) - (defmethod togl-reshape-using-class :around ((self togl) width height) - (trc "reshape-uc cb sees" self width height) - (if (cb-reshape self) - (funcall (cb-reshape self) self width height) - (call-next-method))) - (defmethod togl-reshape-using-class ((self togl) width height) - (declare (ignore width height)))) - +(def-togl-callback reshape) (def-togl-callback destroy) -(def-togl-callback timer) +(def-togl-callback timer + (check-faux-events)) -(defmethod make-tk-instance :around ((self togl)) - (let ((*togl* self)) - (call-next-method))) ;; this leads to "togl [- [- Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv24777 Modified Files: CELTK.lpr demos.lisp gears.lisp ltktest-cells-inside.lisp Log Message: --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/04 06:11:10 1.7 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/04 10:06:37 1.8 @@ -27,8 +27,7 @@ (make-instance 'module :name "togl.lisp") (make-instance 'module :name "run.lisp") (make-instance 'module :name "demos.lisp") - (make-instance 'module :name - "ltktest-cells-inside.lisp") + (make-instance 'module :name "ltktest-ci.lisp") (make-instance 'module :name "gears.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells") --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/04 06:11:10 1.9 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/04 10:06:37 1.10 @@ -24,9 +24,10 @@ (in-package :celtk-user) (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package - ;;(test-window 'one-button) - (test-window 'gears-demo) - ) + (test-window ;; 'one-button + ;;'ltktest-cells-inside + 'gears-demo + )) (defmodel one-button (window) () --- /project/cells/cvsroot/Celtk/gears.lisp 2006/05/04 06:11:10 1.4 +++ /project/cells/cvsroot/Celtk/gears.lisp 2006/05/04 10:06:37 1.5 @@ -2,12 +2,12 @@ (in-package :celtk-user) -(defparameter *startx* nil) -(defparameter *starty* nil) -(defparameter *xangle0* nil) -(defparameter *yangle0* nil) -(defparameter *xangle* 0.0) -(defparameter *yangle* 0.0) +(defvar *startx*) +(defvar *starty*) +(defvar *xangle0*) +(defvar *yangle0*) +(defvar *xangle*) +(defvar *yangle*) (defparameter *vTime* 100) @@ -16,7 +16,7 @@ (*starty* nil) (*xangle0* nil) (*yangle0* nil) - (*xangle* 0.0) + (*xangle* 0.2) (*yangle* 0.0)) (test-window 'gears-demo))) @@ -28,21 +28,19 @@ :kids (c? (the-kids (mk-stack (:packing (c?pack-self)) (mk-label :text "Click and drag to rotate image") - #+tki (mk-row () + (mk-row () (mk-button-ex (" Add " (incf (gear-ct .tkw)))) (mk-button-ex ("Remove" (when (plusp (gear-ct .tkw)) (decf (gear-ct .tkw))))) (mk-entry :id :vtime :md-value (c-in "100")) - (mk-button-ex (" Quit " (progn)))) + (mk-button-ex (" Quit " (tk-eval "destroy .")))) (make-instance 'gears :fm-parent *parent* - :width 400 - :height 400 - :timer-interval nil #+tki (c? (or .cache ;; comment out just ".cache" for some fun - (eko ("vtime is") - (md-value (fm-other :vtime))))) - :double "yes" + :width 400 :height 400 + :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) + (format nil "~a" (or (parse-integer n$ :junk-allowed t) 0)))) + :double 1 ;; "yes" :bindings (c? (list (list '|<1>| (lambda (self event root-x root-y) (declare (ignorable self event root-x root-y)) @@ -74,9 +72,9 @@ (defconstant +pif+ (coerce pi 'single-float)) (defmodel gears (togl) - ((rotx :initform (c-in 0.0) :accessor rotx :initarg :rotx) - (roty :initform (c-in 0.0) :accessor roty :initarg :roty) - (rotz :initform (c-in 0.0) :accessor rotz :initarg :rotz) + ((rotx :initform (c-in 0.2) :accessor rotx :initarg :rotx) + (roty :initform (c-in 0.5) :accessor roty :initarg :roty) + (rotz :initform (c-in 0.8) :accessor rotz :initarg :rotz) (gear1 :accessor gear1 :initform (c-in nil)) (gear2 :accessor gear2 :initform (c-in nil)) (gear3 :accessor gear3 :initform (c-in nil)) @@ -104,7 +102,7 @@ (gl:frustum -1 1 (- h) h 5 60)) (gl:matrix-mode :modelview) (gl:load-identity) - (gl:translate 0 0 -40))) + (gl:translate 0 0 -30))) (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo)))) (declare (ignorable scale)) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/05/03 17:34:58 1.16 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/05/04 10:06:37 1.17 @@ -398,7 +398,7 @@ ; around the TCL after command. See the class definition of timer ; for the fireworks (in terms of Cells) that resulted ; - :repeat (c-in nil) + :repeat (c-in t) :delay 1 ;; milliseconds since this gets passed unvarnished to TK after :action (lambda (timer) (declare (ignorable timer)) From ktilton at common-lisp.net Thu May 4 21:25:12 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 4 May 2006 17:25:12 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20060504212512.DB0A720006@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv14075 Modified Files: md-slot-value.lisp Log Message: Restore integrity wrapper on (setf md-slot-value) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/05/01 20:23:14 1.12 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/05/04 21:25:12 1.13 @@ -162,18 +162,7 @@ (when *defer-changes* (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c)) - (progn ;; with-integrity (:change) - ;; - ;; ok, we had a weird bug to find caused by a SETF being deferred unexpectedly. - ;; This was the gears Togl demo, setf-ing a display-list in the create callback. It got - ;; called within the dynamic scope of the ufb queue handler doing the :make-tk items. - ;; When contemplating a fix, it occurred to me that I had no idea what to return from - ;; (setf md-slot-value) if the core setf behavior got deferred. I concluded one could not - ;; sensibly impose integrity automatically here, as slick as that might seem. So callers - ;; will have to provide the with-integrity (:change... wrapper. Since SETF happens mostly - ;; in event handling callbacks, hopefully this will not be necesssary at all. A quck check - ;; of Celtk confirms this pattern. - ;; + (with-integrity (:change) (md-slot-value-assume c new-value nil)) ;; new-value From ktilton at common-lisp.net Thu May 4 21:26:24 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 4 May 2006 17:26:24 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060504212624.550012200C@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv14123 Modified Files: demos.lisp entry.lisp gears.lisp menu.lisp multichoice.lisp timer.lisp Added Files: ltktest-ci.lisp Removed Files: gears-demo.lisp ltktest-cells-inside.lisp Log Message: --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/04 10:06:37 1.10 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/04 21:26:23 1.11 @@ -25,8 +25,8 @@ (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window ;; 'one-button - ;;'ltktest-cells-inside - 'gears-demo + 'ltktest-cells-inside + ;;'gears-demo )) (defmodel one-button (window) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/03 08:20:49 1.2 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/04 21:26:23 1.3 @@ -50,10 +50,9 @@ (setf (gethash '|write| (event-handlers self)) (lambda (self event-type) ;; &rest args) (declare (ignorable event-type)) - (with-integrity (:change) - (let ((new-value (tk-eval-var (^path)))) + (let ((new-value (tk-eval-var (^path)))) (unless (string= new-value (^md-value)) - (setf (^md-value) new-value)))))))) + (setf (^md-value) new-value))))))) ;;; /// this next replicates the handling of tk-mirror-variable because ;;; those leverage the COMMAND mechanism, which entry lacks --- /project/cells/cvsroot/Celtk/gears.lisp 2006/05/04 10:06:37 1.5 +++ /project/cells/cvsroot/Celtk/gears.lisp 2006/05/04 21:26:23 1.6 @@ -1,3 +1,7 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; gears.lisp --- Celtk/Togl version of cl-opengl Lisp version of gears.c (GLUT Mesa demos). +;;; +;;; Simple program with rotating 3-D gear wheels. (in-package :celtk-user) @@ -33,13 +37,13 @@ (mk-button-ex ("Remove" (when (plusp (gear-ct .tkw)) (decf (gear-ct .tkw))))) (mk-entry :id :vtime - :md-value (c-in "100")) + :md-value (c-in "10")) (mk-button-ex (" Quit " (tk-eval "destroy .")))) (make-instance 'gears :fm-parent *parent* :width 400 :height 400 :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) - (format nil "~a" (or (parse-integer n$ :junk-allowed t) 0)))) + (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" :bindings (c? (list (list '|<1>| (lambda (self event root-x root-y) @@ -50,8 +54,7 @@ (list '|| (lambda (self event root-x root-y) (declare (ignore event)) - (with-integrity (:change) - (RotMove self root-x root-y)) + (RotMove self root-x root-y) 0) "%X %Y"))))))))) @@ -67,17 +70,36 @@ (setf *xangle* (+ *xangle0* (- x *startx*))) (setf *yangle* (+ *yangle0* (- y *starty*))) (setf (rotx self) *xangle*) - (setf (roty self) *yangle*)) + (assert (eql *xangle* (rotx self))) + (setf (roty self) *yangle*) + (trc "RotMove x y" *xangle* *yangle*)) (defconstant +pif+ (coerce pi 'single-float)) (defmodel gears (togl) - ((rotx :initform (c-in 0.2) :accessor rotx :initarg :rotx) - (roty :initform (c-in 0.5) :accessor roty :initarg :roty) - (rotz :initform (c-in 0.8) :accessor rotz :initarg :rotz) - (gear1 :accessor gear1 :initform (c-in nil)) - (gear2 :accessor gear2 :initform (c-in nil)) - (gear3 :accessor gear3 :initform (c-in nil)) + ((rotx :initform (c-in 40) :accessor rotx :initarg :rotx) + (roty :initform (c-in 25) :accessor roty :initarg :roty) + (rotz :initform (c-in 10) :accessor rotz :initarg :rotz) + (gear1 :initarg :gear1 :accessor gear1 + :initform (c_? (trc "making list!!!!! 1") + (let ((dl (gl:gen-lists 1))) + (gl:with-new-list (dl :compile) + (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) + (draw-gear 1.0 4.0 1.0 20 0.7)) + dl))) + (gear2 :initarg :gear2 :accessor gear2 + :initform (c_? (let ((dl (gl:gen-lists 1))) + (gl:with-new-list (dl :compile) + (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0)) + (draw-gear 0.5 2.0 2.0 10 0.7)) + dl))) + (gear3 :initarg :gear3 :accessor gear3 + :initform (c_? (let ((dl (gl:gen-lists 1))) + (gl:with-new-list (dl :compile) + (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0)) + (draw-gear 1.3 2.0 0.5 10 0.7)) + dl))) + (angle :initform (c-in 0.0) :accessor angle :initarg :angle) (frame-count :cell nil :initform 0 :accessor frame-count) (t0 :cell nil :initform 0 :accessor t0) @@ -87,9 +109,8 @@ (defmethod togl-timer-using-class ((self gears)) (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time)) - (with-integrity (:change) - (incf (^angle) 2.0) - (Togl_PostRedisplay (togl-ptr self)))) + (incf (^angle) 2.0) + (Togl_PostRedisplay (togl-ptr self))) (defmethod togl-reshape-using-class ((self gears)) (let ((width (Togl_width (togl-ptr self))) @@ -106,56 +127,38 @@ (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo)))) (declare (ignorable scale)) - (with-slots (rotx roty rotz angle gear1 gear2 gear3) - self - - (gl:clear-color 0 0 0 1) - (gl:clear :color-buffer-bit :depth-buffer-bit) - + + (gl:clear-color 0 0 0 1) + (gl:clear :color-buffer-bit :depth-buffer-bit) + + (gl:with-pushed-matrix + (gl:rotate (^rotx) 1 0 0) + (gl:rotate (^roty) 0 1 0) + (gl:rotate (^rotz) 0 0 1) + (gl:with-pushed-matrix - (gl:rotate rotx 1 0 0) - (gl:rotate roty 0 1 0) - (gl:rotate rotz 0 0 1) - - (gl:with-pushed-matrix ; gear1 (gl:translate -3 -2 0) - (gl:rotate angle 0 0 1) - (gl:call-list gear1)) - - (gl:with-pushed-matrix ; gear2 - (gl:translate 3.1 -2 0) - (gl:rotate (- (* -2 angle) 9) 0 0 1) - (gl:call-list gear2)) - - (gl:with-pushed-matrix ; gear3 - (gl:translate -3.1 4.2 0.0) - (gl:rotate (- (* -2 angle) 25) 0 0 1) - (gl:call-list gear3))) + (gl:rotate (^angle) 0 0 1) + (gl:call-list (^gear1))) - (Togl_SwapBuffers (togl-ptr self)) + (gl:with-pushed-matrix + (gl:translate 3.1 -2 0) + (gl:rotate (- (* -2 (^angle)) 9) 0 0 1) + (gl:call-list (^gear2))) - #+shhh (print-frame-rate self))) + (gl:with-pushed-matrix ; gear3 + (gl:translate -3.1 4.2 0.0) + (gl:rotate (- (* -2 (^angle)) 25) 0 0 1) + (gl:call-list (^gear3)))) + + (Togl_SwapBuffers (togl-ptr self)) + + #+shhh (print-frame-rate self)) (defmethod togl-create-using-class ((self gears)) (gl:light :light0 :position #(5.0 5.0 10.0 0.0)) (gl:enable :cull-face :lighting :light0 :depth-test) - - ;; gear 1 - (setf (^gear1) (gl:gen-lists 1)) - (gl:with-new-list ((^gear1) :compile) - (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) ; red - (draw-gear 1.0 4.0 1.0 20 0.7)) - - ;; gear 2 - (setf (^gear2) (gl:gen-lists 1)) - (gl:with-new-list ((^gear2) :compile) - (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0)) ; green - (draw-gear 0.5 2.0 2.0 10 0.7)) - ;; gear 3 - (setf (^gear3) (gl:gen-lists 1)) - (gl:with-new-list ((^gear3) :compile) - (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0)) ; blue - (draw-gear 1.3 2.0 0.5 10 0.7)) + (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) (gl:enable :normalize)) (defun draw-gear (inner-radius outer-radius width n-teeth tooth-depth) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/05/04 06:11:10 1.10 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/05/04 21:26:24 1.11 @@ -218,8 +218,7 @@ :on-command (lambda (self) (declare (ignore key args)) (trc nil "menu radio button command firing" self (^value) (upper self selector)) - (with-integrity (:change) - (setf (selection (upper self selector)) (^value)))))) + (setf (selection (upper self selector)) (^value))))) (defmodel menu-radio-group (selector family) ((.md-name :cell nil :initform (gentemp "RG") :initarg :id)) @@ -276,8 +275,7 @@ (defobserver initial-value ((self popup-menubutton)) (when new-value - (with-integrity (:change self) - (setf (selection self) new-value)))) + (setf (selection self) new-value))) (defmethod tk-output-selection ((self popup-menubutton) new-value old-value old-value-boundp) (declare (ignorable old-value old-value-boundp)) --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/03 08:20:49 1.2 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/04 21:26:24 1.3 @@ -124,8 +124,7 @@ (defobserver initial-value ((self spinbox)) (when new-value - (with-integrity (:change) - (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) - (setf (^md-value) new-value)))) + (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) + (setf (^md-value) new-value))) --- /project/cells/cvsroot/Celtk/timer.lisp 2006/05/03 08:20:49 1.2 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/05/04 21:26:24 1.3 @@ -79,11 +79,10 @@ (on-command :reader on-command :initform (lambda (self) - (with-integrity (:change self) - (when (eq (^state) :on) + (when (eq (^state) :on) (assert (^action)) (funcall (^action) self) - (setf (^executed) t))))) + (setf (^executed) t)))) (after-factory :reader after-factory :initform (c? (bwhen (rpt (eko (nil ">>> repeat") (when (eq (^state) :on) (^repeat)))) --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/04 21:26:24 NONE +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/04 21:26:24 1.1 #| This software is Copyright (c) 2003, 2004, 2005, 2006 Peter Herth Parts Copyright (c) 2005 Thomas F. Burdick Parts Copyright (c) Cadence Design Systems, GmbH Peter Herth grants you the rights to distribute and use this software as governed by the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!! PROMINENT NOTICE !!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!! !!!!!!!!!!!!!!! !!!!!!!!!!!! This demo was translated to Cells !!!!!!!!!!!!!!! !!!!!!!!!!!! by ken Tilton on March 22, 2006. !!!!!!!!!!!!!!! !!!!!!!!!!!! !!!!!!!!!!!!!!! !!!!!!!!!!!! Original (ltktest) can be found !!!!!!!!!!!!!!! !!!!!!!!!!!! at the end of ltk.lisp !!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |# (in-package :celtk-user) #| The comments throughout this source file cover two broad topics: How is programming with Celtk different from LTk? Contrast the code below with the excellent ltktest "classic" in ltk.lisp to see how Celtk programming is different. I won't say better, because some people prefer an imperative approach where they can have all the bricks laid out in front of them and sequence them manually one by one to get exactly what they want without thinking very hard. The declarative approach makes one think a little harder but in the end do less work as the responsibility for getting things to work falls on the engine behind the declarative interface. Second topic: How is programming with Cells different from without Cells? Those questions are different because not everything different about Celtk depends on Cells. Note: explanatory comments appear after the explained code. n.b. The paint is very fresh on Celtk, so if something like the Timer class looks dumb, well, it may be. Example: the scroller class only scrolls a canvas (well, I have not tried supplying a frame for the canvas slot, maybe it would work, but the slot name at least is certainly wrong (or the class should be canvas-scroller). |# #+test-ltktest (progn (cells-reset 'tk-user-queue-handler) ; ; Tk is fussy about the order in which things happen. It likes: ; - create widgets .x and .y ; - make .x the -textvariable of .y ; - set .x to "Hi, Mom" ; ; Tk does not like Step 3 going before Step 2. That is, .y will not learn about "Hi, Mom.". ; Unfortunately, in a declarative paradigm one does not specify in what order different ; things should happen, one just specifies the things we want to have happen. An underlying ; engine then runs around taking care of making that happen, without bothering the developer ; about how to do that. That includes deciding in what order to make those things happen. That is ; a big win when it works. When it did not work for Tk, and I could imagine the same thing ; coming up again in other situations (Tilton's Law: "The first time you run into something ; is just the first time you ran into it"), I added to Cells the concept of a "client queue", ; where client-code can store order-sensitive tasks. The client also can specify the handler for ; that queue, here 'tk-user-queue-handler. This handler (or the default FIFO handler) gets called ; at just the right time in the larger scheme of state propagation one needs for ; data integrity. What is that scheme? ; ; Data integrity: when the overall Cells data model gets perturbed by imperative code -- typically an ; event loop -- executing a SETF of some datapoint X, we want these requirements met: ; ; - recompute all and (for efficiency) only state computed off X (directly or indirectly through some intermediate datapoint); ; ; - recomputations, when they read other datapoints, must see only values current with the new value of X; ; ; - similarly, client observers ("on change" callbacks) must see only values current with the new value of X; and ; ; - a corollary: should a client observer SETF a datapoint Y, all the above must ; happen with values current with not just X, but also with the value of Y /prior/ ; to the change to Y. ; ; To achieve the above, Cells2 and now Cells3 have taken to using FIFO "unfinished business" queues ; to defer things until The Right Time. Which brings us back to Tk. Inspect the source of ; tk-user-queue-handler and search the Celtk source for "with-integrity (:client" to see how Celtk ; manages to talk to Tk in the order Tk likes. And hack the function tk-format-now to have ; Celtk dump the TCL/Tk code being sent to wish during initialization, and notice how un-random it looks. You can ; then comment out the above specification of a Tk-savvy handler to see (a) the order that would have happened ; before Cells3 and (b) the demo collapse in a broken heap. ; ; But in short, with Cells3 we just add this requirement: ; ; - Deferred "client" code must see only values current with X and not any values current with some ; subsequent change to Y queued by an observer ; (ctk:test-window 'ltktest-cells-inside)) ; That is all the imperative code there is to Celtk application development, aside from widget commands, and those ; invariably (?) consist of a single setf. So where does the rest of the state change necessary to keep a GUI ; interface self-consistent get taken care of? ; Tk handles some of the driving imperative logic -- they call the company ActiveState for a reason -- and Celtk internals ; handle the rest. The application works via Cells rules reacting to change by computing new state for the application model, ; which operates on the outside world via observers (on-change callbacks) triggered ; automatically by the Cells engine. See DEFOBSERVER. (defmodel ltktest-cells-inside (window) () (:default-initargs :id :ltk-test :kids (c? ; c? has quite an expansion. Functionally, one gets: ; - a first-class anonymous function with the expected body, which will have access to... ; - lexical variables self and .cache for the instance and prior computed value, if any ; - guaranteed recomputation when the value of any other cell /used in the most recent computation/ changes ; ; If the abbreviation c? alarms you, look up c-formula. ; (the-kids ; ; Cells GUIs get a lot of mileage out of the family class, which is perfect ; for graphical hierarchies. "the-kids" does not do much, btw. ; (ltk-test-menus) ;; hiding some code. see defun below for deets (mk-scroller ; ; These "mk-" functions do nothing but expand into (make-instance 'scroller ) ; and supply the "parent" :initarg necessary in Family trees. ; ; Where you see, say, mk-button-ex I am (a) poking fun at Microsoft naming of second generation ; library code that did not want to break existing code and (b) adding a little more value (just ; inspect the macro source to see how). ; :packing (c?pack-self "-side top -fill both -expand 1") ; ; Here is an example of how the Family class helps. The above is one of only two packing ; statements needed to recreate the ltktest demo. Other packing is handled via two ; slots in an inline-mixin class for various family subclasses, kids-layout and ; kids-packing. The latter pulls any packing parameters and all kids into one ; big pack statement kicked off by an observer on that slot. See the inline-mixin ; class to see how this works. ; ; See the scroller class to see some automation of grids (but this was my first experience ; with grids so look for that to get enhanced over time -- and later automation ; of the use of PLACE. ; :canvas (c? (make-kid 'ltk-test-canvas))) ;; hiding some code. see defmodel thereof below ; ; My bad. Scroller should not assume a canvas is the scrollee. To be refined. ; (mk-row (:packing (c?pack-self "-side bottom")) ; ; Just expand mk-row to see what is going on. It is pretty neat in one respect: if the ; first row parameter is a string, it knows to make a labelframe instead of plain frame) ; The other thing it does, by forcing row parameters into a sub-list as the first argument, ; is let the programmer then just list other widgets (see next) which are understood to ; be kids/subwidgets contained by the frame. ; (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") ; ; As with Ltk Classic, the Tk widget configurations become Lisp widget initializers, so ; the Tk doc documents Celtk. The advantage to the developer is that neither LTk nor ; Celtk introduce a new API to be mastered, widget-wise. ; (mk-button-ex ("Start" (setf (moire-spin (fm^ :moire-1)) t))) ; ; You were warned about mk-button-ex and its ilk above. Just expand or inspect to ; see what they do, which is pretty much just hide some boilerplate. ; ; fm^ is a wicked abbreviation for "search up the Family tree to find the widget ; with this ID". ie, The Family tree effectively becomes a namespace of IDs. I have a suite of ; routines that search the namespace by name so one widget can operate on or, ; more commonly, ask for the value of a slot of some specific widget known to ; be Out There somewhere. (Kids know their parents, so the search can reach ; anywhere in the tree.) ; ; OK, now what is going on here? The above command starts the canvas display ; spinning, by tweaking (via the (setf moire-spin) defun below) the "repeat" slot of ; an ad hoc "moire" class object created to render the pretty design from ; ltktest. How it accomplishes that will be explained below in the moire class ; definition. ; (mk-button-ex ("Stop" (setf (moire-spin (fm^ :moire-1)) nil)))) ;; ditto (mk-button-ex ("Hallo" (format T "~&Hallo"))) (mk-button-ex ("Welt!" (format T "~&Welt!"))) (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Test:") (mk-button-ex ("OK:" (setf (moire-spin (fm^ :moire-1)) 100)))) ; ; Cells initiata will be surprised to learn the above works twice even if the button is ; clicked twice in a row; Cells is about managing state change, and the second time through ; there is no change. But the system still reacts! See the Timer class for the shocking ; solution to this riddle. ; (mk-entry-numeric :id :point-ct :md-value (c-in "42") ; ; to help motivate "why Cells?" a little more, we deviate from ltktest 'classic" and ; start having the widgets take more interesting effect: The entry field now determines the number ; of points to generate for the canvas line item, which originally was fixed at 100. ; see the moire class for details. ; :num-parse (c? (eko ("numparse") ; ; (EKO is a utils-kt debug hack that prints a value along with arbitrary ; other info before returning the value to the inquirer) ; ; Here we supplement the standard entry-numeric parse rule with ; our own more stringent rule that knows about the moire task ahead. ; ; A vital point with this entry-numeric class (invented just now for ; this demo) is that Cells does not get in the way of CLOS. We are ; subclassing, using initforms, default-initargs, and, what I suspect is ; a big reason Cells are such a big win: different instances of the same ; class do not need to have the same rules for the same slot. Or even ; have rules at all; other instances can have a constant or be setffable ; from outside the model. ; (handler-case (let ((num (parse-integer (^md-value)))) (cond ((< num 2) (list (format nil "Yo, Euclid, at least two, not: ~a!!" num))) ((> num 200) (list (format nil "Bzzt! ~a points will not look so hot." num))) (t num))) (parse-error (c) (princ-to-string c))))) :background (c? (if (user-errors (fm! :point-ct)) "red" 'SystemButtonFace))) ;; TK won't allow "" as a way of saying "default color" ; ; As you edit the field, if you key in an invalid (non-digit) character, the background ; immediately turns red. Delete it and it reverts to the default. ; ; The interesting question is, how does the md-value slot of the Lisp instance stay ; current with the text being edited in the Tk entry widget? Here we have a fundamental ; difference between Ltk and Celtk. Ltk lets Tk take care of everything, including ; storing the data. eg, (text my-entry) is an accessor call that asks Tk the value of ; the -text configuration for the Tk instance mirrored by my-entry. There is no text ; slot in the Lisp entry instance. Makes for nice, lightweight Lisp instances. But Cells works ; by having datapoints watching other datapoints, so we want data in the Lisp domain ; changing automatically as it changes on the TK side (such as when the user is actually ; typing in the entry widget). See the entry class to see how it uses the TCL "trace write" ; mechanism to keep the Lisp md-value slot abreast of the Tk entry text configuration ; keystroke by keystroke. ; ; I added the :user-errors rule above to demonstrate the mechanism in action. Click ; on the entry widget and type "123abc", then delete the alpha characters. The background ; color (as well as the File\Save menu item state) tracks the typing. ; (mk-button-ex ("Print" (format t "~&User wants to see ~A points" (fm^v :point-ct)))) ; ; (fm^v :point-ct) -> (md-value (fm^ :point-ct)) ; ; The idea being that every Cells model object has an md-value slot bearing the value ; of the thing being modeled. Here, the entry widget is modelling a place for users ; to supply information to an application, and the md-value slot is a good place to ; keep that information. ; ; Thus each class uses md-value to hold something different, but in all cases it is ; the current value of whatever the instance of that class is understood to hold. ; (mk-button-ex ("Reset" (setf (fm^v :point-ct) "42"))) ; ; Driving home this point again, in Ltk one would SETF (text my-entry) and the ; SETF method would communicate with Tk to make the change to the Tk widget -text ; configuration. In Celtk, the md-value slot of the entry gets changed (possibly ; triggering other slots to update, which is why we do not just talk to Tk) and ; then that value gets propagated to Tk via "set ". Because ; the textVariable for every entry is the entry itself, the text of the entry ; then changes. If that sounds weird, what we are actually doing is tapping into ; the fact that Tk to a large degree takes the same approach as Cells does with md-value: ; in Cells, we think of model instances as wrapping some model-specific ; value, which is held in the md-value slot of the model instance. Tk simply ; allows a widget path to be a global variable. Furthermore, as the company name ; ActiveState suggests, Tk also provides automatic propagation: change the ; variable, and anyone with that as its textVariable also changes. ))))) (defmodel ltk-test-canvas (canvas) () (:default-initargs :id :test-canvas :background (c? (or (selection (fm! :bkg (^menus))) 'SystemButtonFace)) ; ; we are taking the demo a little further to make it a little more real world than just ; printing to standard output. A point to make here is the decoupling of the menu from ; its application role, namely allowing the user to specify the background color of ; the spinning lines. The pop-up is now a radio-group menu that does not know how the ; choice it is maintaining will be used. It simply takes care of its business of allowing ; the user to choose exactly one color. Changes get propagated automatically by the Cells ; engine to any slot whose rule happens to read the radio-group selection slot. And the coding ; is transparent: just read the value. No need to write explicit code to subscribe, notify, ; or unsubscribe. ; :scroll-region '(0 0 500 400) :gridding "-row 0 -column 0 -sticky news" ; ; As with packing, Celtk tries to simplify life with Tk gridding. But that is achieved partly ; by automating things as with the kids-packing and kids-layout slots, and partly by staying ; out of the programmer's way and letting them specify actual Tk code to be passed unfiltered ; to Tk. The design choice here is to acknowledge that LTk and Celtk users really are still ; doing Tk programming; only some automation (and Lispification) is provided. ; ; This also simplifies Celtk since it just has to pass the Tk code along with "grid " ; appended. ; :bindings (c? (list (list '|<1>| (lambda (self event root-x root-y) (declare (ignorable event root-x root-y)) ; ; Stolen from the original. It means "when the left button is ; pressed on this widget, popup this menu where the button was pressed" ; The only difference is that here we get to specify this along with ; the rest of the configuration of this instance, whereas in the original ; the enabling code was just "out there" in a long sequence of other ; imperatives setting up this widget and that. ie, It is nice having ; everything about X collected in one place. In case you are wondering, ; an observer on the bindings slot passes the needed bindings to Tk ; via the client queue. ; (pop-up (^widget-menu :bkg-pop) root-x root-y)) "%X %Y"))) :menus (c? (the-kids ; ; we could just build the menu in the rule above for bindings and then close over the variable ; bearing the menu's Tk name in the binding callback in the call to pop-up, but I try to decompose ; these things in the event that the bindings become dynamic over time (esp. such that the rule to generate ; the binding list runs repeatedly) so we are not forever regenerating the same pop-up menu. ; premature optimization? well, it also makes the code clearer, and should the list of menus become ; variable over time this allows us to GC (via Tk "destroy") menus, so this is not so much about ; optimization as it is about Good Things happening to well-organized code. ; (mk-menu :id :bkg-pop :kids (c? (the-kids (mk-menu-radio-group :id :bkg :selection (c-in nil) ;; this will start us off with the Tk default :kids (c? (the-kids (mk-menu-entry-radiobutton :label "Crimson Tide" :value "red") (mk-menu-entry-radiobutton :label "Oak Tree Ribbon" :value "yellow") (mk-menu-entry-radiobutton :label "Sky" :value 'blue) (mk-menu-entry-radiobutton :label "Factory" :value 'SystemButtonFace))))))))) :kids (c? (the-kids (mk-text-item :coords (list 10 10) :anchor "nw" :text "Ltk Demonstration") (make-kid 'moire :id :moire-1))))) ; ; we give this widget a specific ID so other rules can look it up, as ; discussed above when explaining fm^. (defmodel moire (line) ((angle-1 :initarg :angle-1 :accessor angle-1 :initform (c-in 0)) (point-ct :initarg :point-ct :accessor point-ct :initform (c? (num-value (fm^ :point-ct))))) (:default-initargs :timers (c? (list (make-instance 'timer ; ; it occurred to me that it might be useful to build a timer utility ; around the TCL after command. See the class definition of timer ; for the fireworks (in terms of Cells) that resulted ; :repeat (c-in t) :delay 1 ;; milliseconds since this gets passed unvarnished to TK after :action (lambda (timer) (declare (ignorable timer)) (incf (^angle-1) 0.1))))) :coords (c? (let ((angle-2 (* 0.3 (^angle-1))) (wx (sin (* 0.1 (^angle-1))))) (loop for i below (^point-ct) for w = (+ (^angle-1) (* i 2.8001)) for x = (+ (* 50 (sin angle-2)) 250 (* 150 (sin w) (1+ wx))) [63 lines skipped] From ktilton at common-lisp.net Fri May 12 08:27:40 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 12 May 2006 04:27:40 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20060512082740.2615367003@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv940 Modified Files: cells.lpr family-values.lisp Log Message: --- /project/cells/cvsroot/cells/cells.lpr 2006/05/01 20:23:14 1.10 +++ /project/cells/cvsroot/cells/cells.lpr 2006/05/12 08:27:39 1.11 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Apr 21, 2006 10:24)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/family-values.lisp 2006/03/16 05:28:28 1.2 +++ /project/cells/cvsroot/cells/family-values.lisp 2006/05/12 08:27:39 1.3 @@ -97,5 +97,4 @@ data)) (defobserver sorted-kids () - (setf (sort-map self) new-value)) ;; cellular trick to avoid cyclicity - + (setf (sort-map self) new-value)) ;; cellular trick to avoid cyclicity \ No newline at end of file From ktilton at common-lisp.net Fri May 12 08:27:39 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 12 May 2006 04:27:39 -0400 (EDT) Subject: [cells-cvs] CVS cells/cells-test Message-ID: <20060512082739.1FCCE650CD@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv940/cells-test Modified Files: cells-test.lpr df-interference.lisp Log Message: --- /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2006/03/18 00:14:01 1.4 +++ /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2006/05/12 08:27:39 1.5 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/cells-test/df-interference.lisp 2006/03/16 05:22:08 1.2 +++ /project/cells/cvsroot/cells/cells-test/df-interference.lisp 2006/05/12 08:27:39 1.3 @@ -118,3 +118,11 @@ )) +(defmodel skipper () + ((price :initform (c-in 0) :accessor price) + (max-price :accessor max-price + :initform (c? (if .cache + (max (^price) .cache) + (^price)))) + (half-max :accessor half-max + :initform (c? (floor (^half-max) \ No newline at end of file From ktilton at common-lisp.net Fri May 12 08:27:40 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 12 May 2006 04:27:40 -0400 (EDT) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20060512082740.435C068001@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv940/utils-kt Modified Files: utils-kt.lpr Log Message: --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/05/03 08:22:16 1.8 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/05/12 08:27:40 1.9 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Apr 21, 2006 10:24)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Fri May 12 08:31:06 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 12 May 2006 04:31:06 -0400 (EDT) Subject: [cells-cvs] CVS gears Message-ID: <20060512083106.339CE77011@common-lisp.net> Update of /project/cells/cvsroot/gears In directory clnet:/tmp/cvs-serv2386 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import From ktilton at common-lisp.net Fri May 12 08:33:46 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 12 May 2006 04:33:46 -0400 (EDT) Subject: [cells-cvs] CVS gears Message-ID: <20060512083346.6837C7A008@common-lisp.net> Update of /project/cells/cvsroot/gears In directory clnet:/tmp/cvs-serv2832 Added Files: gears.lisp gears.lpr Log Message: --- /project/cells/cvsroot/gears/gears.lisp 2006/05/12 08:33:46 NONE +++ /project/cells/cvsroot/gears/gears.lisp 2006/05/12 08:33:46 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; gears.lisp --- Celtk/Togl version of cl-opengl Lisp version of gears.c (GLUT Mesa demos). ;;; ;;; Simple program with rotating 3-D gear wheels. (defpackage :gears (:use :common-lisp :utils-kt :cells :celtk)) (in-package :gears) (defvar *startx*) (defvar *starty*) (defvar *xangle0*) (defvar *yangle0*) (defvar *xangle*) (defvar *yangle*) (defparameter *vTime* 100) (defun gears () ;; ACL project manager needs a zero-argument function, in project package (let ((*startx* nil) (*starty* nil) (*xangle0* nil) (*yangle0* nil) (*xangle* 0.2) (*yangle* 0.0)) (test-window 'gears-demo))) (defmodel gears-demo (window) ((gear-ct :initform (c-in 1) :accessor gear-ct :initarg :gear-ct) (scale :initform (c-in 1) :accessor scale :initarg :scale)) (:default-initargs :title$ "Rotating Gear Widget Test" :kids (c? (the-kids (mk-stack (:packing (c?pack-self "-side left -fill both")) (mk-label :text "Click and drag to rotate image") (mk-row () (mk-button-ex (" Add " (incf (gear-ct .tkw)))) (mk-button-ex ("Remove" (when (plusp (gear-ct .tkw)) (decf (gear-ct .tkw))))) (mk-entry :id :vtime :md-value (c-in "10")) (mk-button-ex (" Quit " (tk-eval "destroy .")))) (make-instance 'gears :fm-parent *parent* :width 400 :height 400 :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" :bindings (c? (list (list '(ctk::|<1>| "%X %Y") (lambda (self event root-x root-y) (declare (ignorable self event root-x root-y)) (RotStart self root-x root-y) 0)) (list '(ctk::|| "%X %Y") (lambda (self event root-x root-y) (declare (ignore event)) (RotMove self root-x root-y) 0)))))))))) (defun RotStart (self x y) ;(trc "Rotstart!!!" self x y) (setf *startx* x) (setf *starty* y) (setf *xangle0* (rotx self)) (setf *yangle0* (roty self))) (defun RotMove (self x y) ;(trc "RotMove!!!!" self x y) (setf *xangle* (+ *xangle0* (- x *startx*))) (setf *yangle* (+ *yangle0* (- y *starty*))) (setf (rotx self) *xangle*) (assert (eql *xangle* (rotx self))) (setf (roty self) *yangle*) (trc nil "RotMove x y" *xangle* *yangle*)) (defconstant +pif+ (coerce pi 'single-float)) (defmodel gears (togl) ((rotx :initform (c-in 40) :accessor rotx :initarg :rotx) (roty :initform (c-in 25) :accessor roty :initarg :roty) (rotz :initform (c-in 10) :accessor rotz :initarg :rotz) (gear1 :initarg :gear1 :accessor gear1 :initform (c_? (trc "making list!!!!! 1") (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) (draw-gear 1.0 4.0 1.0 20 0.7)) dl))) (gear2 :initarg :gear2 :accessor gear2 :initform (c_? (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0)) (draw-gear 0.5 2.0 2.0 10 0.7)) dl))) (gear3 :initarg :gear3 :accessor gear3 :initform (c_? (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0)) (draw-gear 1.3 2.0 0.5 10 0.7)) dl))) (angle :initform (c-in 0.0) :accessor angle :initarg :angle) (frame-count :cell nil :initform 0 :accessor frame-count) (t0 :cell nil :initform 0 :accessor t0) ; (width :initarg :wdith :initform 400 :accessor width) (height :initarg :wdith :initform 400 :accessor height))) (defmethod togl-timer-using-class ((self gears)) (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time)) (incf (^angle) 2.0) (Togl_PostRedisplay (togl-ptr self))) (defmethod togl-create-using-class ((self gears)) (gl:light :light0 :position #(5.0 5.0 10.0 0.0)) (gl:enable :cull-face :lighting :light0 :depth-test) (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) (gl:enable :normalize) (truc self)) (defmethod togl-reshape-using-class ((self gears)) (truc self t)) (defun truc (self &optional truly) (let ((width (Togl_width (togl-ptr self))) (height (Togl_height (togl-ptr self)))) (trc "enter gear reshape" self width (width self)) (gl:viewport 0 (- height (height self)) (width self) (height self)) (unless truly (gl:matrix-mode :projection) (gl:load-identity) (let ((h (/ height width))) (gl:frustum -1 1 (- h) h 5 60))) (progn (gl:matrix-mode :modelview) (gl:load-identity) (gl:translate 0 0 -30)))) (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo)))) (declare (ignorable scale)) (gl:clear-color 0 0 0 1) (gl:clear :color-buffer-bit :depth-buffer-bit) (gl:with-pushed-matrix (gl:rotate (^rotx) 1 0 0) (gl:rotate (^roty) 0 1 0) (gl:rotate (^rotz) 0 0 1) (gl:with-pushed-matrix (gl:translate -3 -2 0) (gl:rotate (^angle) 0 0 1) (gl:call-list (^gear1))) (gl:with-pushed-matrix (gl:translate 3.1 -2 0) (gl:rotate (- (* -2 (^angle)) 9) 0 0 1) (gl:call-list (^gear2))) (gl:with-pushed-matrix ; gear3 (gl:translate -3.1 4.2 0.0) (gl:rotate (- (* -2 (^angle)) 25) 0 0 1) (gl:call-list (^gear3)))) (Togl_SwapBuffers (togl-ptr self)) #+shhh (print-frame-rate self)) (defun draw-gear (inner-radius outer-radius width n-teeth tooth-depth) "Draw a gear." (declare (single-float inner-radius outer-radius width tooth-depth) (fixnum n-teeth)) (let ((r0 inner-radius) (r1 (- outer-radius (/ tooth-depth 2.0))) (r2 (+ outer-radius (/ tooth-depth 2.0))) (da (/ (* 2.0 +pif+) n-teeth 4.0))) (gl:shade-model :flat) (gl:normal 0 0 1) ;; Draw front face. (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))) ;; Draw front sides of teeth. (gl:with-primitives :quads (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))) (gl:normal 0 0 -1) ;; Draw back face. (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))))) ;; Draw back sides of teeth. (gl:with-primitives :quads (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5))))) ;; Draw outward faces of teeth. (gl:with-primitives :quad-strip (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5)) (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle)))) (len (sqrt (+ (* u u) (* v v))))) (setq u (/ u len)) (setq v (/ u len)) (gl:normal v (- u) 0.0) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5)) (gl:normal (cos angle) (sin angle) 0.0) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5)) (setq u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da)))))) (setq v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da)))))) (gl:normal v (- u) 0.0) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5)) (gl:normal (cos angle) (sin angle) 0.0)))) (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5)) (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* (- width) 0.5))) ;; Draw inside radius cylinder. (gl:shade-model :smooth) (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:normal (- (cos angle)) (- (sin angle)) 0.0) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* (- width) 0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))))))) (defun print-frame-rate (window) (with-slots (frame-count t0) window (incf frame-count) (let ((time (get-internal-real-time))) (when (= t0 0) (setq t0 time)) (when (>= (- time t0) (* 5 internal-time-units-per-second)) (let* ((seconds (/ (- time t0) internal-time-units-per-second)) (fps (/ frame-count seconds))) (declare (ignorable fps)) #+shh (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%" frame-count seconds fps)) (setq t0 time) (setq frame-count 0))))) --- /project/cells/cvsroot/gears/gears.lpr 2006/05/12 08:33:46 NONE +++ /project/cells/cvsroot/gears/gears.lpr 2006/05/12 08:33:46 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :GEARS) (define-project :name :gears :modules (list (make-instance 'module :name "gears.lisp")) :projects (list (make-instance 'project-module :name "..\\Celtk\\CELTK") (make-instance 'project-module :name "C:\\0devtools\\cl-opengl\\glu")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :gears :main-form nil :compilation-unit t :verbose nil :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.check-box :cg.choice-list :cg.choose-printer :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate :cg.printing :cg.progress-indicator :cg.project-window :cg.property :cg.radio-button :cg.rich-edit :cg.rich-edit-pane :cg.rich-edit-pane.clipboard :cg.rich-edit-pane.printing :cg.sample-file-menu :cg.scaling-stream :cg.scroll-bar :cg.scroll-bar-mixin :cg.selected-object :cg.shortcut-menu :cg.static-text :cg.status-bar :cg.string-dialog :cg.tab-control :cg.template-string :cg.text-edit-pane :cg.text-edit-pane.file-io :cg.text-edit-pane.mark :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray :cg.up-down-control :cg.utility-dialog :cg.web-browser :cg.web-browser.dde :cg.wrap-string :cg.yes-no-list :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:top-level :debugger) :build-flags '(:allow-runtime-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+M +t \"Console for Debugging\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'gears::gears :on-restart 'do-default-restart) ;; End of Project Definition From ktilton at common-lisp.net Sat May 13 13:26:43 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 13 May 2006 09:26:43 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060513132643.44F1F5300F@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv17026 Modified Files: CELTK.lpr Celtk.lisp demos.lisp entry.lisp ltktest-ci.lisp run.lisp tk-interp.lisp Log Message: --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/12 08:30:13 1.9 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/13 13:26:42 1.10 @@ -8,6 +8,7 @@ :modules (list (make-instance 'module :name "Celtk.lisp") (make-instance 'module :name "tk-interp.lisp") (make-instance 'module :name "tk-object.lisp") + (make-instance 'module :name "tk-events.lisp") (make-instance 'module :name "widget.lisp") (make-instance 'module :name "font.lisp") (make-instance 'module :name "layout.lisp") --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/12 08:30:13 1.18 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/13 13:26:43 1.19 @@ -24,6 +24,7 @@ (:nicknames "CTK") (:use :common-lisp :utils-kt :cells :cffi) (:export + #:<1> #:title$ #:pop-up #:event-root-x #:event-root-y #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget #:mk-panedwindow @@ -127,7 +128,7 @@ ; ; --- debug stuff --- ; - (let ((yes '( )) + (let ((yes '("bind" "entry")) (no '("tk-events"))) (declare (ignorable yes no)) @@ -135,7 +136,7 @@ (break "Hey, fix this.") (replace tk$ "{Alt Q}" :start1 st)) - (when nil #+not (and (or (null yes) (find-if (lambda (s) (search s tk$)) yes)) + (when (and (or (null yes) (find-if (lambda (s) (search s tk$)) yes)) (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) @@ -144,7 +145,7 @@ ; --- serious stuff --- ; (setf *tk-last* tk$) - (eval-script *tki* tk$)) + (tcl-eval-ex *tki* tk$)) (defun tk-format (defer-info fmt$ &rest fmt-args) "Format then send to wish (via user queue)" --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/12 08:30:14 1.12 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/13 13:26:43 1.13 @@ -24,21 +24,13 @@ (in-package :celtk-user) (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package - #+test (dolist (dll (ff:list-all-foreign-libraries)) - (when (find-if (lambda (lib) - (search lib (pathname-name dll))) '("ftgl" "tcl" "tk")) - (print `(unloading foreign library ,dll)) - (ff:unload-foreign-library dll))) - ;(cffi:use-foreign-library ctk::tcl) - ;(cffi:use-foreign-library ctk::tk) - ;(cffi:use-foreign-library ctk::togl) (test-window - ;;'one-button - 'ltktest-cells-inside - ;;'menu-button-test - ;;'spinbox-test - ;; 'lotsa-widgets - ;;'gears-demo + ;; dont try this one, it is deliberately dysfunctional 'one-button + ;; OK 'ltktest-cells-inside + ;; OK 'menu-button-test + ;; OK 'spinbox-test + 'lotsa-widgets + ;; Now in Gears project 'gears-demo )) (defmodel one-button (window) @@ -72,6 +64,10 @@ :width 25) (make-instance 'button :fm-parent *parent* + :text "<>" + :command "event generate . <> -data \"Hi mom\"") + (make-instance 'button + :fm-parent *parent* :text "time now?" :on-command (c? (lambda (self) (trc "we got callbacks" self)))) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/12 08:30:14 1.4 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/13 13:26:43 1.5 @@ -84,12 +84,26 @@ :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :modified (c-in nil) - :bindings (c? (list (list '|<>| + :borderwidth (c? (if (^modified) 8 2)) + :bindings nil #+not (c? (list (list '|<>| (lambda (self event &rest args) (eko ("<> !!TK value for text-widget" self event args) - (setf (^modified) t)))))))) + nil #+not (setf (^modified) t)))))))) + +(defcallback entry-modified-handler :void ((self-tkwin :int)(XEvent :pointer)) + (trc "yowza entry-modified-handler" self-tkwin XEvent (mem-aref XEvent :int) + (TK-EVENT-TYPE (mem-aref XEvent :int)))) + +(defmethod make-tk-instance :after ((self text-widget)) + (with-integrity(:client `(:post-make-tk ,self)) + ;;(tk-format-now "bind ~a <> {set bxbxbxbx}" (^path)) ;; {event generate ~:*~a <>}" (^path)) + (let ((self-tkwin (widget-to-tkwin self))) + (assert (plusp self-tkwin)) + (trc "setting up text-widget virtual-event handler" self :tkwin self-tkwin) + (tk-create-event-handler self-tkwin (expt 2 30) (callback entry-modified-handler) self-tkwin)))) + ;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=))) ;;; (with-open-file (ksyms "/0dev/math-paper/tk-keysym.dat" :direction :input) --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/12 08:30:14 1.2 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/13 13:26:43 1.3 @@ -328,7 +328,7 @@ ; appended. ; :bindings (c? (list - (list '(|<1>| "%X %Y") + (list '(<1> "%X %Y") (lambda (self event root-x root-y) (declare (ignorable event root-x root-y)) --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/12 08:30:14 1.7 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/13 13:26:43 1.8 @@ -44,13 +44,14 @@ ;; not recommended by Tcl doc (tcl-do-when-idle (get-callback 'tcl-idle-proc) 42) (tk-app-init *tki*) (tk-togl-init *tki*) - (tk-format-now "proc TraceOP {n1 n2 op} {call-back-event $n1 $op}") (tk-format-now "set tk-events {}") + (tk-format-now "event add <> ") (tk-format-now "proc call-back {w args} {global tk-events; lappend tk-events [concat do-on-command \\\"$w\\\" $args]}") (tk-format-now "proc call-back-event {w e args} {global tk-events; lappend tk-events [concat do-on-event \\\"$w\\\" \\\"$e\\\" $args]}") ;; (tk-format-now "bind . {call-back-event %W :type :time %t}") - + (tk-create-event-handler (tk-main-window *tki*) (expt 2 30) (callback tk-event-proc) 42) + (with-integrity () (setf *tkw* (make-instance root-class))) @@ -88,7 +89,7 @@ do (tk-process-event e)))) (progn (trc nil "tcl-do-one-event-loop sees no events" (get-internal-real-time)) - (sleep *event-loop-delay*))))) + #+nah (sleep *event-loop-delay*))))) (defun tk-process-event (event) (trc nil "tk-process-event >" event *package*) --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/12 08:30:14 1.5 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/13 13:26:43 1.6 @@ -29,10 +29,10 @@ (define-foreign-library Tcl (:darwin (:framework "Tcl")) - (:windows (:or "/tcl/bin/Tcl84.dll"))) + (:windows (:or "/tcl/bin/Tcl85.dll"))) (define-foreign-library Tk (:darwin (:framework "Tk")) - (:windows (:or "/tcl/bin/tk84.dll"))) + (:windows (:or "/tcl/bin/tk85.dll"))) ;; Togl (define-foreign-library Togl @@ -47,7 +47,7 @@ (defmethod translate-from-foreign (value (type (eql 'tcl-retcode))) (unless (eq value (foreign-enum-value 'tcl-retcode-values :tcl-ok)) - (error "*** Tcl error !")) + (error "Tcl error: ~a" (tcl-get-string-result *tki*))) value) ;; --- initialization ---------------------------------------- @@ -129,44 +129,31 @@ (with-foreign-string (filename-cstr filename) (%Tcl_EvalFile interp filename-cstr))) -;; Tcl_Eval +(defcfun ("Tcl_Eval" tcl-eval) tcl-retcode + (interp :pointer) + (script-cstr :string)) -(defcfun ("Tcl_Eval" %Tcl_Eval) tcl-retcode +(defcfun ("Tcl_EvalEx" tcl_evalex) tcl-retcode (interp :pointer) - (script-cstr :pointer)) + (script-cstr :string) + (num-bytes :int) + (flags :int)) + +(defun tcl-eval-ex (i s) + (tcl_evalex i s -1 0)) (defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string (interp :pointer)) (defcfun ("Tk_GetNumMainWindows" tk-get-num-main-windows) :int) +(defcfun ("Tk_MainWindow" tk-main-window) :pointer (interp :pointer)) +(defcfun ("Tk_NameToWindow" tk-name-to-window) :pointer + (interp :pointer) + (pathName :string) + (related-tkwin :pointer)) -(defun Tcl_Eval (interp script) - (with-foreign-string (script-cstr script) - (%Tcl_Eval interp script-cstr))) - -(defcenum tcl-event-flag-values - (:tcl-dont-wait 2) - (:tcl-window-events 4) - (:tcl-file-events 8) - (:tcl-timer-events 16) - (:tcl-idle-events 32) - (:tcl-all-events -3)) - -(defcfun ("Tcl_DoOneEvent" Tcl_DoOneEvent) :int - (flags :int)) - -(defcfun ("Tcl_DoWhenIdle" tcl-do-when-idle) :void - (tcl-idle-proc :pointer) - (client-data :int)) - -(defcallback tcl-idle-proc :void ((client-data :int)) - (unless (c-stopped) - (print (list :idle-proc :client-data client-data)))) - -;; Tk_MainLoop - -(defcfun ("Tk_MainLoop" Tk_MainLoop) :void) - +(defun widget-to-tkwin (self) + (tk-name-to-window *tki* (^path) (tk-main-window *tki*))) ;;; --- Togl (Version 1.7 and above needed!) ----------------------------- @@ -257,7 +244,7 @@ (assert interp) (assert script) - (Tcl_Eval interp script)) + (tcl-eval interp script)) #+testing (defun exec-button () From ktilton at common-lisp.net Sat May 13 13:44:25 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 13 May 2006 09:44:25 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060513134425.0FD7F5F001@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv19613 Added Files: x1.xbm Log Message: --- /project/cells/cvsroot/Celtk/x1.xbm 2006/05/13 13:44:25 NONE +++ /project/cells/cvsroot/Celtk/x1.xbm 2006/05/13 13:44:25 1.1 #define x1_width 626 #define x1_height 428 static char x1_bits[] = { 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x07,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0x1f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0x03,0x80,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0xe0,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x20,0x00,0x00,0x00, 0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x00,0x00, 0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x00,0x00,0x00,0x00,0x80,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0x00, 0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0x00, 0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0x1f,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0x0f, 0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0xff, 0xff,0xff,0xff,0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00, 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0xfc, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x00,0x00,0x00, 0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0x1f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff, 0xff,0x03,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0xff, 0xff,0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0x00,0x00,0x00, 0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x00, 0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0xff, 0xff,0xff,0x3f,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x00,0x00,0x00,0x00,0x00,0xfc,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x00, 0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0x03,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0xff,0xff, 0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0x00,0x00,0xfc,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x00,0x00, 0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0xff,0xff,0xff,0xff,0xff, 0xff,0x3f,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0x07,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff, 0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x00,0x00,0x00,0x00,0xfc, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01, 0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x06,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0x03,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80, 0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0xfc,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0xe0,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0x00, 0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0x1f,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x7c,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x00,0x00,0x00,0xfc,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0xc0,0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00, 0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0x1f,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0x00,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0x0f,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0x01,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0xfe,0x07,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0x1f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0x00,0x00,0xfc,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x80,0xff,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03, 0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0x03,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x07,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0x07,0x00,0x00,0xfc,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0x01,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0xfc,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0xfc,0xff,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0xfc, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00,0xfe,0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, [1858 lines skipped] From ktilton at common-lisp.net Sat May 13 14:36:58 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 13 May 2006 10:36:58 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060513143658.EE680200B@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv26494 Added Files: Gears.lpr lotsa-widgets.lisp tk-events.lisp Log Message: --- /project/cells/cvsroot/Celtk/Gears.lpr 2006/05/13 14:36:58 NONE +++ /project/cells/cvsroot/Celtk/Gears.lpr 2006/05/13 14:36:58 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :GEARS) (define-project :name :gears :modules (list (make-instance 'module :name "gears.lisp")) :projects (list (make-instance 'project-module :name "CELTK") (make-instance 'project-module :name "C:\\0devtools\\cl-opengl\\glu")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :gears :main-form nil :compilation-unit t :verbose nil :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.check-box :cg.choice-list :cg.choose-printer :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate :cg.printing :cg.progress-indicator :cg.project-window :cg.property :cg.radio-button :cg.rich-edit :cg.rich-edit-pane :cg.rich-edit-pane.clipboard :cg.rich-edit-pane.printing :cg.sample-file-menu :cg.scaling-stream :cg.scroll-bar :cg.scroll-bar-mixin :cg.selected-object :cg.shortcut-menu :cg.static-text :cg.status-bar :cg.string-dialog :cg.tab-control :cg.template-string :cg.text-edit-pane :cg.text-edit-pane.file-io :cg.text-edit-pane.mark :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray :cg.up-down-control :cg.utility-dialog :cg.web-browser :cg.web-browser.dde :cg.wrap-string :cg.yes-no-list :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:top-level :debugger) :build-flags '(:allow-runtime-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+M +t \"Console for Debugging\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'gears::gears :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/05/13 14:36:58 NONE +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/05/13 14:36:58 1.1 (in-package :celtk-user) (defmodel lotsa-widgets (window) () (:default-initargs :kids (c? (the-kids (demo-all-menubar) (mk-row (:packing (c?pack-self)) (mk-label :text "aaa" :image-files (list (list 'kt (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "Celtk") :name "kt69" :type "gif"))) :height 200 :width 300 :image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt))) (assorted-canvas-items) (mk-stack () (mk-text-widget :id :my-text :md-value (c?n "hello, world") :height 8 :width 25) (spin-package-with-symbols)) (mk-stack () (mk-row (:id :radio-ny :selection (c-in 'yes)) (mk-radiobutton-ex ("yes" 'yes)) (mk-radiobutton-ex ("no" 'no)) (mk-label :text (c? (string (selection (upper self selector)))))) (mk-row () (mk-checkbutton :id :check-me :text "Check Me" :md-value (c-in t)) (mk-label :text (c? (if (fm^v :check-me) "checked" "unchecked")))) (mk-row () (mk-button-ex ("Time now?" (setf (fm^v :push-time) (get-universal-time)))) (mk-label :text (c? (time-of-day (^md-value))) :id :push-time :md-value (c-in (get-universal-time)))) (style-by-edit-menu) (style-by-widgets) (mk-row (:layout-anchor 'sw) (mk-entry :id :enter-me) (mk-label :text (c? (conc$ "echo " (fm^v :enter-me)))))) (duelling-scrolled-lists) ))))) (defun style-by-edit-menu () (mk-row ("Style by Edit Menu") (mk-label :text "Four score and seven years ago today" :wraplength 600 :tkfont (c? (list (selection (fm^ :app-font-face)) (selection (fm^ :app-font-size)) (if (fm^v :app-font-italic) 'italic 'roman) (if (fm^v :app-font-bold) 'bold 'normal)))))) (defun spin-package-with-symbols () (mk-stack () (mk-spinbox :id :spin-pkg :md-value (cells::c?n "cells") :tk-values (mapcar 'down$ (sort (mapcar 'package-name (list-all-packages)) 'string>))) (mk-scrolled-list :id :spinpkg-sym-list :list-height 6 :list-item-keys (c? (let* ((spinner (fm^ :spin-pkg)) (item (when spinner (md-value spinner))) (pkg (find-package (string-upcase item)))) (when pkg (loop for sym being the symbols in pkg for n below 25 counting sym into symct collecting sym into syms finally (trc "syms found !!!" symct) (return syms))))) :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* :md-value sym :item-text (down$ (symbol-name sym))))))) (defun duelling-scrolled-lists () (mk-row () (mk-scrolled-list :id :pkg-list :selection (c-in (find-package "ASDF")) :list-height 6 :list-item-keys (list-all-packages) :list-item-factory (lambda (pkg) (make-instance 'listbox-item :fm-parent *parent* :md-value pkg :item-text (down$ (package-name pkg))))) (mk-scrolled-list :id :pkg-sym-list :list-height 6 :list-item-keys (c? (bwhen (pkg (selection (fm^ :pkg-list))) (loop for sym being the present-symbols in pkg for n below 25 collecting sym))) :list-item-factory (lambda (sym) (make-instance 'listbox-item :md-value sym :fm-parent *parent* :item-text (down$ (symbol-name sym))))))) (defun assorted-canvas-items () (mk-canvas :height 350 :kids (c? (the-kids (mk-bitmap :coords (list 140 140) :bitmap "@\\0dev\\Celtk\\x1.xbm" #+not "@\\temp\\gsl.xbm") (mk-rectangle :coords (list 10 10 100 60) :tk-fill "red") (mk-text-item :coords (list 100 80) :text "i am an item" :tk-fill 'blue) (mk-arc :coords (list 10 100 100 160) :start 45 :tk-fill "orange") (mk-line :coords (list 250 10 300 40 250 70 400 100) :width 8 :smooth 'bezier :joinstyle 'miter :arrow 'both :tk-fill 'purple) (mk-oval :coords (list 10 200 100 260) :tk-fill "yellow") (mk-polygon :coords (list 250 210 300 220 340 200 260 180) :width 4 :tk-fill 'green :smooth 'bezier :joinstyle 'miter) (mk-arc :coords (list 10 300 100 360) :start 45 :tk-fill "white") )))) (defun style-by-widgets () (mk-stack ("Style by Widgets" :id :widstyle) (mk-row (:id :stywid :packing-side 'left :layout-anchor 'sw) (mk-popup-menubutton :id :font-face :initial-value (c? (second (^entry-values))) :entry-values (c? (eko ("popup ff") (subseq (tk-eval-list "font families") 4 10)))) (mk-scale :id :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, our fathers broguht forth on this continent a new nation..." :wraplength 200 :justify 'left :tkfont (c? (list (selection (fm^ :font-face)) (md-value (fm^ :font-size))))))) (defun demo-all-menubar () (mk-menubar :id 'mbar :kids (c? (the-kids (mk-menu-entry-cascade :id 'file :label "File" :kids (c? (the-kids (mk-menu :id 'filemenu :kids (c? (the-kids (mk-menu-entry-command :label "New" :command "exit") (mk-menu-entry-command :label "Open" :command "tk_getOpenFile") (mk-menu-entry-command :label "Close" :command "exit") (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" :state (c? (if t ;; (md-value (fm^ :check-me)) 'normal 'disabled)) :command "exit"))))))) (mk-menu-entry-cascade :id 'editcascade :label "Edit" :kids (c? (the-kids (mk-menu :id 'editmenu :kids (c? (the-kids (mk-menu-entry-command :label "Undo" :on-command (lambda (self) (trc "edit menu undo" self))) (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-radio-group :id :app-font-face :selection (c-in "courier") :kids (c? (the-kids (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 :id :app-font-size :label "Font Size" :menu (c? (path (kid1 self))) :selection (c-in 12) :kids (c? (the-kids (mk-menu :id :fsztoff :tearoff 1 :kids (c? (the-kids (loop for (label value) in '(("9" 9)("12" 12)("14" 14)) collecting (mk-menu-entry-radiobutton :label label :value value)))))))) (mk-menu-entry-separator) (mk-menu-entry-checkbutton :id :app-font-italic :label "Italic") (mk-menu-entry-checkbutton :id :app-font-bold :label "Bold" :md-value (c-in t)))))))))))) --- /project/cells/cvsroot/Celtk/tk-events.lisp 2006/05/13 14:36:58 NONE +++ /project/cells/cvsroot/Celtk/tk-events.lisp 2006/05/13 14:36:58 1.1 (in-package :celtk) #| typedef struct { int type; unsigned long serial; /* # of last request processed by server */ Bool send_event; /* True if this came from a SendEvent request */ Display *display; /* Display the event was read from */ Window event; /* Window on which event was requested. */ Window root; /* root window that the event occured on */ Window subwindow; /* child window */ Time time; /* milliseconds */ int x, y; /* pointer x, y coordinates in event window */ int x_root, y_root; /* coordinates relative to root */ unsigned int state; /* key or button mask */ Tk_Uid name; /* Name of virtual event. */ Bool same_screen; /* same screen flag */ Tcl_Obj *user_data; /* application-specific data reference; Tk will * decrement the reference count *once* when it * has finished processing the event. */ } XVirtualEvent; |# (defctype Window-ptr :unsigned-long) (defctype Time :unsigned-long) (defctype Tk_Uid :string) (defcstruct x-virtual-event (type :int) (serial :unsigned-long) (send-event :boolean) (display :pointer) (event-window Window-ptr) (root-window Window-ptr) (sub-window Window-ptr) (time Time) (x :int) (y :int) (x-root :int) (y-root :int) (state :unsigned-int) (name Tk_Uid) (same-screen :boolean) (user-data :string) ) (defcenum tcl-event-flag-values (:tcl-dont-wait 2) (:tcl-window-events 4) (:tcl-file-events 8) (:tcl-timer-events 16) (:tcl-idle-events 32) (:tcl-all-events -3)) (defcfun ("Tcl_DoOneEvent" Tcl_DoOneEvent) :int (flags :int)) (defcfun ("Tcl_DoWhenIdle" tcl-do-when-idle) :void (tcl-idle-proc :pointer) (client-data :int)) (defcallback tcl-idle-proc :void ((client-data :int)) (unless (c-stopped) (print (list :idle-proc :client-data client-data)))) ;; Tk_MainLoop (defcfun ("Tk_MainLoop" Tk_MainLoop) :void) (defcfun ("Tk_CreateEventHandler" tk-create-event-handler) :void (tkwin :pointer) (mask :int) (proc :pointer) (client-data :int)) (defcallback tk-event-proc :void ((client-data :int)(XEvent :pointer)) (trc "yowza tk-event-proc" client-data XEvent (tk-event-type (mem-aref XEvent :int)) [42 lines skipped] From ktilton at common-lisp.net Mon May 15 09:00:56 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 15 May 2006 05:00:56 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060515090056.8BE192009@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv18787 Modified Files: togl.lisp Added Files: tk-structs.lisp Log Message: --- /project/cells/cvsroot/Celtk/togl.lisp 2006/05/15 05:15:37 1.4 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/05/15 09:00:47 1.5 @@ -130,8 +130,7 @@ (def-togl-callback display ()) (def-togl-callback reshape ()) (def-togl-callback destroy ()) -(def-togl-callback timer () - (check-faux-events)) +(def-togl-callback timer ()) (defmethod make-tk-instance ((self togl)) (with-integrity (:client `(:make-tk ,self)) --- /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/05/15 09:00:48 NONE +++ /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/05/15 09:00:48 1.1 (in-package :celtk) (defctype Window :unsigned-long) ;; The XWindow pointer stored in the tkwin record (defctype Time :unsigned-long) (defctype Tk_Uid :string) (defcstruct tk-fake-win "Used by macros to peek at tkwins (why use a fake window definition?)" (display :pointer) (dummy1 :pointer) (screen-num :int) (visual :pointer) (depth :int) (window Window) (dummy2 :pointer) (dummy3 :pointer) (parent-ptr Window) (dummy4 :pointer) (dummy5 :pointer) (pathName :string) ;;; Tk_Uid nameUid; ;;; Tk_Uid classUid; ;;; XWindowChanges changes; ;;; unsigned int dummy6; /* dirtyChanges */ ;;; XSetWindowAttributes atts; ;;; unsigned long dummy7; /* dirtyAtts */ ;;; unsigned int flags; ;;; char *dummy8; /* handlerList */ ;;;#ifdef TK_USE_INPUT_METHODS ;;; XIC dummy9; /* inputContext */ ;;;#endif /* TK_USE_INPUT_METHODS */ ;;; ClientData *dummy10; /* tagPtr */ ;;; int dummy11; /* numTags */ ;;; int dummy12; /* optionLevel */ ;;; char *dummy13; /* selHandlerList */ ;;; char *dummy14; /* geomMgrPtr */ ;;; ClientData dummy15; /* geomData */ ;;; int reqWidth, reqHeight; ;;; int internalBorderLeft; ;;; char *dummy16; /* wmInfoPtr */ ;;; char *dummy17; /* classProcPtr */ ;;; ClientData dummy18; /* instanceData */ ;;; char *dummy19; /* privatePtr */ ;;; int internalBorderRight; ;;; int internalBorderTop; ;;; int internalBorderBottom; ;;; int minReqWidth; ;;; int minReqHeight; ) (defun tkwin-pathname (tkwin) (foreign-slot-value tkwin 'tk-fake-win 'pathname)) (defun tkwin-window (tkwin) "Get the (different!) XWindow pointer from the tkwin data structure. Note that the Xwindow structure is not allocated straight away, not until (I guess) the XWindow server has gotten involved with the widget." (foreign-slot-value tkwin 'tk-fake-win 'window)) #| typedef struct { int type; unsigned long serial; /* # of last request processed by server */ Bool send_event; /* True if this came from a SendEvent request */ Display *display; /* Display the event was read from */ Window event; /* Window on which event was requested. */ Window root; /* root window that the event occured on */ Window subwindow; /* child window */ Time time; /* milliseconds */ int x, y; /* pointer x, y coordinates in event window */ int x_root, y_root; /* coordinates relative to root */ unsigned int state; /* key or button mask */ Tk_Uid name; /* Name of virtual event. */ Bool same_screen; /* same screen flag */ Tcl_Obj *user_data; /* application-specific data reference; Tk will * decrement the reference count *once* when it * has finished processing the event. */ } XVirtualEvent; |# (defcstruct x-virtual-event "Virtual event, OK?" (type :int) (serial :unsigned-long) (send-event :boolean) (display :pointer) (event-window Window) (root-window Window) (sub-window Window) (time Time) (x :int) (y :int) (x-root :int) (y-root :int) (state :unsigned-int) (name :string) (same-screen :boolean) (user-data :pointer) ) (defmacro xsv (slot-name xptr) `(foreign-slot-value ,xptr 'X-Virtual-Event ',slot-name)) (defun xevent-type (xe) (tk-event-type (xsv type xe))) (defcenum tcl-event-flag-values (:tcl-dont-wait 2) (:tcl-window-events 4) (:tcl-file-events 8) (:tcl-timer-events 16) (:tcl-idle-events 32) (:tcl-all-events -3)) (defcenum tcl-variable-related-flag "Flags passed to getvar, setvar, tracevar, etc" (:TCL_GLOBAL_ONLY 1) (:TCL_NAMESPACE_ONLY 2) (:TCL_APPEND_VALUE 4) (:TCL_LIST_ELEMENT 8) (:TCL_TRACE_READS #x10) (:TCL_TRACE_WRITES #x20) (:TCL_TRACE_UNSETS #x40) (:TCL_TRACE_DESTROYED #x80) (:TCL_INTERP_DESTROYED #x100) (:TCL_LEAVE_ERR_MSG #x200) (:TCL_TRACE_ARRAY #x800) ;; Required to support old variable/vdelete/vinfo traces */ (:TCL_TRACE_OLD_STYLE #x1000) ;; Indicate the semantics of the result of a trace */ (:TCL_TRACE_RESULT_DYNAMIC #x8000) (:TCL_TRACE_RESULT_OBJECT #x10000)) (defun var-flags (&rest kws) (apply '+ (loop for kw in kws collecting (foreign-enum-value 'tcl-variable-related-flag kw)))) From ktilton at common-lisp.net Tue May 16 02:52:22 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 15 May 2006 22:52:22 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060516025222.014516401B@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27500 Modified Files: Celtk.asd Celtk.lisp demos.lisp entry.lisp ltktest-ci.lisp multichoice.lisp run.lisp timer.lisp tk-interp.lisp widget.lisp Log Message: Celtk2 alpha release --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/12 08:30:13 1.6 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/16 02:52:22 1.7 @@ -15,7 +15,9 @@ :depends-on (:cells :cl-opengl :cl-glu) :serial t :components ((:file "Celtk") + (:file "tk-structs") (:file "tk-interp") + (:file "tk-events") (:file "tk-object") (:file "widget") (:file "font") @@ -35,6 +37,6 @@ (:file "frame") (:file "togl") (:file "run") - (:file "demos") (:file "ltktest-ci") - (:file "gears"))) + (:file "lotsa-widgets") + (:file "demos"))) --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/15 05:15:37 1.20 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/16 02:52:22 1.21 @@ -24,8 +24,8 @@ (:nicknames "CTK") (:use :common-lisp :utils-kt :cells :cffi) (:export - #:<1> - #:title$ #:pop-up #:event-root-x #:event-root-y + #:<1> #:tk-event-type #:xsv #:name #:x-root #:y-root + #:title$ #:pop-up #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget #:mk-panedwindow #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label @@ -47,7 +47,7 @@ #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps #:^widget-menu #:widget-menu #:tk-format-now #:coords #:^coords #:tk-translate-keysym - #:do-on-event #:*tkw*)) + #:*tkw*)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/15 05:15:37 1.14 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/16 02:52:22 1.15 @@ -25,10 +25,10 @@ (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window - ;; 'one-button-window - ;;'ltktest-cells-inside - ;; OK 'menu-button-test - ;; OK 'spinbox-test + ;; true tester: 'one-button-window + ;; Not so good: 'ltktest-cells-inside + ;; 'menu-button-test + ;; 'spinbox-test 'lotsa-widgets ;; Now in Gears project 'gears-demo )) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/15 05:15:37 1.6 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/16 02:52:22 1.7 @@ -46,18 +46,27 @@ :id (gentemp "ENT") :xscrollcommand (c-in nil) :textvariable (c? (intern (^path))) - :virtual-event-handlers (c? (list `(tracewrite ,(lambda (self event client-data) - (declare (ignore event client-data)) - (let ((new-value (tcl-get-var *tki* (^path) - (var-flags :TCL_GLOBAL_ONLY :TCL_LEAVE_ERR_MSG)))) - (unless (string= new-value (^md-value)) - (setf (^md-value) new-value))))))) + :event-handler (lambda (self xe) + (TRC nil "widget-event-handler" self (xsv type xe) ) + (case (tk-event-type (xsv type xe)) + (:virtualevent + (trc nil "v/e" (xsv name xe)) + (case (read-from-string (string-upcase (xsv name xe))) + (trace + (TRC nil "entry e/h trace" self (when (plusp (xsv user-data xe)) + (tcl-get-string (xsv user-data xe)))) + ;; assuming write op, but data field shows that + (let ((new-value (tcl-get-var *tki* (^path) + (var-flags :TCL_NAMESPACE_ONLY)))) + (unless (string= new-value (^md-value)) + (setf (^md-value) new-value)))))))) :md-value (c-in ""))) (defmethod md-awaken :after ((self entry)) ;; move this to a traces slot on widget (with-integrity (:client `(:trace ,self)) - (tk-format-now "trace add variable ~a write TraceOP" (^path)))) + (tk-format-now "trace add variable ~a write TraceOP" (^path)) + )) ;;; /// this next replicates the handling of tk-mirror-variable because ;;; those leverage the COMMAND mechanism, which entry lacks @@ -90,9 +99,14 @@ :yscrollcommand (c-in nil) :modified (c-in nil) :borderwidth (c? (if (^modified) 8 2)) - :virtual-event-handlers (c? (list `(modified ,(lambda (self event client-data) - (eko ("<> !!TK value for text-widget" self event client-data) - (setf (^modified) t)))))))) + :event-handler (lambda (self xe) + (case (tk-event-type (xsv type xe)) + (:virtualevent + (case (read-from-string (string-upcase (xsv name xe))) + (modified + (eko (nil "<> !!TK value for text-widget" self) + (setf (^modified) t))))))))) + ;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=))) ;;; (with-open-file (ksyms "/0dev/math-paper/tk-keysym.dat" :direction :input) --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/15 05:15:37 1.4 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/16 02:52:22 1.5 @@ -327,22 +327,13 @@ ; This also simplifies Celtk since it just has to pass the Tk code along with "grid " ; appended. ; - :event-handlers nil #+not (c? (list - (list '(<1> "%X %Y") - (lambda (self event root-x root-y) - (declare (ignorable event root-x root-y)) - - ; - ; Stolen from the original. It means "when the left button is - ; pressed on this widget, popup this menu where the button was pressed" - ; The only difference is that here we get to specify this along with - ; the rest of the configuration of this instance, whereas in the original - ; the enabling code was just "out there" in a long sequence of other - ; imperatives setting up this widget and that. ie, It is nice having - ; everything about X collected in one place. In case you are wondering, - ; a standard event-handler is created for any widget with handlers. - ; - (pop-up (^widget-menu :bkg-pop) root-x root-y))))) + :event-handler (c? (lambda (self xe) + (case (tk-event-type (xsv type xe)) + (:virtualevent + (trc "canvas virtual" (xsv name xe))) + (:buttonpress + (TRC "canvas buttonpress" self (xsv x-root xe)(xsv y-root xe)) + (pop-up (^widget-menu :bkg-pop) (xsv x-root xe) (xsv y-root xe)))))) :menus (c? (the-kids ; --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/15 05:15:37 1.5 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/16 02:52:22 1.6 @@ -69,16 +69,14 @@ :id (gentemp "LBX") :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) - :virtual-event-handlers - (c? (assert (selector self)) - (when (selector self) ;; if not? Figure out how listbox tracks own selection - (list `(ListboxSelect ,(lambda (self event client-data) - (declare (ignore client-data event)) - (trc "NEW listbox callback firing" self ) - (let ((selection (parse-integer (tk-eval "~a curselection" (^path))))) - (trc "NEW listbox selection" self selection) - (setf (selection (selector self)) - (md-value (elt (^kids) selection))))))))))) + :event-handler (lambda (self xe) + (case (tk-event-type (xsv type xe)) + (:virtualevent + (case (read-from-string (string-upcase (xsv name xe))) + (ListboxSelect + (let ((selection (parse-integer (tk-eval "~a curselection" (^path))))) + (setf (selection (selector self)) + (md-value (elt (^kids) selection))))))))))) (defmodel listbox-item (tk-object) ((item-text :initarg :item-text :accessor item-text --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/15 05:15:37 1.9 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/16 02:52:22 1.10 @@ -38,7 +38,7 @@ ;; not recommended by Tcl doc (tcl-do-when-idle (get-callback 'tcl-idle-proc) 42) (tk-app-init *tki*) (tk-togl-init *tki*) - (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <> -data {$n1 $op}}") + (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <> -data $op}") (with-integrity () (setf *tkw* (make-instance root-class)) @@ -48,9 +48,7 @@ (tk-format `(:fini) "wm deiconify .") (tk-format-now "bind . {destroy .}") - ;; one or the other of... - (tcl-do-one-event-loop)#+either-or (Tk_MainLoop) - ) + (tcl-do-one-event-loop)) (defcallback main-window-proc :void ((client-data :int)(xe :pointer)) (declare (ignore client-data)) @@ -73,28 +71,11 @@ (defun tcl-do-one-event-loop () (loop while (plusp (tk-get-num-main-windows)) do (loop until (zerop (Tcl_DoOneEvent 2))) ;; 2== TCL_DONT_WAIT - (sleep *event-loop-delay*) + (sleep *event-loop-delay*) ;; give the IDE a few cycles finally ;;(tk-eval "exit") - (tcl-delete-interp *tki*) + (tcl-delete-interp *tki*) ;; probably unnecessary (setf *tki* nil))) - - -(defmethod do-on-event (self event-type$ &rest args &aux (event-type (intern event-type$ :ctk))) - (assert (symbolp event-type)) - (trc nil "on event!!!" self event-type args) - (bif (ecb (gethash event-type (event-handlers self))) - (apply ecb self event-type args) - (progn - (trc "no event handlers for" self event-type (symbol-package event-type)) - (loop for k being the hash-keys of (event-handlers self) - do (trc "known key" k (symbol-package k)))))) - -(defmethod do-on-command (self &rest args) - (bif (ocb (on-command self)) - (apply ocb self args) - (trc "weird, no on-command value" self args))) - (defun test-window (root-class) "nails existing window as a convenience in iterative development" (declare (ignorable root-class)) --- /project/cells/cvsroot/Celtk/timer.lisp 2006/05/15 05:15:37 1.4 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/05/16 02:52:22 1.5 @@ -52,7 +52,7 @@ (export '(repeat ^repeat))) (defmodel timer () - ((id :cell nil :initarg :id :accessor id :initform (gentemp "AFTER") + ((id :cell nil :initarg :id :accessor id :initform :anon :documentation "A debugging aid") (tag :cell nil :initarg :tag :accessor tag :initform :anon :documentation "A debugging aid") @@ -99,8 +99,9 @@ (setf (id self) (set-timer self (^delay))))))))))) (defun set-timer (self time) - (setf (gethash (id self) (dictionary *tkw*)) self) ;; redundant but fast - (tk-eval "after ~a {event generate . <> -data ~a}" time (id self))) + (let ((lookup-id (gentemp "AFTER"))) + (setf (gethash lookup-id (dictionary *tkw*)) self) + (tk-eval "after ~a {event generate . <> -data ~a}" time lookup-id))) (defobserver timers ((self tk-object) new-value old-value) (dolist (k (set-difference old-value new-value)) --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/15 05:15:37 1.7 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/16 02:52:22 1.8 @@ -160,8 +160,6 @@ (pathName :string) (related-tkwin :pointer)) - - ;;; --- Togl (Version 1.7 and above needed!) ----------------------------- @@ -253,39 +251,7 @@ (tcl-eval interp script)) -#+testing -(defun exec-button () - (tk-interp-init-ensure) - (let ((interp (Tcl_CreateInterp))) - (tk-app-init interp) - (togl_init interp) - #+works (progn - (eval-script interp "button .b1 -text Hello") - (eval-script interp "pack .b1")) - (eval-script interp "togl .t1 -height 100 -height 100 -ident t1") - ;;(eval-script interp "puts \"Hello puts\"") - ) - (Tk_MainLoop)) - -#+testing -(defun test-result () - (tk-interp-init-ensure) - (let ((*tki* (Tcl_CreateInterp))) - (tk-app-init *tki*) - #+wait (eval-script *tki* "font families") - #+ok (eval-script *tki* "tk scaling") - #+ok (progn - (eval-script *tki* "set xyz 42") - (eval-script *tki* "set xyz")) - ;;(trc "string result:" (tcl-get-string-result interp)) - (trc "tk-eval result:" (tk-eval "tk scaling")) - (trc "tk-eval-list result:" (tk-eval-list "font families")))) - -;;;(defun exec-main () -;;; (main "\\0devtools\\frgotk\\psu-rc-gui.tcl")) -;;; -;;;#+test -;;;(exec-main) + ;;; Togl stuff --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/15 05:15:37 1.5 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/16 02:52:22 1.6 @@ -22,6 +22,31 @@ (in-package :Celtk) +;;; --- widget tkwin window glue ----------------------- + +(defun widget-to-tkwin (self) + (tk-name-to-window *tki* (path self) (tk-main-window *tki*))) + +(defun xwin-register (self) + (when (tkwin self) + (let ((xwin (tkwin-window (tkwin self)))) + (when (plusp xwin) + (setf (gethash xwin (xwins .tkw)) self) + xwin)))) + +(defun tkwin-widget (tkwin) + (gethash tkwin (tkwins *tkw*))) + +(defun xwin-widget (xwin) ;; assignment of xwin is deferred so...all this BS.. + (when (plusp xwin) + (or (gethash xwin (xwins *tkw*)) + (loop for self being the hash-values of (tkwins *tkw*) + using (hash-key tkwin) + unless (xwin self) ;; we woulda found it by now + do (when (eql xwin (xwin-register self)) + (return-from xwin-widget self)) + finally (trc "xwin-widget > no widget for xwin " xwin))))) + ;;; --- widget ----------------------------------------- (defmodel widget (family tk-object) @@ -35,10 +60,7 @@ (packing :reader packing :initarg :packing :initform nil) (gridding :reader gridding :initarg :gridding :initform nil) (enabled :reader enabled :initarg :enabled :initform t) - (event-handlers :reader event-handlers :initarg :event-handlers :initform nil) - (virtual-event-handlers :reader virtual-event-handlers :initarg :virtual-event-handlers :initform nil) - (needs-event-handler-p :reader needs-event-handler-p - :initform (c? (or (^event-handlers)(^virtual-event-handlers)))) + (event-handler :reader event-handler :initarg :event-handler :initform nil) (menus :reader menus :initarg :menus :initform nil :documentation "An assoc of an arbitrary key and the associated CLOS menu instances (not their tk ids)") (image-files :reader image-files :initarg :image-files :initform nil) @@ -48,26 +70,12 @@ (:default-initargs :id (gentemp "W"))) -(defobserver needs-event-handler-p () - (when new-value +(defobserver event-handler () + (when new-value ;; \\\ work out how to unregister any old value (with-integrity (:client `(:post-make-tk ,self)) + (trc "creating event handler for" self) (tk-create-event-handler-ex self 'widget-event-handler -1)))) ;; // make this -1 more efficient -(defun widget-to-tkwin (self) - (tk-name-to-window *tki* (path self) (tk-main-window *tki*))) - -(defcallback widget-event-handler :void ((client-data :int)(xe :pointer)) - (trc "bingo" (tk-event-type (xsv type xe))) - (case (tk-event-type (xsv type xe)) - (:virtualevent - (let* ((self (xwin-widget (xsv event-window xe))) - (name (read-from-string (string-upcase (xsv name xe)))) - (entry (assoc name (^virtual-event-handlers)))) - (TRC "widget-event-handler" self name) - (if entry - (funcall (second entry) self xe client-data) - (trc "no handler for" name self)))))) - (defun tk-create-event-handler-ex (widget callback-name &rest masks) (let ((self-tkwin (widget-to-tkwin widget))) (assert (plusp self-tkwin)) @@ -77,6 +85,13 @@ (get-callback callback-name) self-tkwin))) +(defcallback widget-event-handler :void ((client-data :int)(xe :pointer)) + (let ((self (tkwin-widget client-data))) + (assert self () "widget-event-handler > no widget for tkwin ~a" client-data) + (bif (h (^event-handler)) + (funcall h self xe) + (trc "widget-event-handler > warning: no handler in instance requesting event handling" self)))) + (defclass commander () () (:default-initargs @@ -112,26 +127,6 @@ (tk-name-to-window *tki* (^path) (tk-main-window *tki*)))))) (setf (gethash tkwin (tkwins .tkw)) self))) -(defun xwin-register (self) - (when (tkwin self) - (let ((xwin (tkwin-window (tkwin self)))) - (when (plusp xwin) - (setf (gethash xwin (xwins .tkw)) self) - xwin)))) - -(defun tkwin-widget (tkwin) - (gethash tkwin (tkwins *tkw*))) - -(defun xwin-widget (xwin) ;; assignment of xwin is deferred so...all this BS.. - (when (plusp xwin) - (or (gethash xwin (xwins *tkw*)) - (loop for self being the hash-values of (tkwins *tkw*) - using (hash-key tkwin) - unless (xwin self) ;; we woulda found it by now - do (when (eql xwin (xwin-register self)) - (return-from xwin-widget self)) - finally (trc "xwin-widget > no widget for xwin " xwin))))) - (defmethod make-tk-instance ((self widget)) (setf (gethash (^path) (dictionary .tkw)) self) (trc nil "mktki" self (^path)) @@ -139,6 +134,10 @@ (when (tk-class self) (tk-format-now "~(~a~) ~a ~{~(~a~) ~a~^ ~}" ;; call to this GF now integrity-wrapped by caller (tk-class self) (path self)(tk-configurations self))) + #+tryinafter (tkwin-register self))) + +(defmethod make-tk-instance :after ((self widget)) + (with-integrity (:client `(:post-make-tk ,self)) (tkwin-register self))) (defmethod tk-configure ((self widget) option value) From ktilton at common-lisp.net Tue May 16 02:53:12 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 15 May 2006 22:53:12 -0400 (EDT) Subject: [cells-cvs] CVS gears Message-ID: <20060516025312.BCA826401C@common-lisp.net> Update of /project/cells/cvsroot/gears In directory clnet:/tmp/cvs-serv27612 Modified Files: gears.lisp Log Message: Celtk2 alpha release --- /project/cells/cvsroot/gears/gears.lisp 2006/05/12 08:33:46 1.1 +++ /project/cells/cvsroot/gears/gears.lisp 2006/05/16 02:53:12 1.2 @@ -47,33 +47,29 @@ :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" - :bindings (c? (list - (list '(ctk::|<1>| "%X %Y") - (lambda (self event root-x root-y) - (declare (ignorable self event root-x root-y)) - (RotStart self root-x root-y) - 0)) - (list '(ctk::|| "%X %Y") - (lambda (self event root-x root-y) - (declare (ignore event)) - (RotMove self root-x root-y) - 0)))))))))) + :event-handler (c? (lambda (self xe) + (case (tk-event-type (xsv type xe)) + (:virtualevent + (trc "canvas virtual" (xsv name xe))) + (:buttonpress + (RotStart self (xsv x-root xe) (xsv y-root xe))) + (:motionnotify + (RotMove self (xsv x-root xe) (xsv y-root xe))) + (:buttonrelease + (setf *startx* nil))))))))))) (defun RotStart (self x y) - ;(trc "Rotstart!!!" self x y) (setf *startx* x) (setf *starty* y) (setf *xangle0* (rotx self)) (setf *yangle0* (roty self))) (defun RotMove (self x y) - ;(trc "RotMove!!!!" self x y) - (setf *xangle* (+ *xangle0* (- x *startx*))) - (setf *yangle* (+ *yangle0* (- y *starty*))) - (setf (rotx self) *xangle*) - (assert (eql *xangle* (rotx self))) - (setf (roty self) *yangle*) - (trc nil "RotMove x y" *xangle* *yangle*)) + (when *startx* + (setf *xangle* (+ *xangle0* (- x *startx*))) + (setf *yangle* (+ *yangle0* (- y *starty*))) + (setf (rotx self) *xangle*) + (setf (roty self) *yangle*))) (defconstant +pif+ (coerce pi 'single-float)) @@ -138,6 +134,7 @@ (gl:load-identity) (gl:translate 0 0 -30)))) + (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo)))) (declare (ignorable scale)) From ktilton at common-lisp.net Tue May 16 16:44:18 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 16 May 2006 12:44:18 -0400 (EDT) Subject: [cells-cvs] CVS Celtk/gears Message-ID: <20060516164418.E10257800A@common-lisp.net> Update of /project/cells/cvsroot/Celtk/gears In directory clnet:/tmp/cvs-serv17766/gears Log Message: Directory /project/cells/cvsroot/Celtk/gears added to the repository From ktilton at common-lisp.net Tue May 16 16:45:00 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 16 May 2006 12:45:00 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060516164500.2155D13006@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv17807 Removed Files: gears.lisp Log Message: From ktilton at common-lisp.net Tue May 16 21:17:16 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 16 May 2006 17:17:16 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060516211716.15AEF64010@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv26224 Modified Files: Celtk.lisp demos.lisp load.lisp lotsa-widgets.lisp menu.lisp multichoice.lisp tk-interp.lisp widget.lisp Log Message: --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/16 02:52:22 1.21 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/16 21:17:15 1.22 @@ -62,23 +62,22 @@ (define-symbol-macro .tkw (nearest self window)) + ; --- tk-format --- talking to wish/Tk ----------------------------------------------------- +(defconstant +tk-client-task-priority+ + '(:delete :forget :destroy + :pre-make-tk :make-tk :make-tk-menubutton :post-make-tk + :variable :bind :selection :trace :configure :grid :pack :fini)) + (defun tk-user-queue-sort (task1 task2) "Intended for use as user queue sorter, to make Tk happy by giving it stuff in the order it needs to work properly." - (let ((priority '(:delete :forget :destroy - :pre-make-tk :make-tk :make-tk-menubutton :post-make-tk - :variable :bind :selection :trace :configure :grid :pack :fini))) - (destructuring-bind (type1 self1 &rest dbg) task1 + (destructuring-bind (type1 self1 &rest dbg) task1 (declare (ignorable dbg)) - (assert type1) - (assert (find type1 priority) () "unknown task type ~a in task ~a" type1 task1) (destructuring-bind (type2 self2 &rest dbg) task2 (declare (ignorable dbg)) - (assert type2) - (assert (find type2 priority) () "unknown task type ~a in task ~a" type2 task2) - (let ((p1 (position type1 priority)) - (p2 (position type2 priority))) + (let ((p1 (position type1 +tk-client-task-priority+)) + (p2 (position type2 +tk-client-task-priority+))) (cond ((< p1 p2) t) ((< p2 p1) nil) @@ -86,12 +85,14 @@ (:make-tk (fm-ordered-p self1 self2)) (:pack - (fm-ascendant-p self2 self1)))))))))) + (fm-ascendant-p self2 self1))))))))) (defun tk-user-queue-handler (user-q) - #+shh (loop for (defer-info . nil) in (sort (copy-list (fifo-data user-q)) 'tk-user-queue-sort :key 'car) - do (trc "user-q-handler sees" defer-info)) + (loop for (defer-info . nil) in (fifo-data user-q) + unless (find (car defer-info) +tk-client-task-priority+) + do (error "unknown tk client task type ~a in task: ~a " (car defer-info) defer-info)) + (loop for (nil #+not defer-info . task) in (prog1 (sort (fifo-data user-q) 'tk-user-queue-sort :key 'car) (fifo-clear user-q)) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/16 02:52:22 1.15 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/16 21:17:15 1.16 @@ -137,8 +137,7 @@ for n below 5 counting sym into symct collecting sym into syms - finally (trc "syms found !!!" symct) - (return syms))))) + finally (return syms))))) :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* @@ -154,7 +153,7 @@ (mk-popup-menubutton :id :font-face :initial-value (c? (second (^entry-values))) - :entry-values (c? (eko ("popup ff") (subseq (tk-eval-list "font families") 4 10)))) + :entry-values (c? (subseq (tk-eval-list "font families") 4 10))) (mk-label :text "Four score and seven years ago today, our fathers broguht forth on this continent a new nation..." :wraplength 200 :justify 'left --- /project/cells/cvsroot/Celtk/load.lisp 2006/05/12 08:30:14 1.5 +++ /project/cells/cvsroot/Celtk/load.lisp 2006/05/16 21:17:15 1.6 @@ -1,9 +1,26 @@ +;;; +;;; +;;; First, grab these: +;;; +;;; http://common-lisp.net/cgi-bin/viewcvs.cgi/cells/?root=cells +;;; Celtk: http://common-lisp.net/cgi-bin/viewcvs.cgi/Celtk/?root=cells +;;; CFFI: http://common-lisp.net/project/cffi/releases/cffi_0.9.1.tar.gz +;;; cl-opengl: http://common-lisp.net/cgi-bin/darcsweb/darcsweb.cgi?r=cl-opencl%20cl-opengl;a=summary +;; +;;; At the bottom of any of those pages look for a "Download tarball" link. Except cl-opengl, those guys +;;; are not download-friendly. +;;; +;;; Next, get ASDF loaded: + #+eval-this-if-you-do-not-autoload-asdf (load (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "cells") :name "asdf" :type "lisp")) +;;; /After/ you have manually evaluated the above form, you can tell ASDF +;;; where you put everything by adjusting these paths and evaluating: + (progn (push (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "cells")) @@ -21,16 +38,14 @@ :directory '(:absolute "0dev" "Celtk")) asdf:*central-registry*)) -#-runtestsuite -(ASDF:OOS 'ASDF:LOAD-OP :CELLS) - -#+runtestsuite -(ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST) +;;; and now you can try building the whole mess: (ASDF:OOS 'ASDF:LOAD-OP :CELTK) -#+ortestceltk -(ctk:test-window 'celtk-user::ltktest-cells-inside) +;;; and test: + +(ctk::test-window 'celtk-user::lotsa-widgets) + +;;; When that crashes, track down all the define-foreign-library calls in the source +;;; and fix the pathnames to point to your shared libraries. -#+opengl -(celtk-user::gears) \ No newline at end of file --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/05/13 14:36:58 1.1 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/05/16 21:17:15 1.2 @@ -88,8 +88,7 @@ for n below 25 counting sym into symct collecting sym into syms - finally (trc "syms found !!!" symct) - (return syms))))) + finally (return syms))))) :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* @@ -161,7 +160,7 @@ (mk-popup-menubutton :id :font-face :initial-value (c? (second (^entry-values))) - :entry-values (c? (eko ("popup ff") (subseq (tk-eval-list "font families") 4 10)))) + :entry-values (c? (subseq (tk-eval-list "font families") 4 10))) (mk-scale :id :font-size :md-value (c-in 14) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/05/15 05:15:37 1.13 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/05/16 21:17:15 1.14 @@ -63,11 +63,11 @@ `(mk-menu :kids (c? (the-kids , at submenus)))) (defmethod make-tk-instance :after ((self menu)) - (trc "make-tk-instance > traversing menu" self) + (trc nil "make-tk-instance > traversing menu" self) (fm-menu-traverse self (lambda (entry &aux (menu self)) (assert (typep entry 'menu-entry)) - (trc "make-tk-instance visiting menu entry" (path menu) entry) + (trc nil "make-tk-instance visiting menu entry" (path menu) entry) (tk-format `(:post-make-tk ,self) "~(~a~) add ~(~a~) ~{~(~a~) ~a~^ ~}" (path menu) (tk-class entry) @@ -273,11 +273,9 @@ :kids (c? (the-kids ;; don't worry, this flattens (loop for v in (entry-values .parent) collecting - (progn - (trc "popup-menubutton entry label" v (down$ v)) - (mk-menu-entry-radiobutton + (mk-menu-entry-radiobutton :label (down$ v) - :value v)))))))))) + :value v))))))))) (defobserver initial-value ((self popup-menubutton)) (when new-value --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/16 02:52:22 1.6 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/16 21:17:15 1.7 @@ -46,7 +46,7 @@ :yscrollcommand (c-in nil) :command (c? (format nil "event generate ~a <> -data" (^path))) :on-command (lambda (self value) - (trc "hi scale" self value) + ;; (trc "hi scale" self value) (setf (^md-value) value)))) (defmethod make-tk-instance :after ((self scale)) --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/16 02:52:22 1.8 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/16 21:17:15 1.9 @@ -100,7 +100,7 @@ (Tcl_Init interp) (Tk_Init interp) - (format t "~%*** Tk_AppInit has been called.~%") + ;;(format t "~%*** Tk_AppInit has been called.~%") ;; Return OK (foreign-enum-value 'tcl-retcode-values :tcl-ok)) --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/16 02:52:22 1.6 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/16 21:17:15 1.7 @@ -73,13 +73,13 @@ (defobserver event-handler () (when new-value ;; \\\ work out how to unregister any old value (with-integrity (:client `(:post-make-tk ,self)) - (trc "creating event handler for" self) + (trc nil "creating event handler for" self) (tk-create-event-handler-ex self 'widget-event-handler -1)))) ;; // make this -1 more efficient (defun tk-create-event-handler-ex (widget callback-name &rest masks) (let ((self-tkwin (widget-to-tkwin widget))) (assert (plusp self-tkwin)) - (trc "setting up widget virtual-event handler" widget :tkwin self-tkwin) + (trc nil "setting up widget virtual-event handler" widget :tkwin self-tkwin) (tk-create-event-handler self-tkwin (apply 'foreign-masks-combine 'tk-event-mask masks) (get-callback callback-name) From ktilton at common-lisp.net Wed May 17 00:40:55 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 16 May 2006 20:40:55 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060517004055.692004C015@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv17320 Modified Files: demos.lisp entry.lisp menu.lisp multichoice.lisp run.lisp timer.lisp tk-events.lisp widget.lisp Log Message: create command replacing event generate --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/16 21:17:15 1.16 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/17 00:40:55 1.17 @@ -25,11 +25,11 @@ (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window - ;; true tester: 'one-button-window + ;;'one-button-window ;; Not so good: 'ltktest-cells-inside ;; 'menu-button-test - ;; 'spinbox-test - 'lotsa-widgets + 'spinbox-test + ;; 'lotsa-widgets ;; Now in Gears project 'gears-demo )) @@ -40,6 +40,11 @@ (mk-frame-stack :packing (c?pack-self) :kids (c? (the-kids + (mk-menubar + :kids (c? (the-kids + (mk-menu-entry-cascade-ex (:label "File") + (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) + (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) (make-instance 'entry :id :entree :fm-parent *parent* @@ -48,70 +53,19 @@ :fm-parent *parent* :text "read" :on-command (lambda (self) - (trc "entry reads" (ctk::tk-eval-var (path (fm^ :entree))))))))))))) - -#+save -(defmodel one-button-window (window) - () - (:default-initargs - :on-event (lambda (self &rest event-args) - (trc "we got events" self event-args)) - :kids (c? (the-kids - (mk-menubar - :kids (c? (the-kids - (mk-menu-entry-cascade-ex (:label "File") - (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) - (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) - (mk-frame-stack - :packing (c?pack-self) - :kids (c? (the-kids - - ;;; (mk-scrolled-list - ;;; :id :spinpkg-sym-list - ;;; :list-height 6 - ;;; :list-item-keys (c? (loop for sym being the symbols in (find-package "CELTK") - ;;; for n below 5 - ;;; counting sym into symct - ;;; collecting sym into syms - ;;; finally (trc "syms found !!!" symct) - ;;; (return syms))) - ;;; :list-item-factory (lambda (sym) - ;;; (trc "make list item" sym *parent*) - ;;; (make-instance 'listbox-item - ;;; :fm-parent *parent* - ;;; :md-value sym - ;;; :item-text (down$ (symbol-name sym))))) - (mk-text-widget - :id :my-text - :md-value (c?n "hello, world") - :height 3 - :width 25) - (make-instance 'button - :fm-parent *parent* - :text "<>" - :on-command (lambda (self) - (trc "button pushed!!!" self))) - ;;; (make-instance 'button - ;;; :fm-parent *parent* - ;;; :text "time now?" - ;;; :on-command (c? (lambda (self) - ;;; (trc "we got callbacks" self)))) + (trc "entry reads" (ctk::tk-eval-var (path (fm^ :entree)))))) (make-instance 'scale :fm-parent *parent* :tk-label "Boots" :on-command (c? (lambda (self value) - (trc "we got scale callbacks" self value)))) + (trc "we got scale callbacks" self (parse-integer value))))) (mk-spinbox :id :spin-pkg :md-value (c-in "cells") ;;(cells::c?n "cells") :tk-values (mapcar 'down$ (sort (mapcar 'package-name (list-all-packages)) - 'string>))) - (make-instance 'entry - :fm-parent *parent* - :md-value (c-in "Boots")) - ))))))) + 'string>)))))))))) (defmodel spinbox-test (window) () @@ -142,7 +96,8 @@ (make-instance 'listbox-item :fm-parent *parent* :md-value sym - :item-text (down$ (symbol-name sym)))))))))) + :item-text (down$ (symbol-name sym))))) + (mk-label :text (c? (selection (fm^ :spinpkg-sym-list))))))))) (defmodel menu-button-test (window) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/16 02:52:22 1.7 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/17 00:40:55 1.8 @@ -65,8 +65,7 @@ (defmethod md-awaken :after ((self entry)) ;; move this to a traces slot on widget (with-integrity (:client `(:trace ,self)) - (tk-format-now "trace add variable ~a write TraceOP" (^path)) - )) + (tk-format-now "trace add variable ~a write TraceOP" (^path)))) ;;; /// this next replicates the handling of tk-mirror-variable because ;;; those leverage the COMMAND mechanism, which entry lacks --- /project/cells/cvsroot/Celtk/menu.lisp 2006/05/16 21:17:15 1.14 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/05/17 00:40:55 1.15 @@ -172,7 +172,7 @@ () (:tk-spec command -command) (:default-initargs - :command (c? (format nil "event generate . <> -data ~a" (path-idx self))))) + :command (c? (format nil "do-on-command ~a" (path-idx self))))) (defmacro mk-menu-entry-command-ex ((&rest menu-command-initargs) lbl callback-body) `(mk-menu-entry-command --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/16 21:17:15 1.7 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/17 00:40:55 1.8 @@ -44,10 +44,9 @@ :tk-variable nil ;;(c? (^path)) :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) - :command (c? (format nil "event generate ~a <> -data" (^path))) :on-command (lambda (self value) ;; (trc "hi scale" self value) - (setf (^md-value) value)))) + (setf (^md-value) (parse-integer value))))) (defmethod make-tk-instance :after ((self scale)) "Still necessary?" @@ -116,7 +115,7 @@ :id (gentemp "SPN") :textVariable (c? (^path)) :xscrollcommand (c-in nil) - :command (c? (format nil "event generate ~a <> -data %s" (^path))) + :command (c? (format nil "do-on-command ~a %s" (^path))) :on-command (c? (lambda (self text) (eko ("variable mirror command fired !!!!!!!" text) (setf (^md-value) text)))))) --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/16 02:52:22 1.10 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/17 00:40:55 1.11 @@ -39,12 +39,13 @@ (tk-app-init *tki*) (tk-togl-init *tki*) (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <> -data $op}") + (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) 42 0) (with-integrity () (setf *tkw* (make-instance root-class)) (tk-create-event-handler-ex *tkw* 'main-window-proc :virtualEventMask)) - + (tk-format `(:fini) "wm deiconify .") (tk-format-now "bind . {destroy .}") @@ -55,9 +56,6 @@ (when (eq (xevent-type xe) :virtualevent) (bwhen (n$ (xsv name xe)) (case (read-from-string (string-upcase n$)) - (do-menu-command (let ((self (gethash (tcl-get-string (xsv user-data xe)) (dictionary *tkw*)))) - (bwhen (c (^on-command)) - (funcall c self)))) (time-is-up (let ((self (gethash (tcl-get-string (xsv user-data xe)) (dictionary *tkw*)))) (bwhen (c (^on-command)) (funcall c self)))) --- /project/cells/cvsroot/Celtk/timer.lisp 2006/05/16 02:52:22 1.5 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/05/17 00:40:55 1.6 @@ -52,7 +52,7 @@ (export '(repeat ^repeat))) (defmodel timer () - ((id :cell nil :initarg :id :accessor id :initform :anon + ((id :cell nil :initarg :id :accessor id :initform (gentemp "AFTER") :documentation "A debugging aid") (tag :cell nil :initarg :tag :accessor tag :initform :anon :documentation "A debugging aid") @@ -99,9 +99,8 @@ (setf (id self) (set-timer self (^delay))))))))))) (defun set-timer (self time) - (let ((lookup-id (gentemp "AFTER"))) - (setf (gethash lookup-id (dictionary *tkw*)) self) - (tk-eval "after ~a {event generate . <> -data ~a}" time lookup-id))) + (setf (gethash (id self) (dictionary *tkw*)) self) + (tk-eval "after ~a {do-on-command ~a}" time (id self))) (defobserver timers ((self tk-object) new-value old-value) (dolist (k (set-difference old-value new-value)) --- /project/cells/cvsroot/Celtk/tk-events.lisp 2006/05/15 05:15:37 1.2 +++ /project/cells/cvsroot/Celtk/tk-events.lisp 2006/05/17 00:40:55 1.3 @@ -8,6 +8,18 @@ (tcl-idle-proc :pointer) (client-data :int)) +(defcfun ("Tcl_CreateCommand" tcl-create-command) :pointer + (interp :pointer) + (cmdName :string) + (proc :pointer) + (client-data :int) + (delete-proc :pointer)) + +(defcfun ("Tcl_SetResult" tcl-set-result) :void + (interp :pointer) + (result :string) + (free-proc :pointer)) + (defcfun ("Tcl_GetString" tcl-get-string) :string (tcl-obj :pointer)) --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/16 21:17:15 1.7 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/17 00:40:55 1.8 @@ -95,24 +95,21 @@ (defclass commander () () (:default-initargs - :command (c? (format nil "event generate ~a <>" (^path))))) + :command (c? (format nil "do-on-command ~a" (^path))))) -(defcallback commander-event-proc :void ((client-data :int)(xe :pointer)) +(defcallback do-on-command :int ((client-data :int)(interp :pointer)(argc :int)(argv :pointer)) (declare (ignore client-data)) - (when (eq (xevent-type xe) :virtualevent) - (bwhen (n$ (xsv name xe)) - (case (read-from-string (string-upcase n$)) - (do-on-command (let ((self (xwin-widget (xsv event-window xe)))) - (bwhen (c (^on-command)) - (let ((d (xsv user-data xe))) - (if (plusp d) - (funcall c self (read-from-string (tcl-get-string d))) - (funcall c self)))))) - (otherwise (trc "commander sees unknown" n$)))))) - -(defmethod make-tk-instance :after ((self commander)) - (with-integrity (:client `(:post-make-tk ,self)) - (tk-create-event-handler-ex self 'commander-event-proc :virtualEventMask))) + (destructuring-bind (path &rest args) + (loop for argn upfrom 1 below argc + collecting (mem-aref argv :string argn)) + (bif (self (gethash path (dictionary *tkw*))) + (bIf (cmd (^on-command)) + (progn (apply cmd self args) + 0) + (progn (tcl-set-result interp (format nil "do-on-command> Target widget ~a has no on-command to run" path) 0) + 1)) + (progn (tcl-set-result interp (format nil "do-on-command> Target widget ~a does not exist" path) 0) + 1)))) (defun widget-menu (self key) (or (find key (^menus) :key 'md-name) From ktilton at common-lisp.net Sat May 20 06:32:19 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 20 May 2006 02:32:19 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20060520063219.CABA722008@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv6697 Modified Files: README.txt cell-types.lisp cells.lisp cells.lpr constructors.lisp defmodel.lisp family-values.lisp family.lisp fm-utilities.lisp initialize.lisp integrity.lisp link.lisp load.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp optimization.lisp propagate.lisp slot-utilities.lisp synapse-types.lisp synapse.lisp Log Message: A slow tedious transition to LLGPL --- /project/cells/cvsroot/cells/README.txt 2006/03/22 04:08:34 1.2 +++ /project/cells/cvsroot/cells/README.txt 2006/05/20 06:32:19 1.3 @@ -25,7 +25,7 @@ Now in .\doc is cells-overview.pdf. That is pretty rough and obsolete in re the code, but some of it might be enlightening. -Cells is written in almost-portable ANSI Common Lisp. It makes very +Cells is written in portable ANSI Common Lisp. It makes very light use of the introspective portions of the MOP, and contains a few workarounds for shortcomings in common implementations. @@ -44,7 +44,7 @@ * MCL One of the Cells tests fails with CMUCL. This appears to be caused by -a bug in its CLOS implementation, but has not been investigated in +a bug in CMUCL's CLOS implementation, but has not been investigated in great depth. Cells is believed to work with Corman CL, but has not been recently @@ -57,8 +57,6 @@ package where the MOP lives. In reality, however, you might have to find workarounds for bugs in ANSI compliance. - - ***** Installation ***** [ Cells follows the usual convention for asdf and asdf-installable --- /project/cells/cvsroot/cells/cell-types.lisp 2006/03/16 05:28:27 1.8 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/05/20 06:32:19 1.9 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/cells.lisp 2006/05/01 20:23:14 1.8 +++ /project/cells/cvsroot/cells/cells.lisp 2006/05/20 06:32:19 1.9 @@ -1,27 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| -;;;(eval-when (compile load) -;;; (proclaim '(optimize (speed 1) (safety 1) (space 1) (debug 2)))) + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (eval-when (compile load) (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) --- /project/cells/cvsroot/cells/cells.lpr 2006/05/12 08:27:39 1.11 +++ /project/cells/cvsroot/cells/cells.lpr 2006/05/20 06:32:19 1.12 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/constructors.lisp 2006/05/01 20:23:14 1.5 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/05/20 06:32:19 1.6 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/defmodel.lisp 2006/03/16 05:28:28 1.3 +++ /project/cells/cvsroot/cells/defmodel.lisp 2006/05/20 06:32:19 1.4 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/family-values.lisp 2006/05/12 08:27:39 1.3 +++ /project/cells/cvsroot/cells/family-values.lisp 2006/05/20 06:32:19 1.4 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/family.lisp 2006/05/01 20:23:14 1.6 +++ /project/cells/cvsroot/cells/family.lisp 2006/05/20 06:32:19 1.7 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/05/01 20:23:14 1.6 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/05/20 06:32:19 1.7 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/initialize.lisp 2006/05/01 20:23:14 1.4 +++ /project/cells/cvsroot/cells/initialize.lisp 2006/05/20 06:32:19 1.5 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/integrity.lisp 2006/05/03 08:22:15 1.8 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/05/20 06:32:19 1.9 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/link.lisp 2006/03/16 05:28:28 1.8 +++ /project/cells/cvsroot/cells/link.lisp 2006/05/20 06:32:19 1.9 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/load.lisp 2006/03/22 05:26:53 1.4 +++ /project/cells/cvsroot/cells/load.lisp 2006/05/20 06:32:19 1.5 @@ -11,10 +11,10 @@ asdf:*central-registry*) #-runtestsuite -(ASDF:OOS 'ASDF:LOAD-OP :CELLS) +(asdf:oos 'asdf:load-op :cells) #+runtestsuite -(ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST) +(asdf:oos 'asdf:load-op :cells-test) #+checkoutceltk (ASDF:OOS 'ASDF:LOAD-OP :CELTK) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/05/04 21:25:12 1.13 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/05/20 06:32:19 1.14 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/md-utilities.lisp 2006/03/16 05:28:28 1.3 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/05/20 06:32:19 1.4 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/model-object.lisp 2006/03/18 00:15:40 1.4 +++ /project/cells/cvsroot/cells/model-object.lisp 2006/05/20 06:32:19 1.5 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/optimization.lisp 2006/03/16 05:28:28 1.5 +++ /project/cells/cvsroot/cells/optimization.lisp 2006/05/20 06:32:19 1.6 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/propagate.lisp 2006/03/22 18:48:13 1.11 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/05/20 06:32:19 1.12 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/slot-utilities.lisp 2006/03/16 05:28:28 1.2 +++ /project/cells/cvsroot/cells/slot-utilities.lisp 2006/05/20 06:32:19 1.3 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/synapse-types.lisp 2006/03/16 05:28:28 1.4 +++ /project/cells/cvsroot/cells/synapse-types.lisp 2006/05/20 06:32:19 1.5 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) --- /project/cells/cvsroot/cells/synapse.lisp 2006/03/16 05:28:28 1.9 +++ /project/cells/cvsroot/cells/synapse.lisp 2006/05/20 06:32:19 1.10 @@ -1,24 +1,20 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) From ktilton at common-lisp.net Sat May 20 06:32:20 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 20 May 2006 02:32:20 -0400 (EDT) Subject: [cells-cvs] CVS cells/doc Message-ID: <20060520063220.08DA52300B@common-lisp.net> Update of /project/cells/cvsroot/cells/doc In directory clnet:/tmp/cvs-serv6697/doc Modified Files: 01-Cell-basics.lisp Log Message: A slow tedious transition to LLGPL --- /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2006/05/01 20:23:14 1.3 +++ /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2006/05/20 06:32:19 1.4 @@ -1,17 +1,20 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; All rights reserved. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +#| + + Cells -- Automatic Dataflow Managememnt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cells) From ktilton at common-lisp.net Sat May 20 06:32:20 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 20 May 2006 02:32:20 -0400 (EDT) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20060520063220.5118124029@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv6697/utils-kt Modified Files: datetime.lisp debug.lisp defpackage.lisp detritus.lisp flow-control.lisp strings.lisp utils-kt.lpr Log Message: A slow tedious transition to LLGPL --- /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2006/03/22 20:36:38 1.1 +++ /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2006/05/20 06:32:20 1.2 @@ -1,25 +1,21 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- -;;; -;;; -;;; Copyright ? 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Utils-kt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# + (in-package :utils-kt) --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/05/01 20:23:14 1.7 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/05/20 06:32:20 1.8 @@ -1,24 +1,22 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*- ;;; -;;; Copyright (c) 1995,2004 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Utils-kt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# + (in-package :utils-kt) --- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/04/01 21:47:00 1.3 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/05/20 06:32:20 1.4 @@ -1,24 +1,19 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*- -;;; -;;; Copyright (c) 1995,2004 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Utils-kt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# (in-package :cl-user) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/05/03 08:22:16 1.5 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/05/20 06:32:20 1.6 @@ -1,24 +1,21 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Utils-kt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# + (in-package :utils-kt) --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2005/05/18 21:47:32 1.2 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/05/20 06:32:20 1.3 @@ -1,25 +1,21 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*- -;;; -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Utils-kt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# + (in-package :utils-kt) --- /project/cells/cvsroot/cells/utils-kt/strings.lisp 2006/03/16 05:26:47 1.3 +++ /project/cells/cvsroot/cells/utils-kt/strings.lisp 2006/05/20 06:32:20 1.4 @@ -1,24 +1,21 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*- -;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. +#| + + Utils-kt + +Copyright (C) 1995, 2006 by Kenneth Tilton + +This library is free software; you can redistribute it and/or +modify it under the terms of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), known as the LLGPL. + +This library is distributed WITHOUT ANY WARRANTY; without even +the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +See the Lisp Lesser GNU Public License for more details. + +|# + (in-package :utils-kt) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/05/12 08:27:40 1.9 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/05/20 06:32:20 1.10 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Wed May 24 20:39:38 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 24 May 2006 16:39:38 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20060524203938.AA38A4713C@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv19700 Modified Files: cells.lpr Log Message: --- /project/cells/cvsroot/cells/cells.lpr 2006/05/20 06:32:19 1.12 +++ /project/cells/cvsroot/cells/cells.lpr 2006/05/24 20:39:38 1.13 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) @@ -27,7 +27,9 @@ (make-instance 'module :name "doc\\01-Cell-basics.lisp") (make-instance 'module :name - "doc\\motor-control.lisp")) + "doc\\motor-control.lisp") + (make-instance 'module :name + "porting\\do-no-harm.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil From ktilton at common-lisp.net Wed May 24 20:39:38 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 24 May 2006 16:39:38 -0400 (EDT) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20060524203938.E29084707F@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv19700/utils-kt Modified Files: utils-kt.lpr Log Message: --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/05/20 06:32:20 1.10 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/05/24 20:39:38 1.11 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Thu May 25 07:12:59 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 25 May 2006 03:12:59 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060525071259.A95905E0FA@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv18670 Modified Files: Celtk.lisp demos.lisp ltktest-ci.lisp run.lisp timer.lisp widget.lisp Log Message: Window destruction looking OK --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/24 20:38:54 1.23 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/25 07:12:59 1.24 @@ -125,24 +125,25 @@ "\"" "\\\"")) (defun tk-format-now (fmt$ &rest fmt-args) - (let ((*print-circle* nil) - (tk$ (apply 'format nil fmt$ fmt-args))) - ; - ; --- debug stuff --------------------------------- - ; - (let ((yes '( "destroy")) - (no '())) - (declare (ignorable yes no)) - (when (and (find-if (lambda (s) (search s tk$)) yes) - (not (find-if (lambda (s) (search s tk$)) no))) - (format t "~&tk> ~a~%" tk$))) - (assert *tki*) - ; --- end debug stuff ------------------------------ - ; - ; --- serious stuff --- - ; - (setf *tk-last* tk$) - (tcl-eval-ex *tki* tk$))) + (unless (find *tkw* *windows-destroyed*) + (let ((*print-circle* nil) + (tk$ (apply 'format nil fmt$ fmt-args))) + ; + ; --- debug stuff --------------------------------- + ; + (let ((yes '( "destroy")) + (no '())) + (declare (ignorable yes no)) + (when nil #+not (and (find-if (lambda (s) (search s tk$)) yes) + (not (find-if (lambda (s) (search s tk$)) no))) + (format t "~&tk> ~a~%" tk$))) + (assert *tki*) + ; --- end debug stuff ------------------------------ + ; + ; --- serious stuff --- + ; + (setf *tk-last* tk$) + (tcl-eval-ex *tki* tk$)))) (defun tk-format (defer-info fmt$ &rest fmt-args) "Format then send to wish (via user queue)" --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/24 20:38:54 1.18 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/25 07:12:59 1.19 @@ -21,10 +21,10 @@ (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window ;;'one-button-window - 'ltktest-cells-inside - ;; 'menu-button-test + ;;'ltktest-cells-inside + ;;'menu-button-test ;;'spinbox-test - ;;'lotsa-widgets + 'lotsa-widgets ;; Now in Gears project 'gears-demo )) @@ -32,15 +32,14 @@ () (:default-initargs :kids (c? (the-kids - (mk-frame-stack - :packing (c?pack-self) - :kids (c? (the-kids - (one-deep-menubar) - #+not (mk-menubar + (mk-menubar :kids (c? (the-kids (mk-menu-entry-cascade-ex (:label "File") (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) + (mk-frame-stack + :packing (c?pack-self) + :kids (c? (the-kids (mk-text-widget :id :my-text :md-value (c?n "hello, world") --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/24 20:38:54 1.6 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/25 07:12:59 1.7 @@ -332,7 +332,7 @@ (:virtualevent (trc "canvas virtual" (xsv name xe))) (:buttonpress - (TRC "canvas buttonpress" self (xsv x-root xe)(xsv y-root xe)) + (TRC nil "canvas buttonpress" self (xsv x-root xe)(xsv y-root xe)) (pop-up (^widget-menu :bkg-pop) (xsv x-root xe) (xsv y-root xe)))))) :menus (c? (the-kids @@ -382,7 +382,7 @@ :delay 1 ;; milliseconds since this gets passed unvarnished to TK after :action (lambda (timer) (declare (ignorable timer)) - (trc "timer fires!!" timer) + (trc nil "timer fires!!" timer) (incf (^angle-1) 0.1))))) :coords (c? (let ((angle-2 (* 0.3 (^angle-1))) (wx (sin (* 0.1 (^angle-1))))) @@ -429,7 +429,7 @@ ; declaring them to the menu widget, it seems to me. In Celtk, they do. ; :underline 1 - :command "destroy .")))))) + :command "destroy .; break")))))) (defmodel entry-numeric (entry) --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/24 20:38:54 1.12 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/25 07:12:59 1.13 @@ -34,7 +34,7 @@ (tk-app-init *tki*) (tk-togl-init *tki*) (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <> -data $op}") - (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer)) + (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer)) (with-integrity () (setf *tkw* (make-instance root-class)) @@ -43,12 +43,13 @@ (tk-format `(:fini) "wm deiconify .") (tk-format-now "bind . {destroy .}") - (tk-format-now "bind . {event generate . <>}") (tcl-do-one-event-loop)) (defun ensure-destruction (w) + (TRC nil "ensure-destruction entry" W) (unless (find w *windows-being-destroyed*) + (TRC nil "ensure-destruction not-to-being" W) (let ((*windows-being-destroyed* (cons w *windows-being-destroyed*))) (not-to-be w)))) @@ -61,6 +62,8 @@ (ensure-destruction *tkw*))) (:virtualevent (bwhen (n$ (xsv name xe)) + (trc nil "main-window-proc :" n$ (unless (null-pointer-p (xsv user-data xe)) + (tcl-get-string (xsv user-data xe)))) (case (read-from-string (string-upcase n$)) (close-window @@ -74,7 +77,8 @@ (bwhen (c (^on-command)) (funcall c self)))) - (otherwise (trc "main window sees unknown" n$))))))) + (otherwise (trc "main window sees unknown" n$)))))) + 0) ;; Our own event loop ! - Use this if it is desirable to do something ;; else between events @@ -82,14 +86,14 @@ (defparameter *event-loop-delay* 0.08 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)") (defun tcl-do-one-event-loop () - (loop while (progn (trc "checking num main windows") + (loop while (progn (trc nil "checking num main windows") (plusp (tk-get-num-main-windows))) - do (trc "calling Tcl_DoOneEvent" (tk-get-num-main-windows)) + do (trc nil "calling Tcl_DoOneEvent" (tk-get-num-main-windows)) (loop until (zerop (Tcl_DoOneEvent 2))) ;; 2== TCL_DONT_WAIT - (trc "sleeping") + (trc nil "sleeping") (sleep *event-loop-delay*) ;; give the IDE a few cycles finally - (trc "Tcl-do-one-event-loop sees no more windows" *tki*) + (trc nil "Tcl-do-one-event-loop sees no more windows" *tki*) (tcl-delete-interp *tki*) ;; probably unnecessary (setf *tki* nil))) --- /project/cells/cvsroot/Celtk/timer.lisp 2006/05/24 20:38:54 1.7 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/05/25 07:12:59 1.8 @@ -82,11 +82,8 @@ :initform (c? (bwhen (rpt (eko (nil ">>> repeat") (when (eq (^state) :on) (^repeat)))) (when (or (zerop (^executions)) (^executed)) ;; dispatch initially or after an execution - (if (zerop (^executions)) - (setf (elapsed self) (now)) - (when (and (numberp rpt) - (>= (^executions) rpt)) - (print `(stop timer!!! ,(* 1.0 (- (now) (elapsed self))))))) + (when (zerop (^executions)) + (setf (elapsed self) (now))) (when (if (numberp rpt) (< (^executions) rpt) rpt) ;; playing it safe/robust: redundant with initial bwhen check that rpt is not nil --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/24 20:38:54 1.9 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/25 07:12:59 1.10 @@ -149,7 +149,8 @@ (tk-format `(:configure ,self ,option) "~a configure ~(~a~) ~a" (path self) option (tk-send-value value))) (defmethod not-to-be :after ((self widget)) - (unless (find .tkw *windows-destroyed*) + (when (or (and (eql self .tkw) (not (find .tkw *windows-destroyed*))) + (not (find .tkw *windows-being-destroyed*))) (tk-format `(:forget ,self) "pack forget ~a" (^path)) (tk-format `(:destroy ,self) "destroy ~a" (^path)))) @@ -159,7 +160,6 @@ (export '(canvas-offset ^canvas-offset coords-tweak ^coords-tweak caret-tweak ^caret-tweak decorations ^decorations))) - (defmodel item-geometer () ;; mix-in ((canvas-offset :initarg :canvas-offset :accessor canvas-offset :initform (c_? (eko (nil "standard canvas offset" self (type-of self) (^p-offset)) @@ -274,5 +274,5 @@ ;;; --- menus --------------------------------- (defun pop-up (menu x y) - (trc "popping up" menu x y) + (trc nil "popping up" menu x y) (tk-format-now "tk_popup ~A ~A ~A" (path menu) x y)) From fgoenninger at common-lisp.net Thu May 25 13:32:45 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Thu, 25 May 2006 09:32:45 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060525133245.5FC5F2E1AA@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv11797 Added Files: fileevent.lisp Log Message: New file. Implements Tk's fileevent command via Cells. --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/25 13:32:45 NONE +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/25 13:32:45 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- ;;; ;;; Copyright (c) 2006 by Frank Goenninger, Germany. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a ;;; copy of this software and associated documentation files (the "Software"), ;;; to deal in the Software without restriction, including without limitation ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;;; and/or sell copies of the Software, and to permit persons to whom the ;;; Software is furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- ;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.1 2006/05/25 13:32:45 fgoenninger Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== ;;; PACKAGE / EXPORTS ;;; =========================================================================== (in-package :celtk) (eval-when (:load-toplevel :compile-toplevel) (export '(tk-fileevent iostream read-fn write-fn eof-fn mk-fileevent))) ;;; =========================================================================== ;;; TK-FILEEVENT MODEL ;;; =========================================================================== (defmodel tk-fileevent (widget) ((.md-name :accessor id :initarg :id :initform (c-in nil) :documentation "ID of the fileevent instance.") (input-fd :accessor input-fd :initarg :input-fd :initform (c? (if (^iostream) (stream-2-in-fd (^iostream)))) :documentation "The input/read file descriptor - internal use only.") (output-fd :accessor output-fd :initarg :output-fd :initform (c? (if (^iostream) (stream-2-out-fd (^iostream)))) :documentation "The output/write file descriptor - internal use only.") (in-tcl-channel :accessor in-tcl-channel :initarg :in-tcl-channel :initform (c? (fd-to-tcl-channel (^tki) (^input-fd))) :documentation "The TCL channel generated from the input file descriptor. - Internal use only.") (out-tcl-channel :accessor out-tcl-channel :initarg :in-tcl-channel :initform (c? (fd-to-tcl-channel (^tki) (^output-fd))) :documentation "The TCL channel generated from the output file descriptor. - Internal use only.") (in-tcl-ch-name :accessor in-tcl-ch-name :initarg :in-tcl-ch-name :initform (c? (if (^in-tcl-channel) (Tcl_GetChannelName (^in-tcl-channel)) nil)) :documentation "The input TCL channel's name as passed to the fileevent command. - Internal use only.") (out-tcl-ch-name :accessor out-tcl-ch-name :initarg :in-tcl-ch-name :initform (c? (if (^out-tcl-channel) (Tcl_GetChannelName (^out-tcl-channel)) nil)) :documentation "The output TCL channel's name as passed to the fileevent command. - Internal use only.") (iostream :accessor iostream :initarg :iostream :initform (c-in nil) :documentation "The Lisp stream to be monitored - API: initarg,setf.") (readable-cb :accessor readable-cb :initarg :readable-cb :initform (c-in nil) :documentation "The readable callback. A dispatcher function used to call the function supplied via the read-fn slot. - Internal use only.") (writeable-cb :accessor writeable-cb :initarg :writeable-cb :initform (c-in nil) :documentation "The writeable callback. A dispatcher function used to call the function supplied via the read-fn slot. - Internal use only.") (eof-cb :accessor eof-cb :initarg :eof-cb :initform (c-in nil) :documentation "The eof callback. A dispatcher function used to call the function supplied via the eof-fn slot. - Internal use only.") (tki :accessor tki :initarg :tki :initform (c-in nil) :documentation "The Tcl/Tk Interpreter used. - API: initarg.") (opcode :accessor opcode :initarg :opcode :initform (file-event-opcode-cell-rule) :documentation "The opcode slot is used to control the operaion of the fileevent instance. - Internal use only.") (read-fn :accessor read-fn :initarg :read-fn :initform (c-in nil) :documentation "User supplied function, gets called when iostream is ready for reading. Gets iostream as parameter. - API: initarg, setf") (write-fn :accessor write-fn :initarg :write-fn :initform (c-in nil) :documentation "User supplied function, gets called when iostream is ready for writing. Gets iostream as parameter. - API: initarg, setf") (eof-fn :accessor eof-fn :initarg :eof-fn :initform (c-in nil) :documentation "User supplied function, gets called when iostream is EOF. Gets iostream as parameter. - API: initarg, setf (Via default-initarg set to fn default-eof-fn which simply closes the stream).")) (:default-initargs :id (gensym "tk-fileevent-") :eof-fn 'default-eof-fn)) ;;; =========================================================================== ;;; CELL RULE: FILE-EVENT/OPCODE ;;; =========================================================================== ;;; ;;; Depending on opcode call the appropriate function to handle the various ;;; cases/combinations of input-fd, output-fd, and the previously executed ;;; update operation. (defun file-event-opcode-cell-rule () (c? ;; Set the opcode depending on values of input-fd, output-fd, iostream, ;; readable-cb, writeable-cb (if (and (not (^input-fd)) (not (^output-fd)) (not .cache)) :nop (if (and (^input-fd) (^iostream) (^readable-cb)) :update-input-tk-fileevent (if (and (^output-fd) (^iostream) (^writeable-cb)) :update-output-tk-fileevent (if (and (not (^iostream)) (not (^input-fd))) :reset-input-tk-fileevent (if (and (not (^iostream)) (not (^output-fd))) :reset-output-tk-fileevent :nop))))))) ;;; =========================================================================== ;;; INIT-TK-FILEEVENT - CALLED UPON INITIALIZATION ;;; =========================================================================== (defun init-tk-fileevent (tki) (assert tki) ;; Nop - all init done in observers now. ) ;;; =========================================================================== ;;; FILEEVENT HELPER METHODS AND FUCTIONS ;;; =========================================================================== (defmethod set-tk-readable ((self tk-fileevent) ch-name path) (tk-format-now "proc readable {channel path} { if [ eof $channel ] then { eof-cb $path } else { readable-cb $path } }") (tk-format-now "fileevent ~A readable [list readable ~A ~A]" ch-name ch-name path)) (defmethod set-tk-writeable ((self tk-fileevent) ch-name path) (tk-format-now "proc writeable {channel path} { if [ eof $channel ] then { eof-cb $path } else { readable-cb $path } }") (tk-format-now "fileevent ~A writeable [list writeable ~A ~A]" ch-name ch-name path)) ;;; =========================================================================== ;;; OBSERVERS - USED TO SEND UPDATES TO TK LAND ;;; =========================================================================== (defobserver opcode ((self tk-fileevent)) (let ((*tki* (tki self))) (ecase new-value ((:init-tk-fileevent) (init-tk-fileevent (tki self))) ((:update-input-tk-fileevent) (let* ((channel (in-tcl-channel self)) (path (path self)) (ch-name (Tcl_GetChannelName channel))) (set-tk-readable self ch-name path))) ((:update-output-tk-fileevent) (let* ((channel (out-tcl-channel self)) (path (path self)) (ch-name (Tcl_GetChannelName channel))) (set-tk-writeable self ch-name path))) ((:reset-input-tk-fileevent) ;; Do nothing nil) ((:reset-output-tk-fileevent) ;; Do nothing nil) ((:nop) ;; Do nothing nil)))) (defobserver in-tcl-channel ((self tk-fileevent)) (let ((*tki* (tki self))) (if (and new-value (not old-value)) (Tcl_RegisterChannel *tki* new-value)) (if (and old-value (not new-value)) (progn (tk-format-now "fileevent ~A readable {}" (Tcl_GetChannelName old-value)) (Tcl_UnregisterChannel *tki* old-value))))) (defobserver out-tcl-channel ((self tk-fileevent)) (let ((*tki* (tki self))) (if (and new-value (not old-value)) (Tcl_RegisterChannel *tki* new-value)) (if (and old-value (not new-value)) (progn (tk-format-now "fileevent ~A writeable {}" (Tcl_GetChannelName old-value)) (Tcl_UnregisterChannel *tki* old-value))))) (defobserver readable-cb ((self tk-fileevent)) (if new-value (Tcl_CreateCommand *tki* "readable-cb" new-value (null-pointer) (null-pointer)))) (defobserver writeable-cb ((self tk-fileevent)) (if new-value (Tcl_CreateCommand *tki* "writeable-cb" new-value (null-pointer) (null-pointer)))) (defobserver eof-cb ((self tk-fileevent)) (if new-value (Tcl_CreateCommand *tki* "eof-cb" new-value (null-pointer) (null-pointer)))) ;;; =========================================================================== ;;; HELPER FUNCTIONS - FILE DESCRIPTOR TO STREAM AND CHANNEL ;;; =========================================================================== (defun fd-to-tcl-channel (interp fd) (assert interp) (if fd (let ((channel (Tcl_MakeFileChannel fd 6))) ;; 6 = READ/WRITE (if channel channel (error "*** Tcl error: ~a" (tcl-get-string-result interp)))))) (defun stream-2-out-fd (stream) ;; FRGO: PORTING... #+allegro (excl:stream-output-fn stream) #-allegro (error "STREAM-2-OUT-FD: Not implemented for ~A Version ~A. Sorry." (lisp-implementation-type) (lisp-implementation-version)) ) (defun stream-2-in-fd (stream) ;; FRGO: PORTING... #+allegro (excl:stream-input-fn stream) #-allegro (error "STREAM-2-IN-FD: Not implemented for ~A Version ~A. Sorry." (lisp-implementation-type) (lisp-implementation-version)) ) ;;; =========================================================================== ;;; CALLBACKS ;;; =========================================================================== (defcallback readable-cb :int ((clientData :pointer) (interp :pointer) (argc :int) (argv :pointer)) (declare (ignorable clientData argc interp)) (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^read-fn)) (funcall fn self :read))) (values (foreign-enum-value 'tcl-retcode-values :tcl-ok))) (defcallback writeable-cb :int ((clientData :pointer) (interp :pointer) (argc :int) (argv :pointer)) (declare (ignorable clientData argc interp)) (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^write-fn)) (funcall fn self :write))) (values (foreign-enum-value 'tcl-retcode-values :tcl-ok))) (defcallback eof-cb :int ((clientData :pointer) (interp :pointer) (argc :int) (argv :pointer)) (declare (ignorable clientData interp argc)) (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^eof-fn)) (funcall fn self))) (values (foreign-enum-value 'tcl-retcode-values :tcl-ok))) ;;; =========================================================================== ;;; MK-FILEEVENT: CONVENIENCE MACRO ;;; =========================================================================== (defmacro mk-fileevent (&rest inits) `(make-instance 'tk-fileevent :tki *tki* :readable-cb (get-callback 'readable-cb) :writeable-cb (get-callback 'writeable-cb) :eof-cb (get-callback 'eof-cb) :fm-parent *parent* , at inits)) ;;; =========================================================================== ;;; A DEFAULT EOF FUNCTION, USER MAY SUPPLY ANOTHER FUNCTION WHEN MAKING THE ;;; INSTANCE OF TK-FILEEVENT ;;; =========================================================================== (defmethod default-eof-fn ((self tk-fileevent)) ;; Default action: close stream (bwhen (iostream (^iostream)) (close iostream) (setf (^iostream) nil))) ;;; =========================================================================== ;;; TESTING ;;; =========================================================================== ;;; ;;; With these few lines below we get a simple application with a text widget ;;; that shows data sent to a pipe in that text widget. ;;; ;;; The app does this by opening the named pipe for reading. It then waits ;;; for data on the pipe via the Tcl fileevent command. When establishing ;;; the fileevent a set of callbacks is established. The callbacks call ;;; two Lisp functions, depending on the type of channel (read or write. ;;; ;;; The callback functions look for the file channel's registered read or ;;; write functions. Those functions are set via the write-fn and read-fn ;;; methods of the tk-fileevent object. ;;; ;;; In the test example below we use the read case: the function read-from-pipe ;;; actually reads from the pipe and sends the data to the text widget by ;;; setting the text widgets model value. ;;; [48 lines skipped] From fgoenninger at common-lisp.net Thu May 25 14:03:44 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Thu, 25 May 2006 10:03:44 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060525140344.647504707F@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv16350 Modified Files: fileevent.lisp Log Message: Exports now also stream-2-in-fd and stream-2-out-fd. --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/25 13:32:45 1.1 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/25 14:03:44 1.2 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.1 2006/05/25 13:32:45 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.2 2006/05/25 14:03:44 fgoenninger Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== @@ -36,7 +36,9 @@ read-fn write-fn eof-fn - mk-fileevent))) + mk-fileevent + stream-2-in-fd + stream-2-out-fd))) ;;; =========================================================================== ;;; TK-FILEEVENT MODEL From fgoenninger at common-lisp.net Thu May 25 14:25:02 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Thu, 25 May 2006 10:25:02 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060525142502.237A259081@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv18242 Modified Files: Celtk.asd Log Message: Added: fileevent.lisp now in fileset to be loaded. --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/16 02:52:22 1.7 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/25 14:25:02 1.8 @@ -37,6 +37,7 @@ (:file "frame") (:file "togl") (:file "run") + (:file "fileevent") (:file "ltktest-ci") (:file "lotsa-widgets") (:file "demos"))) From fgoenninger at common-lisp.net Thu May 25 14:35:27 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Thu, 25 May 2006 10:35:27 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060525143527.D4BF47020E@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv19984 Modified Files: tk-interp.lisp Log Message: Added: CFFI function definitions for Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_MakeFileChannel, Tcl_GetChannelName, Tcl_GetChannel --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/24 20:38:54 1.10 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/25 14:35:27 1.11 @@ -180,6 +180,41 @@ (pathName :string) (related-tkwin :pointer)) +;; ---------------------------------------------------------------------------- +;; Tcl_CreateCommand - used to implement direct callbacks +;; ---------------------------------------------------------------------------- + +(defcfun ("Tcl_CreateCommand" Tcl_CreateCommand) :pointer + (interp :pointer) + (cmdName :string) + (cmdProc :pointer) + (clientData :int) + (deleteProc :pointer)) + +;; ---------------------------------------------------------------------------- +;; Tcl/Tk channel related stuff +;; ---------------------------------------------------------------------------- + +(defcfun ("Tcl_RegisterChannel" Tcl_RegisterChannel) :void + (interp :pointer) + (channel :pointer)) + +(defcfun ("Tcl_UnregisterChannel" Tcl_UnregisterChannel) :void + (interp :pointer) + (channel :pointer)) + +(defcfun ("Tcl_MakeFileChannel" Tcl_MakeFileChannel) :pointer + (handle :int) + (readOrWrite :int)) + +(defcfun ("Tcl_GetChannelName" Tcl_GetChannelName) :string + (channel :pointer)) + +(defcfun ("Tcl_GetChannel" Tcl_GetChannel) :pointer + (interp :pointer) + (channelName :string) + (modePtr :pointer)) + ;;; --- Togl (Version 1.7 and above needed!) ----------------------------- From fgoenninger at common-lisp.net Thu May 25 15:31:35 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Thu, 25 May 2006 11:31:35 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060525153135.68F25415B@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv26901 Removed Files: tk-format.lisp Log Message: Obsolete. Now in Celtk.lisp. Removed. From fgoenninger at common-lisp.net Thu May 25 15:33:56 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Thu, 25 May 2006 11:33:56 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060525153356.638A47800A@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv26974 Removed Files: widgets.lisp Log Message: Obselete. Now in several other files. Removed. From fgoenninger at common-lisp.net Thu May 25 15:41:32 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Thu, 25 May 2006 11:41:32 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060525154132.A2F1F19001@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27202 Modified Files: Celtk.lisp Log Message: Changed: function tk-format-now: let -> let* in order to get *print-circle* to be set to nil for the formatting of the string to be passed to tk-eval-ex. --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/25 07:12:59 1.24 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/25 15:41:32 1.25 @@ -126,8 +126,8 @@ (defun tk-format-now (fmt$ &rest fmt-args) (unless (find *tkw* *windows-destroyed*) - (let ((*print-circle* nil) - (tk$ (apply 'format nil fmt$ fmt-args))) + (let* ((*print-circle* nil) + (tk$ (apply 'format nil fmt$ fmt-args))) ; ; --- debug stuff --------------------------------- ; From ktilton at common-lisp.net Fri May 26 17:50:36 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 26 May 2006 13:50:36 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060526175036.625FA3C005@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv4378 Modified Files: Celtk.asd load.lisp run.lisp tk-interp.lisp togl.lisp Log Message: Gears demo at last --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/25 14:25:02 1.8 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/26 17:50:36 1.9 @@ -9,10 +9,10 @@ :author "Kenny Tilton " :version "2.0" :maintainer "Kenny Tilton " - :licence "MIT Style" + :licence "Lisp LGPL" :description "Tcl/Tk with Cells Inside(tm)" - :long-description "A Cells-driven portable GUI, ultimately implmented by Tk" - :depends-on (:cells :cl-opengl :cl-glu) + :long-description "A Cells-driven portable GUI, ultimately implmented by Tcl/Tk" + :depends-on (:cells :cffi) :serial t :components ((:file "Celtk") (:file "tk-structs") --- /project/cells/cvsroot/Celtk/load.lisp 2006/05/24 20:38:54 1.7 +++ /project/cells/cvsroot/Celtk/load.lisp 2006/05/26 17:50:36 1.8 @@ -31,16 +31,12 @@ asdf:*central-registry*) (push (make-pathname #+lispworks :host #-lispworks :device "c" - :directory '(:absolute "1-devtools" "cl-opengl")) - asdf:*central-registry*) - - (push (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "Celtk")) asdf:*central-registry*)) ;;; and now you can try building the whole mess: -(ASDF:OOS 'ASDF:LOAD-OP :CELTK) +(ASDF:OOS 'ASDF:LOAD-OP :celtk) ;;; and test: @@ -49,3 +45,13 @@ ;;; When that crashes, track down all the define-foreign-library calls in the source ;;; and fix the pathnames to point to your shared libraries. +;;; To see the OpenGL Gears demo: + +(push (make-pathname #+lispworks :host #-lispworks :device "c" + :directory '(:absolute "1-devtools" "cl-opengl")) + asdf:*central-registry*) + +(ASDF:OOS 'ASDF:LOAD-OP :gears) + +#+test +(gears::gears) --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/25 07:12:59 1.13 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/26 17:50:36 1.14 @@ -39,7 +39,7 @@ (with-integrity () (setf *tkw* (make-instance root-class)) - (tk-create-event-handler-ex *tkw* 'main-window-proc :structureNotifyMask :virtualEventMask)) + (tk-create-event-handler-ex *tkw* 'main-window-proc -1 :structureNotifyMask :virtualEventMask)) (tk-format `(:fini) "wm deiconify .") (tk-format-now "bind . {destroy .}") --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/25 14:35:27 1.11 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/26 17:50:36 1.12 @@ -19,31 +19,6 @@ (in-package :celtk) -;;------------------------------------------------------------------------------ -;; GLOBAL VARS AND PARAMS -;;------------------------------------------------------------------------------ - - -;;------------------------------------------------------------------------------ -;; External LIBRARIES -;;------------------------------------------------------------------------------ - -#+FRANKG -(eval-when (:load-toplevel :compile-toplevel :execute) - #+asdf (progn - #-cffi (progn - (asdf:operate 'asdf:load-op :cffi) - (use-package :cffi)) - #-cl-opengl (progn - (asdf:operate 'asdf:load-op :cl-opengl) - (use-package :cl-opengl)) - #-cells (progn - (asdf:operate 'asdf:load-op :cells) - (use-package :cells)) - ) - ) - - ;; Tcl/Tk (define-foreign-library Tcl @@ -57,19 +32,7 @@ (:windows (:or "/tcl/bin/tk85.dll")) (:unix "libtk.so") (t (:default "libtk"))) - -;; Togl -(define-foreign-library Togl - (:darwin (:or "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib")) - (:windows (:or "/tcl/lib/togl/togl17.dll")) - (:unix "/usr/lib/Togl1.7/libTogl1.7.so")) - -;;; wait till Stu confirms (use-foreign-library Togl) - -;; Togl -(define-foreign-library Togl - (:darwin (:or "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib")) - (:windows (:or "/tcl/lib/togl/togl17.dll"))) + (defctype tcl-retcode :int) @@ -84,44 +47,23 @@ ;; --- initialization ---------------------------------------- -(defcfun ("Tcl_FindExecutable" %Tcl_FindExecutable) :void +(defcfun ("Tcl_FindExecutable" tcl-find-executable) :void (argv0 :string)) -(defun Tcl_FindExecutable () - (with-foreign-string (argv0-cstr (argv0)) - (%Tcl_FindExecutable argv0-cstr))) - -;; Tcl_Init - (defcfun ("Tcl_Init" Tcl_Init) tcl-retcode (interp :pointer)) -;; Tk_Init - (defcfun ("Tk_Init" Tk_Init) tcl-retcode (interp :pointer)) -;; Tcl_SetVal -(defcfun ("Tcl_GetVar" tcl-get-var) :string (interp :pointer)(varName :string)(flags :int)) - -(defcfun ("Tcl_SetVar" tcl-set-var) :string - (interp :pointer) - (var-name :string) - (new-value :string) - (flags :int)) - (defcallback Tk_AppInit tcl-retcode ((interp :pointer)) (tk-app-init interp)) - -;; Tcl_AppInit (defun tk-app-init (interp) (Tcl_Init interp) (Tk_Init interp) - ;;(format t "~%*** Tk_AppInit has been called.~%") - ;; Return OK (foreign-enum-value 'tcl-retcode-values :tcl-ok)) @@ -146,7 +88,17 @@ (defcfun ("Tcl_DeleteInterp" tcl-delete-interp) :void (interp :pointer)) -;; Tcl_EvalFile +;;; --- windows ---------------------------------- + +(defcfun ("Tk_GetNumMainWindows" tk-get-num-main-windows) :int) +(defcfun ("Tk_MainWindow" tk-main-window) :pointer (interp :pointer)) + +(defcfun ("Tk_NameToWindow" tk-name-to-window) :pointer + (interp :pointer) + (pathName :string) + (related-tkwin :pointer)) + +;;; --- eval ----------------------------------------------- (defcfun ("Tcl_EvalFile" %Tcl_EvalFile) tcl-retcode (interp :pointer) @@ -169,16 +121,16 @@ (defun tcl-eval-ex (i s) (tcl_evalex i s -1 0)) -(defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string - (interp :pointer)) - -(defcfun ("Tk_GetNumMainWindows" tk-get-num-main-windows) :int) -(defcfun ("Tk_MainWindow" tk-main-window) :pointer (interp :pointer)) +(defcfun ("Tcl_GetVar" tcl-get-var) :string (interp :pointer)(varName :string)(flags :int)) -(defcfun ("Tk_NameToWindow" tk-name-to-window) :pointer +(defcfun ("Tcl_SetVar" tcl-set-var) :string (interp :pointer) - (pathName :string) - (related-tkwin :pointer)) + (var-name :string) + (new-value :string) + (flags :int)) + +(defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string + (interp :pointer)) ;; ---------------------------------------------------------------------------- ;; Tcl_CreateCommand - used to implement direct callbacks @@ -215,67 +167,6 @@ (channelName :string) (modePtr :pointer)) -;;; --- Togl (Version 1.7 and above needed!) ----------------------------- - - -(defcfun ("Togl_Init" Togl_Init) tcl-retcode - (interp :pointer)) - -(defcfun ("Togl_CreateFunc" Togl_CreateFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_DisplayFunc" Togl_DisplayFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_ReshapeFunc" Togl_ReshapeFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_DestroyFunc" Togl_DestroyFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_TimerFunc" Togl_TimerFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_PostRedisplay" Togl_PostRedisplay) :void - (togl-struct-ptr :pointer)) - -(defcfun ("Togl_SwapBuffers" Togl_SwapBuffers) :void - (togl-struct-ptr :pointer)) - -(defcfun ("Togl_Ident" Togl-Ident) :string - (togl-struct-ptr :pointer)) - -(defcfun ("Togl_Width" Togl_Width) :int - (togl-struct-ptr :pointer)) - -(defcfun ("Togl_Height" Togl_Height) :int - (togl-struct-ptr :pointer)) - -(defcfun ("Togl_Interp" Togl_Interp) :pointer - (togl-struct-ptr :pointer)) - -;; Togl_AllocColor -;; Togl_FreeColor - -;; Togl_LoadBitmapFont -;; Togl_UnloadBitmapFont - -;; Togl_SetClientData -;; Togl_ClientData - -;; Togl_UseLayer -;; Togl_ShowOverlay -;; Togl_HideOverlay -;; Togl_PostOverlayRedisplay -;; Togl_OverlayDisplayFunc -;; Togl_ExistsOverlay -;; Togl_GetOverlayTransparentValue -;; Togl_IsMappedOverlay -;; Togl_AllocColorOverlay -;; Togl_FreeColorOverlay -;; Togl_DumpToEpsFile - - ;; Initialization mgmt - required to avoid multiple library loads (defvar *initialized* nil) @@ -287,16 +178,16 @@ (setq *initialized* nil)) (defun argv0 () - #+allegro (sys:command-line-argument 0) - #+lispworks (nth 0 (io::io-get-command-line-arguments)) - #+sbcl (nth 0 sb-ext:*posix-argv*)) + #+allegro (sys:command-line-argument 0) + #+lispworks (nth 0 system:*line-arguments-list*) ;; portable to OS X + #+sbcl (nth 0 sb-ext:*posix-argv*)) (defun tk-interp-init-ensure () (unless *initialized* (use-foreign-library Tcl) (use-foreign-library Tk) (use-foreign-library Togl) - (Tcl_FindExecutable) + (tcl-find-executable (argv0)) (set-initialized))) ;; Send a script to a piven Tcl/Tk interpreter @@ -304,19 +195,5 @@ (defun eval-script (interp script) (assert interp) (assert script) - (tcl-eval interp script)) - - -;;; Togl stuff - -(defparameter *togl-initialized* nil - "Flag, t if Togl is considered initialized") - -;; Callbacks, global - -(defctype togl-struct-ptr-type :pointer) - - - --- /project/cells/cvsroot/Celtk/togl.lisp 2006/05/24 20:38:54 1.6 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/05/26 17:50:36 1.7 @@ -1,7 +1,7 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| - Celtk -- Cells, Tcl, and Tk + Togl Bindings and Cells/Tk Interfaces Copyright (C) 2006 by Kenneth Tilton @@ -16,36 +16,74 @@ |# - (in-package :celtk) -;;;(defctype tcl-retcode :int) -;;; -;;;(defcenum tcl-retcode-values -;;; (:tcl-ok 0) -;;; (:tcl-error 1)) -;;; -;;;(defmethod translate-from-foreign (value (type (eql 'tcl-retcode))) -;;; (unless (eq value (foreign-enum-value 'tcl-retcode-values :tcl-ok)) -;;; (error "*** Tcl error !")) -;;; value) -;;; -;;;(define-foreign-library Tcl -;;; (:windows "/tcl/bin/Tcl84.dll") -;;; (:darwin (:framework "Tcl"))) -;;; -;;;(define-foreign-library Tk -;;; (:windows "/tcl/bin/Tk84.dll") -;;; (:darwin (:framework "Tk"))) -;;; -;;;(defcfun ("Tcl_InitStubs" tcl-init-stubs) :int -;;; (interp :pointer)(version :string)(math-version-exactly :int)) -;;; -;;;(defcfun ("Tk_InitStubs" tk-init-stubs) :int -;;; (interp :pointer)(version :string)(math-version-exactly :int)) -;;; -;;;(defcfun ("Togl_Init" togl-init) tcl-retcode -;;; (interp :pointer)) + +(define-foreign-library Togl + (:darwin (:or "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib")) + (:windows (:or "/tcl/lib/togl/togl17.dll")) + (:unix "/usr/lib/Togl1.7/libTogl1.7.so")) + +(defctype togl-struct-ptr-type :pointer) + +;;; --- Togl (Version 1.7 and above needed!) ----------------------------- + +(defcfun ("Togl_Init" Togl_Init) tcl-retcode + (interp :pointer)) + +(defcfun ("Togl_CreateFunc" Togl_CreateFunc) :void + (togl-callback-ptr :pointer)) + +(defcfun ("Togl_DisplayFunc" Togl_DisplayFunc) :void + (togl-callback-ptr :pointer)) + +(defcfun ("Togl_ReshapeFunc" Togl_ReshapeFunc) :void + (togl-callback-ptr :pointer)) + +(defcfun ("Togl_DestroyFunc" Togl_DestroyFunc) :void + (togl-callback-ptr :pointer)) + +(defcfun ("Togl_TimerFunc" Togl_TimerFunc) :void + (togl-callback-ptr :pointer)) + +(defcfun ("Togl_PostRedisplay" Togl_PostRedisplay) :void + (togl-struct-ptr :pointer)) + +(defcfun ("Togl_SwapBuffers" Togl_SwapBuffers) :void + (togl-struct-ptr :pointer)) + +(defcfun ("Togl_Ident" Togl-Ident) :string + (togl-struct-ptr :pointer)) + +(defcfun ("Togl_Width" Togl_Width) :int + (togl-struct-ptr :pointer)) + +(defcfun ("Togl_Height" Togl_Height) :int + (togl-struct-ptr :pointer)) + +(defcfun ("Togl_Interp" Togl_Interp) :pointer + (togl-struct-ptr :pointer)) + +;; Togl_AllocColor +;; Togl_FreeColor + +;; Togl_LoadBitmapFont +;; Togl_UnloadBitmapFont + +;; Togl_SetClientData +;; Togl_ClientData + +;; Togl_UseLayer +;; Togl_ShowOverlay +;; Togl_HideOverlay +;; Togl_PostOverlayRedisplay +;; Togl_OverlayDisplayFunc +;; Togl_ExistsOverlay +;; Togl_GetOverlayTransparentValue +;; Togl_IsMappedOverlay +;; Togl_AllocColorOverlay +;; Togl_FreeColorOverlay +;; Togl_DumpToEpsFile (eval-when (compile load eval) (export '(togl_swapbuffers togl_postredisplay togl-ptr togl-reshape-func @@ -150,9 +188,6 @@ (def-togl-callback reshape ()) (def-togl-callback destroy ()) (def-togl-callback timer ()) -#+not -(defmethod togl-timer-using-class :after ((self togl)) - (loop until (zerop (ctk::Tcl_DoOneEvent 2)))) (defmethod make-tk-instance ((self togl)) (with-integrity (:client `(:make-tk ,self)) From ktilton at common-lisp.net Fri May 26 17:50:36 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 26 May 2006 13:50:36 -0400 (EDT) Subject: [cells-cvs] CVS Celtk/gears Message-ID: <20060526175036.96C4D3C005@common-lisp.net> Update of /project/cells/cvsroot/Celtk/gears In directory clnet:/tmp/cvs-serv4378/gears Added Files: gears.lisp gears.lpr Log Message: Gears demo at last --- /project/cells/cvsroot/Celtk/gears/gears.lisp 2006/05/26 17:50:36 NONE +++ /project/cells/cvsroot/Celtk/gears/gears.lisp 2006/05/26 17:50:36 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; gears.lisp --- Celtk/Togl version of cl-opengl Lisp version of gears.c (GLUT Mesa demos). ;;; ;;; Simple program with rotating 3-D gear wheels. (defpackage :gears (:use :common-lisp :utils-kt :cells :celtk)) (in-package :gears) (defvar *startx*) (defvar *starty*) (defvar *xangle0*) (defvar *yangle0*) (defvar *xangle*) (defvar *yangle*) (defparameter *vTime* 100) (defun gears () ;; ACL project manager needs a zero-argument function, in project package (let ((*startx* nil) (*starty* nil) (*xangle0* nil) (*yangle0* nil) (*xangle* 0.2) (*yangle* 0.0)) (test-window 'gears-demo))) (defmodel gears-demo (window) ((gear-ct :initform (c-in 1) :accessor gear-ct :initarg :gear-ct) (scale :initform (c-in 1) :accessor scale :initarg :scale)) (:default-initargs :title$ "Rotating Gear Widget Test" :kids (c? (the-kids (mk-stack (:packing (c?pack-self "-side left -fill both")) (mk-label :text "Click and drag to rotate image") (mk-row () (mk-label :text "Spin delay (ms):") (mk-entry :id :vtime :md-value (c-in "10")) (mk-button-ex (" Quit " (tk-eval "destroy .")))) (make-instance 'gears :fm-parent *parent* :width 400 :height 400 :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" :event-handler (c? (lambda (self xe) (case (tk-event-type (xsv type xe)) (:virtualevent (trc "canvas virtual" (xsv name xe))) (:buttonpress (RotStart self (xsv x-root xe) (xsv y-root xe))) (:motionnotify (RotMove self (xsv x-root xe) (xsv y-root xe))) (:buttonrelease (setf *startx* nil))))))))))) (defun RotStart (self x y) (setf *startx* x) (setf *starty* y) (setf *xangle0* (rotx self)) (setf *yangle0* (roty self))) (defun RotMove (self x y) (when *startx* (setf *xangle* (+ *xangle0* (- x *startx*))) (setf *yangle* (+ *yangle0* (- y *starty*))) (setf (rotx self) *xangle*) (setf (roty self) *yangle*))) (defconstant +pif+ (coerce pi 'single-float)) (defmodel gears (togl) ((rotx :initform (c-in 40) :accessor rotx :initarg :rotx) (roty :initform (c-in 25) :accessor roty :initarg :roty) (rotz :initform (c-in 10) :accessor rotz :initarg :rotz) (gear1 :initarg :gear1 :accessor gear1 :initform (c_? (trc "making list!!!!! 1") (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) (draw-gear 1.0 4.0 1.0 20 0.7)) dl))) (gear2 :initarg :gear2 :accessor gear2 :initform (c_? (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0)) (draw-gear 0.5 2.0 2.0 10 0.7)) dl))) (gear3 :initarg :gear3 :accessor gear3 :initform (c_? (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0)) (draw-gear 1.3 2.0 0.5 10 0.7)) dl))) (angle :initform (c-in 0.0) :accessor angle :initarg :angle) (frame-count :cell nil :initform 0 :accessor frame-count) (t0 :cell nil :initform 0 :accessor t0) ; (width :initarg :wdith :initform 400 :accessor width) (height :initarg :wdith :initform 400 :accessor height))) (defmethod togl-timer-using-class ((self gears)) (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time)) (incf (^angle) 5.0) (Togl_PostRedisplay (togl-ptr self)) ;(loop until (zerop (ctk::Tcl_DoOneEvent 2))) ) (defmethod togl-create-using-class ((self gears)) (gl:light :light0 :position #(5.0 5.0 10.0 0.0)) (gl:enable :cull-face :lighting :light0 :depth-test) (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) (gl:enable :normalize) (truc self)) (defmethod togl-reshape-using-class ((self gears)) (trc "reshape") (truc self t) ) (defun truc (self &optional truly) (let ((width (Togl_width (togl-ptr self))) (height (Togl_height (togl-ptr self)))) (trc "enter gear reshape" self width (width self)) (gl:viewport 0 (- height (height self)) (width self) (height self)) (unless truly (gl:matrix-mode :projection) (gl:load-identity) (let ((h (/ height width))) (gl:frustum -1 1 (- h) h 5 60))) (progn (gl:matrix-mode :modelview) (gl:load-identity) (gl:translate 0 0 -30)))) (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo)))) (declare (ignorable scale)) (gl:clear-color 0 0 0 1) (gl:clear :color-buffer-bit :depth-buffer-bit) (gl:with-pushed-matrix (gl:rotate (^rotx) 1 0 0) (gl:rotate (^roty) 0 1 0) (gl:rotate (^rotz) 0 0 1) (gl:with-pushed-matrix (gl:translate -3 -2 0) (gl:rotate (^angle) 0 0 1) (gl:call-list (^gear1))) (gl:with-pushed-matrix (gl:translate 3.1 -2 0) (gl:rotate (- (* -2 (^angle)) 9) 0 0 1) (gl:call-list (^gear2))) (gl:with-pushed-matrix ; gear3 (gl:translate -3.1 4.2 0.0) (gl:rotate (- (* -2 (^angle)) 25) 0 0 1) (gl:call-list (^gear3)))) (Togl_SwapBuffers (togl-ptr self)) #+shhh (print-frame-rate self)) (defun draw-gear (inner-radius outer-radius width n-teeth tooth-depth) "Draw a gear." (declare (single-float inner-radius outer-radius width tooth-depth) (fixnum n-teeth)) (let ((r0 inner-radius) (r1 (- outer-radius (/ tooth-depth 2.0))) (r2 (+ outer-radius (/ tooth-depth 2.0))) (da (/ (* 2.0 +pif+) n-teeth 4.0))) (gl:shade-model :flat) (gl:normal 0 0 1) ;; Draw front face. (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))) ;; Draw front sides of teeth. (gl:with-primitives :quads (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))) (gl:normal 0 0 -1) ;; Draw back face. (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))))) ;; Draw back sides of teeth. (gl:with-primitives :quads (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5))))) ;; Draw outward faces of teeth. (gl:with-primitives :quad-strip (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5)) (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle)))) (len (sqrt (+ (* u u) (* v v))))) (setq u (/ u len)) (setq v (/ u len)) (gl:normal v (- u) 0.0) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5)) (gl:normal (cos angle) (sin angle) 0.0) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5)) (setq u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da)))))) (setq v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da)))))) (gl:normal v (- u) 0.0) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5)) (gl:normal (cos angle) (sin angle) 0.0)))) (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5)) (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* (- width) 0.5))) ;; Draw inside radius cylinder. (gl:shade-model :smooth) (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:normal (- (cos angle)) (- (sin angle)) 0.0) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* (- width) 0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))))))) (defun print-frame-rate (window) (with-slots (frame-count t0) window (incf frame-count) (let ((time (get-internal-real-time))) (when (= t0 0) (setq t0 time)) (when (>= (- time t0) (* 5 internal-time-units-per-second)) (let* ((seconds (/ (- time t0) internal-time-units-per-second)) (fps (/ frame-count seconds))) (declare (ignorable fps)) #+shh (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%" frame-count seconds fps)) (setq t0 time) (setq frame-count 0))))) --- /project/cells/cvsroot/Celtk/gears/gears.lpr 2006/05/26 17:50:36 NONE +++ /project/cells/cvsroot/Celtk/gears/gears.lpr 2006/05/26 17:50:36 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :GEARS) (define-project :name :gears :modules (list (make-instance 'module :name "gears.lisp")) :projects (list (make-instance 'project-module :name "..\\CELTK") (make-instance 'project-module :name "C:\\1-devtools\\cl-opengl\\glu")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :gears :main-form nil :compilation-unit t :verbose nil :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.check-box :cg.choice-list :cg.choose-printer :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate :cg.printing :cg.progress-indicator :cg.project-window :cg.property :cg.radio-button :cg.rich-edit :cg.rich-edit-pane :cg.rich-edit-pane.clipboard :cg.rich-edit-pane.printing :cg.sample-file-menu :cg.scaling-stream :cg.scroll-bar :cg.scroll-bar-mixin :cg.selected-object :cg.shortcut-menu :cg.static-text :cg.status-bar :cg.string-dialog :cg.tab-control :cg.template-string :cg.text-edit-pane :cg.text-edit-pane.file-io :cg.text-edit-pane.mark :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray :cg.up-down-control :cg.utility-dialog :cg.web-browser :cg.web-browser.dde :cg.wrap-string :cg.yes-no-list :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:top-level :debugger) :build-flags '(:allow-runtime-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+M +t \"Console for Debugging\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'gears::gears :on-restart 'do-default-restart) ;; End of Project Definition From ktilton at common-lisp.net Fri May 26 18:02:02 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 26 May 2006 14:02:02 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060526180202.587EA7D005@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv6466 Modified Files: widget.lisp Removed Files: Gears.lpr textual.lisp Log Message: --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/25 07:12:59 1.10 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/26 18:02:02 1.11 @@ -260,12 +260,6 @@ ;;; --- images ------------------------------------------------------- (defobserver image-files () - ; - ; I do not know how to create the photo for X before X exists - ; though it seems to work. perhaps Tk understands it does not need to - ; place the image in a tree and lets the undefined path go? If so, - ; just add :pre-make-kt before :make-kt in the sort list - ; (loop for (name file-pathname) in (set-difference new-value old-value :key 'car) do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file ~a" (^path) name (tkescape (namestring file-pathname))))) From ktilton at common-lisp.net Sat May 27 06:04:22 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 27 May 2006 02:04:22 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060527060422.215DB3106C@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv7353 Modified Files: CELTK.lpr togl.lisp Log Message: Get destroy callbacks working on Togls --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/24 20:38:54 1.12 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/27 06:04:22 1.13 @@ -10,6 +10,7 @@ (make-instance 'module :name "tk-interp.lisp") (make-instance 'module :name "tk-events.lisp") (make-instance 'module :name "tk-object.lisp") + (make-instance 'module :name "fileevent.lisp") (make-instance 'module :name "widget.lisp") (make-instance 'module :name "font.lisp") (make-instance 'module :name "layout.lisp") @@ -103,7 +104,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'celtk::tk-test + :on-initialization 'celtk::test-fileevent :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/togl.lisp 2006/05/26 17:50:36 1.7 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/05/27 06:04:22 1.8 @@ -98,7 +98,7 @@ ;(assert (not (zerop (tk-init-stubs interp "8.1" 0)))) (togl_init interp) (togl-create-func (callback togl-create)) - ;;; needed? (togl-destroy-func (callback togl-destroy) + (togl-destroy-func (callback togl-destroy)) (togl-display-func (callback togl-display)) (togl-reshape-func (callback togl-reshape)) (togl-timer-func (callback togl-timer)) ;; probably want to make this optional @@ -175,6 +175,7 @@ (let ((,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*)) (gethash (togl-ident ,ptr-var)(dictionary *tkw*))))) , at preamble + (trc nil "selves" ,cb$ (togl-ident ,ptr-var) (gethash (pointer-address ,ptr-var) (tkwins *tkw*))(gethash (togl-ident ,ptr-var)(dictionary *tkw*))) (,(intern uc$) ,self-var)))) (defmethod ,(intern uc$) :around ((self togl)) (if (,(intern cb-slot$) self) @@ -183,7 +184,9 @@ (defmethod ,(intern uc$) ((self togl)))))) (def-togl-callback create () - (setf (togl-ptr self) togl-ptr)) + (setf (togl-ptr self) togl-ptr) + (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self)) + (def-togl-callback display ()) (def-togl-callback reshape ()) (def-togl-callback destroy ()) @@ -195,3 +198,16 @@ (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}" (path self)(tk-configurations self)))) ;; this leads to "togl [- Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv12756 Modified Files: fileevent.lisp Log Message: Changed testing example to use the new slot eval-text of the text widget. See file entry.lisp for more details. --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/25 14:03:44 1.2 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/27 22:25:18 1.3 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.2 2006/05/25 14:03:44 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.3 2006/05/27 22:25:18 fgoenninger Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== @@ -188,6 +188,33 @@ ;;; =========================================================================== (defmethod set-tk-readable ((self tk-fileevent) ch-name path) + +;; frgo, 2006-05-26: +;; The code here was aimed at EOF checking after reading... +;; So the API needs rework... +;; (tk-format-now " proc readable {channel path} { +;; # check for async errors (sockets only, I think) +;; if {[string length [set err [fconfigure $channel -error]]]} { +;; error-cb $path $err +;; close $channel +;; return +;; } +;; # read a line from the channel +;; if {[catch {set line [gets $channel]} err]} { +;; error-cb $path $err +;; close $channel +;; return +;; } +;; if {[string length $line]} { +;; received-cb $path $line +;; } +;; # check for eof +;; if {[eof $channel]} { +;; eof-cb $path +;; close $channel +;; } +;; }") + (tk-format-now "proc readable {channel path} { if [ eof $channel ] then { eof-cb $path } else { readable-cb $path } }") (tk-format-now "fileevent ~A readable [list readable ~A ~A]" ch-name @@ -419,8 +446,7 @@ (let ((data (read-line stream nil nil nil))) (trc "*** READ-FROM-PIPE: data = " data) (when data - (setf (md-value (fm-other :receive-window)) data)))) -) + (setf (md-value (fm-other :receive-window)) data))))) (defmodel fileevent-test-window (window) () @@ -436,7 +462,8 @@ :width 80 :borderwidth 2 :relief 'sunken - :pady 5)) + :pady 5 + :eval-text nil)) (mk-fileevent :id :fileevent-test :read-fn 'read-from-pipe :iostream (open "/Users/frgo/tmp/frgo-test" From fgoenninger at common-lisp.net Sat May 27 22:28:01 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sat, 27 May 2006 18:28:01 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060527222801.39BF824002@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv12824 Modified Files: entry.lisp Log Message: Changed/added: text widget: new slot eval-text. Defaults to t. If nil then upon setting the model value of the text widget the new valiue will be scanned for "dangerous" characters. These are: [?]?{?} Reason: Tcl evaluates text in brackets as commands. This may be dangerous. If any such dangerous character is found it is replaced by a Space character in order to not change the length of the text. --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/24 20:38:54 1.9 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/27 22:28:01 1.10 @@ -68,7 +68,9 @@ (tk-format `(:variable ,self) "set ~a ~s" (^path) new-value)))) (deftk text-widget (widget) - ((modified :initarg :modified :accessor modified :initform nil)) + ((modified :initarg :modified :accessor modified :initform nil) + (eval-text :initarg :eval-text :accessor eval-text :initform (c-in t) + :documentation "Set to nil if you want to make sure text entries do not get evaluated. If set to nil the /dangerous charachters/ will be replaced by space char.")) (:tk-spec text -background -borderwidth -cursor -exportselection (tkfont -font) -foreground @@ -102,8 +104,25 @@ (trc nil "md-value output" self new-value) (with-integrity (:client `(:variable ,self)) (tk-format-now "~a delete 1.0 end" (^path)) - (when (plusp (length new-value)) - (tk-format-now "~a insert end ~s" (^path) new-value)))) + (let ((value nil)) + (when (plusp (length new-value)) + (if (not (^eval-text)) + (setq value (replace-dangerous-chars new-value)) + (setq value new-value)) + (tk-format-now "~a insert end ~s" (^path) value))))) + +;; frgo, 2006-05-27: +;; replace-dangeorous-chars is meant to replace characters in a +;; sequence that would start/end evaluation in Tcl land. +(defun replace-dangerous-chars (seq &optional (dangerous-chars "[]{}")) + (assert (stringp seq)) + (let ((result seq)) + (loop for pos from 0 to (1- (length result)) + do + (let ((c (char result pos))) + (if (find c dangerous-chars) + (setf (char result pos) #\Space)))) + (values result))) ;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=))) @@ -116,7 +135,7 @@ ;;; finally (return ht))))) (defun tk-translate-keysym (keysym$) - (if (= 1 (length keysym$)) + (if (= 1 (length keysym$)) (schar keysym$ 0) (intern (string-upcase keysym$)) #+nah (gethash keysym$ +tk-keysym-table+))) \ No newline at end of file From ktilton at common-lisp.net Sun May 28 15:34:28 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 28 May 2006 11:34:28 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060528153428.343315B017@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv19640 Modified Files: CELTK.lpr Celtk.lisp demos.lisp entry.lisp fileevent.lisp tk-structs.lisp Log Message: Suppress Tcl evaluation of entry and text fields; look for more of these to surface --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/27 06:04:22 1.13 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/28 15:34:27 1.14 @@ -104,7 +104,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'celtk::test-fileevent + :on-initialization 'celtk::tk-test :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/25 15:41:32 1.25 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/28 15:34:27 1.26 @@ -124,6 +124,8 @@ "]" "\\]") "\"" "\\\"")) +(tkescape "[exit]") + (defun tk-format-now (fmt$ &rest fmt-args) (unless (find *tkw* *windows-destroyed*) (let* ((*print-circle* nil) @@ -131,10 +133,10 @@ ; ; --- debug stuff --------------------------------- ; - (let ((yes '( "destroy")) + (let ((yes '( "insert")) (no '())) (declare (ignorable yes no)) - (when nil #+not (and (find-if (lambda (s) (search s tk$)) yes) + (when (and (find-if (lambda (s) (search s tk$)) yes) (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) (assert *tki*) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/25 07:12:59 1.19 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/28 15:34:27 1.20 @@ -20,11 +20,11 @@ (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window - ;;'one-button-window + 'one-button-window ;;'ltktest-cells-inside ;;'menu-button-test ;;'spinbox-test - 'lotsa-widgets + ;;'lotsa-widgets ;; Now in Gears project 'gears-demo )) @@ -33,22 +33,22 @@ (:default-initargs :kids (c? (the-kids (mk-menubar - :kids (c? (the-kids - (mk-menu-entry-cascade-ex (:label "File") - (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) - (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) + :kids (c? (the-kids + (mk-menu-entry-cascade-ex (:label "File") + (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) + (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) (mk-frame-stack :packing (c?pack-self) :kids (c? (the-kids (mk-text-widget :id :my-text - :md-value (c?n "hello, world") + :md-value (c?n "[bzbzbzbz]") :height 8 :width 25) - ;;; (make-instance 'entry - ;;; :id :entree - ;;; :fm-parent *parent* - ;;; :md-value (c-in "Boots")) + (make-instance 'entry + :id :entree + :fm-parent *parent* + :md-value (c-in "Boots")) ;;; (make-instance 'button ;;; :fm-parent *parent* ;;; :text "read" --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/27 22:28:01 1.10 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/28 15:34:27 1.11 @@ -48,7 +48,7 @@ (tcl-get-string (xsv user-data xe)))) ;; assuming write op, but data field shows that (let ((new-value (tcl-get-var *tki* (^path) - (var-flags :TCL_NAMESPACE_ONLY)))) + (var-flags :TCL-NAMESPACE-ONLY)))) (unless (string= new-value (^md-value)) (setf (^md-value) new-value)))))))) @@ -65,7 +65,7 @@ (when new-value (unless (string= new-value old-value) (trc nil "md-value output" self new-value) - (tk-format `(:variable ,self) "set ~a ~s" (^path) new-value)))) + (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY))))) (deftk text-widget (widget) ((modified :initarg :modified :accessor modified :initform nil) @@ -104,12 +104,8 @@ (trc nil "md-value output" self new-value) (with-integrity (:client `(:variable ,self)) (tk-format-now "~a delete 1.0 end" (^path)) - (let ((value nil)) - (when (plusp (length new-value)) - (if (not (^eval-text)) - (setq value (replace-dangerous-chars new-value)) - (setq value new-value)) - (tk-format-now "~a insert end ~s" (^path) value))))) + (when (plusp (length new-value)) + (tk-format-now "~a insert end {~a}" (^path) new-value)))) ;; kt060528: simple {} seems to block evaluation ;; frgo, 2006-05-27: ;; replace-dangeorous-chars is meant to replace characters in a @@ -123,6 +119,7 @@ (if (find c dangerous-chars) (setf (char result pos) #\Space)))) (values result))) +>>>>>>> 1.10 ;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=))) --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/27 22:25:18 1.3 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/28 15:34:27 1.4 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.3 2006/05/27 22:25:18 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.4 2006/05/28 15:34:27 ktilton Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== @@ -352,7 +352,7 @@ (interp :pointer) (argc :int) (argv :pointer)) - (declare (ignorable clientData argc interp)) + (declare (ignore clientData argc interp)) (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^read-fn)) @@ -364,7 +364,7 @@ (interp :pointer) (argc :int) (argv :pointer)) - (declare (ignorable clientData argc interp)) + (declare (ignore clientData argc interp)) (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^write-fn)) @@ -376,7 +376,8 @@ (interp :pointer) (argc :int) (argv :pointer)) - (declare (ignorable clientData interp argc)) + (declare (ignore clientData interp argc)) + (trc "eof!!!!!") (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^eof-fn)) @@ -466,7 +467,7 @@ :eval-text nil)) (mk-fileevent :id :fileevent-test :read-fn 'read-from-pipe - :iostream (open "/Users/frgo/tmp/frgo-test" + :iostream (open "/0dev/hw.txt" ;;; Adapt here !!! ^^^^^^^^^^^^^^^^^^^^^^^^^^^ :direction :input)))))) @@ -475,3 +476,6 @@ (trc "-----------------------------------------------------------------------------") (test-window 'fileevent-test-window) (trc "-----------------------------------------------------------------------------")) + +#+test +(test-window 'fileevent-test-window) \ No newline at end of file --- /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/05/24 20:38:54 1.2 +++ /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/05/28 15:34:27 1.3 @@ -132,23 +132,23 @@ (:tcl-all-events -3)) (defcenum tcl-variable-related-flag - "Flags passed to getvar, setvar, tracevar, etc" - (:TCL_GLOBAL_ONLY 1) - (:TCL_NAMESPACE_ONLY 2) - (:TCL_APPEND_VALUE 4) - (:TCL_LIST_ELEMENT 8) - (:TCL_TRACE_READS #x10) - (:TCL_TRACE_WRITES #x20) - (:TCL_TRACE_UNSETS #x40) - (:TCL_TRACE_DESTROYED #x80) - (:TCL_INTERP_DESTROYED #x100) - (:TCL_LEAVE_ERR_MSG #x200) - (:TCL_TRACE_ARRAY #x800) - ;; Required to support old variable/vdelete/vinfo traces */ - (:TCL_TRACE_OLD_STYLE #x1000) - ;; Indicate the semantics of the result of a trace */ - (:TCL_TRACE_RESULT_DYNAMIC #x8000) - (:TCL_TRACE_RESULT_OBJECT #x10000)) + "flags passed to getvar, setvar, tracevar, etc" + (:tcl-global-only 1) + (:tcl-namespace-only 2) + (:tcl-append-value 4) + (:tcl-list-element 8) + (:tcl-trace-reads #x10) + (:tcl-trace-writes #x20) + (:tcl-trace-unsets #x40) + (:tcl-trace-destroyed #x80) + (:tcl-interp-destroyed #x100) + (:tcl-leave-err-msg #x200) + (:tcl-trace-array #x800) + ;; required to support old variable/vdelete/vinfo traces */ + (:tcl-trace-old-style #x1000) + ;; indicate the semantics of the result of a trace */ + (:tcl-trace-result-dynamic #x8000) + (:tcl-trace-result-object #x10000)) (defun var-flags (&rest kws) (apply '+ (loop for kw in kws From fgoenninger at common-lisp.net Sun May 28 23:40:32 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 28 May 2006 19:40:32 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060528234032.509C92B02A@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv18540 Modified Files: entry.lisp Log Message: Removed function replace-dangerous-chars. Removed slot eval-text from text widget. --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/28 15:34:27 1.11 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/28 23:40:32 1.12 @@ -16,6 +16,8 @@ |# +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.12 2006/05/28 23:40:32 fgoenninger Exp $ + (in-package :Celtk) ;---------------------------------------------------------------------------- @@ -68,9 +70,7 @@ (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY))))) (deftk text-widget (widget) - ((modified :initarg :modified :accessor modified :initform nil) - (eval-text :initarg :eval-text :accessor eval-text :initform (c-in t) - :documentation "Set to nil if you want to make sure text entries do not get evaluated. If set to nil the /dangerous charachters/ will be replaced by space char.")) + ((modified :initarg :modified :accessor modified :initform nil)) (:tk-spec text -background -borderwidth -cursor -exportselection (tkfont -font) -foreground @@ -106,20 +106,8 @@ (tk-format-now "~a delete 1.0 end" (^path)) (when (plusp (length new-value)) (tk-format-now "~a insert end {~a}" (^path) new-value)))) ;; kt060528: simple {} seems to block evaluation - -;; frgo, 2006-05-27: -;; replace-dangeorous-chars is meant to replace characters in a -;; sequence that would start/end evaluation in Tcl land. -(defun replace-dangerous-chars (seq &optional (dangerous-chars "[]{}")) - (assert (stringp seq)) - (let ((result seq)) - (loop for pos from 0 to (1- (length result)) - do - (let ((c (char result pos))) - (if (find c dangerous-chars) - (setf (char result pos) #\Space)))) - (values result))) ->>>>>>> 1.10 + ;; Yes, it does. But we had to change ~s to ~a also in order to prevent + ;; side effects - frgo 2006-05-29 1:30 am ;-) ;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=))) From fgoenninger at common-lisp.net Sun May 28 23:45:03 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 28 May 2006 19:45:03 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060528234503.2367C2E1AC@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv18944 Modified Files: Celtk.lisp Log Message: Commented out debug stuff in tk-format-now. Added Header info tag at beginning of file. --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/28 15:34:27 1.26 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/28 23:45:03 1.27 @@ -16,6 +16,7 @@ |# +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.27 2006/05/28 23:45:03 fgoenninger Exp $ (defpackage :celtk (:nicknames "CTK") @@ -133,6 +134,16 @@ ; ; --- debug stuff --------------------------------- ; +<<<<<<< Celtk.lisp +;; (let ((yes '( "insert" "end")) +;; (no '())) +;; (declare (ignorable yes no)) +;; (when (and (find-if (lambda (s) (search s tk$)) yes) +;; (not (find-if (lambda (s) (search s tk$)) no))) +;; (format t "~&tk> ~a~%" tk$)) +;; (break)) +;; (assert *tki*) +======= (let ((yes '( "insert")) (no '())) (declare (ignorable yes no)) @@ -140,6 +151,7 @@ (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) (assert *tki*) +>>>>>>> 1.26 ; --- end debug stuff ------------------------------ ; ; --- serious stuff --- From fgoenninger at common-lisp.net Sun May 28 23:47:24 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 28 May 2006 19:47:24 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060528234724.CD0942F00A@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv20152 Modified Files: Celtk.lisp Log Message: CVS playing tricks on me... No change, really. --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/28 23:45:03 1.27 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/28 23:47:24 1.28 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.27 2006/05/28 23:45:03 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.28 2006/05/28 23:47:24 fgoenninger Exp $ (defpackage :celtk (:nicknames "CTK") @@ -134,7 +134,6 @@ ; ; --- debug stuff --------------------------------- ; -<<<<<<< Celtk.lisp ;; (let ((yes '( "insert" "end")) ;; (no '())) ;; (declare (ignorable yes no)) @@ -143,15 +142,6 @@ ;; (format t "~&tk> ~a~%" tk$)) ;; (break)) ;; (assert *tki*) -======= - (let ((yes '( "insert")) - (no '())) - (declare (ignorable yes no)) - (when (and (find-if (lambda (s) (search s tk$)) yes) - (not (find-if (lambda (s) (search s tk$)) no))) - (format t "~&tk> ~a~%" tk$))) - (assert *tki*) ->>>>>>> 1.26 ; --- end debug stuff ------------------------------ ; ; --- serious stuff --- From fgoenninger at common-lisp.net Sun May 28 23:53:57 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 28 May 2006 19:53:57 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060528235357.7A07239003@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv20307 Modified Files: fileevent.lisp Log Message: Changed: function test-fileevent: No more using slot eval-text (this slot is obsolete in the text widget). --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/28 15:34:27 1.4 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/28 23:53:57 1.5 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.4 2006/05/28 15:34:27 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.5 2006/05/28 23:53:57 fgoenninger Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== @@ -463,8 +463,7 @@ :width 80 :borderwidth 2 :relief 'sunken - :pady 5 - :eval-text nil)) + :pady 5)) (mk-fileevent :id :fileevent-test :read-fn 'read-from-pipe :iostream (open "/0dev/hw.txt" From ktilton at common-lisp.net Tue May 30 02:45:41 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 29 May 2006 22:45:41 -0400 (EDT) Subject: [cells-cvs] CVS cells/tutorial Message-ID: <20060530024541.873022E1AA@common-lisp.net> Update of /project/cells/cvsroot/cells/tutorial In directory clnet:/tmp/cvs-serv19816/tutorial Log Message: Directory /project/cells/cvsroot/cells/tutorial added to the repository From ktilton at common-lisp.net Tue May 30 02:47:45 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 29 May 2006 22:47:45 -0400 (EDT) Subject: [cells-cvs] CVS cells/cells-test Message-ID: <20060530024745.58EEC34027@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv19862/cells-test Modified Files: df-interference.lisp test.lisp Log Message: Beginnings of tutorial/porting suite of demonstration/example/regression test code. Also, a fix to core Cells so rules can happen to return multiple values (say by using ROUND as the last form) without tripping over Synapse-handling. --- /project/cells/cvsroot/cells/cells-test/df-interference.lisp 2006/05/12 08:27:39 1.3 +++ /project/cells/cvsroot/cells/cells-test/df-interference.lisp 2006/05/30 02:47:45 1.4 @@ -118,11 +118,3 @@ )) -(defmodel skipper () - ((price :initform (c-in 0) :accessor price) - (max-price :accessor max-price - :initform (c? (if .cache - (max (^price) .cache) - (^price)))) - (half-max :accessor half-max - :initform (c? (floor (^half-max) \ No newline at end of file --- /project/cells/cvsroot/cells/cells-test/test.lisp 2006/03/16 05:22:08 1.4 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2006/05/30 02:47:45 1.5 @@ -98,17 +98,21 @@ () (:default-initargs :md-value (c? (bwhen (ks (^kids)) + ;(trc "chya" (mapcar 'md-value ks)) (apply '+ (mapcar 'md-value ks)))))) (def-cell-test many-useds - (with-integrity () - (let ((i (make-instance 'm-index))) - (loop for n below 100 - do (push (make-instance 'model - :fm-parent i - :md-value (c-in n)) - (kids i))) - (trc "index total" (md-value i))))) + (let ((i (make-instance 'm-index))) + (loop for n below 100 + do (push (make-instance 'model + :fm-parent i + :md-value (c-in n)) + (kids i))) + (trc "index total" (md-value i)) + (ct-assert (= 4950 (md-value i))))) + +#+test +(many-useds) (defmodel m-null () ((aa :initform nil :cell nil :initarg :aa :accessor aa))) From ktilton at common-lisp.net Tue May 30 02:47:45 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 29 May 2006 22:47:45 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20060530024745.B4A3A34027@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv19862 Modified Files: cells.asd cells.lisp cells.lpr md-slot-value.lisp propagate.lisp Log Message: Beginnings of tutorial/porting suite of demonstration/example/regression test code. Also, a fix to core Cells so rules can happen to return multiple values (say by using ROUND as the last form) without tripping over Synapse-handling. --- /project/cells/cvsroot/cells/cells.asd 2006/03/19 00:28:38 1.3 +++ /project/cells/cvsroot/cells/cells.asd 2006/05/30 02:47:45 1.4 @@ -8,7 +8,7 @@ :name "cells" :author "Kenny Tilton " :maintainer "Kenny Tilton " - :licence "MIT Style" + :licence "Lisp LGPL" :description "Cells" :long-description "Cells: a dataflow extension to CLOS." :serial t --- /project/cells/cvsroot/cells/cells.lisp 2006/05/20 06:32:19 1.9 +++ /project/cells/cvsroot/cells/cells.lisp 2006/05/30 02:47:45 1.10 @@ -84,11 +84,11 @@ (define-condition unbound-cell (unbound-slot) ()) (defgeneric slot-value-observe (slotname self new old old-boundp) - #-(or cormanlisp clisp) + #-(or cormanlisp) (:method-combination progn)) #-cells-testing -(defmethod slot-value-observe #-(or cormanlisp clisp) progn +(defmethod slot-value-observe #-(or cormanlisp) progn (slot-name self new old old-boundp) (declare (ignorable slot-name self new old old-boundp))) --- /project/cells/cvsroot/cells/cells.lpr 2006/05/24 20:39:38 1.13 +++ /project/cells/cvsroot/cells/cells.lpr 2006/05/30 02:47:45 1.14 @@ -27,9 +27,7 @@ (make-instance 'module :name "doc\\01-Cell-basics.lisp") (make-instance 'module :name - "doc\\motor-control.lisp") - (make-instance 'module :name - "porting\\do-no-harm.lisp")) + "doc\\motor-control.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/05/20 06:32:19 1.14 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/05/30 02:47:45 1.15 @@ -191,9 +191,9 @@ ; --- data flow propagation ----------- ; - (trc nil "md-sv comparing no-prop" c prior-state absorbed-value prior-value) + (trc nil "md-sv testing propagation" c propagation-code prior-state absorbed-value prior-value) (if (or (eq propagation-code :no-propagate) ;; possible if c is a cell serving as a synapse between two cells - (and (null propagation-code) + (and (not (eq propagation-code :propagate)) (eql prior-state :valid) (c-no-news c absorbed-value prior-value))) (progn --- /project/cells/cvsroot/cells/propagate.lisp 2006/05/20 06:32:19 1.12 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/05/30 02:47:45 1.13 @@ -119,7 +119,7 @@ ,(if (eql (last1 output-body) :test) (let ((temp1 (gensym)) (loc-self (gensym))) - `(defmethod slot-value-observe #-(or clisp cormanlisp) ,(if aroundp :around 'progn) + `(defmethod slot-value-observe #-(or cormanlisp) ,(if aroundp :around 'progn) ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) (let ((,temp1 (bump-output-count ,slotname)) (,loc-self ,(if (listp self-arg) @@ -129,7 +129,7 @@ (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg)) (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg)))) `(defmethod slot-value-observe - #-(or clisp cormanlisp) ,(if aroundp :around 'progn) + #-(or cormanlisp) ,(if aroundp :around 'progn) ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) (declare (ignorable ,@(flet ((arg-name (arg-spec) @@ -138,9 +138,7 @@ (atom arg-spec)))) (list (arg-name self-arg)(arg-name new-varg) (arg-name oldvarg)(arg-name oldvargboundp))))) - , at output-body - ;;broke cells-gtk #+(or clisp cormanlisp) (call-next-method) - ))))) + , at output-body))))) (defmacro bump-output-count (slotname) ;; pure test func `(if (get ',slotname :outputs) From ktilton at common-lisp.net Tue May 30 02:47:45 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 29 May 2006 22:47:45 -0400 (EDT) Subject: [cells-cvs] CVS cells/tutorial Message-ID: <20060530024745.F2D6939004@common-lisp.net> Update of /project/cells/cvsroot/cells/tutorial In directory clnet:/tmp/cvs-serv19862/tutorial Added Files: 01-lesson.lisp 01a-dataflow.lisp 01b-change-handling.lisp 01c-cascade.lisp 02-lesson.lisp 03-ephemeral.lisp test.lisp tutorial.lpr Log Message: Beginnings of tutorial/porting suite of demonstration/example/regression test code. Also, a fix to core Cells so rules can happen to return multiple values (say by using ROUND as the last form) without tripping over Synapse-handling. --- /project/cells/cvsroot/cells/tutorial/01-lesson.lisp 2006/05/30 02:47:45 NONE +++ /project/cells/cvsroot/cells/tutorial/01-lesson.lisp 2006/05/30 02:47:45 1.1 (defmacro cells::ct-assert (form &rest stuff) `(progn (print `(attempting ,',form)) (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff)))) (defpackage #:tu-selfinit (:use :cl :cells)) ;; ;; We will keep making new packages so we can incrementally develop the ;; same class without newer versions stomping on earlier versions (by ;; being in the same package and effectively redefining earlier versions). ;; (in-package #:tu-selfinit) (defmodel rectangle () ((len :initarg :len :accessor len :initform (c? (* 2 (width self)))) (width :initarg :width :initform nil :accessor width)) (:default-initargs :width (c? (/ (len self) 2)))) #+test (cells::ct-assert (eql 21 (width (make-instance 'rectangle :len 42)))) ;;; The first thing we see is that we are not creating something new, we are ;;; merely /extending/ CLOS. defmodel works like defclass in all ways, except for ;;; extensions to provide the behavior of Cells. We see both :initform ;;; and :default-initarg used to provide rules for a slot. We also see ;;; the initarg :len used to override the default initform. ;;; ;;; By extending defclass we (a) retain its expressiveness, and (b) produce ;;; something hopefully easier to learn by developers already familiar with CLOS. ;;; ;;; The first extension we see is that the len initform refers to the ;;; Smalltalk-like anaphoric variable self, to which will be bound ;;; the rectangle instance being initialized. Normally an initform is evaluated ;;; without being able to see the instance, and any initialization requiring ;;; that must be done in the class initializer. --- /project/cells/cvsroot/cells/tutorial/01a-dataflow.lisp 2006/05/30 02:47:45 NONE +++ /project/cells/cvsroot/cells/tutorial/01a-dataflow.lisp 2006/05/30 02:47:45 1.1 (defpackage #:tu-dataflow (:use :cl :cells)) (in-package #:tu-dataflow) (defmodel rectangle () ((len :initarg :len :accessor len :initform (c? (* 2 (width self)))) (width :initarg :width :initform nil :accessor width)) (:default-initargs :width (c? (/ (len self) 2)))) #+test (let ((r (make-instance 'rectangle :len (c-in 42)))) (cells::ct-assert (eql 21 (width r))) (cells::ct-assert (= 1000 (setf (len r) 1000))) ;; make sure we did not break SETF, which must return the value set (cells::ct-assert (eql 500 (width r)))) ;; make sure new value propagated --- /project/cells/cvsroot/cells/tutorial/01b-change-handling.lisp 2006/05/30 02:47:45 NONE +++ /project/cells/cvsroot/cells/tutorial/01b-change-handling.lisp 2006/05/30 02:47:45 1.1 #| There is the fun part: automatic state management. Not only can a slot get its value from a self-aware rule, but that value will stay current with other values as they change. But often changes to a value must be reflected outside the automatic dataflow model. See next. |# (defpackage #:tu-change-handling (:use :cl :cells)) (in-package #:tu-change-handling) (defmodel rectangle () ((len :initarg :len :accessor len :initform (c? (* 2 (width self)))) (width :initarg :width :initform nil :accessor width)) (:default-initargs :width (c? (/ (len self) 2)))) (defvar *gui-told*) (defobserver len ((self rectangle) new-value old-value old-value-bound-p) ;; Where rectangle is a GUI element, we need to tell the GUI framework ;; to update this area of the screen (setf *gui-told* t) (print (list "tell GUI about" self new-value old-value old-value-bound-p))) #+test (let* ((*gui-told* nil) (r (make-instance 'rectangle :len (c-in 42)))) (cells::ct-assert *gui-told*) (setf *gui-told* nil) (cells::ct-assert (eql 21 (width r))) (cells::ct-assert (= 1000 (setf (len r) 1000))) (cells::ct-assert *gui-told*) (cells::ct-assert (eql 500 (width r)))) --- /project/cells/cvsroot/cells/tutorial/01c-cascade.lisp 2006/05/30 02:47:45 NONE +++ /project/cells/cvsroot/cells/tutorial/01c-cascade.lisp 2006/05/30 02:47:45 1.1 #| Now we have automatic state management (including change propagation) outside the Cells model as well as in. Now lets look at cascading change by adding another level of computation, so A->B->C. [Actually, I see I need to make this a little deeper, since area has a direct dependency on width. Not tonight. :)] |# (defpackage #:tu-depth (:use :cl :cells)) (in-package #:tu-depth) (defmodel rectangle () ((area :initarg :area :accessor area :initform (c? (print :compue-area) (* (len self)(width self)))) (len :initarg :len :accessor len :initform (c? (print :compute-len) (* 2 (width self)))) (width :initarg :width :accessor width :initform (c? (print :compute-width) (floor (len self) 2))))) #+test (let ((r (make-instance 'rectangle :len (c-in 42)))) (cells::ct-assert (eql 21 (width r))) (cells::ct-assert (eql (* 21 42) (area r))) (cells::ct-assert (= 1000 (setf (len r) 1000))) (cells::ct-assert (eql 500000 (area r)))) --- /project/cells/cvsroot/cells/tutorial/02-lesson.lisp 2006/05/30 02:47:45 NONE +++ /project/cells/cvsroot/cells/tutorial/02-lesson.lisp 2006/05/30 02:47:45 1.1 #| A->B->C works. For efficiency, let's have propagation stop if some rule computes the same value as last time. |# (defpackage #:tu-smart-propagation (:use :cl :cells :utils-kt :tu-cells)) (in-package #:tu-smart-propagation) ;;; ----------------------------------------------- (defmodel rectangle () ((padded-width :initarg :padded-width :accessor padded-width :initform (c? (compute-log :padded-width) (+ 10 (width self)))) (len :initarg :len :accessor len :initform (c? (compute-log :len) (* 2 (width self)))) (width :initarg :width :accessor width :initform (c? (compute-log :width) (floor (len self) 2))))) (defobserver width () (assert (not (eql new-value old-value))) (TRC "observing width" new-value old-value) (compute-log :width-observer)) (defobserver len () (compute-log :len-observer)) #+test (let* ((r (progn (CELLS-RESET) (clear-computed) (make-instance 'rectangle :len (c-in 42))))) (cells::ct-assert (eql 21 (width r))) ;; first check that setting an input cell does not ;; propagate needlessly... (clear-computed) (verify-not-computed :len-observer :width :width-observer :padded-width) (setf (len r) 42) ;; n.b. same as existing value, no change (cells::ct-assert (eql 21 (width r))) ;; floor truncates (verify-not-computed :len-observer :width :width-observer :padded-width) ;; now check that intermediate computations, when unchanged ;; from the preceding computation, does not propagate needlessly... (clear-computed) (setf (len r) 43) (cells::ct-assert (eql 21 (width r))) ;; floor truncates (verify-computed :len-observer :width) (verify-not-computed :width-observer :padded-width) #| Ok, so the engine runs the width rule, sees that it computes the same value as before, so does not invoke either the width observer or recalculation of are. Very efficient. The sanity check reconfirms that the engine does do that work when necessary. |# (clear-computed) (setf (len r) 44) (verify-computed :len-observer :width :width-observer :padded-width)) --- /project/cells/cvsroot/cells/tutorial/03-ephemeral.lisp 2006/05/30 02:47:45 NONE +++ /project/cells/cvsroot/cells/tutorial/03-ephemeral.lisp 2006/05/30 02:47:45 1.1 (defpackage #:tu-ephemeral (:use :cl :utils-kt :cells :tu-cells)) (in-package #:tu-ephemeral) #| Events present a problem for spreadsheet models. Suppose we have a clicked rule for a button which says: :clicked (c? (point-in-rect (screen-location (mouse-event *window*)) (bounding-box self))) Now suppose we get a mouse-event outside the bounding box of widget X, and then in the next application event something happens that makes the bounding box grow such that it includes the location of the old mouse event. We need the mouse-event not to be there any more, because, well, events are events. It is relevant only in the moment of its creation and propagation. Note, btw, that this must happen not as bang-bang: (setf (mouse-event *window*) (get-next-event) (setf (mouse-event *window*) nil) ...because observers can kick off state change, and anyway SETF has interesting Cell semantics, including observers firing. So setf-nil is a kludge, better that the Cells engine acknowledge that events are different and accomodate them by silently reverting an event to nil as soon as it finishes propagating. Finally, so far this has worked out well as a slot attribute as defined at the class level, not instance by instance, by specifying :cell :ephemeral |# (defmodel rectangle () ((click :cell :ephemeral :initform (c-in nil) :accessor click) (bbox :initarg :bbox :initform (c-in nil) :accessor bbox) (clicked :cell :ephemeral :accessor clicked :initform (c? (point-in-rect (^click)(^bbox)))))) (defun point-in-rect (p r) (when (and p r) (destructuring-bind (x y) p (destructuring-bind (l top r b) r (and (<= l x r) (<= b y top)))))) (defobserver click ((self rectangle) new-value old-value old-value-bound-p) (when new-value (with-integrity (:change) (TRC "setting bbox!!!") (setf (bbox self) (list -1000 1000 1000 -1000))))) (defobserver clicked ((self rectangle) new-value old-value old-value-bound-p) (when new-value (TRC "clicked!!!!" self new-value) (compute-log :clicked))) #+test (progn (cells-reset) (let* ((starting-bbox (list 10 10 20 20)) (r (make-instance 'rectangle :bbox (c-in (list 10 10 20 20))))) (clear-computed) (setf (click r) (list 0 0)) (assert (and (not (point-in-rect (list 0 0) starting-bbox)) (point-in-rect (list 0 0)(bbox r)) (verify-not-computed :clicked))))) #| The assertion demonstrates... well, it is complicated. Point 0-0 is in the current bbox, but the system correctly determines that it was not clicked. The click event at 0-0 happened when the bbox was elsewhwer. When the bbox moved, the Cells engine had already cleared the "ephemeral" click. Note that now we have less transparency: if one wants to perturb the data model from with an observer of some ongoing perturbation, one needs to arrange for that nested perturbation to wait until the ongoing one completes. That explains the "with-integrity" macro. |# --- /project/cells/cvsroot/cells/tutorial/test.lisp 2006/05/30 02:47:45 NONE +++ /project/cells/cvsroot/cells/tutorial/test.lisp 2006/05/30 02:47:45 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- ;;; ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (eval-when (compile load) (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) (defpackage #:tu-cells (:use :cl :utils-kt) (:export #:clear-computed #:verify-computed #:verify-not-computed #:compute-log)) (in-package :tu-cells) (defmacro ct-assert (form &rest stuff) `(progn (print `(attempting ,',form)) (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff)))) (defvar *computed*) (defun clear-computed () (setf *computed* nil)) (defun compute-log (&rest keys) (loop for k in keys do (pushnew k *computed*))) (defun verify-computed (&rest keys) (loop for k in keys do (assert (find k *computed*)() "Unable verify ~a computed: ~a" k *computed*))) (defun verify-not-computed (&rest keys) (loop for k in keys do (assert (not (find k *computed*)) () "Unable verify ~a NOT computed: ~a" k *computed*) finally (return t)))--- /project/cells/cvsroot/cells/tutorial/tutorial.lpr 2006/05/30 02:47:45 NONE +++ /project/cells/cvsroot/cells/tutorial/tutorial.lpr 2006/05/30 02:47:45 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :COMMON-GRAPHICS-USER) (define-project :name :tutorial :modules (list (make-instance 'module :name "test.lisp") (make-instance 'module :name "01-lesson.lisp") (make-instance 'module :name "01a-dataflow.lisp") (make-instance 'module :name "01b-change-handling.lisp") (make-instance 'module :name "01c-cascade.lisp") (make-instance 'module :name "02-lesson.lisp") (make-instance 'module :name "03-ephemeral.lisp")) :projects (list (make-instance 'project-module :name "..\\cells")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :common-graphics-user :main-form nil :compilation-unit t :verbose nil :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.check-box :cg.choice-list :cg.choose-printer :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate :cg.printing :cg.progress-indicator :cg.project-window :cg.property :cg.radio-button :cg.rich-edit :cg.rich-edit-pane :cg.rich-edit-pane.clipboard :cg.rich-edit-pane.printing :cg.sample-file-menu :cg.scaling-stream :cg.scroll-bar :cg.scroll-bar-mixin :cg.selected-object :cg.shortcut-menu :cg.static-text :cg.status-bar :cg.string-dialog :cg.tab-control :cg.template-string :cg.text-edit-pane :cg.text-edit-pane.file-io :cg.text-edit-pane.mark :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray :cg.up-down-control :cg.utility-dialog :cg.web-browser :cg.web-browser.dde :cg.wrap-string :cg.yes-no-list :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:top-level :debugger) [12 lines skipped] From fgoenninger at common-lisp.net Wed May 31 05:08:25 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Wed, 31 May 2006 01:08:25 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060531050825.C49BD30021@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv12092 Modified Files: entry.lisp Log Message: Changed: Text widget md-value propagation to Tcl. --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/28 23:40:32 1.12 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/31 05:08:25 1.13 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.12 2006/05/28 23:40:32 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.13 2006/05/31 05:08:25 fgoenninger Exp $ (in-package :Celtk) @@ -100,14 +100,23 @@ (setf (^modified) t))))) )))) +(defmethod clear ((self text-widget)) + (setf (md-value self) nil)) + (defobserver .md-value ((self text-widget)) (trc nil "md-value output" self new-value) (with-integrity (:client `(:variable ,self)) (tk-format-now "~a delete 1.0 end" (^path)) (when (plusp (length new-value)) - (tk-format-now "~a insert end {~a}" (^path) new-value)))) ;; kt060528: simple {} seems to block evaluation + (trc "*** md-value text widget: new-value" new-value) + (tk-format-now "~a insert end {~a}" (^path) new-value)) ;; kt060528: simple {} seems to block evaluation ;; Yes, it does. But we had to change ~s to ~a also in order to prevent ;; side effects - frgo 2006-05-29 1:30 am ;-) + (tk-format-now "update idletasks"))) ;; Causes a display update after each text widget operation. + +;; The beginnings of a new text widget api: +;; (defmethod insert ((self text-widget) &rest args) +;; (tk-format-now )) ;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=))) From fgoenninger at common-lisp.net Wed May 31 05:09:14 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Wed, 31 May 2006 01:09:14 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060531050914.408D330021@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv12140 Modified Files: fileevent.lisp Log Message: Changed:EOF now handled on both sides: in Lisp land and in Tcl land --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/28 23:53:57 1.5 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/31 05:09:14 1.6 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.5 2006/05/28 23:53:57 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.6 2006/05/31 05:09:14 fgoenninger Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== @@ -108,6 +108,11 @@ :initform (c-in nil) :documentation "The eof callback. A dispatcher function used to call the function supplied via the eof-fn slot. - Internal use only.") + (error-cb + :accessor error-cb :initarg :error-cb + :initform (c-in nil) + :documentation "The error callback. A dispatcher function used to call the function supplied via the error-fn slot. - Internal use only.") + (tki :accessor tki :initarg :tki :initform (c-in nil) @@ -131,7 +136,12 @@ (eof-fn :accessor eof-fn :initarg :eof-fn :initform (c-in nil) - :documentation "User supplied function, gets called when iostream is EOF. Gets iostream as parameter. - API: initarg, setf (Via default-initarg set to fn default-eof-fn which simply closes the stream).")) + :documentation "User supplied function, gets called when iostream is EOF. Gets iostream as parameter. - API: initarg, setf (Via default-initarg set to fn default-eof-fn which simply closes the stream).") + + (error-fn + :accessor error-fn :initarg :error-fn + :initform (c-in nil) + :documentation "User supplied function, gets called when iostream has encountntered an error. Gets iostream and error sting as parameters. - API: initarg, setf (Via default-initarg set to fn default-error-fn which simply closes the stream and signals an error of class tcl-error).")) (:default-initargs :id (gensym "tk-fileevent-") @@ -187,11 +197,13 @@ ;;; FILEEVENT HELPER METHODS AND FUCTIONS ;;; =========================================================================== -(defmethod set-tk-readable ((self tk-fileevent) ch-name path) +(defmethod set-tk-readable ((self tk-fileevent) ch-name path type) ;; frgo, 2006-05-26: ;; The code here was aimed at EOF checking after reading... -;; So the API needs rework... +;; So the API needs rework... +;; STATUS: IN WORK +;; ;; (tk-format-now " proc readable {channel path} { ;; # check for async errors (sockets only, I think) ;; if {[string length [set err [fconfigure $channel -error]]]} { @@ -199,7 +211,7 @@ ;; close $channel ;; return ;; } -;; # read a line from the channel +;; # Read a line from the channel ;; if {[catch {set line [gets $channel]} err]} { ;; error-cb $path $err ;; close $channel @@ -214,19 +226,56 @@ ;; close $channel ;; } ;; }") + +;; frgo: Old code snippet: +;; (tk-format-now "proc readable {channel path} { if [ eof $channel ] then { eof-cb $path } else { readable-cb $path } }") +;; (tk-format-now "fileevent ~A readable [list readable ~A ~A]" +;; ch-name +;; ch-name +;; path) + + (trc "tk-set-readable sees ch-name path type" ch-name path type) + (tk-format-now + "proc readable {channel path type} { + + if {! [string compare $type \"socket\"]} { + if {[string length [set err [fconfigure $channel -error]]]} { + error-cb $path $err + close $channel + return + } + } + + readable-cb $path + + catch { if {[eof $channel]} { + eof-cb $path + close $channel + } + } + }") - (tk-format-now "proc readable {channel path} { if [ eof $channel ] then { eof-cb $path } else { readable-cb $path } }") - (tk-format-now "fileevent ~A readable [list readable ~A ~A]" + (tk-format-now "fileevent ~A readable [list readable ~A ~A ~a]" ch-name ch-name - path)) + path + type) +) -(defmethod set-tk-writeable ((self tk-fileevent) ch-name path) - (tk-format-now "proc writeable {channel path} { if [ eof $channel ] then { eof-cb $path } else { readable-cb $path } }") - (tk-format-now "fileevent ~A writeable [list writeable ~A ~A]" +(defmethod set-tk-writeable ((self tk-fileevent) ch-name path type) + (tk-format-now "proc writeable {channel path type} { if [ eof $channel ] then { eof-cb $path } else { writeable-cb $path } }") + (tk-format-now "fileevent ~A writeable [list writeable ~A ~A ~a]" ch-name ch-name - path)) + path + type)) + +;;; =========================================================================== +;;; FILEEVENT CONDITIONS +;;; =========================================================================== + +(define-condition tcl-fileevent-error (error) + ()) ;;; =========================================================================== ;;; OBSERVERS - USED TO SEND UPDATES TO TK LAND @@ -242,14 +291,26 @@ ((:update-input-tk-fileevent) (let* ((channel (in-tcl-channel self)) (path (path self)) - (ch-name (Tcl_GetChannelName channel))) - (set-tk-readable self ch-name path))) + (ch-name (Tcl_GetChannelName channel)) + (ch-type (Tcl_GetChannelType channel))) + (set-tk-readable self + ch-name + path + (foreign-slot-value ch-type + 'Tcl_ChannelType + 'typeName )))) ((:update-output-tk-fileevent) (let* ((channel (out-tcl-channel self)) (path (path self)) - (ch-name (Tcl_GetChannelName channel))) - (set-tk-writeable self ch-name path))) + (ch-name (Tcl_GetChannelName channel)) + (ch-type (Tcl_GetChannelType channel))) + (set-tk-writeable self + ch-name + path + (foreign-slot-value ch-type + 'Tcl_ChannelType + 'typeName)))) ((:reset-input-tk-fileevent) ;; Do nothing @@ -308,6 +369,14 @@ (null-pointer) (null-pointer)))) +(defobserver error-cb ((self tk-fileevent)) + (if new-value + (Tcl_CreateCommand *tki* + "error-cb" + new-value + (null-pointer) + (null-pointer)))) + ;;; =========================================================================== ;;; HELPER FUNCTIONS - FILE DESCRIPTOR TO STREAM AND CHANNEL ;;; =========================================================================== @@ -377,13 +446,27 @@ (argc :int) (argv :pointer)) (declare (ignore clientData interp argc)) - (trc "eof!!!!!") + (trc "EOF-CB !!!") (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^eof-fn)) (funcall fn self))) (values (foreign-enum-value 'tcl-retcode-values :tcl-ok))) +(defcallback error-cb :int + ((clientData :pointer) + (interp :pointer) + (argc :int) + (argv :pointer)) + (declare (ignore clientData interp argc)) + (trc "ERROR-CB !!!") + (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) + (err$ (foreign-string-to-lisp (mem-aref argv :pointer 2))) + (self (gethash path (dictionary *tkw*)))) + (bwhen (fn (^error-fn)) + (funcall fn self err$))) + (values (foreign-enum-value 'tcl-retcode-values :tcl-error))) + ;;; =========================================================================== ;;; MK-FILEEVENT: CONVENIENCE MACRO ;;; =========================================================================== @@ -394,6 +477,7 @@ :readable-cb (get-callback 'readable-cb) :writeable-cb (get-callback 'writeable-cb) :eof-cb (get-callback 'eof-cb) + :error-cb (get-callback 'error-cb) :fm-parent *parent* , at inits)) @@ -403,10 +487,26 @@ ;;; =========================================================================== (defmethod default-eof-fn ((self tk-fileevent)) - ;; Default action: close stream - (bwhen (iostream (^iostream)) - (close iostream) - (setf (^iostream) nil))) + ;; Default action: close stream + (bwhen (iostream (^iostream)) + (with-integrity (:client `(:variable ,self)) + (setf (^iostream) nil) + (close iostream)))) + +;;; =========================================================================== +;;; A DEFAULT ERROR FUNCTION, USER MAY SUPPLY ANOTHER FUNCTION WHEN MAKING THE +;;; INSTANCE OF TK-FILEEVENT +;;; =========================================================================== + +(defmethod default-error-fn ((self tk-fileevent) err$) + (declare (ignorable err$)) + (trc "Heya! Error ~a ... :-(" err$) + ;; Default action 1: close stream + (bwhen (iostream (^iostream)) + (close iostream) + (setf (^iostream) nil)) + ;; Default action 2: signal error + (signal 'tcl-fileevent-error)) ;;; =========================================================================== ;;; TESTING @@ -441,13 +541,18 @@ ;;; ;;; May 2006 -(defmethod read-from-pipe ((self tk-fileevent) &optional (operation :read)) + +;;; This is the User Supplied Read Function USRF. USRF has to take care of +;;; closing the channel if it is a file that is read from !!! +;;; The sample supplied here may serve as a template ... +(defmethod USRF ((self tk-fileevent) &optional (operation :read)) (declare (ignorable operation)) (let ((stream (^iostream))) (let ((data (read-line stream nil nil nil))) - (trc "*** READ-FROM-PIPE: data = " data) - (when data - (setf (md-value (fm-other :receive-window)) data))))) + (trc "*** USRF: data = " data) + (if data + (setf (md-value (fm-other :receive-window)) data) + (funcall (^eof-fn) self))))) (defmodel fileevent-test-window (window) () @@ -465,10 +570,11 @@ :relief 'sunken :pady 5)) (mk-fileevent :id :fileevent-test - :read-fn 'read-from-pipe - :iostream (open "/0dev/hw.txt" + :read-fn 'USRF + :iostream (c-in + (open "/Users/frgo/dribble.lisp" ;;; Adapt here !!! ^^^^^^^^^^^^^^^^^^^^^^^^^^^ - :direction :input)))))) + :direction :input))))))) ;;; Call this function for testing !! (defun test-fileevent () From fgoenninger at common-lisp.net Wed May 31 05:10:30 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Wed, 31 May 2006 01:10:30 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060531051030.424687D022@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv12271 Modified Files: tk-interp.lisp Log Message: Added: CFFI defcfun for Tcl_GetChannelType --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/26 17:50:36 1.12 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/31 05:10:30 1.13 @@ -162,6 +162,10 @@ (defcfun ("Tcl_GetChannelName" Tcl_GetChannelName) :string (channel :pointer)) +(defcfun ("Tcl_GetChannelType" Tcl_GetChannelType) :pointer + (channel :pointer)) + + (defcfun ("Tcl_GetChannel" Tcl_GetChannel) :pointer (interp :pointer) (channelName :string) From fgoenninger at common-lisp.net Wed May 31 05:11:28 2006 From: fgoenninger at common-lisp.net (fgoenninger) Date: Wed, 31 May 2006 01:11:28 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20060531051128.825AA44055@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv12343 Modified Files: tk-structs.lisp Log Message: Added: defcstruct Tcl_Channel --- /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/05/28 15:34:27 1.3 +++ /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/05/31 05:11:28 1.4 @@ -154,3 +154,16 @@ (apply '+ (loop for kw in kws collecting (foreign-enum-value 'tcl-variable-related-flag kw)))) +(defcstruct Tcl_ChannelType + (typeName :string) + (blockModeProc :pointer) + (closeProc :pointer) + (inputProc :pointer) + (outputProc :pointer) + (seekProc :pointer) + (setOptionProc :pointer) + (getOptionProc :pointer) + (watchChannelProc :pointer) + (channelReadyProc :pointer) + (getFileProc :pointer)) +