cells-cvs June 2006

cells-cvs@common-lisp.net

1 participants
44 discussions

[cells-cvs] CVS Celtk
by ktilton 07 Jun '06

07 Jun '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv13881 Modified Files: CELTK.lpr Celtk.asd Celtk.lisp demos.lisp font.lisp item-pictorial.lisp layout.lisp load.lisp lotsa-widgets.lisp ltktest-ci.lisp multichoice.lisp run.lisp scroll.lisp tk-interp.lisp tk-object.lisp tk-structs.lisp widget.lisp Log Message: Resurrect under Lispworks --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/06/03 12:12:19 1.15 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/06/07 22:13:41 1.16 @@ -11,8 +11,8 @@ (make-instance 'module :name "tk-events.lisp") (make-instance 'module :name "tk-object.lisp") (make-instance 'module :name "widget.lisp") - (make-instance 'module :name "font.lisp") (make-instance 'module :name "layout.lisp") + (make-instance 'module :name "font.lisp") (make-instance 'module :name "timer.lisp") (make-instance 'module :name "menu.lisp") (make-instance 'module :name "label.lisp") @@ -35,7 +35,9 @@ :projects (list (make-instance 'project-module :name "..\\cells\\cells") (make-instance 'project-module :name - "C:\\1-devtools\\cffi\\cffi")) + "C:\\1-devtools\\cffi\\cffi") + (make-instance 'project-module :name + "..\\Cells\\gui-geometry\\gui-geometry")) :libraries nil :distributed-files nil :internally-loaded-files nil --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/26 17:50:36 1.9 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/06/07 22:13:41 1.10 @@ -12,7 +12,7 @@ :licence "Lisp LGPL" :description "Tcl/Tk with Cells Inside(tm)" :long-description "A Cells-driven portable GUI, ultimately implmented by Tcl/Tk" - :depends-on (:cells :cffi) + :depends-on (:cells :cffi :gui-geometry) :serial t :components ((:file "Celtk") (:file "tk-structs") @@ -20,8 +20,8 @@ (:file "tk-events") (:file "tk-object") (:file "widget") - (:file "font") (:file "layout") + (:file "font") (:file "timer") (:file "menu") (:file "label") @@ -35,9 +35,9 @@ (:file "item-shaped") (:file "composites") (:file "frame") + (:file "fileevent") (:file "togl") (:file "run") - (:file "fileevent") - (:file "ltktest-ci") + (:file "ltktest-ci") (:file "lotsa-widgets") (:file "demos"))) --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/06/03 12:04:37 1.29 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/06/07 22:13:41 1.30 @@ -16,14 +16,14 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.29 2006/06/03 12:04:37 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.30 2006/06/07 22:13:41 ktilton Exp $ (defpackage :celtk (:nicknames "CTK") (:use :common-lisp :utils-kt :cells :cffi) (:export - #:<1> #:tk-event-type #:xsv #:name #:x-root #:y-root - #:title$ #:pop-up + #:<1> #:tk-event-type #:xsv #:name #:x #:y #:x-root #:y-root + #:title$ #:pop-up #:path #:parent-path #:^keyboard-modifiers #:keyboard-modifiers #: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 @@ -62,7 +62,6 @@ (define-symbol-macro .tkw (nearest self window)) - ; --- tk-format --- talking to wish/Tk ----------------------------------------------------- (defconstant +tk-client-task-priority+ @@ -133,11 +132,12 @@ ; --- debug stuff --------------------------------- ; - (let ((yes '( "photo")) - (no '())) + (let ((yes '()) + (no '("font"))) (declare (ignorable yes no)) - (when (and (find-if (lambda (s) (search s tk$)) yes) - (not (find-if (lambda (s) (search s tk$)) no))) + (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$))) (assert *tki*) @@ -194,7 +194,8 @@ (format nil "{~{~a~^ ~}}" (mapcar 'tk-send-value values))) (defmethod parent-path ((nada null)) "") -(defmethod parent-path ((self t)) (path self)) +(defmethod parent-path ((other t)) "") + ; --- tk eval ---------------------------------------------------- @@ -213,6 +214,9 @@ (tk-format :grouped (apply 'format nil tk-form$ fmt-args)) (parse-tcl-list-result (tcl-get-string-result *tki*))) +#+test +(parse-tcl-list-result "-ascent 58 -descent 15 -linespace 73 -fixed 0") + (defun parse-tcl-list-result (result &aux item items) (when (plusp (length result)) (trc nil "parse-tcl-list-result" result) @@ -239,5 +243,6 @@ else do (gather-item) (setf item nil) else do (push ch item) - finally (return (nreverse items)))))) + finally (gather-item) + (return (nreverse items)))))) \ No newline at end of file --- /project/cells/cvsroot/Celtk/demos.lisp 2006/06/03 12:04:37 1.21 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/06/07 22:13:41 1.22 @@ -18,10 +18,11 @@ (in-package :celtk-user) + (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window ;;'place-test - ;;'one-button-window + ;; 'one-button-window ;;'ltktest-cells-inside ;;'menu-button-test ;;'spinbox-test @@ -34,14 +35,14 @@ (:default-initargs :kids (c? (the-kids (mk-label :text "hi, Mom" - :x 100 - :y 20))))) + :px 100 + :py 20))))) (defmodel one-button-window (window) () (:default-initargs :kids (c? (the-kids - (mk-menubar + #+shhhh (mk-menubar :kids (c? (the-kids (mk-menu-entry-cascade-ex (:label "File") (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) --- /project/cells/cvsroot/Celtk/font.lisp 2006/05/24 20:38:54 1.4 +++ /project/cells/cvsroot/Celtk/font.lisp 2006/06/07 22:13:41 1.5 @@ -22,7 +22,7 @@ (eval-when (compile load eval) (export '(make-tkfinfo tkfinfo-family tkfinfo-size tkfinfo-slant tkfinfo-ascent tkfinfo-linespace tkfinfo-fixed - tkfont-id tkfont-info bounds-offset tkfinfo-ascent tkfont-height tkfont-ascent + tkfont-id tkfont-info tkfinfo-ascent tkfont-height tkfont-ascent tkfinfo-descent ^tkfont-descent ^tkfont-find tkfinfo tkfinfo-em ^tkfont-em line-up line-down tkfont-size-info))) --- /project/cells/cvsroot/Celtk/item-pictorial.lisp 2006/05/24 20:38:54 1.2 +++ /project/cells/cvsroot/Celtk/item-pictorial.lisp 2006/06/07 22:13:41 1.3 @@ -34,7 +34,7 @@ -disabledforeground)) -(deftk image (item) +(deftk image-item (item) () (:tk-spec image -state --- /project/cells/cvsroot/Celtk/layout.lisp 2006/05/24 20:38:54 1.2 +++ /project/cells/cvsroot/Celtk/layout.lisp 2006/06/07 22:13:41 1.3 @@ -27,7 +27,7 @@ This parent is ~a, kids-packing ~a" self (list .parent (type-of .parent)) (kids-packing .parent))) ; ; This use next of the parent instead of self is pretty tricky. It has to do with getting - ; the pack commands out nested widgets before parents. The pack command issued on behalf + ; the pack commands out with nested widgets pacing before parents. The pack command issued on behalf ; of a top frame is sorted on the parent. Now we have to pack the top frame. If we associate ; the command with the frame, the sort is a tie and either might go first. So we continue ; the theme and associate /this/ pack with this top frame's parent. Note that we cannot go the @@ -59,80 +59,3 @@ (loop for config in rows for idx upfrom 0 do (tk-format `(:grid ,self) (format nil "grid rowconfigure ~a ~a ~a" (^path) idx config))))))) - -;;; --- Layout ------------ - -(eval-when (compile load eval) - (export '( b-left b-top b-right b-bottom b-width b-height - l-bounds l-left l-top l-right l-left l-top l-right l-bottom l-width l-height - p-offset ^p-offset p-bounds ^p-bounds p-left p-top p-right p-bottom - make-bounds p-center-vt b-center-vt p-center-hz - c-offset c-bounds offset+))) - -(defun bounds-offset (b x-y) - (destructuring-bind (x y) x-y - (vector (+ (svref b 0) x) - (+ (svref b 1) y) - (+ (svref b 2) x) - (+ (svref b 3) y)))) - -(defun c-offset (self) - (assert (typep self 'item-geometer)() "~a is not typep item-geomete. Type is ~a" self (type-of self)) - (if (or (null .parent) (typep .parent 'canvas)) - (eko (nil "c-offset at top" self (type-of self) .parent) - (progn - (unless .parent (break "no parent for ~a?!" self)) - #+not (when (and (null .parent)(typep self 'mathx::mx-theq)) - (break)) - (^p-offset))) - (offset+ (p-offset self) (c-offset .parent)))) - -(defun c-bounds (self) ;; make this a slot? - (assert (typep self 'item)) - (bounds-offset (l-bounds self) (c-offset self))) - -(defmacro b-left (b) `(svref ,b 0)) -(defmacro b-top (b) `(svref ,b 1)) -(defmacro b-right (b) `(svref ,b 2)) -(defmacro b-bottom (b) `(svref ,b 3)) -(defun b-width (b) (- (b-right b) (b-left b))) -(defun b-height (b) (- (b-bottom b) (b-top b))) - -(defmacro l-left (mx) `(b-left (l-bounds ,mx))) -(defmacro l-top (mx) `(b-top (l-bounds ,mx))) -(defmacro l-right (mx) `(b-right (l-bounds ,mx))) -(defmacro l-bottom (mx) `(b-bottom (l-bounds ,mx))) -(defun l-center-vt (self) - (floor (+ (l-top self)(l-bottom self)) 2)) - -(defun l-width (mx) (b-width (l-bounds mx))) -(defun l-height (mx) (b-height (l-bounds mx))) - -(defmacro p-left (mx) `(b-left (p-bounds ,mx))) -(defmacro p-top (mx) `(b-top (p-bounds ,mx))) -(defmacro p-right (mx) `(b-right (p-bounds ,mx))) -(defmacro p-bottom (mx) `(b-bottom (p-bounds ,mx))) - -(defun make-bounds (left top right bottom) - (vector left top right bottom)) - -(defun p-center-vt (self) - (b-center-vt (p-bounds self))) - -(defun b-center-vt (b) - (floor (+ (b-bottom b)(b-top b)) 2)) - -(defun p-center-hz (self) - (b-center-hz (p-bounds self))) - -(defun b-center-hz (b) - (floor (+ (b-left b)(b-right b)) 2)) - -(defun offset+ (off1 off2) - (mapcar '+ off1 off2)) - - - - - - --- /project/cells/cvsroot/Celtk/load.lisp 2006/05/26 17:50:36 1.8 +++ /project/cells/cvsroot/Celtk/load.lisp 2006/06/07 22:13:41 1.9 @@ -1,25 +1,34 @@ ;;; ;;; -;;; First, grab these: +;;; 1. 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-openg… ;; -;;; At the bottom of any of those pages look for a "Download tarball" link. Except cl-opengl, those guys -;;; are not download-friendly. +;;; 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: +;;; 2. Get ASDF loaded. From http://www.cliki.net/asdf we learn: +;;; +;;; "If you have SBCL, OpenMCL, ECL or ACL, it's bundled and you need only (require 'asdf). +;;; If you have Debian or Gentoo and the Common Lisp Controller installed, you also +;;; already have it. Otherwise you can find it in the Sourceforge cCLan CVS repository: +;;; +;;; http://cclan.cvs.sourceforge.net/cclan/asdf/ " +;;; +;;; 3. If the automatic options in step 2 could not be used, adjust the path and evaluate + +#+adjust-pathname-first! -#+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: +;;; 4. Only after you have gotten ASDF loaded, you can tell ASDF +;;; where you put everything by adjusting these paths and evaluating: (progn (push (make-pathname #+lispworks :host #-lispworks :device "c" @@ -27,14 +36,21 @@ asdf:*central-registry*) (push (make-pathname #+lispworks :host #-lispworks :device "c" - :directory '(:absolute "1-devtools" "cffi")) + :directory '(:absolute "1-devtools" "cffi-060606")) 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: +;;; 5. Track down all the define-foreign-library calls in the source +;;; and fix the pathnames to point to your shared libraries. Recently these were: +;;; +;;; In tk-interp.lisp, Tcl and Tk d-f-ls. + +;;; 6. Now you can try building the whole mess. Warning: I use ":serial t" to work around +;;; silly ASDF default behavior, so if you start fiddling with the code you may not want +;;; to use ASDF to build (or comment out the :serial option until the next session): (ASDF:OOS 'ASDF:LOAD-OP :celtk) @@ -42,16 +58,30 @@ (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. - -;;; To see the OpenGL Gears demo: +;;; To see the OpenGL Gears demo, some heavy lifting is required. +;;; +;;; 1. Get, install, and test Togl. Here is a Web link: +;;; +;;; http://www.mesa3d.org/brianp/sig97/togl.htm +;;; +;;; If you are on win32 and have trouble, send an email to the list and I will send you a DLL +;;; +;;; 2. You already grabbed cl-opengl from the location shown above. Now: +;;; +#+adjust-pathname-and-evaluate (push (make-pathname #+lispworks :host #-lispworks :device "c" - :directory '(:absolute "1-devtools" "cl-opengl")) - asdf:*central-registry*) + :directory '(:absolute "1-devtools" "cl-opengl")) + asdf:*central-registry*) + +;;; +;;; 3. Adjust the pathname again in togl.lisp, in the define-foreign-library for Togl. +;;; +;;; 4. Build: (ASDF:OOS 'ASDF:LOAD-OP :gears) +;;; 5. Test: + #+test (gears::gears) --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/05/24 20:38:54 1.3 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/06/07 22:13:41 1.4 @@ -16,6 +16,7 @@ |# + (in-package :celtk-user) (defmodel lotsa-widgets (window) --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/25 07:12:59 1.7 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/06/07 22:13:41 1.8 @@ -82,7 +82,7 @@ ; 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 + ; Data integrity: when the overall Cells data model gets perturbed by imperative code -- typically in 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); @@ -119,6 +119,7 @@ ; which operates on the outside world via observers (on-change callbacks) triggered ; automatically by the Cells engine. See DEFOBSERVER. + (defmodel ltktest-cells-inside (window) () --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/24 20:38:54 1.9 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/06/07 22:13:41 1.10 @@ -65,6 +65,7 @@ :event-handler (lambda (self xe) (case (tk-event-type (xsv type xe)) (:virtualevent + (trc ":virtualevent" (xsv name xe)) (case (read-from-string (string-upcase (xsv name xe))) (ListboxSelect (let ((selection (parse-integer (tk-eval "~a curselection" (^path))))) --- /project/cells/cvsroot/Celtk/run.lisp 2006/06/03 12:04:37 1.15 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/06/07 22:13:41 1.16 @@ -153,9 +153,8 @@ (^on-name (read-from-string (format nil "^ON-~a" name)))) `(progn (defmethod ,do-on-name (self &rest args) - (bIf (cmd (,^on-name)) - (apply cmd self args) - (format t "~&Warning: Target widget ~a has no ~a to run" self ',do-on-name)) + (bwhen (cmd (,^on-name)) + (apply cmd self args)) 0) (defcallback ,do-on-name :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer)) @@ -176,16 +175,3 @@ (defcommand key-up) (defcommand key-down) -;;;(defcallback do-on-command :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer)) -;;; (declare (ignore client-data)) -;;; (let ((*tki* interp) -;;; (args (loop for argn upfrom 1 below argc -;;; collecting (mem-aref argv :string argn)))) -;;; (bif (self (gethash (car args) (dictionary *tkw*))) -;;; (apply 'do-on-command self (rest args)) -;;; (progn -;;; (break "do-on-command> Target widget ~a does not exist" path) -;;; #+anyvalue? (tcl-set-result interp -;;; (format nil "do-on-command> Target widget ~a does not exist" path) -;;; (null-pointer)) -;;; 1))))) \ No newline at end of file --- /project/cells/cvsroot/Celtk/scroll.lisp 2006/05/24 20:38:54 1.3 +++ /project/cells/cvsroot/Celtk/scroll.lisp 2006/06/07 22:13:41 1.4 @@ -21,7 +21,6 @@ ; --- scroll bars ---------------------------------------- - (deftk scrollbar (widget) () (:tk-spec scrollbar --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/06/03 12:04:37 1.14 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/06/07 22:13:41 1.15 @@ -33,7 +33,6 @@ (:unix "libtk.so") (t (:default "libtk"))) - (defctype tcl-retcode :int) (defcenum tcl-retcode-values --- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/06/03 12:04:37 1.5 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/06/07 22:13:41 1.6 @@ -35,6 +35,8 @@ (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) +(defmethod parent-path ((self tk-object)) (path self)) + ;;; --- deftk -------------------- (defmacro deftk (class superclasses --- /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/06/03 12:04:37 1.5 +++ /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/06/07 22:13:41 1.6 @@ -120,6 +120,8 @@ (defmacro xsv (slot-name xptr) `(foreign-slot-value ,xptr 'X-Virtual-Event ',slot-name)) +(defun myx (xe) + (xsv x xe)) (defmacro xke (slot-name xptr) `(foreign-slot-value ,xptr 'x-key-event ',slot-name)) --- /project/cells/cvsroot/Celtk/widget.lisp 2006/06/03 12:04:37 1.12 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/06/07 22:13:41 1.13 @@ -55,8 +55,8 @@ (xwin :cell nil :accessor xwin :initform nil) (packing :reader packing :initarg :packing :initform nil) (gridding :reader gridding :initarg :gridding :initform nil) - (x :reader x :initarg :x :initform nil) - (y :reader y :initarg :y :initform nil) + (px :reader px :initarg :px :initform nil) + (py :reader py :initarg :py :initform nil) (relx :reader relx :initarg :relx :initform nil) (rely :reader rely :initarg :rely :initform nil) (enabled :reader enabled :initarg :enabled :initform t) @@ -71,6 +71,9 @@ :event-handler nil #+debug (lambda (self xe) (TRC "widget-event-handler" self (tk-event-type (xsv type xe)))))) +(eval-when (compile load eval) + (export '())) + (defun tk-create-event-handler-ex (widget callback-name &rest masks) (let ((self-tkwin (widget-to-tkwin widget))) (assert (not (null-pointer-p self-tkwin))) @@ -113,11 +116,11 @@ ;;; "place ~a ~a -relx ~a -rely ~a" (if old-value "configure" "") ;;; (^path) new-value (^rely)))) -(defobserver x ((self widget)) +(defobserver px ((self widget)) (when new-value (tk-format `(:grid ,self) "place ~a ~a -x ~a -y ~a" (if old-value "configure" "") - (^path) new-value (^y)))) + (^path) new-value (^py)))) (defcallback widget-event-handler-callback :void ((client-data :pointer)(xe :pointer)) (let ((self (tkwin-widget client-data))) @@ -159,6 +162,8 @@ decorations ^decorations))) (defmodel item-geometer () ;; mix-in + () + #+vestigial? ((canvas-offset :initarg :canvas-offset :accessor canvas-offset :initform (c_? (eko (nil "standard canvas offset" self (type-of self) (^p-offset)) (c-offset self)))) @@ -184,7 +189,7 @@ (coords-tweak :initarg :coords-tweak :initform '(0 0) :accessor coords-tweak :documentation "Text items need this to get positioned according to baseline") (coords :initarg :coords :accessor coords - :initform (c_? (eko (nil "final coords" self (anchor self)(^l-coords)(^canvas-offset)(^coords-tweak)) + :initform nil #+old (c_? (eko (nil "final coords" self (anchor self)(^l-coords)(^canvas-offset)(^coords-tweak)) (loop for coord-xy = (^l-coords) then (cddr coord-xy) while coord-xy nconcing (mapcar '+ coord-xy (^canvas-offset) (^coords-tweak))))))

1 0

[cells-cvs] CVS cells
by ktilton 07 Jun '06

07 Jun '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv13795 Modified Files: cells-manifesto.txt link.lisp md-slot-value.lisp Log Message: --- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/06 18:19:11 1.3 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/07 22:12:55 1.4 @@ -260,7 +260,14 @@ deferred until all computed cells are up-to-date with the current state of the universe." --- Peter Seibel, comp.lang.lisp +Uncommentary +------------ +-- Peter Seibel, comp.lang.lisp: "I couldn't find anything that explained what it was and why I should care." +-- Alan Crowe, comp.lang.lisp: +"Further confession: I'm bluffing. I've grasped that Cells is +interesting, but I haven't downloaded it yet, and I haven't +checked out how it works or what /exactly/ it does." + \ No newline at end of file --- /project/cells/cvsroot/cells/link.lisp 2006/06/05 00:01:22 1.10 +++ /project/cells/cvsroot/cells/link.lisp 2006/06/07 22:12:55 1.11 @@ -54,7 +54,7 @@ used) -;--- c-unlink-unused -------------------------------- +;--- unlink unused -------------------------------- (defun c-unlink-unused (c &aux (usage (cd-usage c))) (when (cd-useds c) @@ -87,7 +87,6 @@ ; --------------------------------------------- - (defun cd-usage-clear-all (c) (loop with a = (cd-usage c) for bitn below (array-dimension a 0) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/05 00:01:22 1.16 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/07 22:12:55 1.17 @@ -151,8 +151,12 @@ (c-setting-debug self slot-name c new-value)) (unless c - (c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized as inputp" - slot-name self)) + (c-break "cellular slot ~a of ~a cannot be SETFed because it is not +mediated by a Cell with :inputp t. To achieve this, the initial value ~s -- whether +supplied as an :initform, :default-initarg, or at make-instance time via +an :initarg -- should be wrapped in either macro C-IN or C-INPUT. +In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s" + slot-name self (slot-value self slot-name))) (when *defer-changes* (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c))

