December 2006 - cells-cvs@common-lisp.net

[cells-cvs] CVS cells
by ktilton 13 Dec '06

13 Dec '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv6305 Modified Files: cells.lpr constructors.lisp family.lisp Added Files: variables.lisp Log Message: --- /project/cells/cvsroot/cells/cells.lpr 2006/12/12 15:58:42 1.25 +++ /project/cells/cvsroot/cells/cells.lpr 2006/12/13 18:05:08 1.26 @@ -23,8 +23,7 @@ (make-instance 'module :name "md-utilities.lisp") (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") - (make-instance 'module :name "family-values.lisp") - (make-instance 'module :name "variables.lisp")) + (make-instance 'module :name "family-values.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/constructors.lisp 2006/12/12 15:58:42 1.14 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/12/13 18:05:08 1.15 @@ -62,7 +62,8 @@ :rule (c-lambda ,@body) ,@args)) -(export! c?once c?n-until c?1) +(export! c?once c?n-until c?1 c_1) + (defmacro c?once (&body body) `(make-c-dependent :code '(without-c-dependency ,@body) @@ -70,6 +71,14 @@ :value-state :unevaluated :rule (c-lambda (without-c-dependency ,@body)))) +(defmacro c_1 (&body body) + `(make-c-dependent + :code '(without-c-dependency ,@body) + :inputp nil + :lazy t + :value-state :unevaluated + :rule (c-lambda (without-c-dependency ,@body)))) + (defmacro c?1 (&body body) `(c?once ,@body)) --- /project/cells/cvsroot/cells/family.lisp 2006/11/13 05:28:08 1.17 +++ /project/cells/cvsroot/cells/family.lisp 2006/12/13 18:05:08 1.18 @@ -19,12 +19,14 @@ (in-package :cells) (eval-when (:compile-toplevel :execute :load-toplevel) - (export '(model value family kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable))) + (export '(model value family dbg + kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable))) (defmodel model () ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name) (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent) - (.value :initform nil :accessor value :initarg :value))) + (.value :initform nil :accessor value :initarg :value) + (zdbg :initform nil :accessor dbg :initarg :dbg))) (defmethod fm-parent (other) --- /project/cells/cvsroot/cells/variables.lisp 2006/12/13 18:05:08 NONE +++ /project/cells/cvsroot/cells/variables.lisp 2006/12/13 18:05:08 1.1 ;; -*- 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) (defun c-variable-accessor (symbol) (assert (symbolp symbol)) (c-variable-reader symbol)) (defun (setf c-variable-accessor) (value symbol) (assert (symbolp symbol)) (c-variable-writer value symbol)) (defun c-variable-reader (symbol) (assert (symbolp symbol)) (assert (get symbol 'cell)) (cell-read (get symbol 'cell))) (defun c-variable-writer (value symbol) (assert (symbolp symbol)) (setf (md-slot-value nil symbol) value) (setf (symbol-value symbol) value)) (export! def-c-variable) (defmacro def-c-variable (v-name cell &key ephemeral owning unchanged-if) (declare (ignore unchanged-if)) (let ((c 'whathef)) ;;(gensym))) `(progn (eval-when (:compile-toplevel :load-toplevel) (define-symbol-macro ,v-name (c-variable-accessor ',v-name)) (setf (md-slot-cell-type 'null ',v-name) (when ,ephemeral :ephemeral)) (when ,owning (setf (md-slot-owning 'null ',v-name) t))) (eval-when (:load-toplevel) (let ((,c ,cell)) (md-install-cell nil ',v-name ,c) (awaken-cell ,c))) ',v-name))) (defobserver *kenny* () (trcx kenny-obs new-value old-value old-value-boundp)) #+test (def-c-variable *kenny* (c-in nil)) #+test (defmd kenny-watcher () (twice (c? (bwhen (k *kenny*) (* 2 k))))) (defobserver twice () (trc "twice kenny is:" new-value self old-value old-value-boundp)) #+test-ephem (progn (cells-reset) (let ((tvw (make-instance 'kenny-watcher))) (trcx twice-read (twice tvw)) (setf *c-debug* nil) (setf *kenny* 42) (setf *kenny* 42) (trcx post-setf-kenny *kenny*) (trcx print-twice (twice tvw)) )) #+test (let ((*kenny* 13)) (print *kenny*)) #+test (let ((c (c-in 42))) (md-install-cell '*test-c-variable* '*test-c-variable* c) (awaken-cell c) (let ((tvw (make-instance 'test-var-watcher))) (trcx twice-read (twice tvw)) (setf *test-c-variable* 69) (trcx print-testvar *test-c-variable*) (trcx print-twice (twice tvw)) (unless (eql (twice tvw) 138) (inspect (md-slot-cell tvw 'twice)) (inspect c) )) ) #+test2 (let ((tvw (make-instance 'test-var-watcher :twice (c-in 42)))) (let ((c (c? (trcx joggggggggging!!!!!!!!!!!!!!!) (floor (twice tvw) 2)))) (md-install-cell '*test-c-variable* '*test-c-variable* c) (awaken-cell c) (trcx print-testvar *test-c-variable*) (trcx twice-read (twice tvw)) (setf (twice tvw) 138) (trcx print-twice (twice tvw)) (trcx print-testvar *test-c-variable*) (unless (eql *test-c-variable* 69) (inspect (md-slot-cell tvw 'twice)) (inspect c) )) )

1 0

[cells-cvs] CVS Celtk
by ktilton 12 Dec '06

12 Dec '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv11738 Modified Files: Celtk.lisp composites.lisp run.lisp tk-interp.lisp togl.lisp widget.lisp Added Files: CelloTk-test.lisp CelloTk.lpr Celtk3D.lpr cellogears.lisp gears.asd Log Message: --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/11/13 05:28:52 1.37 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/12/12 16:00:44 1.38 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.37 2006/11/13 05:28:52 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.38 2006/12/12 16:00:44 ktilton Exp $ (defpackage :celtk (:nicknames "CTK") @@ -53,6 +53,7 @@ (in-package :Celtk) + #+(and allegrocl ide (not runtime-system)) (ide::defdefiner defcallback defun) @@ -111,7 +112,7 @@ ; --- debug stuff --------------------------------- ; - (let ((yes '("pack")) + (let ((yes '()) (no '("font"))) (declare (ignorable yes no)) (when (and (or ;; (null yes) --- /project/cells/cvsroot/Celtk/composites.lisp 2006/11/13 05:28:52 1.21 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/12/12 16:00:44 1.22 @@ -147,6 +147,7 @@ ) + (defmethod do-on-key-down :before (self &rest args &aux (keysym (car args))) (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw)) (bwhen (mod (keysym-to-modifier keysym)) --- /project/cells/cvsroot/Celtk/run.lisp 2006/11/13 05:28:52 1.23 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/12/12 16:00:44 1.24 @@ -117,15 +117,17 @@ #+shhh (call-dump-event client-data xe)) (:configurenotify - (setf (^width) (ekx new-width!!! parse-integer (tk-eval "winfo width ."))) + (setf (^width) (parse-integer (tk-eval "winfo width ."))) (with-cc :height (setf (^height) (parse-integer (tk-eval "winfo height .")))) ) (:visibilitynotify - (mathx::a1-snack-off :startup "" 0.8)) + ;;(funcall (find-symbol "A1-SOUND-EFFECT-PLAY" '#:mathx) self :startup "" 0.8) + ) + (:destroyNotify - (mathx::a1-snack-off :quit "-blocking yes" 0.5) + ;(funcall (find-symbol "A1-SOUND-EFFECT-PLAY" '#:mathx) self :quit "-blocking yes" 0.5) (let ((*windows-destroyed* (cons *tkw* *windows-destroyed*))) (ensure-destruction *tkw*))) --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/06/07 22:13:41 1.15 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/12/12 16:00:45 1.16 @@ -183,7 +183,10 @@ (defun argv0 () #+allegro (sys:command-line-argument 0) #+lispworks (nth 0 system:*line-arguments-list*) ;; portable to OS X - #+sbcl (nth 0 sb-ext:*posix-argv*)) + #+sbcl (nth 0 sb-ext:*posix-argv*) + #+openmcl (car ccl:*command-line-argument-list*) + #-(or allegro lispworks sbcl openmcl) + (error "argv0 function not implemented for this lisp")) (defun tk-interp-init-ensure () (unless *initialized* --- /project/cells/cvsroot/Celtk/togl.lisp 2006/11/04 20:53:08 1.23 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/12/12 16:00:46 1.24 @@ -197,8 +197,8 @@ ; ; just comment out these two lines if not using Cello ; - (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready - (kt-opengl:kt-opengl-reset) + ;; (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready + ;;(kt-opengl:kt-opengl-reset) (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self)) --- /project/cells/cvsroot/Celtk/widget.lisp 2006/10/02 02:56:01 1.18 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/12/12 16:00:46 1.19 @@ -121,10 +121,22 @@ (^path) new-value (^parent-y))))) (defcallback widget-event-handler-callback :void ((client-data :pointer)(xe :pointer)) + #+demo + (handler-case + (bif (self (tkwin-widget client-data)) + (widget-event-handle self xe) + ;; sometimes I hit the next branch restarting after crash.... + (trc "widget-event-handler > no widget for tkwin ~a" client-data)) + (t (error) + (declare (ignorable error)) + ;;(mathx::a1-sound-play :backtrace) + #-demo (invoke-debugger error) + )) + #-demo (bif (self (tkwin-widget client-data)) - (widget-event-handle self xe) - ;; sometimes I hit the next branch restarting after crash.... - (trc "widget-event-handler > no widget for tkwin ~a" client-data))) + (widget-event-handle self xe) + ;; sometimes I hit the next branch restarting after crash.... + (trc "widget-event-handler > no widget for tkwin ~a" client-data))) (defmethod widget-event-handle ((self widget) xe) ;; override for class-specific handling (trc nil "bingo widget-event-handle" (xevent-type xe)) --- /project/cells/cvsroot/Celtk/CelloTk-test.lisp 2006/12/12 16:00:47 NONE +++ /project/cells/cvsroot/Celtk/CelloTk-test.lisp 2006/12/12 16:00:47 1.1 #| This library is meant to be the minimal Tk/Togl reuired to support a Cello application that dpes not use Tk widgets other than the Window, Menus, and Togl. This library does not have a test function. To test, look for Celtk3D which pulls in cl-opengl, this project, and the gears demo. |#--- /project/cells/cvsroot/Celtk/CelloTk.lpr 2006/12/12 16:00:47 NONE +++ /project/cells/cvsroot/Celtk/CelloTk.lpr 2006/12/12 16:00:47 1.1 ;; -*- lisp-version: "8.0 [Windows] (Dec 9, 2006 20:44)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :CELTK) (define-project :name :celtk :modules (list (make-instance 'module :name "Celtk.lisp") (make-instance 'module :name "tk-structs.lisp") (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 "font.lisp") (make-instance 'module :name "widget.lisp") (make-instance 'module :name "layout.lisp") (make-instance 'module :name "timer.lisp") (make-instance 'module :name "menu.lisp") (make-instance 'module :name "composites.lisp") (make-instance 'module :name "frame.lisp") (make-instance 'module :name "fileevent.lisp") (make-instance 'module :name "togl.lisp") (make-instance 'module :name "run.lisp") (make-instance 'module :name "CelloTk-test.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells") (make-instance 'project-module :name "C:\\1-devtools\\cffi\\cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :celtk :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 'celtk::cellogears :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/Celtk3D.lpr 2006/12/12 16:00:47 NONE +++ /project/cells/cvsroot/Celtk/Celtk3D.lpr 2006/12/12 16:00:47 1.1 ;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :CELTK) (define-project :name :celtk3d :modules (list (make-instance 'module :name "cellogears.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells") (make-instance 'project-module :name "C:\\1-devtools\\cffi\\cffi") (make-instance 'project-module :name "cellotk") (make-instance 'project-module :name "C:\\1-devtools\\cl-opengl\\glu")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :celtk :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 'celtk::cellogears :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/cellogears.lisp 2006/12/12 16:00:47 NONE +++ /project/cells/cvsroot/Celtk/cellogears.lisp 2006/12/12 16:00:47 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. (in-package :celtk) (defvar *startx*) (defvar *starty*) (defvar *xangle0*) (defvar *yangle0*) (defvar *xangle*) (defvar *yangle*) (defparameter *vTime* 100) (defun cellogears () ;; 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")) (make-instance 'gears :fm-parent *parent* :width 400 :height 400 :timer-interval (c? (let ((n$ "100")) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" :event-handler (c? (lambda (self xe) (trc nil "togl event" (tk-event-type (xsv type xe))) (case (tk-event-type (xsv type xe)) (:virtualevent (trc nil "canvas virtual" (xsv name xe))) (:buttonpress #+not (RotStart self (xsv x xe) (xsv y xe)) (RotStart self (xsv x-root xe) (xsv y-root xe))) (:motionnotify #+not (RotMove self (xsv x xe) (xsv y xe)) (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* (trc nil "rotmove started" x *startx* *xangle0*) (setf *xangle* (+ *xangle0* (- x *startx*))) (setf *yangle* (+ *yangle0* (- y *starty*))) (setf (rotx self) *xangle*) (setf (roty self) *yangle*) (togl-post-redisplay (togl-ptr self)))) (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 nil "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-post-redisplay (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 nil "reshape") (truc self t) ) (defun truc (self &optional truly) (let ((width (Togl-width (togl-ptr self))) (height (Togl-height (togl-ptr self)))) (trc nil "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)) (trc nil "display angle" (^rotx)(^roty)(^rotz)) (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-Swap-Buffers (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))) [103 lines skipped] --- /project/cells/cvsroot/Celtk/gears.asd 2006/12/12 16:00:47 NONE +++ /project/cells/cvsroot/Celtk/gears.asd 2006/12/12 16:00:47 1.1 [120 lines skipped]

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 12 Dec '06

12 Dec '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv9859/utils-kt Modified Files: detritus.lisp flow-control.lisp utils-kt.lpr Log Message: --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/10/11 22:16:22 1.11 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/12/12 15:58:43 1.12 @@ -20,12 +20,15 @@ (in-package :utils-kt) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(eval-now! export!))) + (export '(eval-now! export! assocd rassoca))) (defmacro wdbg (&body body) `(let ((*dbg* t)) ,@body)) +(defun assocd (x y) (cdr (assoc x y))) +(defun rassoca (x y) (car (assoc x y))) + ;;;(defmethod class-slot-named ((classname symbol) slotname) ;;; (class-slot-named (find-class classname) slotname)) ;;; --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/11/04 20:52:02 1.8 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/12/12 15:58:43 1.9 @@ -149,3 +149,33 @@ (defmethod instance-slots (self) (class-slots (class-of self))) ;; acl has this for structs +;;; ---- without-repeating ---------------------------------------------- + +;; Returns a function that generates an elements from ALL each time it +;; is called. When a certain element is generated it will take at +;; least DECENT-INTERVAL calls before it is generated again. +;; +;; note: order of ALL is important for first few calls, could be fixed + +(defun without-repeating-generator (decent-interval all) + (let ((len (length all)) + (head (let ((v (copy-list all))) + (nconc v v)))) + (lambda () + (if (< len 2) + (car all) + (prog2 + (rotatef (car head) + (car (nthcdr (random (- len decent-interval)) + head))) + (car head) + (setf head (cdr head))))))) + +(export! without-repeating) + +(let ((generators (make-hash-table :test 'equalp))) + (defun without-repeating (key all &optional (decent-interval (floor (length all) 2))) + (funcall (or (gethash key generators) + (setf (gethash key generators) + (without-repeating-generator decent-interval all)))))) + --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/11/13 05:28:09 1.20 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/12/12 15:58:43 1.21 @@ -15,7 +15,8 @@ (make-instance 'module :name "flow-control.lisp") (make-instance 'module :name "detritus.lisp") (make-instance 'module :name "strings.lisp") - (make-instance 'module :name "datetime.lisp")) + (make-instance 'module :name "datetime.lisp") + (make-instance 'module :name "split-sequence.lisp")) :projects nil :libraries nil :distributed-files nil

1 0

[cells-cvs] CVS cells
by ktilton 12 Dec '06

12 Dec '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv9859 Modified Files: cell-types.lisp cells.lisp cells.lpr constructors.lisp defmodel.lisp link.lisp md-slot-value.lisp Log Message: --- /project/cells/cvsroot/cells/cell-types.lisp 2006/11/13 05:28:08 1.23 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/12/12 15:58:42 1.24 @@ -42,6 +42,8 @@ debug md-info) + + ;_____________________ print __________________________________ #+sigh @@ -67,7 +69,7 @@ (format stream "=~d/~a/~a]" (c-pulse c) (symbol-name (or (c-slot-name c) :anoncell)) - (bwhen (md (c-model c)) (md-name md) :anonmd))))))) + (bwhen (md (c-model c)) (or (md-name md) :anonmd)))))))) (defmethod trcp :around ((c cell)) (or (c-debug c) @@ -79,6 +81,7 @@ (defun caller-ensure (used new-caller) (unless (find new-caller (c-callers used)) + (trc nil "caller-ensure fifo-adding new-caller" new-caller :used used) (fifo-add (c-caller-store used) new-caller))) (defun caller-drop (used caller) --- /project/cells/cvsroot/cells/cells.lisp 2006/10/28 18:20:48 1.18 +++ /project/cells/cvsroot/cells/cells.lisp 2006/12/12 15:58:42 1.19 @@ -76,7 +76,11 @@ `t)))) (defmacro without-c-dependency (&body body) - `(let (*call-stack*) ,@body)) + `(call-without-c-dependency (lambda () ,@body))) + +(defun call-without-c-dependency (fn) + (let (*call-stack*); *no-tell*) + (funcall fn))) (export! .cause) --- /project/cells/cvsroot/cells/cells.lpr 2006/11/13 05:28:08 1.24 +++ /project/cells/cvsroot/cells/cells.lpr 2006/12/12 15:58:42 1.25 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Dec 9, 2006 20:44)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/constructors.lisp 2006/11/13 05:28:08 1.13 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/12/12 15:58:42 1.14 @@ -62,7 +62,7 @@ :rule (c-lambda ,@body) ,@args)) -(export! c?once c?n-until) +(export! c?once c?n-until c?1) (defmacro c?once (&body body) `(make-c-dependent :code '(without-c-dependency ,@body) @@ -70,6 +70,9 @@ :value-state :unevaluated :rule (c-lambda (without-c-dependency ,@body)))) +(defmacro c?1 (&body body) + `(c?once ,@body)) + (defmacro c?dbg (&body body) `(make-c-dependent :code ',body --- /project/cells/cvsroot/cells/defmodel.lisp 2006/11/13 05:28:08 1.11 +++ /project/cells/cvsroot/cells/defmodel.lisp 2006/12/12 15:58:42 1.12 @@ -23,10 +23,14 @@ (assert (not (find class directsupers))() "~a cannot be its own superclass" class) `(progn (eval-when (:compile-toplevel :execute :load-toplevel) - (setf (get ',class :cell-types) nil)) - ; - ; define slot macros before class so they can appear in initforms and default-initargs - ; + (setf (get ',class :cell-types) nil) + (setf (get ',class 'slots-excluded-from-persistence) + ',(loop for slotspec in slotspecs + unless (and (getf (cdr slotspec) :ps t) + (getf (cdr slotspec) :persistable t)) + collect (car slotspec)))) + ;; define slot macros before class so they can appear in + ;; initforms and default-initargs ,@(delete nil (loop for slotspec in slotspecs nconcing (destructuring-bind @@ -54,6 +58,8 @@ ,(mapcar (lambda (s) (list* (car s) (let ((ias (cdr s))) + (remf ias :persistable) + (remf ias :ps) ;; We handle accessor below (when (getf ias :cell t) (remf ias :reader) @@ -120,6 +126,8 @@ (defun defmd-canonicalize-slot (slotname &key (cell nil cell-p) + (ps t ps-p) + (persistable t persistable-p) (owning nil owning-p) (type nil type-p) (initform nil initform-p) @@ -133,6 +141,8 @@ (list* slotname :initarg initarg (append (when cell-p (list :cell cell)) + (when ps-p (list :ps ps)) + (when persistable-p (list :persistable persistable)) (when owning-p (list :owning owning)) (when type-p (list :type type)) (when initform-p (list :initform initform)) @@ -158,7 +168,7 @@ ((keywordp (car spec)) (assert (find (car spec) '(:documentation :metaclass))) (push spec class-options)) - ((find (cadr spec) '(:initarg :type :cell :initform :allocation :reader :writer :accessor :documentation)) + ((find (cadr spec) '(:initarg :type :ps :persistable :cell :initform :allocation :reader :writer :accessor :documentation)) (push (apply 'defmd-canonicalize-slot spec) slots)) (t ;; shortform (slotname initform &rest slotdef-key-values) (push (apply 'defmd-canonicalize-slot @@ -186,4 +196,4 @@ (ccc 42 :allocation :class) (ddd (c-in nil) :cell :ephemeral) :superx 42 ;; default-initarg - (:documentation "as if!"))) \ No newline at end of file + (:documentation "as if!"))) --- /project/cells/cvsroot/cells/link.lisp 2006/11/03 13:37:10 1.21 +++ /project/cells/cvsroot/cells/link.lisp 2006/12/12 15:58:42 1.22 @@ -22,12 +22,18 @@ (eval-when (compile load) (proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0)))) + (defun record-caller (used &aux (caller (car *call-stack*))) (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell (trc nil "caller not being recorded because used optimized away" caller (c-value used) :used used) (return-from record-caller nil)) (trc nil "record-caller entry: used=" used :caller caller) - +;;; (when (trcp caller) +;;; +;;; ;;(when (eq (c-slot-name caller) 'mathx::phrases) +;;; (when (eq (c-slot-name used) 'mathx::opnds) +;;; (break "bingo"))) + (multiple-value-bind (used-pos useds-len) (loop with u-pos for known in (cd-useds caller) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/11/13 05:28:08 1.32 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/12/12 15:58:42 1.33 @@ -55,10 +55,14 @@ (when (eq :eternal-rest (md-state s)) (break "model ~a is dead at ~a" s key))) -(defun ensure-value-is-current (c debug-id caller) - (declare (ignorable debug-id caller)) +(defun ensure-value-is-current (c debug-id ensurer) + ; + ; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure + ; dependencies are up-to-date before deciding if it itself is up-to-date + ; + (declare (ignorable debug-id ensurer)) (count-it :ensure-value-is-current) - (trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id caller) + (trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id ensurer) (when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c)))) (break "model ~a of cell ~a is dead" (c-model c) c)) @@ -87,7 +91,7 @@ (or (check-reversed (cdr useds)) (let ((used (car useds))) (ensure-value-is-current used :nested c) - (trc nil "comparing pulses (caller, used, used-changed): " c debug-id used (c-pulse-last-changed used)) + (trc nil "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used)) (when (> (c-pulse-last-changed used)(c-pulse c)) (trc nil "used changed and newer !!!!!!" c debug-id used) t)))))) @@ -246,8 +250,8 @@ (c-value-state c) :valid (c-state c) :awake) - - (case (cd-optimize c) + (case (and (typep c 'c-dependent) + (cd-optimize c)) ((t) (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking (:when-value-t (when (c-value c) (c-unlink-from-used c)))) @@ -273,8 +277,8 @@ (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around) (not (c-inputp c)) ;; yes, dependent cells can be inputp ) - (when (trcp c) (break "go optimizing ~a" c)) - (trc c "optimizing away" c (c-state c)) + ;; (when (trcp c) (break "go optimizing ~a" c)) + (trc nil "optimizing away" c (c-state c)) (count-it :c-optimized) (setf (c-state c) :optimized-away) @@ -283,7 +287,7 @@ (unless entry (describe c)) (c-assert entry) - (trc c "c-optimize-away?! moving cell to flushed list" c) + (trc nil "c-optimize-away?! moving cell to flushed list" c) (setf (cells (c-model c)) (delete entry (cells (c-model c)))) (push entry (cells-flushed (c-model c))))

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 12 Dec '06

12 Dec '06

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv9859/gui-geometry Modified Files: geo-data-structures.lisp Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/10/28 18:20:54 1.8 +++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/12/12 15:58:42 1.9 @@ -146,6 +146,7 @@ (expt (v2-v to) 2)))) ;------------------------------------------------- +(export! rect) (defstruct (rect (:conc-name r-)) (left 0 ) (top 0 )

1 0