1 0

[cells-cvs] CVS cells/doc
by ktilton 07 Jun '06

07 Jun '06

Update of /project/cells/cvsroot/cells/doc In directory clnet:/tmp/cvs-serv13795/doc Modified Files: motor-control.lisp Log Message: --- /project/cells/cvsroot/cells/doc/motor-control.lisp 2006/03/22 04:08:35 1.2 +++ /project/cells/cvsroot/cells/doc/motor-control.lisp 2006/06/07 22:12:55 1.3 @@ -58,6 +58,11 @@ :initform (c? (ecase (^status) (:on :open) (:off :closed)))) (temp :initarg :temp :accessor temp :initform (c-in 0)))) +#+test +(progn + (cells-reset) + (setf (status (make-instance 'motor :status :on)) 42)) + #| Note that "status" is a cell with no initial value or formula, "fuel-pump" is

1 0

[cells-cvs] CVS cells
by ktilton 06 Jun '06

06 Jun '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv15386 Modified Files: cells-manifesto.txt Log Message: --- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/06 17:40:41 1.2 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/06 18:19:11 1.3 @@ -260,5 +260,7 @@ deferred until all computed cells are up-to-date with the current state of the universe." +-- Peter Seibel, comp.lang.lisp +"I couldn't find anything that explained what it was and why I should care." \ No newline at end of file

1 0

[cells-cvs] CVS cells
by ktilton 06 Jun '06

06 Jun '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv10286 Modified Files: cells-manifesto.txt Log Message: mo better doc --- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/06 04:54:10 1.1 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/06 17:40:41 1.2 @@ -1,11 +1,41 @@ - Cells In A Nutshell - + +Cells In A Nutshell +------------------- The Cells library as it stands is all about doing interesting things with slots of CLOS instances. Nothing says a global variable could not be mediated by a Cell, and indeed one Cells user is known to have experimented with that. Also, some work was done on having slots of DEFSTRUCTs mediated by Cells. But for the rest of this exposition let's just talk about CLOS slots and instances. +DEFMODEL and Slot types +----------------------- +Classes, some of whose slots may be mediated by Cells, are defined by DEFMODEL, which is exactly +like DEFCLASS but adds support for two slot definition options, :cell and :unchanged-if. + + :cell {nil | t | :ephemeral} + +:cell is optional. The default is ":cell t", meaning the Cells engine will manage the slot. +Specifying NIL signifies that this slot is entirely +outside any handling by the Cells engine; it is just a plain CLOS slot. + +Specifying :ephemeral causes the Cells engine to reset the apparent slot +value to NIL immediately and only after fully propagating any value assumed by the slot, either +by assignment to an input Cell (the vastly more common case) or by a rule calculation. + +Ephemeral cells are necessary to correctly model events in the otherwise steady-state +spreadsheet paradigm. + + :unchanged-if <function-name> + +Specifying :unchanged-if is optional. [Come to think of it, it should be an error to specify +both :cell nil and :unchanged-if.] If specified, the named function is a predicate +of two arguments, the new and old value in that order. The predicate determines if a subsequent +slot value (either computed or assigned to an input) is unchanged in the sense that no propagation +is necessary, either to dependent ruled cells or (getting ahead of ourselves) "on change" observers. +The default unchanged test is EQL. + +Cell types +---------- The Cells library allows the programmer to specify at make-instance time that a slot of an instance be mediated for the life of that instance by one of: @@ -13,36 +43,77 @@ -- a "ruled" Cell; or -- no Cell at all. -Note that "slot of an instance" is not the same as "slot of a class". A vital feature of the Cells library -is that different instances may do different things Cells-wise with the same slot. - -A slot mediated by an input Cell may be assigned new values at runtime. It is an error to assign a new -value to a slot of an instance not mediated by any Cell. Ruled Cells come with an instance-specific -rule in the form of an anonymous function of two variables, the instance owning the slot and the prior value -(if any) computed by the rule. These rules consist of arbitrarily complex Common Lisp code, and are invoked -immediately after instance initialization or, if they are declared lazy, when their slot readers are invoked. +Note that different instances of the same class may do different things Cells-wise with the same slot. +One label widget may have a fixed width of 42 and text "Hi, Mom!", where another might have +an input Cell mediating the text (so edit logic can assign new values as the user types) and a +rule mediating the width so the widget can have a minimum width of 42(so it does not disappear altogether) +yet grow based on text length and relevant font metrics to always leave room for one more character +(if the GUI design calls for that). + +To summarize, the class specification supplied with DEFMODEL specifies whether a slot can ever +be managed by the Cells engine. For those that can, at and only at instance initialization time, +different instances can have different Cell types mediating the same slot. + +Input Cells +----------- +A slot mediated by an input Cell may be assigned new values at runtime. These are how Cell-based models +get data from the world outside the model -- it cannot be rules all the way down. Typically, these +input assignements are made by code polling OS events via some GetNextEvent API call, or by callbacks +registered with an event system such as win32 WindowProc functions. Other code may poll sockets or +serial inputs from some external device. + +Ruled Cells +----------- +Ruled Cells come with an instance-specific rule in the form of an anonymous function of two variables, +the instance owning the slot and the prior value (if any) computed by the rule. These rules consist of +arbitrarily complex Common Lisp code, and are invoked immediately after instance initialization or, if +they are declared lazy, when their slot readers are invoked. When a rule runs, any dynamic read (either expressly in the rule source or during the execution of some function invoked by the rule) of a slot of any instance mediated by a Cell of any type establishes a runtime dependency of the ruled cell on the slot of the instance that was read. Note then that thanks to code branching, dependencies can vary after every rule invocation. +Dataflow +-------- When application code assigns a new value to an input Cell (a quick way of saying an instance slot mediated by an input Cell) -- typically by code polling OS events or a socket or an input device -- a cascade of recalculation ensues to bring direct and indirect ruled dependents current with the new value assigned to the input Cell. +No Cell at All +-------------- +Because of all that, it is an error to assign a new value to a slot of an instance not mediated by any Cell. +The Cells engine can do a handy optimization by treating such slots as constants and not creating dependencies when ruled +Cells read these. But then we cannot let these Cells vary and still guarantee data integrity, because +we no longer know who else to update in light of such variation. The optimization, by the way, extends to +eliminating ruled Cells which, after any computation, end up not depending on any other cell. + +Again, note that this is different than specifying ":cell nil" for some slot. Here, the Cells engine +has been told to manage some slot, but for some instance the slot has been authored to bear some value +for the lifetime of that instance. + +Observers +--------- To allow the emergent data animation model to operate usefully on the world outside the model--if only to update the screen--programmers may specify so-called observer callbacks dispatched according to: slot name, instance, new value, old value, and whether the old value actually existed (false only on the first go). +It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer executuion +until the observed state change has fully propagated; and (b) doing so compromises the declarative +quality of an application -- one can no longer look to one rule to see how a slot (in this case the +input slot being assigned by the observer) gets its value. A reasonable usage might be one with +a cycle, where changing slot A requires a change to slot B, and changing slot B requires a change to +slot A, such as the scroll thumb position and the amount a document has been scrolled. + Finally, to make it possible for such a declarative model to talk intelligibly to imperative systems such as Tcl/Tk which sometimes requires a precise sequence of commands for something to work at all, a mechanism exists by which client code can (a) queue tasks for execution after a data change has fully propagated and (b) process those tasks with a client-supplied handler. Tasks are queued with arbitrary keying data which can be used by the handler to sort or compress the queued tasks. - Data Integrity - + +Data Integrity +-------------- When application code assigns to some input cell X, the Cells engine guarantees: - recomputation exactly once of all and only state affected by the change to X, directly or indirectly through @@ -63,8 +134,8 @@ - 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 - Benefits - +Benefits +-------- Program state guaranteed to be self-consistent, without programmer effort. Dependencies are identified by the engine, and change propagation happens automatically. @@ -74,12 +145,120 @@ Natural decomposition of overall application complexity into so many simple rules and slot observers. - Applications - +Applications +------------ Any application that must maintain an interesting, long-lived data model incorporating a stream of unpredictable data. Two examples: any GUI application and a RoboCup soccer client. An application needing to shadow data between two systems. Examples: a Lisp GUI imlemented by thinly wrapping a C GUI library, where Lisp-land activity must be propagated to the C GUI, and C GUI events must propagate to Lisp-land. See the Cells-Gtk or Celtk projects. Also, a persistent CLOS implementation that must echo -CLOS instance data into, say, SQL tables. \ No newline at end of file +CLOS instance data into, say, SQL tables. + +Prior Art +--------- +The entire constraint programming field, beginning I guess with Guy Steele's +PhD Thesis in which he develops a constraint programming language or two: + http://portal.acm.org/citation.cfm?id=889490&dl=ACM&coll=ACM + http://www.cs.utk.edu/~bvz/quickplan.html + +Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963. +Steele himself cites Sketchpad as inexlicably unappreciated prior +art to his Constraints system: + +Garnet's KR: http://www.cs.cmu.edu/~garnet/ +Also written in Lisp. Cells looks much like KR, though Cells was +developed in ignorance of KR (or any other prior art). KR has +an astonishing number of backdoors to its constraint +engine, none of which have turned out to be necessary for Cells. + +COSI: + "The Constraint Sequencing Infrastructure (COSI) is an extension to +the Common Lisp Object System (*(CLOS)) which supports a constraint +based object-oriented programming model. ..... + +"A constraint is a specialized method which will be automatically +re-run by the COSI infrastructure whenever any of its input values +change. Input values are any of the object attributes that are +accessed by the constraint, and which are therefore assumed to +alter the processing within the constraint. + +"Whenever a state change occurs those constraints which depend upon +that state are added to a propagation queue. When the system is +queried a propagation cycle runs ensuring that the state of the +system is consistent with all constraints prior to returning a value." +-- http://www.cliki.net/ACL2/COSI?source + +Adobe Adam: +http://opensource.adobe.com/group__asl__overview.html#asl_overview_intro_to_adam_and_eve +"Adam is a modeling engine and declarative language for describing constraints and +relationships on a collection of values, typically the parameters to an +application command. When bound to a human interface (HI) Adam provides +the logic that controls the HI behavior. Adam is similar in concept to a spreadsheet +or a forms manager. Values are set and dependent values are recalculated. +Adam provides facilities to resolve interrelated dependencies and to track +those dependencies, beyond what a spreadsheet provides." + +See also: + The spreadsheet paradigm: http://www.cs.utk.edu/~bvz/active-value-spreadsheet.html + The dataflow paradigm: http://en.wikipedia.org/wiki/Dataflow + Reactive programming: http://www.haskell.org/yampa/AFPLectureNotes.pdf + Frame-based programming + +Commentary +---------- +-- Jack Unrue, comp.lang.lisp +"Cells provides the plumbing for data dependency management which every +non-trivial program must have; a developer using Cells can focus on +computing program state and reacting to state changes, leaving Cells to worry about +how that state is propagated. Cells does this by enabling a declarative +mechanism built via an extension to CLOS, and hence achieves its goal in a way +that meshes well with with typical Common Lisp programming style." + +-- Bill Clementson, http://bc.tech.coop/blog/030911.html +"Kenny Tilton has been talking about his Cells implementation on comp.lang.lisp +for some time but I've only just had a look at it over the past few evenings. +It's actually pretty neat. Kenny describes Cells as, conceptually, analogous to +a spreadsheet cell (e.g. -- something in which you can put a value or a formula +and have it updated automatically based on changes in other "cell" values). +Another way of saying this might be that Cells allows you to define classes +whose slots can be dynamically (and automatically) updated and for which +standard observers can be defined that react to changes in those slots." + +-- "What is Cells?", Cells-GTk FAQ, http://common-lisp.net/project/cells-gtk/faq.html#q2 +"If you are at all familiar with developing moderately complex software that +is operated through a GUI, then you have probably +learned this lesson: Keeping what is presented through the GUI in-sync with what +the user is allowed to do, and in-sync with the computational state of the +program is often tedious, complicated work. .... Cells-GTK helps +with these tasks by providing an abstraction over the details; each of the tasks +just listed can be controlled by (a) formula that specify the value of +attributes of graphic features in the part-subpart declaration (that declaration +is called 'defpart' in cells-gtk); and, (b) formula that specify the value of CLOS slots." + +-- Phillip Eby, PyCells and peak.events, +... http://www.eby-sarna.com/pipermail/peak/2006-May/002545.html +"What I discovered is quite cool. The Cells system *automatically +discovers* dynamic dependencies, without having to explicitly specify that +X depends on Y, as long as X and Y are both implemented using cell +objects. The system knows when you are computing a value for X, and +registers the fact that Y was read during this computation, thus allowing +it to automatically invalidate the X calculation if Y changes. + +"...Aside from the automatic dependency +detection, the cells system has another trick that is able to significantly +reduce the complexity of event cascades, similar to what I was trying (but +failing) to do using the "scheduled thread" concept in peak.events. + +"Specifically, the cells system understands how to make event-based updates +orderly and deterministic, in a way that peak.events cannot. It +effectively divides time into "propagation" and "non-propagation" +states. Instead of simply making callbacks whenever a computed value +changes, the system makes orderly updates by queueing invalidated cells for +updating. Also, if you write code that sets a new value imperatively (as +opposed to it being pulled declaratively), the actual set operation is +deferred until all computed cells are up-to-date with the current state of +the universe." + + + \ No newline at end of file

1 0

[cells-cvs] CVS cells
by ktilton 05 Jun '06

05 Jun '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv5743 Added Files: cells-manifesto.txt Log Message: Doc, OK? --- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/06 04:54:11 NONE +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/06 04:54:11 1.1 Cells In A Nutshell The Cells library as it stands is all about doing interesting things with slots of CLOS instances. Nothing says a global variable could not be mediated by a Cell, and indeed one Cells user is known to have experimented with that. Also, some work was done on having slots of DEFSTRUCTs mediated by Cells. But for the rest of this exposition let's just talk about CLOS slots and instances. The Cells library allows the programmer to specify at make-instance time that a slot of an instance be mediated for the life of that instance by one of: -- a so-called "input" Cell; -- a "ruled" Cell; or -- no Cell at all. Note that "slot of an instance" is not the same as "slot of a class". A vital feature of the Cells library is that different instances may do different things Cells-wise with the same slot. A slot mediated by an input Cell may be assigned new values at runtime. It is an error to assign a new value to a slot of an instance not mediated by any Cell. Ruled Cells come with an instance-specific rule in the form of an anonymous function of two variables, the instance owning the slot and the prior value (if any) computed by the rule. These rules consist of arbitrarily complex Common Lisp code, and are invoked immediately after instance initialization or, if they are declared lazy, when their slot readers are invoked. When a rule runs, any dynamic read (either expressly in the rule source or during the execution of some function invoked by the rule) of a slot of any instance mediated by a Cell of any type establishes a runtime dependency of the ruled cell on the slot of the instance that was read. Note then that thanks to code branching, dependencies can vary after every rule invocation. When application code assigns a new value to an input Cell (a quick way of saying an instance slot mediated by an input Cell) -- typically by code polling OS events or a socket or an input device -- a cascade of recalculation ensues to bring direct and indirect ruled dependents current with the new value assigned to the input Cell. To allow the emergent data animation model to operate usefully on the world outside the model--if only to update the screen--programmers may specify so-called observer callbacks dispatched according to: slot name, instance, new value, old value, and whether the old value actually existed (false only on the first go). Finally, to make it possible for such a declarative model to talk intelligibly to imperative systems such as Tcl/Tk which sometimes requires a precise sequence of commands for something to work at all, a mechanism exists by which client code can (a) queue tasks for execution after a data change has fully propagated and (b) process those tasks with a client-supplied handler. Tasks are queued with arbitrary keying data which can be used by the handler to sort or compress the queued tasks. Data Integrity When application code assigns to some input cell X, the Cells engine guarantees: - recomputation exactly once of all and only state affected by the change to X, directly or indirectly through some intermediate datapoint. note that if A depends on B, and B depends on X, when B gets recalculated it may come up with the same value as before. In this case A is not considered to have been affected by the change to X and will not be recomputed. - recomputations, when they read other datapoints, must see only values current with the new value of X. Example: if A depends on B and X, and B depends on X, when A reads B it must return a value recomputed from the new value of X. - similarly, client observer 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. - 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 Benefits Program state guaranteed to be self-consistent, without programmer effort. Dependencies are identified by the engine, and change propagation happens automatically. Greater object re-use. Slots of instances can be authored with rules, not just literal values. In a sense, we get greater reuse by allowing instances to override slot derivations instance by instance. But not slot expressions, which are still class-oriented. Natural decomposition of overall application complexity into so many simple rules and slot observers. Applications Any application that must maintain an interesting, long-lived data model incorporating a stream of unpredictable data. Two examples: any GUI application and a RoboCup soccer client. An application needing to shadow data between two systems. Examples: a Lisp GUI imlemented by thinly wrapping a C GUI library, where Lisp-land activity must be propagated to the C GUI, and C GUI events must propagate to Lisp-land. See the Cells-Gtk or Celtk projects. Also, a persistent CLOS implementation that must echo CLOS instance data into, say, SQL tables.

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 04 Jun '06

04 Jun '06

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv2216/gui-geometry Modified Files: defpackage.lisp geo-family.lisp geometer.lisp Log Message: evolving geometry; refinement of test case 01c-cascade --- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2006/06/04 13:19:59 1.1 +++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2006/06/05 00:01:22 1.2 @@ -17,4 +17,46 @@ (defpackage #:gui-geometry (:nicknames #:geo) (:use #:common-lisp #:utils-kt #:cells) - (:export #:geometer #:px #:py #:ll #:lt #:lr #:lb)) \ No newline at end of file + (:export #:geometer #:geo-zero-tl #:geo-inline + #:px #:py #:ll #:lt #:lr #:lb + #:u96ths #:udots #:uinches #:uin #:upoints #:upts #:u8ths #:u16ths #:u32nds + #:mkr #:v2-move #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h + #:r-bounds + #:lb + #:cs-target-res + #:nr-make + #:r-contains + #:collapsed + #:g-box + #:v2-in-rect-ratio + #:v2-xlate + #:v2-in-rect + #:v2-add + #:v2-subtract + #:log2scr + #:^lr-width + #:px-maintain-pr + #:outset + #:py-maintain-pb + #:cs-logical-dpi + #:px-maintain-pl + #:py-maintain-pt + #:scr2log + #:inset-width + #:inset-height + #:res-to-res + #:logical-to-screen-point + #:nres-to-res + #:cs-logical-screen-resolution + #:outl + #:with-r-bounds + #:r-inset + #:ncopy-rect + #:l + #:r-height + #:r-width + #:r-top + #:r-right + #:r-bottom + #:r-left + #:l-width )) --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/06/04 13:19:59 1.1 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/06/05 00:01:22 1.2 @@ -55,16 +55,6 @@ (c? (px-maintain-pl (^prior-sib-pr self (spacing .parent))))))))))) -(defmodel geo-stack (geo-inline) - () - (:default-initargs - :orientation :vertical)) - -(defmodel geo-row (geo-inline) - () - (:default-initargs - :orientation :horizontal)) - (defmacro a-stack ((&rest stack-args) &body dd-kids) `(mk-part ,(copy-symbol 'a-stack) (geo-inline) ,@stack-args --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/06/04 13:19:59 1.1 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/06/05 00:01:22 1.2 @@ -30,6 +30,10 @@ (w-box :cell nil :initform (mkr 0 0 0 0) :accessor w-box :documentation "bbox in window coordinate system"))) +(defmethod collapsed (other) + (declare (ignore other)) + nil) + ;;-------- Zero-zero Top Left ---------------------------- ;; (defmodel geo-zero-tl (family)

1 0

[cells-cvs] CVS cells
by ktilton 04 Jun '06

04 Jun '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv2216 Modified Files: link.lisp md-slot-value.lisp propagate.lisp Log Message: evolving geometry; refinement of test case 01c-cascade --- /project/cells/cvsroot/cells/link.lisp 2006/05/20 06:32:19 1.9 +++ /project/cells/cvsroot/cells/link.lisp 2006/06/05 00:01:22 1.10 @@ -22,30 +22,14 @@ (eval-when (compile load) (proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0)))) - (defun c-link-ex (used &aux (user (car *c-calculators*))) - (c-assert user) - (c-assert used) (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell (return-from c-link-ex nil)) - - - ; - ; --------- debug stuff -------------- - (c-assert user) - (c-assert (c-model user)) - (c-assert (c-model used)) - - #+dfdbg (trc user "c-link > user, used" user used) - (c-assert (not (eq :eternal-rest (md-state (c-model user))))) - (c-assert (not (eq :eternal-rest (md-state (c-model used))))) - (count-it :c-link-entry) - + (trc nil "c-link-ex entry: used=" used :user user) (multiple-value-bind (used-pos useds-len) (loop with u-pos for known in (cd-useds user) counting known into length - ;; do (print (list :data known length)) when (eq used known) do (count-it :known-used) @@ -56,7 +40,9 @@ (trc nil "c-link > new user,used " user used) (count-it :new-used) (setf used-pos useds-len) - (push used (cd-useds user))) + (push used (cd-useds user)) + (user-ensure used user) ;; 060604 experiment was in unlink + ) (handler-case (setf (sbit (cd-usage user) used-pos) 1) @@ -68,7 +54,6 @@ used) - ;--- c-unlink-unused -------------------------------- (defun c-unlink-unused (c &aux (usage (cd-usage c))) @@ -81,7 +66,10 @@ (count-it :unlink-unused) (c-unlink-user (car useds) c) (rplaca useds nil)) - (user-ensure (car useds) c)))) + (progn + ;; moved into c-link-ex 060604 (user-ensure (car useds) c) + ) + ))) (if (cdr useds) (progn (nail-unused (cdr useds)) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/05/30 02:47:45 1.15 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/05 00:01:22 1.16 @@ -42,13 +42,12 @@ (if c (prog1 (with-integrity () - (c-value-ensure-current c :md-slot-value)) + (c-value-ensure-current c)) (when (car *c-calculators*) (c-link-ex c))) (values (bd-slot-value self slot-name) nil))) -(defun c-value-ensure-current (c &optional (debug-id :anon-caller)) - (declare (ignorable debug-id)) +(defun c-value-ensure-current (c) (count-it :c-value-ensure-current) (trc nil "c-value-ensure-current >" c) (cond @@ -59,7 +58,7 @@ ((or (not (c-validp c)) (some (lambda (used) - (c-value-ensure-current used :recursive-used) + (c-value-ensure-current used) (trc nil "comparing pulses (user, used): " (c-pulse c)(c-pulse used)) (when (and (c-changed used) (> (c-pulse used)(c-pulse c))) (trc nil "used changed" c used) --- /project/cells/cvsroot/cells/propagate.lisp 2006/05/30 02:47:45 1.13 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/06/05 00:01:22 1.14 @@ -165,11 +165,11 @@ (with-integrity (:tell-dependents c) (assert (null *c-calculators*)) (let ((*causation* causation)) - (trc nil "c-propagate-to-users > notifying users of" c) + (trc "c-propagate-to-users > notifying users of" c (mapcar 'c-slot-name (c-users c))) (dolist (user (c-users c)) (unless (member (cr-lazy user) '(t :always :once-asked)) (trc nil "propagating to user is (used,user):" c user) - (c-value-ensure-current user :user-propagation)))))))) + (c-value-ensure-current user))))))))

1 0

[cells-cvs] CVS cells/tutorial
by ktilton 04 Jun '06

04 Jun '06

Update of /project/cells/cvsroot/cells/tutorial In directory clnet:/tmp/cvs-serv2216/tutorial Modified Files: 01c-cascade.lisp Log Message: evolving geometry; refinement of test case 01c-cascade --- /project/cells/cvsroot/cells/tutorial/01c-cascade.lisp 2006/05/30 02:47:45 1.1 +++ /project/cells/cvsroot/cells/tutorial/01c-cascade.lisp 2006/06/05 00:01:22 1.2 @@ -1,31 +1,94 @@ -#| Now we have automatic state management (including change propagation) +#| + +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. :)] +In this case: len->area->brightness +Also: len->width->area->brightness + +That leads to some complications I will discuss, but no assertions here +enforce correct behavior in re those complications. Soon. :) |# (defpackage #:tu-depth (:use :cl :cells)) (in-package #:tu-depth) +(defmacro start-finish (key rule) + `(progn + (print (list :start ,key)) + (prog1 + (progn ,rule) + (print (list :finish ,key))))) (defmodel rectangle () - ((area :initarg :area :accessor area - :initform (c? (print :compue-area) - (* (len self)(width self)))) + ((lumens :initform 1000000 :reader lumens) (len :initarg :len :accessor len - :initform (c? (print :compute-len) - (* 2 (width self)))) + :initform (c? (start-finish :len + (* 2 (width self))))) + (area :initarg :area :accessor area + :initform (c? (start-finish :area + (* (len self)(width self))))) (width :initarg :width :accessor width - :initform (c? (print :compute-width) - (floor (len self) 2))))) + :initform (c? (start-finish :width + (floor (len self) 2)))) + (brightness :reader brightness + :initform (c? (start-finish :brightness + (/ (^lumens) (^area))))) + )) #+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))) +(let ((r (make-instance 'rectangle :len (c-in 100)))) + (cells::ct-assert (eql 50 (width r))) + (cells::ct-assert (eql 5000 (area r))) + (cells::ct-assert (eql 200 (brightness r))) (cells::ct-assert (= 1000 (setf (len r) 1000))) - (cells::ct-assert (eql 500000 (area r)))) + (cells::ct-assert (eql 500000 (area r))) + (cells::ct-assert (eql 2 (brightness r)))) + +#| --- discussion ---------------------------- + +The output in Cells is: + +(:START :AREA) +(:START :WIDTH) +(:finish :WIDTH) +(:finish :AREA) +(:START :BRIGHTNESS) +(:finish :BRIGHTNESS) +(CELTK::ATTEMPTING (EQL 50 (WIDTH R))) +(CELTK::ATTEMPTING (EQL 5000 (AREA R))) +(CELTK::ATTEMPTING (EQL 200 (BRIGHTNESS R))) +(CELTK::ATTEMPTING (= 1000 (SETF (LEN R) 1000))) +0> c-propagate-to-users > notifying users of | [i :=[24]LEN/#<RECTANGLE>] | (AREA WIDTH) + +Notice here that the LEN cell is about to tell both the width and area to recalculate, +since area depends (of course) on len and (rather artificially) width also derives +from LEN. + +ie, This example has accidentally deviated into more complexity than intended. But we are +approaching these issues anyay, so I will leave it for now. We can always break it up +later. + +Let's continue: + +(:START :WIDTH) +(:finish :WIDTH) +(:START :AREA) +(:finish :AREA) + +Fine, now here comes the challenge. Width is also going to tell area to recalculate: + +0> c-propagate-to-users > notifying users of | [? :<vld>=[24]WIDTH/#<RECTANGLE>] | (AREA) +0> c-propagate-to-users > notifying users of | [? :<vld>=[24]AREA/#<RECTANGLE>] | (BRIGHTNESS) + +Correct: Area does not actually run its rule since it already did so when notified by LEN, + but it does propagate to brightness. + +(:START :BRIGHTNESS) +(:finish :BRIGHTNESS) +(CELTK::ATTEMPTING (EQL 500000 (AREA R))) +(CELTK::ATTEMPTING (EQL 2 (BRIGHTNESS R))) +|# \ No newline at end of file

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 04 Jun '06

04 Jun '06

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv13961/gui-geometry Added Files: coordinate-xform.lisp defpackage.lisp geo-data-structures.lisp geo-family.lisp geometer.lisp gui-geometry.lpr Log Message: Mostly adding a general-purpose GUI geometry component that makes good use of the Family class and specifically the kid-slotting mechanism. --- /project/cells/cvsroot/cells/gui-geometry/coordinate-xform.lisp 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/coordinate-xform.lisp 2006/06/04 13:19:59 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*- #| Copyright (C) 2004 by Kenneth William 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 :gui-geometry) (defconstant *reference-dpi* 1440) (let ( (logical-dpi 96) ;;1440) ; This is cello's internal dots per inch. This value is germane only if size references are unqualified by a function call. ; Size references should always be qualified, as in (:pts 6), except when specifying pen widths. ; (Pen widths may pose a special case -- we may need to match screen pens to print pens.) (scan-resolution 300) ; This is the desired scan resolution, and the assumed resolution of all scans. ; Hypothetically, a scanner not capable of scanning at 300 dpi could make a big hash of this scheme. ; Rather than even pretend to support multiple resolutions within a study, for now we'll enforce 300 across the board. ; Dependencies on this spec can be identified by searching on scan-resolution. (logical-screen-resolution 96) ; This is the internal logical screen resolution, which does _not_ have to equal the current LOGPIXELSX (LOGPIXELSY) value ; reported by GetDeviceCaps. The original thought was that we could use this to rescale _all_ drawing on the fly. Now that ; idea is being superseded by targetRes, but this functions (1) as a tacit targetRes for the outer window and (2) as a magic ; number to complicate debugging [we need to root out a few references in .bmp drawing, I think]. ;;(printer-resolution 600) ; /// improve #'cs-printer-resolution to bypass this. ;;(emf-resolution 600) ) (declare (ignorable logical-dpi scan-resolution logical-screen-resolution printer-resolution)) ; Notice the somewhat nonstandard naming convention: ; #'uInches takes logical inches and returns logical units (DPI) ; so, for instance, if logical-dpi = 1440, then (uInches 0.5) = 720. (defun u-round (number &optional (divisor 1)) (multiple-value-bind (quotient remainder) (round number divisor) (declare (ignorable remainder)) ;(assert (zerop remainder)) ;(assert (zerop (mod quotient 15))) ;96ths quotient)) (defun udots (dots dpi) (u-round (* dots logical-dpi) dpi)) ;only the first value will be used. (defun uinches (logical-inches) (u-round (* logical-inches logical-dpi))) ;only the first value will be used. (defun uin (logical-inches) (uinches logical-inches)) (defun upoints (logical-points) (udots logical-points 72)) (defun upts (logical-points) (upoints logical-points)) (defun u96ths (logical-96ths) (udots logical-96ths 96)) (defun u8ths (logical-8ths) (udots logical-8ths 8)) (defun u16ths (logical-16ths) (udots logical-16ths 16)) (defun u32nds (logical-32nds) (udots logical-32nds 32)) (defun u120ths (logical-120ths) (udots logical-120ths 120)) (defun cs-logical-dpi () logical-dpi) (defsetf cs-logical-dpi cs-logical-dpi-setf) (defun cs-logical-dpi-setf (new-value) (setf logical-dpi new-value)) (defun cs-scan-resolution () scan-resolution) (defun cs-logical-screen-resolution () logical-screen-resolution) ) (defmethod u-cvt ((nn number) (units (eql :96ths)) ) (u96ths nn)) (defmethod u-cvt ((nn number) (units (eql :8ths)) ) (u8ths nn)) (defmethod u-cvt ((nn number) (units (eql :16ths)) ) (u16ths nn)) (defmethod u-cvt ((nn number) (units (eql :32nds)) ) (u32nds nn)) (defmethod u-cvt ((nn number) (units (eql :inches)) ) (uinches nn)) (defmethod u-cvt ((nn number) (units (eql :points)) ) (upoints nn)) (defmethod u-cvt (other units) (declare (ignore units)) other) (defmethod u-cvt ((nns cons) units) (cons (u-cvt (car nns) units) (u-cvt (cdr nns) units))) (defmacro u-cvt! (nn units) `(u-cvt ,nn ,units)) (defun uv2 (x y u-key) (apply #'mkv2 (u-cvt (list x y) u-key))) ;----------------- (defun os-logical-screen-dpi () (break "need (win:GetDeviceCaps (device-context (screen *cg-system*)) win:LOGPIXELSX))")) #+no(defun browser-target-resolution () (target-resolution (find-window :clinisys))) ; set to 96 because the code is trying to do rect-frames for the header before the window is init'ed. (let ((current-target-resolution 96)) ;initialize when main window is created (defun set-current-target-resolution (resolution) #+shh(trc "setting current-target-resolution to" resolution) (setf current-target-resolution resolution)) (defun cs-current-target-resolution () current-target-resolution) (defun cs-target-res () current-target-resolution) (defmacro with-target-resolution ((new-resolution) &rest body) (let ((old-resolution (gensym)) ) `(let ((,old-resolution (cs-current-target-resolution)) ) (prog2 (set-current-target-resolution ,new-resolution) (progn ,@body) (set-current-target-resolution ,old-resolution) )))) ) ;converts screen pixels to logical pixels given the current target resolution OR OPTIONAL OTHER RES (defun scr2log (dots &optional (target-res (cs-target-res))) (round (* dots (cs-logical-dpi)) target-res)) (defun log2scr (logv &optional (target-res (cs-target-res))) (floor-round (* logv target-res ) (cs-logical-dpi))) (defun cs-archos-dpi () (cs-logical-dpi)) (defun floor-round (x &optional (divisor 1)) (ceiling (- (/ x divisor) 1/2))) ;converts logical pixels to screen pixels given the current target resolution OR OPTIONAL OTHER RES (defun logical-to-screen-vector (dots &optional target-res) (let ((convert-res (or target-res (cs-target-res)))) (floor-round (* dots convert-res) (cs-logical-dpi)))) (defun logical-to-screen-point (point &optional target-res) (mkv2 (log2scr (v2-h point) target-res) (log2scr (v2-v point) target-res))) (defun screen-to-logical-v2 (point &optional target-res) (mkv2 (scr2log (v2-h point) target-res) (scr2log (v2-v point) target-res))) (defun nr-screen-to-logical (logical-rect screen-rect &optional target-res) (nr-make logical-rect (scr2log (r-left screen-rect) target-res) (scr2log (r-top screen-rect) target-res) (scr2log (r-right screen-rect) target-res) (scr2log (r-bottom screen-rect) target-res))) ; logical-to-target is a more sensible name throughout (defun logical-to-target-vector (dots &optional target-res) (log2scr dots target-res)) ;-------------------------------------------------------------------------------------------- (defun r-logical-to-screen (logical-rect &optional target-res) (count-it :r-logical-to-screen) (nr-logical-to-screen (mkr 0 0 0 0) logical-rect target-res)) (defun nr-logical-to-screen (screen-rect logical-rect &optional target-res) (nr-make screen-rect (log2scr (r-left logical-rect) target-res) (log2scr (r-top logical-rect) target-res) (log2scr (r-right logical-rect) target-res) (log2scr (r-bottom logical-rect) target-res))) ;------------------------------------------------------------------------------------------------ ;;;(defun set-scaling (window) ;;; #+shh(trc "targetResolution" (targetRes window)) ;;; ;;; (set-current-target-resolution (cs-logical-screen-resolution)) ;here and below, we'll probably make scalable ;;; ;(set-current-target-resolution (cs-logical-dpi)) ;;; (let ((dc (device-context window)) ;;; (display-dpi (cs-logical-screen-resolution)) ;... and use (targetRes window) ;;; (logical-dpi (cs-logical-dpi))) ;;; (os-SetMapMode dc win:MM_ISOTROPIC) ;;; (os-SetWindowExtEx dc logical-dpi logical-dpi ct:hnull) ;;; (os-SetViewportExtEx dc display-dpi display-dpi ct:hnull))) (defun move-v2-x-y (v2 x y) (incf (v2-h v2) x) (incf (v2-v v2) y) v2) (defmethod ncanvas-to-screen-point (self point) (ncanvas-to-screen-point (fm-parent self) (move-v2-x-y point (px self) (py self)))) (defmethod res-to-res ((amount number) from-res to-res) (if to-res (round (* amount from-res) to-res) from-res)) (defmethod res-to-res ((point v2) from-res to-res) (nres-to-res (copy-v2 point) from-res to-res)) #+no-2e-h (defmethod nres-to-res ((point v2) from-res to-res) (setf (v2-h point) (res-to-res (v2-h point) from-res to-res)) (setf (v2-v point) (res-to-res (v2-v point) from-res to-res)) point) (defmethod res-to-res ((box rect) from-res to-res) (count-it :res-to-res) (nres-to-res (nr-copy (mkr 0 0 0 0) box) from-res to-res)) (defmethod nres-to-res :around (geo-thing from-res (to-res null)) (declare (ignore from-res)) geo-thing) (defmethod nres-to-res ((box rect) from-res to-res) (setf (r-left box) (res-to-res (r-left box) from-res to-res)) (setf (r-top box) (res-to-res (r-top box) from-res to-res)) (setf (r-right box) (res-to-res (r-right box) from-res to-res)) (setf (r-bottom box) (res-to-res (r-bottom box) from-res to-res)) box) (defun canvas-to-screen-box (self box) (count-it :canvas-to-screen-box) (nr-make-from-corners (mkr 0 0 0 0) (ncanvas-to-screen-point self (r-top-left box)) (ncanvas-to-screen-point self (r-bottom-right box)))) --- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2006/06/04 13:19:59 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*- #| Copyright (C) 2004 by Kenneth William 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. |# (defpackage #:gui-geometry (:nicknames #:geo) (:use #:common-lisp #:utils-kt #:cells) (:export #:geometer #:px #:py #:ll #:lt #:lr #:lb))--- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/06/04 13:19:59 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*- #| Copyright (C) 2004 by Kenneth William 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 :gui-geometry) ;----------------------------- (defstruct v2 (h 0 ) (v 0 ) ) #+(or) (instance-slots (mkv2 1 2)) (defmethod print-object ((self v2) s) (format s "(~a ~a)" (v2-h self)(v2-v self))) (defun mkv2 (h v) (make-v2 :h h :v v)) (defun v2= (a b) (and a b (= (v2-h a)(v2-h b)) (= (v2-v a)(v2-v b)))) (defun v2-add (p1 p2) (make-v2 :h (+ (v2-h p1) (v2-h p2)) :v (+ (v2-v p1) (v2-v p2)))) (defun v2-move (p1 x y) (make-v2 :h (+ (v2-h p1) x) :v (+ (v2-v p1) y))) (defun v2-subtract (p1 p2) (make-v2 :h (- (v2-h p1) (v2-h p2)) :v (- (v2-v p1) (v2-v p2)))) (defun v2-in-rect (v2 r) (mkv2 (min (r-right r) (max (r-left r) (v2-h v2))) (min (r-top r) (max (r-bottom r) (v2-v v2))))) (defun v2-in-rect-ratio (v2 r) (assert (<= (r-left r) (v2-h v2) (r-right r))) (assert (<= (r-bottom r) (v2-v v2) (r-top r))) (mkv2 (div-safe (- (v2-h v2) (r-left r)) (r-width r)) (div-safe (- (v2-v v2) (r-bottom r)) (r-height r)))) (defun div-safe (n d &optional (zero-div-return-value 1)) (if (zerop d) zero-div-return-value (/ n d))) (defmethod c-value-incf (c (base v2) (delta number)) (declare (ignore c)) (mkv2 (+ (v2-h base) delta) (+ (v2-v base) delta))) (defmethod c-value-incf (c (base v2) (delta v2)) (declare (ignore c)) (v2-add base delta)) ; synapse support ; (defmethod delta-diff ((new v2) (old v2) (subtypename (eql 'v2))) (v2-subtract new old)) (defmethod delta-identity ((dispatcher number) (subtypename (eql 'v2))) (mkv2 0 0)) (defun long-v2 (long-hv) (c-assert (numberp long-hv)) (multiple-value-bind (fv fh) (floor long-hv 65536) (mkv2 fh fv))) (defun long-x (long-hv) (c-assert (numberp long-hv)) (mod long-hv 65536)) (defun long-y (long-hv) (c-assert (numberp long-hv)) (floor long-hv 65536)) [229 lines skipped] --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/06/04 13:19:59 1.1 [369 lines skipped] --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/06/04 13:19:59 1.1 [722 lines skipped] --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/06/04 13:19:59 NONE +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/06/04 13:19:59 1.1 [809 lines skipped]

1 0

2025

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs June 2006