├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── doc └── intro.md ├── lisp ├── cell-types.lisp ├── cells-store.lisp ├── cells.lisp ├── constructors.lisp ├── defmodel.lisp ├── defpackage.lisp ├── family-values.lisp ├── family.lisp ├── fm-utilities.lisp ├── initialize.lisp ├── integrity.lisp ├── link.lisp ├── md-slot-value.lisp ├── md-utilities.lisp ├── model-object.lisp ├── propagate.lisp ├── slot-utilities.lisp ├── synapse-types.lisp ├── synapse.lisp ├── test-cc.lisp ├── test-cycle.lisp ├── test-ephemeral.lisp ├── test-propagation.lisp ├── test-synapse.lisp ├── test.lisp ├── trc-eko.lisp └── variables.lisp ├── project.clj ├── src └── tiltontec │ ├── its_alive │ ├── cell_types.clj │ ├── cells.clj │ ├── evaluate.clj │ ├── family.clj │ ├── integrity.clj │ ├── model.clj │ ├── model_base.clj │ ├── observer.clj │ └── utility.clj │ └── lisp │ ├── 01-lesson.lisp │ ├── cell-types.lisp │ ├── cells-store.lisp │ ├── cells.lisp │ ├── constructors.lisp │ ├── defmodel.lisp │ ├── defpackage.lisp │ ├── family-values.lisp │ ├── family.lisp │ ├── fm-utilities.lisp │ ├── initialize.lisp │ ├── integrity.lisp │ ├── link.lisp │ ├── md-slot-value.lisp │ ├── md-utilities.lisp │ ├── model-object.lisp │ ├── propagate.lisp │ ├── slot-utilities.lisp │ ├── synapse-types.lisp │ ├── synapse.lisp │ ├── test-cc.lisp │ ├── test-cycle.lisp │ ├── test-ephemeral.lisp │ ├── test-propagation.lisp │ ├── test-synapse.lisp │ ├── test.lisp │ ├── trc-eko.lisp │ └── variables.lisp └── test └── tiltontec └── its_alive ├── cell_types_test.clj ├── cells_test.clj ├── evaluate_test.clj ├── family_test.clj ├── hello_world_test.clj ├── integrity_test.clj ├── kids_test.clj ├── lazy_cells_test.clj ├── model_base_test.clj ├── model_test.clj ├── observer_test.clj └── utility_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | pom.xml 2 | pom.xml.asc 3 | *jar 4 | /lib/ 5 | /classes/ 6 | /target/ 7 | /otest/ 8 | /absorbed/ 9 | /archive/ 10 | /notyet/ 11 | /checkouts/ 12 | .lein-deps-sum 13 | .lein-repl-history 14 | .lein-plugins/ 15 | .lein-failures 16 | .nrepl-port 17 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change Log 2 | All notable changes to this project will be documented in this file. This change log follows the conventions of [keepachangelog.com](http://keepachangelog.com/). 3 | 4 | ## [Unreleased] 5 | ### Changed 6 | - Add a new arity to `make-widget-async` to provide a different widget shape. 7 | 8 | ## [0.1.1] - 2016-04-08 9 | ### Changed 10 | - Documentation on how to make the widgets. 11 | 12 | ### Removed 13 | - `make-widget-sync` - we're all async, all the time. 14 | 15 | ### Fixed 16 | - Fixed widget maker to keep working when daylight savings switches over. 17 | 18 | ## 0.1.0 - 2016-04-08 19 | ### Added 20 | - Files from the new template. 21 | - Widget maker public API - `make-widget-sync`. 22 | 23 | [Unreleased]: https://github.com/your-name/its-alive/compare/0.1.1...HEAD 24 | [0.1.1]: https://github.com/your-name/its-alive/compare/0.1.0...0.1.1 25 | -------------------------------------------------------------------------------- /doc/intro.md: -------------------------------------------------------------------------------- 1 | # Introduction to its-alive 2 | 3 | TODO: write [great documentation](http://jacobian.org/writing/what-to-write/) 4 | -------------------------------------------------------------------------------- /lisp/cell-types.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (defstruct (cell (:conc-name c-)) 13 | model 14 | slot-name 15 | value 16 | 17 | inputp ;; t for old c-variable class 18 | synaptic 19 | (caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO 20 | 21 | (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away 22 | (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :uncurrent | :valid} 23 | ; uncurrent (aka dirty) new for 06-10-15. we need this so 24 | ; c-quiesce can force a caller to update when asked 25 | ; in case the owner of the quiesced cell goes out of existence 26 | ; in a way the caller will not see via any kids dependency. Saw 27 | ; this one coming a long time ago: depending on cell X implies 28 | ; a dependency on the existence of instance owning X 29 | (pulse 0 :type fixnum) 30 | (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP 31 | (pulse-observed 0 :type fixnum) 32 | lazy 33 | (optimize t) 34 | debug 35 | md-info) 36 | 37 | 38 | 39 | ;_____________________ print __________________________________ 40 | 41 | #+sigh 42 | (defmethod print-object :before ((c cell) stream) 43 | (declare (ignorable stream)) 44 | #+shhh (unless (or *stop* *print-readably*) 45 | (format stream "[~a~a:" (if (c-inputp c) "i" "?") 46 | (cond 47 | ((null (c-model c)) #\0) 48 | ((eq :eternal-rest (md-state (c-model c))) #\_) 49 | ((not (c-currentp c)) #\#) 50 | (t #\space))))) 51 | 52 | (defmethod print-object ((c cell) stream) 53 | (declare (ignorable stream)) 54 | (if *stop* 55 | (format stream "<~d:~a ~a/~a = ~a>" 56 | (c-pulse c) 57 | (subseq (string (c-state c)) 0 1) 58 | (symbol-name (or (c-slot-name c) :anoncell)) 59 | (md-name (c-model c)) 60 | (type-of (c-value c))) 61 | (let ((*print-circle* t)) 62 | #+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c)) 63 | (if *print-readably* 64 | (call-next-method) 65 | (progn 66 | (c-print-value c stream) 67 | (format stream "<~a ~d:~a ~a/~a = ~a>" 68 | (type-of c) 69 | (c-pulse c) 70 | (subseq (string (c-state c)) 0 1) 71 | (symbol-name (or (c-slot-name c) :anoncell)) 72 | (print-cell-model (c-model c)) 73 | (if (consp (c-value c)) 74 | "LST" (c-value c)))))))) 75 | 76 | (export! print-cell-model) 77 | 78 | (defgeneric print-cell-model (md) 79 | (:method (other) (print-object other nil))) 80 | 81 | (defmethod trcp :around ((c cell)) 82 | (and ;*c-debug* 83 | (or (c-debug c) 84 | (call-next-method)))) 85 | 86 | (defun c-callers (c) 87 | "Make it easier to change implementation" 88 | (fifo-data (c-caller-store c))) 89 | 90 | (defun caller-ensure (used new-caller) 91 | (unless (find new-caller (c-callers used)) 92 | (trc nil "caller-ensure fifo-adding new-caller" new-caller :used used) 93 | (fifo-add (c-caller-store used) new-caller))) 94 | 95 | (defun caller-drop (used caller) 96 | (fifo-delete (c-caller-store used) caller)) 97 | 98 | ; --- ephemerality -------------------------------------------------- 99 | ; 100 | ; Not a type, but an option to the :cell parameter of defmodel 101 | ; 102 | (defun ephemeral-p (c) 103 | (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c)))) 104 | 105 | (defun ephemeral-reset (c) 106 | (when (ephemeral-p c) ;; so caller does not need to worry about this 107 | ; 108 | ; as of Cells3 we defer resetting ephemerals because everything 109 | ; else gets deferred and we cannot /really/ reset it until 110 | ; within finish_business we are sure all callers have been recalculated 111 | ; and all outputs completed. 112 | ; 113 | ; ;; good q: what does (setf 'x) return? historically nil, but...? 114 | ; 115 | ;;(trcx bingo-ephem c) 116 | (with-integrity (:ephemeral-reset c) 117 | (trc nil "!!!!!!!!!!!!!! ephemeral-reset resetting:" c) 118 | (md-slot-value-store (c-model c) (c-slot-name c) nil) 119 | (setf (c-value c) nil)))) 120 | 121 | ; ----------------------------------------------------- 122 | 123 | (defun c-validate (self c) 124 | (when (not (and (c-slot-name c) (c-model c))) 125 | (format t "~&unadopted cell: ~s md:~s" c self) 126 | (c-break "unadopted cell ~a ~a" self c) 127 | (error 'c-unadopted :cell c))) 128 | 129 | (defstruct (c-ruled 130 | (:include cell) 131 | (:conc-name cr-)) 132 | (code nil :type list) ;; /// feature this out on production build 133 | rule) 134 | 135 | (defun c-optimized-away-p (c) 136 | (eq :optimized-away (c-state c))) 137 | 138 | ;---------------------------- 139 | 140 | (defmethod trcp-slot (self slot-name) 141 | (declare (ignore self slot-name))) 142 | 143 | (defstruct (c-dependent 144 | (:include c-ruled) 145 | (:conc-name cd-)) 146 | ;; chop (synapses nil :type list) 147 | (useds nil :type list) 148 | (usage (blank-usage-mask))) 149 | 150 | (defun blank-usage-mask () 151 | (make-array 64 :element-type 'bit 152 | :initial-element 0)) 153 | 154 | #+xxxx 155 | (cd-usage nil) 156 | #+xxx 157 | (test-xxx) 158 | (defun test-xxx () 159 | (let ((u (blank-usage-mask))) 160 | (setf (sbit u 25) 1))) 161 | 162 | (defstruct (c-drifter 163 | (:include c-dependent))) 164 | 165 | (defstruct (c-drifter-absolute 166 | (:include c-drifter))) 167 | 168 | ;_____________________ accessors __________________________________ 169 | 170 | (defmethod c-useds (other) (declare (ignore other))) 171 | (defmethod c-useds ((c c-dependent)) (cd-useds c)) 172 | 173 | (defun c-validp (c) 174 | (eql (c-value-state c) :valid)) 175 | 176 | (defun c-unboundp (c) 177 | (eql :unbound (c-value-state c))) 178 | 179 | 180 | ;__________________ 181 | 182 | (defmethod c-print-value ((c c-ruled) stream) 183 | (format stream "~a" (cond ((c-validp c) (cons (c-value c) "")) 184 | ((c-unboundp c) "") 185 | ((not (c-currentp c)) "dirty") 186 | (t "")))) 187 | 188 | (defmethod c-print-value (c stream) 189 | (declare (ignore c stream))) 190 | 191 | -------------------------------------------------------------------------------- /lisp/constructors.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (eval-now! 13 | (export '(.cache-bound-p 14 | 15 | ;; Cells Constructors 16 | c?n 17 | c?once 18 | c?n-until 19 | c?1 20 | c_1 21 | c?+n 22 | 23 | ;; Debug Macros and Functions 24 | c?dbg 25 | c_?dbg 26 | c-input-dbg 27 | 28 | ))) 29 | 30 | ;___________________ constructors _______________________________ 31 | 32 | (defmacro c-lambda (&body body) 33 | `(c-lambda-var (slot-c) ,@body)) 34 | 35 | (defmacro c-lambda-var ((c) &body body) 36 | `(lambda (,c &aux (self (c-model ,c)) 37 | (.cache (c-value ,c)) 38 | (.cache-bound-p (cache-bound-p ,c))) 39 | (declare (ignorable .cache .cache-bound-p self)) 40 | ,@body)) 41 | 42 | (defmacro with-c-cache ((fn) &body body) 43 | (let ((new (gensym))) 44 | `(or (bwhen (,new (progn ,@body)) 45 | (funcall ,fn ,new .cache)) 46 | .cache))) 47 | 48 | ;----------------------------------------- 49 | 50 | (defmacro c? (&body body) 51 | `(make-c-dependent 52 | :code #+live nil #-live ',body 53 | :value-state :unevaluated 54 | :rule (c-lambda ,@body))) 55 | 56 | (defmacro c?+n (&body body) 57 | `(make-c-dependent 58 | :inputp t 59 | :code #+live nil #-live ',body 60 | :value-state :unevaluated 61 | :rule (c-lambda ,@body))) 62 | 63 | (defmacro c?n (&body body) 64 | `(make-c-dependent 65 | :code '(without-c-dependency ,@body) 66 | :inputp t 67 | :value-state :unevaluated 68 | :rule (c-lambda (without-c-dependency ,@body)))) 69 | 70 | (defmacro c_?n (&body body) 71 | `(make-c-dependent 72 | :code '(without-c-dependency ,@body) 73 | :inputp t 74 | :lazy :until-asked 75 | :value-state :unevaluated 76 | :rule (c-lambda (without-c-dependency ,@body)))) 77 | 78 | (export! c?n-dbg c_?n) 79 | 80 | (defmacro c?n-dbg (&body body) 81 | `(make-c-dependent 82 | :code '(without-c-dependency ,@body) 83 | :inputp t 84 | :debug t 85 | :value-state :unevaluated 86 | :rule (c-lambda (without-c-dependency ,@body)))) 87 | 88 | (defmacro c?n-until (args &body body) 89 | `(make-c-dependent 90 | :optimize :when-value-t 91 | :code #+live nil #-live ',body 92 | :inputp t 93 | :value-state :unevaluated 94 | :rule (c-lambda ,@body) 95 | ,@args)) 96 | 97 | (defmacro c?once (&body body) 98 | `(make-c-dependent 99 | :code '(without-c-dependency ,@body) 100 | :inputp nil 101 | :value-state :unevaluated 102 | :rule (c-lambda (without-c-dependency ,@body)))) 103 | 104 | (defmacro c_1 (&body body) 105 | `(make-c-dependent 106 | :code '(without-c-dependency ,@body) 107 | :inputp nil 108 | :lazy t 109 | :value-state :unevaluated 110 | :rule (c-lambda (without-c-dependency ,@body)))) 111 | 112 | (defmacro c?1 (&body body) 113 | `(c?once ,@body)) 114 | 115 | (defmacro c?dbg (&body body) 116 | `(make-c-dependent 117 | :code #+live nil #-live ',body 118 | :value-state :unevaluated 119 | :debug t 120 | :rule (c-lambda ,@body))) 121 | 122 | (defmacro c?_ (&body body) 123 | `(make-c-dependent 124 | :code #+live nil #-live ',body 125 | :value-state :unevaluated 126 | :lazy t 127 | :rule (c-lambda ,@body))) 128 | 129 | (defmacro c_? (&body body) 130 | "Lazy until asked, then eagerly propagating" 131 | `(make-c-dependent 132 | :code #+live nil #-live ',body 133 | :value-state :unevaluated 134 | :lazy :until-asked 135 | :rule (c-lambda ,@body))) 136 | 137 | (defmacro c_?dbg (&body body) 138 | "Lazy until asked, then eagerly propagating" 139 | `(make-c-dependent 140 | :code #+live nil #-live ',body 141 | :value-state :unevaluated 142 | :lazy :until-asked 143 | :rule (c-lambda ,@body) 144 | :debug t)) 145 | 146 | (defmacro c?? ((&key (tagp nil) (in nil) (out t))&body body) 147 | (let ((result (copy-symbol 'result)) 148 | (thetag (gensym))) 149 | `(make-c-dependent 150 | :code #+live nil #-live ',body 151 | :value-state :unevaluated 152 | :rule (c-lambda 153 | (let ((,thetag (gensym "tag")) 154 | (*trcdepth* (1+ *trcdepth*)) 155 | ) 156 | (declare (ignorable self ,thetag)) 157 | ,(when in 158 | `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag))) 159 | (count-it :c?? (c-slot-name c) (md-name (c-model c))) 160 | (let ((,result (progn ,@body))) 161 | ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag))) 162 | ,result)))))) 163 | 164 | (defmacro c-formula ((&rest keys &key lazy &allow-other-keys) &body forms) 165 | (assert (member lazy '(nil t :once-asked :until-asked :always))) 166 | `(make-c-dependent 167 | :code ',forms 168 | :value-state :unevaluated 169 | :rule (c-lambda ,@forms) 170 | ,@keys)) 171 | 172 | (defmacro c-input ((&rest keys) &optional (value nil valued-p)) 173 | `(make-cell 174 | :inputp t 175 | :value-state ,(if valued-p :valid :unbound) 176 | :value ,value 177 | ,@keys)) 178 | 179 | (defmacro c-in (value) 180 | `(make-cell 181 | :inputp t 182 | :value-state :valid 183 | :value ,value)) 184 | 185 | (export! c-in-lazy c_in) 186 | 187 | (defmacro c-in-lazy (&body body) 188 | `(c-input (:lazy :once-asked) (progn ,@body))) 189 | 190 | (defmacro c_in (&body body) 191 | `(c-input (:lazy :once-asked) (progn ,@body))) 192 | 193 | (defmacro c-input-dbg (&optional (value nil valued-p)) 194 | `(make-cell 195 | :inputp t 196 | :debug t 197 | :value-state ,(if valued-p :valid :unbound) 198 | :value ,value)) 199 | 200 | (defmacro c... ((value) &body body) 201 | `(make-c-drifter 202 | :code #+live nil #-live ',body 203 | :value-state :valid 204 | :value ,value 205 | :rule (c-lambda ,@body))) 206 | 207 | (defmacro c-abs (value &body body) 208 | `(make-c-drifter-absolute 209 | :code #+live nil #-live ',body 210 | :value-state :valid 211 | :value ,value 212 | :rule (c-lambda ,@body))) 213 | 214 | 215 | (defmacro c-envalue (&body body) 216 | `(make-c-envaluer 217 | :envalue-rule (c-lambda ,@body))) 218 | 219 | -------------------------------------------------------------------------------- /lisp/defpackage.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | ;;; 3 | ;;; Copyright (c) 1995,2010 by Kenneth William Tilton. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;;; of this software and associated documentation files (the "Software"), to deal 7 | ;;; in the Software without restriction, including without limitation the rights 8 | ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;;; copies of the Software, and to permit persons to whom the Software is furnished 10 | ;;; to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 21 | ;;; IN THE SOFTWARE. 22 | 23 | (in-package :common-lisp-user) 24 | 25 | (eval-when (:compile-toplevel :load-toplevel :execute) 26 | (require :safeseq)) 27 | 28 | (defpackage :cells 29 | (:use #:common-lisp #:utils-kt) 30 | (:nicknames :cz) 31 | (:import-from 32 | ;; MOP 33 | #+allegro #:excl 34 | #+clisp #:clos 35 | #+cmu #:mop 36 | #+cormanlisp #:common-lisp 37 | #+lispworks #:clos 38 | #+sbcl #:sb-mop 39 | #+openmcl-partial-mop #:openmcl-mop 40 | #+(and mcl (not openmcl-partial-mop)) #:ccl 41 | 42 | #-(or allegro clisp cmu cormanlisp lispworks mcl sbcl) 43 | #.(cerror "Provide a package name." 44 | "Don't know how to find the MOP package for this Lisp.") 45 | 46 | #:class-precedence-list 47 | #-(and mcl (not openmcl-partial-mop)) #:class-slots 48 | #:slot-definition-name 49 | #:class-direct-subclasses 50 | ) 51 | (:export #:cell #:.md-name 52 | #:c-input #:c-in #:c-in8 53 | #:c-formula #:c? #:c_? #:c?8 #:c?_ #:c?? 54 | #:with-integrity #:without-c-dependency #:self #:*parent* 55 | #:.cache #:.with-c-cache #:c-lambda 56 | #:defmodel #:defmd #:defobserver #:slot-value-observe #:def-c-unchanged-test 57 | #:new-value #:old-value #:old-value-boundp #:c... 58 | #:md-awaken 59 | #:mkpart #:make-kid #:the-kids #:nsib #:value #:^value #:.value #:kids #:^kids #:.kids 60 | #:cells-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot 61 | #:def-kid-slots #:find-prior #:fm-pos #:kid-no #:fm-includes #:fm-ascendant-common 62 | #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib 63 | #:not-to-be #:ssibno 64 | #:c-debug #:c-break #:c-assert #:c-stop #:c-stopped #:c-assert #:.stop #:delta-diff 65 | #:wtrc #:wnotrc #:eko-if #:trc #:wtrc #:eko #:ekx #:trcp #:trcx) 66 | #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) 67 | ) 68 | -------------------------------------------------------------------------------- /lisp/family-values.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (eval-when (:compile-toplevel :load-toplevel :execute) 13 | (export '(family-values family-values-sorted 14 | sort-index sort-direction sort-predicate sort-key 15 | ^sort-index ^sort-direction ^sort-predicate ^sort-key))) 16 | 17 | (defmodel family-values (family) 18 | ( 19 | (kv-collector :initarg :kv-collector 20 | :initform #'identity 21 | :reader kv-collector) 22 | 23 | (kid-values :initform (c? (when (kv-collector self) 24 | (funcall (kv-collector self) (^value)))) 25 | :accessor kid-values 26 | :initarg :kid-values) 27 | 28 | (kv-key :initform #'identity 29 | :initarg :kv-key 30 | :reader kv-key) 31 | 32 | (kv-key-test :initform #'equal 33 | :initarg :kv-key-test 34 | :reader kv-key-test) 35 | 36 | (kid-factory :initform #'identity 37 | :initarg :kid-factory 38 | :reader kid-factory) 39 | 40 | (.kids :initform (c? (c-assert (listp (kid-values self))) 41 | (let ((new-kids (mapcan (lambda (kid-value) 42 | (list (or (find kid-value .cache 43 | :key (kv-key self) 44 | :test (kv-key-test self)) 45 | (trc nil "family-values forced to make new kid" 46 | self .cache kid-value) 47 | (funcall (kid-factory self) self kid-value)))) 48 | (^kid-values)))) 49 | (nconc (mapcan (lambda (old-kid) 50 | (unless (find old-kid new-kids) 51 | (when (fv-kid-keep self old-kid) 52 | (list old-kid)))) 53 | .cache) 54 | new-kids))) 55 | :accessor kids 56 | :initarg :kids))) 57 | 58 | (defmethod fv-kid-keep (family old-kid) 59 | (declare (ignorable family old-kid)) 60 | nil) 61 | 62 | (defmodel family-values-sorted (family-values) 63 | ((sorted-kids :initarg :sorted-kids :accessor sorted-kids 64 | :initform nil) 65 | (sort-map :initform (c-in nil) :initarg :sort-map :accessor sort-map) 66 | (.kids :initform (c? (c-assert (listp (kid-values self))) 67 | (mapsort (^sort-map) 68 | (the-kids 69 | (mapcar (lambda (kid-value) 70 | (trc "making kid" kid-value) 71 | (or (find kid-value .cache :key (kv-key self) :test (kv-key-test self)) 72 | (trc nil "family-values forced to make new kid" self .cache kid-value) 73 | (funcall (kid-factory self) self kid-value))) 74 | (^kid-values))))) 75 | :accessor kids 76 | :initarg :kids))) 77 | 78 | (defun mapsort (map data) 79 | ;;(trc "mapsort map" map) 80 | (if map 81 | (stable-sort data #'< :key (lambda (datum) (or (position datum map) 82 | ;(trc "mapsort datum not in map" datum) 83 | (1+ (length data))))) 84 | data)) 85 | 86 | (defobserver sorted-kids () 87 | (setf (sort-map self) new-value)) ;; cellular trick to avoid cyclicity -------------------------------------------------------------------------------- /lisp/initialize.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | Copyright (C) 1995, 2006 by Kenneth Tilton 7 | 8 | 9 | 10 | |# 11 | 12 | (in-package :cells) 13 | 14 | (eval-when (compile eval load) 15 | (export '(c-envalue))) 16 | 17 | (defstruct (c-envaluer (:conc-name nil)) 18 | envalue-rule) 19 | 20 | (defmethod awaken-cell (c) 21 | (declare (ignorable c))) 22 | 23 | (defmethod awaken-cell ((c cell)) 24 | (assert (c-inputp c)) 25 | ; 26 | ; nothing to calculate, but every cellular slot should be output 27 | ; 28 | (when (> *data-pulse-id* (c-pulse-observed c)) 29 | ;(trc nil "awaken-pulsing" :*dpid* *data-pulse-id* :cdpid (c-pulse-observed c) c) 30 | (setf (c-pulse-observed c) *data-pulse-id*) 31 | (trc nil "awaken cell observing" c *data-pulse-id*) 32 | (let ((*observe-why* :awaken-cell)) 33 | (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil c)) 34 | (ephemeral-reset c))) 35 | 36 | (defmethod awaken-cell ((c c-ruled)) 37 | (let (*depender*) 38 | (calculate-and-set c :fn-awaken-cell nil))) 39 | 40 | #+cormanlisp ; satisfy CormanCL bug 41 | (defmethod awaken-cell ((c c-dependent)) 42 | (let (*depender*) 43 | (trc nil "awaken-cell c-dependent clearing *depender*" c) 44 | (calculate-and-set c :fn-awaken-cell nil))) 45 | 46 | (defmethod awaken-cell ((c c-drifter)) 47 | ; 48 | ; drifters *begin* valid, so the derived version's test for unbounditude 49 | ; would keep (drift) rule ever from being evaluated. correct solution 50 | ; (for another day) is to separate awakening (ie, linking to independent 51 | ; cs) from evaluation, tho also evaluating if necessary during 52 | ; awakening, because awakening's other role is to get an instance up to speed 53 | ; at once upon instantiation 54 | ; 55 | (calculate-and-set c :fn-awaken-cell nil) 56 | (cond ((c-validp c) (c-value c)) 57 | ((c-unboundp c) nil) 58 | (t "illegal state!!!"))) 59 | -------------------------------------------------------------------------------- /lisp/link.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | Copyright (C) 1995, 2006 by Kenneth Tilton 7 | 8 | 9 | 10 | |# 11 | 12 | (in-package :cells) 13 | 14 | (defun record-caller (used) 15 | (assert used) 16 | (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell 17 | (trc nil "depender not being recorded because used optimized away" *depender* (c-value used) :used used) 18 | (return-from record-caller nil)) 19 | #+shhh (trc *depender* "record-caller depender entry: used=" used :caller *depender*) 20 | (assert *depender*) 21 | #+shhh (trc used "record-caller caller entry: used=" (qci used) 22 | :caller *depender*) 23 | 24 | (multiple-value-bind (used-pos useds-len) 25 | (loop with u-pos 26 | for known in (cd-useds *depender*) 27 | counting known into length 28 | when (eq used known) 29 | do 30 | (count-it :known-used) 31 | (setf u-pos length) 32 | finally (return (values (when u-pos (- length u-pos)) length))) 33 | 34 | (when (null used-pos) 35 | (trc nil "c-link > new caller,used " *depender* used) 36 | (count-it :new-used) 37 | (setf used-pos useds-len) 38 | (push used (cd-useds *depender*)) 39 | (caller-ensure used *depender*) ;; 060604 experiment was in unlink 40 | ) 41 | 42 | (when (c-debug *depender*) 43 | (trx rec-caller-sets-usage!!!!!!!!!!!!!!!!!!!! *depender* used used-pos)) 44 | (set-usage-bit *depender* used-pos) 45 | ) 46 | used) 47 | 48 | (defun set-usage-bit (c n) ;; c is caller 49 | ;(trc c "set-usage-bit entry!!!!" c n (array-dimension (cd-usage c) 0)) 50 | #+xxxx(when (> n 32) 51 | (loop for u in (cd-useds c) 52 | do (trc "sub-used" u)) 53 | (trc "set-usage-bit entry > 10!!!!" c n (array-dimension (cd-usage c) 0))) 54 | (unless (< n (array-dimension (cd-usage c) 0)) 55 | ;(trc c "set-usage-bit growing!!!!!" c n (+ n 16)) 56 | (setf (cd-usage c)(adjust-array (cd-usage c) (+ n 16) :initial-element 0))) 57 | (setf (sbit (cd-usage c) n) 1)) 58 | 59 | ;--- unlink unused -------------------------------- 60 | 61 | (defun c-unlink-unused (c &aux (usage (cd-usage c)) 62 | (usage-size (array-dimension (cd-usage c) 0)) 63 | (dbg nil)) 64 | (declare (ignorable dbg usage-size)) 65 | (when (cd-useds c) 66 | (let (rev-pos) 67 | (labels ((nail-unused (useds) 68 | (flet ((handle-used (rpos) 69 | (if (or (>= rpos usage-size) 70 | (zerop (sbit usage rpos))) 71 | (progn 72 | (count-it :unlink-unused) 73 | (trc nil "c-unlink-unused" c :dropping-used (car useds)) 74 | (c-unlink-caller (car useds) c) 75 | (rplaca useds nil)) 76 | (progn 77 | ;; moved into record-caller 060604 (caller-ensure (car useds) c) 78 | ) 79 | ))) 80 | (if (cdr useds) 81 | (progn 82 | (nail-unused (cdr useds)) 83 | (handle-used (incf rev-pos))) 84 | (handle-used (setf rev-pos 0)))))) 85 | (trc nil "cd-useds length" (length (cd-useds c)) c) 86 | 87 | (nail-unused (cd-useds c)) 88 | (setf (cd-useds c) (delete nil (cd-useds c))) 89 | (trc nil "useds of" c :now (mapcar 'qci (cd-useds c))))))) 90 | 91 | (defun c-caller-path-exists-p (from-used to-caller) 92 | (count-it :caller-path-exists-p) 93 | (or (find to-caller (c-callers from-used)) 94 | (find-if (lambda (from-used-caller) 95 | (c-caller-path-exists-p from-used-caller to-caller)) 96 | (c-callers from-used)))) 97 | 98 | ; --------------------------------------------- 99 | 100 | (defun cd-usage-clear-all (c) 101 | (setf (cd-usage c) (blank-usage-mask))) 102 | 103 | 104 | ;--- unlink from used ---------------------- 105 | 106 | (defmethod c-unlink-from-used ((caller c-dependent)) 107 | (dolist (used (cd-useds caller)) 108 | (trc nil "unlinking from used" caller used) 109 | (c-unlink-caller used caller)) 110 | ;; shouldn't be necessary (setf (cd-useds caller) nil) 111 | ) 112 | 113 | (defmethod c-unlink-from-used (other) 114 | (declare (ignore other))) 115 | 116 | ;---------------------------------------------------------- 117 | 118 | (defun c-unlink-caller (used caller) 119 | (trc nil "(1) caller unlinking from (2) used" caller used) 120 | (caller-drop used caller) 121 | (c-unlink-used caller used)) 122 | 123 | (defun c-unlink-used (caller used) 124 | (setf (cd-useds caller) (delete used (cd-useds caller)))) 125 | 126 | ;----------------- link debugging --------------------- 127 | 128 | (defun dump-callers (c &optional (depth 0)) 129 | (format t "~&~v,4t~s" depth c) 130 | (dolist (caller (c-callers c)) 131 | (dump-callers caller (+ 1 depth)))) 132 | 133 | (defun dump-useds (c &optional (depth 0)) 134 | ;(c.trc "dump-useds> entry " c (+ 1 depth)) 135 | (when (zerop depth) 136 | (format t "x~&")) 137 | (format t "~&|usd> ~v,8t~s" depth c) 138 | (when (typep c 'c-ruled) 139 | ;(c.trc "its ruled" c) 140 | (dolist (used (cd-useds c)) 141 | (dump-useds used (+ 1 depth))))) 142 | -------------------------------------------------------------------------------- /lisp/slot-utilities.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (defun c-setting-debug (self slot-name c new-value) 13 | (declare (ignorable new-value)) 14 | (cond 15 | ((null c) 16 | (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (c-in nil)" 17 | slot-name self) 18 | 19 | (c-break "setting-const-cell") 20 | (error "setting-const-cell")) 21 | ((c-inputp c)) 22 | (t 23 | (let ((self (c-model c)) 24 | (slot-name (c-slot-name c))) 25 | ;(trc "c-setting-debug sees" c newvalue self slot-name) 26 | (when (and c (not (and slot-name self))) 27 | ;; cv-test handles errors, so don't set *stop* (c-stop) 28 | (c-break "unadopted ~a for self ~a spec ~a" c self slot-name) 29 | (error 'c-unadopted :cell c)) 30 | #+whocares (typecase c 31 | (c-dependent 32 | ;(trc "setting c-dependent" c newvalue) 33 | (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed" 34 | (c-slot-name c) self) 35 | 36 | (c-break "setting-ruled-cell") 37 | (error "setting-ruled-cell")) 38 | ))))) 39 | 40 | (defun c-absorb-value (c value) 41 | (typecase c 42 | (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true 43 | (c-drifter (c-value-incf c (c-value c) value)) 44 | (t value))) 45 | 46 | (eval-when (:compile-toplevel :load-toplevel :execute) 47 | (export '(c-value-incf))) 48 | 49 | (defmethod c-value-incf (c (envaluer c-envaluer) delta) 50 | (c-assert (c-model c)) 51 | (c-value-incf c (funcall (envalue-rule envaluer) c) 52 | delta)) 53 | 54 | (defmethod c-value-incf (c (base number) delta) 55 | (declare (ignore c)) 56 | (if delta 57 | (+ base delta) 58 | base)) 59 | 60 | 61 | ;---------------------------------------------------------------------- 62 | 63 | (defun bd-slot-value (self slot-name) 64 | (slot-value self slot-name)) 65 | 66 | (defun (setf bd-slot-value) (new-value self slot-name) 67 | (setf (slot-value self slot-name) new-value)) 68 | 69 | (defun bd-bound-slot-value (self slot-name caller-id) 70 | (declare (ignorable caller-id)) 71 | (when (bd-slot-boundp self slot-name) 72 | (bd-slot-value self slot-name))) 73 | 74 | (defun bd-slot-boundp (self slot-name) 75 | (slot-boundp self slot-name)) 76 | 77 | (defun bd-slot-makunbound (self slot-name) 78 | (if slot-name ;; not in def-c-variable 79 | (slot-makunbound self slot-name) 80 | (makunbound self))) 81 | 82 | #| sample incf 83 | (defmethod c-value-incf ((base fpoint) delta) 84 | (declare (ignore model)) 85 | (if delta 86 | (fp-add base delta) 87 | base)) 88 | |# 89 | -------------------------------------------------------------------------------- /lisp/synapse-types.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (export! f-find) 13 | 14 | (defmacro f-find (synapse-id sought where) 15 | `(call-f-find ,synapse-id ,sought ,where)) 16 | 17 | (defun call-f-find (synapse-id sought where) 18 | (with-synapse synapse-id () 19 | (bif (k (progn 20 | (find sought where))) 21 | (values k :propagate) 22 | (values nil :no-propagate)))) 23 | 24 | (defmacro f-sensitivity (synapse-id (sensitivity &optional subtypename) &body body) 25 | `(call-f-sensitivity ,synapse-id ,sensitivity ,subtypename (lambda () ,@body))) 26 | 27 | (defun call-f-sensitivity (synapse-id sensitivity subtypename body-fn) 28 | (with-synapse synapse-id (prior-fire-value) 29 | (let ((new-value (funcall body-fn))) 30 | ;(trc "f-sensitivity fire-p decides new" new-value :from-prior prior-fire-value :sensi sensitivity) 31 | (let ((prop-code (if (or (xor prior-fire-value new-value) 32 | (eko (nil "sens fire-p decides" new-value prior-fire-value sensitivity) 33 | (delta-greater-or-equal 34 | (delta-abs (delta-diff new-value prior-fire-value subtypename) 35 | subtypename) 36 | (delta-abs sensitivity subtypename) 37 | subtypename))) 38 | :propagate 39 | :no-propagate))) 40 | (values (if (eq prop-code :propagate) 41 | (progn 42 | (trc nil "sense prior fire value now" new-value) 43 | (setf prior-fire-value new-value)) 44 | new-value) prop-code))))) 45 | 46 | (defmacro f-delta (synapse-id (&key sensitivity (type 'number)) &body body) 47 | `(call-f-delta ,synapse-id ,sensitivity ',type (lambda () ,@body))) 48 | 49 | (defun call-f-delta (synapse-id sensitivity type body-fn) 50 | (with-synapse synapse-id (last-relay-basis last-bound-p delta-cum) 51 | (let* ((new-basis (funcall body-fn)) 52 | (threshold sensitivity) 53 | (tdelta (delta-diff new-basis 54 | (if last-bound-p 55 | last-relay-basis 56 | (delta-identity new-basis type)) 57 | type))) 58 | (trc nil "tdelta, threshhold" tdelta threshold) 59 | (setf delta-cum tdelta) 60 | (let ((propagation-code 61 | (when threshold 62 | (if (delta-exceeds tdelta threshold type) 63 | (progn 64 | (setf last-bound-p t) 65 | (setf last-relay-basis new-basis) 66 | :propagate) 67 | :no-propagate)))) 68 | (trc nil "f-delta returns values" delta-cum propagation-code) 69 | (values delta-cum propagation-code))))) 70 | 71 | (defmacro f-plusp (key &rest body) 72 | `(with-synapse ,key (prior-fire-value) 73 | (let ((new-basis (progn ,@body))) 74 | (values new-basis (if (xor prior-fire-value (plusp new-basis)) 75 | (progn 76 | (setf prior-fire-value (plusp new-basis)) 77 | :propagate) 78 | :no-propagate))))) 79 | 80 | (defmacro f-zerop (key &rest body) 81 | `(with-synapse ,key (prior-fire-value) 82 | (let ((new-basis (progn ,@body))) 83 | (values new-basis (if (xor prior-fire-value (zerop new-basis)) 84 | (progn 85 | (setf prior-fire-value (zerop new-basis)) 86 | :propagate) 87 | :no-propagate))))) 88 | 89 | 90 | 91 | ;;;(defun f-delta-list (&key (test #'true)) 92 | ;;; (with-synapse (prior-list) 93 | ;;; :fire-p (lambda (syn new-list) 94 | ;;; (declare (ignorable syn)) 95 | ;;; (or (find-if (lambda (new) 96 | ;;; ;--- gaining one? ---- 97 | ;;; (and (not (member new prior-list)) 98 | ;;; (funcall test new))) 99 | ;;; new-list) 100 | ;;; (find-if (lambda (old) 101 | ;;; ;--- losing one? ---- 102 | ;;; (not (member old new-list))) ;; all olds have passed test, so skip test here 103 | ;;; prior-list))) 104 | ;;; 105 | ;;; :fire-value (lambda (syn new-list) 106 | ;;; (declare (ignorable syn)) 107 | ;;; ;/// excess consing on long lists 108 | ;;; (setf prior-list (remove-if-not test new-list))))) 109 | 110 | ;;;(defun f-find-once (finder-fn) 111 | ;;; (mk-synapse (bingo bingobound) 112 | ;;; 113 | ;;; :fire-p (lambda (syn new-list) 114 | ;;; (declare (ignorable syn)) 115 | ;;; (unless bingo ;; once found, yer done 116 | ;;; (setf bingobound t 117 | ;;; bingo (find-if finder-fn new-list)))) 118 | ;;; 119 | ;;; :fire-value (lambda (syn new-list) 120 | ;;; (declare (ignorable syn)) 121 | ;;; (or bingo 122 | ;;; (and (not bingobound) ;; don't bother if fire? already looked 123 | ;;; (find-if finder-fn new-list)))))) 124 | 125 | ;;;(defun fdifferent () 126 | ;;; (mk-synapse (prior-object) 127 | ;;; :fire-p (lambda (syn new-object) 128 | ;;; (declare (ignorable syn)) 129 | ;;; (trc nil "fDiff: prior,new" (not (eql new-object prior-object)) 130 | ;;; prior-object new-object) 131 | ;;; (not (eql new-object prior-object))) 132 | ;;; 133 | ;;; :fire-value (lambda (syn new-object) 134 | ;;; (declare (ignorable syn)) 135 | ;;; (unless (eql new-object prior-object) 136 | ;;; (setf prior-object new-object))) 137 | ;;; )) 138 | 139 | 140 | ;;;(defun f-boolean (&optional (sensitivity 't)) 141 | ;;; (f-delta :sensitivity sensitivity :type 'boolean)) 142 | 143 | 144 | -------------------------------------------------------------------------------- /lisp/synapse.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (eval-when (:compile-toplevel :load-toplevel :execute) 13 | (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent with-synapse))) 14 | 15 | (defmacro with-synapse (synapse-id (&rest closure-vars) &body body) 16 | (let ((syn-id (gensym))) 17 | `(let* ((,syn-id ,synapse-id) 18 | (synapse (or (find ,syn-id (cd-useds *depender*) :key 'c-slot-name) 19 | (let ((new-syn 20 | (let (,@closure-vars) 21 | (make-c-dependent 22 | :model (c-model *depender*) 23 | :slot-name ,syn-id 24 | :code #+live nil #-live ',body 25 | :synaptic t 26 | :rule (c-lambda ,@body))))) 27 | (record-caller new-syn) 28 | new-syn)))) 29 | (prog1 30 | (multiple-value-bind (v p) 31 | (with-integrity () 32 | (ensure-value-is-current synapse :synapse *depender*)) 33 | (values v p)) 34 | (record-caller synapse))))) 35 | 36 | 37 | ;__________________________________________________________________________________ 38 | ; 39 | 40 | (defmethod delta-exceeds (bool-delta sensitivity (subtypename (eql 'boolean))) 41 | (unless (eql bool-delta :unchanged) 42 | (or (eq sensitivity t) 43 | (eq sensitivity bool-delta)))) 44 | 45 | (defmethod delta-diff ((new number) (old number) subtypename) 46 | (declare (ignore subtypename)) 47 | (- new old)) 48 | 49 | (defmethod delta-identity ((dispatcher number) subtypename) 50 | (declare (ignore subtypename)) 51 | 0) 52 | 53 | (defmethod delta-abs ((n number) subtypename) 54 | (declare (ignore subtypename)) 55 | (abs n)) 56 | 57 | (defmethod delta-exceeds ((d1 number) (d2 number) subtypename) 58 | (declare (ignore subtypename)) 59 | (> d1 d2)) 60 | 61 | (defmethod delta-greater-or-equal ((d1 number) (d2 number) subtypename) 62 | (declare (ignore subtypename)) 63 | (>= d1 d2)) 64 | 65 | ;_________________________________________________________________________________ 66 | ; 67 | (defmethod delta-diff (new old (subtypename (eql 'boolean))) 68 | (if new 69 | (if old 70 | :unchanged 71 | :on) 72 | (if old 73 | :off 74 | :unchanged))) 75 | 76 | 77 | (defmethod delta-identity (dispatcher (subtypename (eql 'boolean))) 78 | (declare (ignore dispatcher)) 79 | :unchanged) 80 | 81 | -------------------------------------------------------------------------------- /lisp/test-cc.lisp: -------------------------------------------------------------------------------- 1 | ;; 2 | 3 | (in-package :cells) 4 | 5 | (defmd tcc () 6 | (tccversion 1) 7 | (tcc-a (c-in nil)) 8 | (tcc-2a (c-in nil))) 9 | 10 | (defobserver tcc-a () 11 | (case (^tccversion) 12 | (1 (when new-value 13 | (with-cc :tcc-a-obs 14 | (setf (tcc-2a self) (* 2 new-value)) 15 | (with-cc :aha!2 16 | (assert (eql (tcc-2a self) (* 2 new-value)) 17 | () "one") 18 | (trc "one happy"))) 19 | (with-cc :aha! 20 | (assert (eql (tcc-2a self) (* 2 new-value)) 21 | () "two")))) 22 | (2 (when new-value 23 | (with-cc :tcc-a-obs 24 | (setf (tcc-2a self) (* 2 new-value)) 25 | (with-cc :aha!2 26 | (assert (eql (tcc-2a self) (* 2 new-value)) 27 | () "one") 28 | (trc "one happy"))))))) 29 | 30 | 31 | (defun test-with-cc () 32 | (let ((self (make-instance 'tcc 33 | :tccversion 2 ;:tcc-2a 34 | ))) 35 | (trcx cool 42) 36 | (setf (tcc-a self) 42) 37 | (assert (eql (tcc-2a self) 84)))) 38 | 39 | #+test 40 | (test-with-cc) 41 | 42 | (defmd ccproc () ccp obs drv) 43 | 44 | (defobserver ccp () 45 | (trcx obs-cpp new-value old-value) 46 | (with-cc :obs-cpp 47 | (setf (^obs) (+ (* 10 (^drv)) new-value)))) 48 | 49 | (dbgobserver obs) 50 | 51 | (defun test-ccproc () 52 | (cells-reset) 53 | (let ((x (make-instance 'ccproc 54 | :ccp (c-in 0) 55 | :obs (c-in 0) 56 | :drv (c? (+ 10 (^ccp)))))) 57 | (trcx see-0-10 100 (ccp x)(drv x)(obs x)) 58 | 59 | (setf (ccp x) 1) 60 | (trcx see-1-11-101 (ccp x)(drv x)(obs x)) 61 | 62 | (trcx now-see-1-11-101 (ccp x)(drv x)(obs x)) 63 | (setf (ccp x) 2) 64 | 65 | (trcx see-2-12-102 (ccp x)(drv x)(obs x)) 66 | (trcx see-2-12-102 (ccp x)(drv x)(obs x)))) 67 | -------------------------------------------------------------------------------- /lisp/test-cycle.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | ;;; 3 | ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;;; of this software and associated documentation files (the "Software"), to deal 7 | ;;; in the Software without restriction, including without limitation the rights 8 | ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;;; copies of the Software, and to permit persons to whom the Software is furnished 10 | ;;; to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 21 | ;;; IN THE SOFTWARE. 22 | 23 | (in-package :cells) 24 | 25 | 26 | 27 | (defmodel m-cyc () 28 | ((m-cyc-a :initform (c-in nil) :initarg :m-cyc-a :accessor m-cyc-a) 29 | (m-cyc-b :initform (c-in nil) :initarg :m-cyc-b :accessor m-cyc-b))) 30 | 31 | (def-c-output m-cyc-a () 32 | (print `(output m-cyc-a ,self ,new-value ,old-value)) 33 | (setf (m-cyc-b self) new-value)) 34 | 35 | (def-c-output m-cyc-b () 36 | (print `(output m-cyc-b ,self ,new-value ,old-value)) 37 | (setf (m-cyc-a self) new-value)) 38 | 39 | (defun m-cyc () ;;def-cell-test m-cyc 40 | (let ((m (make-be 'm-cyc))) 41 | (print `(start ,(m-cyc-a m))) 42 | (setf (m-cyc-a m) 42) 43 | (assert (= (m-cyc-a m) 42)) 44 | (assert (= (m-cyc-b m) 42)))) 45 | 46 | #+(or) 47 | (m-cyc) 48 | 49 | (defmodel m-cyc2 () 50 | ((m-cyc2-a :initform (c-in 0) :initarg :m-cyc2-a :accessor m-cyc2-a) 51 | (m-cyc2-b :initform (c? (1+ (^m-cyc2-a))) 52 | :initarg :m-cyc2-b :accessor m-cyc2-b))) 53 | 54 | (def-c-output m-cyc2-a () 55 | (print `(output m-cyc2-a ,self ,new-value ,old-value)) 56 | #+(or) (when (< new-value 45) 57 | (setf (m-cyc2-b self) (1+ new-value)))) 58 | 59 | (def-c-output m-cyc2-b () 60 | (print `(output m-cyc2-b ,self ,new-value ,old-value)) 61 | (when (< new-value 45) 62 | (setf (m-cyc2-a self) (1+ new-value)))) 63 | 64 | (def-cell-test m-cyc2 65 | (cell-reset) 66 | (let ((m (make-be 'm-cyc2))) 67 | (print '(start)) 68 | (setf (m-cyc2-a m) 42) 69 | (describe m) 70 | (assert (= (m-cyc2-a m) 44)) 71 | (assert (= (m-cyc2-b m) 45)) 72 | )) 73 | 74 | #+(or) 75 | (m-cyc2) 76 | 77 | 78 | -------------------------------------------------------------------------------- /lisp/test-ephemeral.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | ;;; 3 | ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;;; of this software and associated documentation files (the "Software"), to deal 7 | ;;; in the Software without restriction, including without limitation the rights 8 | ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;;; copies of the Software, and to permit persons to whom the Software is furnished 10 | ;;; to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 21 | ;;; IN THE SOFTWARE. 22 | 23 | (in-package :cells) 24 | 25 | 26 | (defmodel m-ephem () 27 | ((m-ephem-a :cell :ephemeral :initform nil :initarg :m-ephem-a :accessor m-ephem-a) 28 | (m-test-a :cell nil :initform nil :initarg :m-test-a :accessor m-test-a) 29 | (m-ephem-b :cell :ephemeral :initform nil :initarg :m-ephem-b :accessor m-ephem-b) 30 | (m-test-b :cell nil :initform nil :initarg :m-test-b :accessor m-test-b))) 31 | 32 | (def-c-output m-ephem-a () 33 | (setf (m-test-a self) new-value)) 34 | 35 | (def-c-output m-ephem-b () 36 | (setf (m-test-b self) new-value)) 37 | 38 | (def-cell-test m-ephem 39 | (let ((m (make-be 'm-ephem :m-ephem-a (c-in nil) :m-ephem-b (c? (* 2 (or (^m-ephem-a) 0)))))) 40 | (ct-assert (null (slot-value m 'm-ephem-a))) 41 | (ct-assert (null (m-ephem-a m))) 42 | (ct-assert (null (m-test-a m))) 43 | (ct-assert (null (slot-value m 'm-ephem-b))) 44 | (ct-assert (null (m-ephem-b m))) 45 | (ct-assert (zerop (m-test-b m))) 46 | (setf (m-ephem-a m) 3) 47 | (ct-assert (null (slot-value m 'm-ephem-a))) 48 | (ct-assert (null (m-ephem-a m))) 49 | (ct-assert (eql 3 (m-test-a m))) 50 | ; 51 | (ct-assert (null (slot-value m 'm-ephem-b))) 52 | (ct-assert (null (m-ephem-b m))) 53 | (ct-assert (eql 6 (m-test-b m))) 54 | )) 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /lisp/test-propagation.lisp: -------------------------------------------------------------------------------- 1 | ;; 2 | 3 | (in-package :cells) 4 | 5 | (defmd tcp () 6 | (left (c-in 0)) 7 | (top (c-in 0)) 8 | (right (c-in 0)) 9 | (bottom (c-in 0)) 10 | (area (c? (trc "area running") 11 | (* (- (^right)(^left)) 12 | (- (^top)(^bottom)))))) 13 | 14 | (defobserver area () 15 | (trc "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) 16 | 17 | (defobserver bottom () 18 | (trc "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*) 19 | (with-integrity (:change 'bottom-tells-left) 20 | (setf (^left) new-value))) 21 | 22 | (defobserver left () 23 | (trc "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*)) 24 | 25 | (defun tcprop () 26 | (untrace) 27 | (ukt:test-prep) 28 | (let ((box (make-instance 'tcp))) 29 | (trc "changing top to 10" *data-pulse-id*) 30 | (setf (top box) 10) 31 | (trc "not changing top" *data-pulse-id*) 32 | (setf (top box) 10) 33 | (trc "changing right to 10" *data-pulse-id*) 34 | (setf (right box) 10) 35 | (trc "not changing right" *data-pulse-id*) 36 | (setf (right box) 10) 37 | (trc "changing bottom to -1" *data-pulse-id*) 38 | (decf (bottom box)) 39 | (with-one-datapulse () 40 | (loop repeat 5 do 41 | (trc "changing bottom by -1" *data-pulse-id*) 42 | (decf (bottom box)))))) 43 | 44 | 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /lisp/test-synapse.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | ;;; 3 | ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;;; of this software and associated documentation files (the "Software"), to deal 7 | ;;; in the Software without restriction, including without limitation the rights 8 | ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;;; copies of the Software, and to permit persons to whom the Software is furnished 10 | ;;; to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 21 | ;;; IN THE SOFTWARE. 22 | 23 | (in-package :cells) 24 | 25 | 26 | (defmodel m-syn () 27 | ((m-syn-a :initform nil :initarg :m-syn-a :accessor m-syn-a) 28 | (m-syn-b :initform nil :initarg :m-syn-b :accessor m-syn-b) 29 | (m-syn-factor :initform nil :initarg :m-syn-factor :accessor m-syn-factor) 30 | (m-sens :initform nil :initarg :m-sens :accessor m-sens) 31 | (m-plus :initform nil :initarg :m-plus :accessor m-plus) 32 | )) 33 | 34 | (def-c-output m-syn-b () 35 | (print `(output m-syn-b ,self ,new-value ,old-value))) 36 | 37 | 38 | 39 | (def-cell-test m-syn 40 | (progn (cell-reset) 41 | (let* ((delta-ct 0) 42 | (sens-ct 0) 43 | (plus-ct 0) 44 | (m (make-be 'm-syn 45 | :m-syn-a (c-in 0) 46 | :m-syn-b (c? (incf delta-ct) 47 | (trc nil "syn-b rule firing!!!!!!!!!!!!!!" delta-ct) 48 | (eko (nil "syn-b rule returning") 49 | (f-delta :syna-1 (:sensitivity 2) 50 | (^m-syn-a)))) 51 | :m-syn-factor (c-in 1) 52 | :m-sens (c? (incf sens-ct) 53 | (trc nil "m-sens rule firing ~d !!!!!!!!!!!!!!" sens-ct) 54 | (* (^m-syn-factor) 55 | (f-sensitivity :sensa (3) (^m-syn-a)))) 56 | :m-plus (c? (incf plus-ct) 57 | (trc nil "m-plus rule firing!!!!!!!!!!!!!!" plus-ct) 58 | (f-plusp :syna-2 (- 2 (^m-syn-a))))))) 59 | (ct-assert (= 1 delta-ct)) 60 | (ct-assert (= 1 sens-ct)) 61 | (ct-assert (= 1 plus-ct)) 62 | (ct-assert (= 0 (m-sens m))) 63 | (trc "make-be complete. about to incf m-syn-a") 64 | (incf (m-syn-a m)) 65 | (ct-assert (= 1 delta-ct)) 66 | (ct-assert (= 1 sens-ct)) 67 | (ct-assert (= 1 plus-ct)) 68 | (ct-assert (= 0 (m-sens m))) 69 | (trc "about to incf m-syn-a 2") 70 | (incf (m-syn-a m) 2) 71 | (trc nil "syn-b now" (m-syn-b m)) 72 | (ct-assert (= 2 delta-ct)) 73 | (ct-assert (= 2 sens-ct)) 74 | (ct-assert (= 2 plus-ct)) 75 | 76 | (ct-assert (= 3 (m-sens m))) 77 | (trc "about to incf m-syn-a") 78 | (incf (m-syn-a m)) 79 | (ct-assert (= 2 delta-ct)) 80 | (ct-assert (= 2 sens-ct)) 81 | (trc "about to incf m-syn-factor") 82 | (incf (m-syn-factor m)) 83 | (ct-assert (= 3 sens-ct)) 84 | (ct-assert (= (m-sens m) (* (m-syn-factor m) (m-syn-a m)))) 85 | (trc "about to incf m-syn-a xxx") 86 | (incf (m-syn-a m)) 87 | (ct-assert (= 2 delta-ct)) 88 | (ct-assert (= 3 sens-ct)) 89 | (trc "about to incf m-syn-a yyyy") 90 | (incf (m-syn-a m)) 91 | (ct-assert (= 3 delta-ct)) 92 | (ct-assert (= 4 sens-ct)) 93 | (ct-assert (= 2 plus-ct)) 94 | (describe m) 95 | (print '(start))))) 96 | 97 | (Def-c-output m-syn-a () 98 | (trc "!!! M-SYN-A now =" new-value)) 99 | 100 | #+(or) 101 | (m-syn) 102 | 103 | -------------------------------------------------------------------------------- /lisp/test.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | ;;; 3 | ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;;; of this software and associated documentation files (the "Software"), to deal 7 | ;;; in the Software without restriction, including without limitation the rights 8 | ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;;; copies of the Software, and to permit persons to whom the Software is furnished 10 | ;;; to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 21 | ;;; IN THE SOFTWARE. 22 | 23 | #| Synapse Cell Unification Notes 24 | 25 | - start by making Cells synapse-y 26 | 27 | - make sure outputs show right old and new values 28 | - make sure outputs fire when they should 29 | 30 | - wow: test the Cells II dictates: no output callback sees stale data, no rule 31 | sees stale data, etc etc 32 | 33 | - test a lot of different synapses 34 | 35 | - make sure they fire when they should, and do not when they should not 36 | 37 | - make sure they survive an evaluation by the caller which does not branch to 38 | them (ie, does not access them) 39 | 40 | - make sure they optimize away 41 | 42 | - test with forms which access multiple other cells 43 | 44 | - look at direct alteration of a caller 45 | 46 | - does SETF honor not propagating, as well as a c-ruled after re-calcing 47 | 48 | - do diff unchanged tests such as string-equal work 49 | 50 | |# 51 | 52 | #| do list 53 | 54 | -- can we lose the special handling of the .kids slot? 55 | 56 | -- test drifters (and can they be handled without creating a special 57 | subclass for them?) 58 | 59 | |# 60 | 61 | (eval-when (compile load) 62 | (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) 63 | 64 | (in-package :cells) 65 | 66 | (defvar *cell-tests* nil) 67 | 68 | 69 | #+go 70 | (test-cells) 71 | 72 | (defun test-cells () 73 | (loop for test in (reverse *cell-tests*) 74 | do (cell-test-init test) 75 | (funcall test))) 76 | 77 | (defun cell-test-init (name) 78 | (print (make-string 40 :initial-element #\!)) 79 | (print `(starting test ,name)) 80 | (print (make-string 40 :initial-element #\!)) 81 | (cell-reset)) 82 | 83 | (defmacro def-cell-test (name &rest body) 84 | `(progn 85 | (pushnew ',name *cell-tests*) 86 | (defun ,name () 87 | (cell-reset) 88 | ,@body))) 89 | 90 | (defmacro ct-assert (form &rest stuff) 91 | `(progn 92 | (print `(attempting ,',form)) 93 | (assert ,form () "Error with ~a >> ~a" ',form (list ,@stuff)))) 94 | 95 | ;; test huge number of useds by one rule 96 | 97 | (defmodel m-index (family) 98 | () 99 | (:default-initargs 100 | :value (c? (bwhen (ks (^kids)) 101 | (apply '+ (mapcar 'value ks)))))) 102 | 103 | (def-cell-test many-useds 104 | (let ((i (make-instance 'm-index))) 105 | (loop for n below 100 106 | do (push (make-instance 'model 107 | :value (c-in n)) 108 | (kids i))) 109 | (trc "index total" (value i)))) 110 | 111 | (defmodel m-null () 112 | ((aa :initform nil :cell nil :initarg :aa :accessor aa))) 113 | 114 | (def-cell-test m-null 115 | (let ((m (make-be 'm-null :aa 42))) 116 | (ct-assert (= 42 (aa m))) 117 | (ct-assert (= 21 (decf (aa m) 21))) 118 | :okay-m-null)) 119 | 120 | (defmodel m-solo () 121 | ((m-solo-a :initform nil :initarg :m-solo-a :accessor m-solo-a) 122 | (m-solo-b :initform nil :initarg :m-solo-b :accessor m-solo-b))) 123 | 124 | (def-cell-test m-solo 125 | (let ((m (make-be 'm-solo 126 | :m-solo-a (c-in 42) 127 | :m-solo-b (c? (* 2 (^m-solo-a)))))) 128 | (ct-assert (= 42 (m-solo-a m))) 129 | (ct-assert (= 84 (m-solo-b m))) 130 | (decf (m-solo-a m)) 131 | (ct-assert (= 41 (m-solo-a m))) 132 | (ct-assert (= 82 (m-solo-b m))) 133 | :okay-m-null)) 134 | 135 | (defmodel m-var () 136 | ((m-var-a :initform nil :initarg :m-var-a :accessor m-var-a) 137 | (m-var-b :initform nil :initarg :m-var-b :accessor m-var-b))) 138 | 139 | (def-c-output m-var-b () 140 | (print `(output m-var-b ,self ,new-value ,old-value))) 141 | 142 | (def-cell-test m-var 143 | (let ((m (make-be 'm-var :m-var-a (c-in 42) :m-var-b 1951))) 144 | (ct-assert (= 42 (m-var-a m))) 145 | (ct-assert (= 21 (decf (m-var-a m) 21))) 146 | (ct-assert (= 21 (m-var-a m))) 147 | :okay-m-var)) 148 | 149 | (defmodel m-var-output () 150 | ((cbb :initform nil :initarg :cbb :accessor cbb) 151 | (aa :cell nil :initform nil :initarg :aa :accessor aa))) 152 | 153 | (def-c-output cbb () 154 | (trc "output cbb" self) 155 | (setf (aa self) (- new-value (if old-value-boundp 156 | old-value 0)))) 157 | 158 | (def-cell-test m-var-output 159 | (let ((m (make-be 'm-var-output :cbb (c-in 42)))) 160 | (ct-assert (eql 42 (cbb m))) 161 | (ct-assert (eql 42 (aa m))) 162 | (ct-assert (eql 27 (decf (cbb m) 15))) 163 | (ct-assert (eql 27 (cbb m))) 164 | (ct-assert (eql -15 (aa m))) 165 | (list :okay-m-var (aa m)))) 166 | 167 | (defmodel m-var-linearize-setf () 168 | ((ccc :initform nil :initarg :ccc :accessor ccc) 169 | (ddd :initform nil :initarg :ddd :accessor ddd))) 170 | 171 | (def-c-output ccc () 172 | (with-deference 173 | (setf (ddd self) (- new-value (if old-value-boundp 174 | old-value 0))))) 175 | 176 | (def-cell-test m-var-linearize-setf 177 | (let ((m (make-be 'm-var-linearize-setf 178 | :ccc (c-in 42) 179 | :ddd (c-in 1951)))) 180 | 181 | (ct-assert (= 42 (ccc m))) 182 | (ct-assert (= 42 (ddd m))) 183 | (ct-assert (= 27 (decf (ccc m) 15))) 184 | (ct-assert (= 27 (ccc m))) 185 | (ct-assert (= -15 (ddd m))) 186 | :okay-m-var)) 187 | 188 | ;;; ------------------------------------------------------- 189 | 190 | (defmodel m-ruled () 191 | ((eee :initform nil :initarg :eee :accessor eee) 192 | (fff :initform (c? (floor (^ccc) 2)) :initarg :fff :accessor fff))) 193 | 194 | (def-c-output eee () 195 | (print `(output> eee ,new-value old ,old-value))) 196 | 197 | (def-c-output fff () 198 | (print `(output> eee ,new-value old ,old-value))) 199 | 200 | (def-cell-test m-ruled 201 | (let ((m (make-be 'm-ruled 202 | :eee (c-in 42) 203 | :fff (c? (floor (^eee) 2))))) 204 | (trc "___Initial TOBE done____________________") 205 | (print `(pulse ,*data-pulse-id*)) 206 | (ct-assert (= 42 (eee m))) 207 | (ct-assert (= 21 (fff m))) 208 | (ct-assert (= 36 (decf (eee m) 6))) 209 | (print `(pulse ,*data-pulse-id*)) 210 | (ct-assert (= 36 (eee m))) 211 | (ct-assert (= 18 (fff m)) m) 212 | :okay-m-ruled)) 213 | 214 | (defmodel m-worst-case () 215 | ((wc-x :accessor wc-x :initform (c-input () 2)) 216 | (wc-a :accessor wc-a :initform (c? (when (oddp (wc-x self)) 217 | (wc-c self)))) 218 | (wc-c :accessor wc-c :initform (c? (evenp (wc-x self)))) 219 | (wc-h :accessor wc-h :initform (c? (or (wc-c self)(wc-a self)))))) 220 | 221 | (def-cell-test m-worst-case 222 | (let ((m (make-be 'm-worst-case))) 223 | (trc "___Initial TOBE done____________________") 224 | (ct-assert (eql t (wc-c m))) 225 | (ct-assert (eql nil (wc-a m))) 226 | (ct-assert (eql t (wc-h m))) 227 | (ct-assert (eql 3 (incf (wc-x m)))))) 228 | 229 | -------------------------------------------------------------------------------- /lisp/trc-eko.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | The Newly Cells-aware trc trace and EKO value echo facilities 5 | 6 | |# 7 | 8 | 9 | (in-package :cells) 10 | 11 | ;----------- trc ------------------------------------------- 12 | (defparameter *last-trc* (get-internal-real-time)) 13 | (defparameter *trcdepth* 0) 14 | 15 | (defun trcdepth-reset () 16 | (setf *trcdepth* 0)) 17 | 18 | (defmacro trc (tgt-form &rest os) 19 | (if (eql tgt-form 'nil) 20 | '(progn) 21 | (if (stringp tgt-form) 22 | `(without-c-dependency 23 | (call-trc t ,tgt-form ,@os)) 24 | (let ((tgt (gensym))) 25 | ;(brk "slowww? ~a" tgt-form) 26 | `(without-c-dependency 27 | (bif (,tgt ,tgt-form) 28 | (if (trcp ,tgt) 29 | (progn 30 | (assert (stringp ,(car os)) () "trc with test expected string second, got ~a" ,(car os)) 31 | (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) 32 | (progn 33 | ;(trc "trcfailed") 34 | (count-it :trcfailed))) 35 | (count-it :tgtnileval))))))) 36 | 37 | (defparameter *trc-path-id* nil) 38 | (defparameter *trc-path-id-filter* nil) 39 | (defparameter *trc-path-max* 0) 40 | (defparameter *trc-path-max-path* nil) 41 | (defparameter *trc-suppress* nil) 42 | (export! *trc-path-max* trcap) 43 | 44 | (defmacro trcap (&rest args) 45 | `(let (*trc-path-id-filter*) 46 | (trc ,@args))) 47 | 48 | (defun trc-pathp (path) 49 | (when (> (length path) *trc-path-max*) 50 | ;;(print `(new-*trc-path-max* ,(length path) ,path)) 51 | (setf *trc-path-max* (length path) 52 | *trc-path-max-path* path)) 53 | 54 | #+good-for-test-one 55 | (when (> (- *trc-path-max* (length path)) 4) 56 | (break "big path delta for new path ~s agin max ~a" path *trc-path-max-path*)) 57 | 58 | (or (null *trc-path-id-filter*) 59 | (if (> (length path)(length *trc-path-id-filter*)) 60 | (eql 0 (search *trc-path-id-filter* path )) 61 | (eql 0 (search path *trc-path-id-filter*))))) 62 | 63 | (export! *trc-path-id-filter* trc-pathp *trc-suppress* trx-zero) 64 | 65 | #-allegro-v9.0 66 | (defun curr-thread () 67 | (excl:current-thread)) 68 | 69 | #+allegro-v9.0 70 | (defun curr-thread () 71 | sys:*current-thread*) 72 | 73 | (defun thread-pid () 74 | (or 75 | ;;#+cthread-mess 76 | (b-when thd (curr-thread) 77 | ;(print `(thread-name ,(slot-value thd 'sys::name))) 78 | (b-when p (slot-value thd 'sys::process) 79 | (mp:process-os-id p))) 80 | 0)) 81 | 82 | (defun thread-name () 83 | ;;#+cthread-mess 84 | (b-when thd (curr-thread) 85 | (slot-value thd 'sys::name))) 86 | 87 | (defparameter *trx-zero* 0) 88 | 89 | (defun trx-zero () 90 | (setf *trx-zero* (get-internal-real-time))) 91 | 92 | (defun call-trc (stream s &rest os) 93 | ;; (break) 94 | 95 | (when *trc-suppress* (return-from call-trc)) 96 | 97 | (let ((path (cond 98 | (*trc-path-id* 99 | (unless (trc-pathp *trc-path-id*) 100 | (return-from call-trc)) 101 | *trc-path-id*) 102 | ((and (boundp '*trcdepth*) 103 | *trcdepth*) 104 | (format nil "~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)) 105 | ("")))) 106 | (format stream "~&~@[~a ~]~@[~a:~]~@[<~a> ~]~a: " 107 | (round (- (get-internal-real-time) *trx-zero*) 100) 108 | nil #+slow? (left$ (thread-name) 8) 109 | nil #+xxx .dpid path)) 110 | ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10)) 111 | (setf *last-trc* (get-internal-real-time)) 112 | 113 | (format stream "~a ~{~s ~}~%" s os) 114 | 115 | (force-output stream) 116 | (values)) 117 | 118 | 119 | (export! trx trx! brk brkx .bgo bgo *trc-path-id* ntrcx *trx-tag*) 120 | 121 | (define-symbol-macro .bgo (brk "go")) 122 | 123 | (defmacro bgo (msg) 124 | `(brk "BGO ~a" ',msg)) 125 | 126 | (defmacro brkx (msg) 127 | `(brk "At ~a: OK?" ',msg)) 128 | 129 | (defmacro trcx (tgt-form &rest os) 130 | (if (eql tgt-form 'nil) 131 | '(progn) 132 | `(without-c-dependency 133 | (call-trc t (format nil "TX[~d]> ~(~s~)" 134 | (thread-pid) ',tgt-form) 135 | ,@(loop for obj in (or os (list tgt-form)) 136 | nconcing (list (intern (format nil "~a" obj) :keyword) obj)))))) 137 | 138 | (defmacro trx! (tag &rest os) 139 | `(let ((*trc-suppress* nil)) 140 | (trx ,tag ,@os))) 141 | 142 | 143 | (defparameter *trx-tag* "") 144 | 145 | (defmacro trx (tgt-form &rest os) 146 | (if (eql tgt-form 'nil) 147 | '(progn) 148 | `(without-c-dependency 149 | (call-trc t (format nil "> ~a" ;; "TX[~a]> ~a" 150 | ;; *trx-tag* ;; (ukt::irt-mshh$) 151 | ,(string tgt-form)) 152 | ,@(loop for obj in (or os (list tgt-form)) 153 | nconcing (list (intern (format nil "~a" obj) :keyword) obj)))))) 154 | 155 | (defmacro ntrcx (&rest os) 156 | (declare (ignore os)) 157 | '(progn)) 158 | 159 | (defun call-trc-to-string (fmt$ &rest fmt-args) 160 | (let ((o$ (make-array '(0) :element-type 'base-char 161 | :fill-pointer 0 :adjustable t))) 162 | (with-output-to-string (os-stream o$) 163 | (apply 'call-trc os-stream fmt$ fmt-args)) 164 | o$)) 165 | 166 | #+findtrcevalnils 167 | (defmethod trcp :around (other) 168 | (unless (call-next-method other)(brk))) 169 | 170 | (defmethod trcp (other) 171 | (eq other t)) 172 | 173 | (defmethod trcp (($ string)) 174 | t) 175 | 176 | (defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) 177 | `(let ((*trcdepth* (if *trcdepth* 178 | (1+ *trcdepth*) 179 | 0))) 180 | ,(when banner `(when (>= *trcdepth* ,min) 181 | (if (< *trcdepth* ,max) 182 | (trc ,@banner) 183 | (progn 184 | (brk "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) 185 | nil)))) 186 | (when (< *trcdepth* ,max) 187 | ,@body))) 188 | 189 | (defmacro wtrcx ((&key (min 1) (max 50) (on? t))(&rest banner) &body body ) 190 | `(let ((*trcdepth* (if *trcdepth* 191 | (1+ *trcdepth*) 192 | 0))) 193 | ,(when banner `(when (and (>= *trcdepth* ,min) ,on?) 194 | (if (< *trcdepth* ,max) 195 | (trc ,@banner) 196 | (progn 197 | (brk "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) 198 | nil)))) 199 | (when (< *trcdepth* ,max) 200 | ,@body))) 201 | 202 | (defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body ) 203 | (declare (ignore min max banner)) 204 | `(progn ,@body)) 205 | 206 | ;------ eko -------------------------------------- 207 | 208 | (defmacro eko ((&rest trcargs) &rest body) 209 | (let ((result (gensym))) 210 | `(let ((,result ,@body)) 211 | ,(if (stringp (car trcargs)) 212 | `(trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) 213 | `(trc ,(car trcargs) ,(cadr trcargs) :=> ,result ,@(cddr trcargs))) 214 | ,result))) 215 | 216 | (defmacro ekx (ekx-id &rest body) 217 | (let ((result (gensym))) 218 | `(let ((,result (,@body))) 219 | (trc ,(string-downcase (symbol-name ekx-id)) :=> ,result) 220 | ,result))) 221 | 222 | (defmacro eko-if ((&rest trcargs) &rest body) 223 | (let ((result (gensym))) 224 | `(let ((,result ,@body)) 225 | (when ,result 226 | (trc ,(car trcargs) :res ,result ,@(cdr trcargs))) 227 | ,result))) 228 | 229 | (defmacro ek (label &rest body) 230 | (let ((result (gensym))) 231 | `(let ((,result (,@body))) 232 | (when ,label 233 | (trc ,label ,result)) 234 | ,result))) 235 | 236 | -------------------------------------------------------------------------------- /lisp/variables.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | Copyright (C) 1995, 2006 by Kenneth Tilton 7 | 8 | This library is free software; you can redistribute it and/or 9 | modify it under the terms of the Lisp Lesser GNU Public License 10 | (http://opensource.franz.com/preamble.html), known as the LLGPL. 11 | 12 | This library is distributed WITHOUT ANY WARRANTY; without even 13 | the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 14 | 15 | See the Lisp Lesser GNU Public License for more details. 16 | 17 | |# 18 | 19 | (in-package :cells) 20 | 21 | (defun c-variable-accessor (symbol) 22 | (assert (symbolp symbol)) 23 | (c-variable-reader symbol)) 24 | 25 | (defun (setf c-variable-accessor) (value symbol) 26 | (assert (symbolp symbol)) 27 | (c-variable-writer value symbol)) 28 | 29 | (defun c-variable-reader (symbol) 30 | (assert (symbolp symbol)) 31 | (assert (get symbol 'cell)) 32 | (cell-read (get symbol 'cell))) 33 | 34 | (defun c-variable-writer (value symbol) 35 | (assert (symbolp symbol)) 36 | (setf (md-slot-value nil symbol) value) 37 | (setf (symbol-value symbol) value)) 38 | 39 | (export! def-c-variable) 40 | 41 | (defmacro def-c-variable (v-name cell &key ephemeral owning unchanged-if) 42 | (declare (ignore unchanged-if)) 43 | (let ((c 'whathef)) ;;(gensym))) 44 | `(progn 45 | (eval-when (:compile-toplevel :load-toplevel) 46 | (define-symbol-macro ,v-name (c-variable-accessor ',v-name)) 47 | (setf (md-slot-cell-type 'null ',v-name) (when ,ephemeral :ephemeral)) 48 | (when ,owning 49 | (setf (md-slot-owning 'null ',v-name) t))) 50 | (eval-when (:load-toplevel) 51 | (let ((,c ,cell)) 52 | (md-install-cell nil ',v-name ,c) 53 | (awaken-cell ,c))) 54 | ',v-name))) 55 | 56 | 57 | (defobserver *kenny* () 58 | (trcx kenny-obs new-value old-value old-value-boundp)) 59 | 60 | #+test 61 | (def-c-variable *kenny* (c-in nil)) 62 | 63 | 64 | #+test 65 | (defmd kenny-watcher () 66 | (twice (c? (bwhen (k *kenny*) 67 | (* 2 k))))) 68 | 69 | (defobserver twice () 70 | (trc "twice kenny is:" new-value self old-value old-value-boundp)) 71 | 72 | #+test-ephem 73 | (progn 74 | (cells-reset) 75 | (let ((tvw (make-instance 'kenny-watcher))) 76 | (trcx twice-read (twice tvw)) 77 | (setf *c-debug* nil) 78 | (setf *kenny* 42) 79 | (setf *kenny* 42) 80 | (trcx post-setf-kenny *kenny*) 81 | (trcx print-twice (twice tvw)) 82 | )) 83 | 84 | #+test 85 | (let ((*kenny* 13)) (print *kenny*)) 86 | 87 | #+test 88 | (let ((c (c-in 42))) 89 | (md-install-cell '*test-c-variable* '*test-c-variable* c) 90 | (awaken-cell c) 91 | (let ((tvw (make-instance 'test-var-watcher))) 92 | (trcx twice-read (twice tvw)) 93 | (setf *test-c-variable* 69) 94 | (trcx print-testvar *test-c-variable*) 95 | (trcx print-twice (twice tvw)) 96 | (unless (eql (twice tvw) 138) 97 | (inspect (md-slot-cell tvw 'twice)) 98 | (inspect c) 99 | )) 100 | ) 101 | 102 | #+test2 103 | (let ((tvw (make-instance 'test-var-watcher :twice (c-in 42)))) 104 | (let ((c (c? (trcx joggggggggging!!!!!!!!!!!!!!!) 105 | (floor (twice tvw) 2)))) 106 | (md-install-cell '*test-c-variable* '*test-c-variable* c) 107 | (awaken-cell c) 108 | (trcx print-testvar *test-c-variable*) 109 | (trcx twice-read (twice tvw)) 110 | (setf (twice tvw) 138) 111 | (trcx print-twice (twice tvw)) 112 | (trcx print-testvar *test-c-variable*) 113 | (unless (eql *test-c-variable* 69) 114 | (inspect (md-slot-cell tvw 'twice)) 115 | (inspect c) 116 | )) 117 | ) 118 | 119 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject its-alive "0.1.0-SNAPSHOT" 2 | :description "FIXME: write description" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.8.0"]]) 7 | -------------------------------------------------------------------------------- /src/tiltontec/its_alive/cell_types.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.cell-types 2 | (:require [tiltontec.its-alive.utility :refer :all])) 3 | 4 | ;; --- the Cells beef ----------------------- 5 | 6 | (def +pulse+ (ref 0)) 7 | 8 | (defn cells-init [] 9 | (dosync 10 | (ref-set +pulse+ 0))) 11 | 12 | (def ^:dynamic *causation* '()) 13 | (def ^:dynamic *call-stack* nil) 14 | (def ^:dynamic *depender* 15 | "*depender* let's us differentiate between the call stack and 16 | and dependency. The problem with overloading *call-stack* with both roles 17 | is that we miss cyclic reentrance when we use without-c-dependency in a 18 | rule to get once behavior or just when fm-traversing to find someone" 19 | nil) 20 | 21 | (def ^:dynamic *defer-changes* false) 22 | (def +client-q-handler+ (atom nil)) 23 | 24 | 25 | (defonce unbound (gensym "unbound-cell-value")) 26 | (defonce uncurrent (gensym "uncurrent-formulaic-value")) 27 | 28 | (def ^:dynamic *not-to-be* false) 29 | 30 | 31 | (def ^:dynamic *unfinished-business* nil) 32 | (def ^:dynamic *within-integrity* false) 33 | 34 | ;; --- debug stuff ----------------------------- 35 | (def ^:dynamic *finbiz-id* 0) 36 | (def ^:dynamic *c-prop-depth* 0) 37 | 38 | (def +c-debug+ (atom false)) 39 | (def ^:dynamic +stop+ (atom false)) ;; emergency brake 40 | 41 | ;; --- procedure division ---------------------- 42 | 43 | (defn cells-reset 44 | ([] (cells-reset {})) 45 | ([options] 46 | (reset! +c-debug+ (:debug options false)) 47 | (reset! @+pulse+ 0) 48 | (reset! +client-q-handler+ (:client-queue-handler options)))) 49 | 50 | (defmacro without-c-dependency [& body] 51 | `(binding [*depender* nil] 52 | ~@body)) 53 | 54 | (defn .cause [] 55 | (first *causation*)) 56 | 57 | ;; --- 19000 ---------------------------------- 58 | 59 | (defn c-stopper [why] 60 | (reset! +stop+ why)) ;; in webserver, make sure each thread binds this freshly 61 | 62 | (def +c-stopper+ (atom c-stopper)) 63 | 64 | (defn c-stop 65 | ([] (c-stop true)) 66 | ([why] 67 | (@+c-stopper+ why))) 68 | 69 | (defn c-stopped [] 70 | @+stop+) 71 | 72 | (defmacro un-stopped [& body] 73 | `(when-not @+stop+ 74 | ~@body)) 75 | 76 | (defn ustack$ [tag] ;; debug aid 77 | (str tag "ustack> "(vec (map (fn [c] (:slot @c)) *call-stack*)))) 78 | 79 | (defn c-assert 80 | ([assertion] (when-not assertion 81 | (err "c-assert anon failed"))) 82 | ([assertion fmt$ & fmt-args] 83 | (unless +stop+ 84 | (unless assertion 85 | (apply #'err format (str "c-assert> " fmt$) 86 | fmt-args))))) 87 | 88 | (defn c-break [& args] 89 | (unless +stop+ 90 | (err (apply 'str args)))) 91 | 92 | (defn c-warn [& args] 93 | (unless +stop+ 94 | (format "WARNING!!!!!!!!! %s" 95 | (apply 'str args)))) 96 | 97 | ;; --------------------------------------------------------- 98 | 99 | (defonce ia-types (-> (make-hierarchy) 100 | (derive ::model ::object) 101 | (derive ::cell ::object) 102 | (derive ::c-formula ::cell))) 103 | 104 | (defn ia-type? [it typ] 105 | (isa? ia-types (type it) typ)) 106 | 107 | (defn c-formula? [c] 108 | (ia-type? c ::c-formula)) 109 | 110 | (defn c-ref? [x] 111 | (ia-type? x ::cell)) 112 | 113 | (def-rmap-slots c- 114 | me slot state input? rule pulse pulse-last-changed pulse-observed 115 | useds users callers optimize ephemeral? 116 | lazy synaptic?) 117 | 118 | (defn c-value [c] 119 | (assert (any-ref? c)) 120 | (cond 121 | (and (c-ref? c) 122 | (map? @c)) (:value @c) 123 | :else @c)) 124 | 125 | (defn c-optimized-away? [c] 126 | (cond 127 | (c-ref? c) (or (not (map? @c)) 128 | (= :optimized-away (:state @c))) 129 | :else true)) 130 | 131 | (defn c-model [rc] 132 | (:me @rc)) 133 | 134 | (defn c-slot-name [rc] 135 | (:slot @rc)) 136 | 137 | (defn c-value-state [rc] 138 | (let [v (c-value rc)] 139 | (cond 140 | (= v unbound) :unbound 141 | (= v uncurrent) :uncurrent 142 | :else :valid))) 143 | 144 | (defn c-unbound? [rc] 145 | (= :unbound (c-value-state rc))) 146 | 147 | (defn c-valid? [rc] 148 | (= :valid (c-value-state rc))) 149 | 150 | ;; --- dependency maintenance -------------------------------- 151 | 152 | (defn caller-ensure [used new-caller] 153 | (alter used assoc :callers (conj (c-callers used) new-caller))) 154 | 155 | (defn caller-drop [used caller] 156 | (alter used assoc :callers (disj (c-callers used) caller))) 157 | 158 | (defn unlink-from-callers [c] 159 | (for [caller (c-callers c)] 160 | (caller-drop c caller)) 161 | (rmap-setf [:callers c] nil)) 162 | 163 | ;; debug aids -------------- 164 | 165 | (defn c-slots [c k] 166 | (assert (c-ref? c)) 167 | (set (map c-slot (k @c)))) 168 | 169 | ;; --- defmodel rizing --------------------- 170 | 171 | (defn md-ref? [x] 172 | ;;(trx :md-ref?-sees x) 173 | (and (instance? clojure.lang.Ref x) 174 | ;; hhack (ia-type? x ::model) 175 | )) 176 | 177 | ;; --- mdead? --- 178 | 179 | (defmulti mdead? (fn [me] 180 | (assert (or (nil? me) 181 | (md-ref? me))) 182 | [(type (when me @me))])) 183 | 184 | (defmethod mdead? :default [me] 185 | false) 186 | 187 | ;;--- 188 | 189 | (set! *print-level* 3) ;; cells are recursive data for now 190 | 191 | (defn md-slot-owning? [class-name slot-name] 192 | ;; hhack 193 | false) 194 | 195 | :cell-types-ok 196 | 197 | -------------------------------------------------------------------------------- /src/tiltontec/its_alive/cells.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.cells 2 | (:require [tiltontec.its-alive.utility :refer :all] 3 | [tiltontec.its-alive.cell-types :refer :all as cty] 4 | [tiltontec.its-alive.observer :refer :all] 5 | [tiltontec.its-alive.evaluate :refer :all] 6 | [tiltontec.its-alive.integrity :refer :all])) 7 | 8 | (set! *print-level* 3) 9 | 10 | (defn make-cell [& kvs] 11 | (let [options (apply hash-map kvs)] 12 | (ref (merge {:value unbound 13 | :state :nascent 14 | :pulse 0 15 | :pulse-last-changed 0 16 | :pulse-observed 0 17 | :callers #{} 18 | :lazy false ;; not a predicate (can hold, inter alia, :until-asked) 19 | :ephemeral? false 20 | :input? true 21 | } 22 | options) 23 | :meta {:type ::tiltontec.its-alive.cell-types/cell}))) 24 | 25 | (defn make-c-formula [& kvs] 26 | (let [options (apply hash-map kvs) 27 | rule (:rule options)] 28 | (assert rule) 29 | (assert (fn? rule)) 30 | (ref (merge {:value unbound 31 | :state :nascent ;; s/b :unbound? 32 | :pulse 0 33 | :pulse-last-changed 0 34 | :pulse-observed 0 35 | :callers #{} 36 | :useds #{} 37 | :lazy false 38 | :ephemeral? false 39 | :optimize true ;; this can also be :when-not-nil 40 | :input? false ;; not redundant: can start with rule, continue as input 41 | } 42 | options) 43 | :meta {:type ::tiltontec.its-alive.cell-types/c-formula}))) 44 | 45 | ;;___________________ constructors _______________________________ 46 | ;; I seem to have created a zillion of these, but I normally 47 | ;; use just c-in, c?, and c?n (which starts out as c? and becomes c-in). 48 | ;; 49 | 50 | (defmacro c-fn-var [[c] & body] 51 | `(fn [~c] 52 | (let [~'me (c-model ~c) 53 | ~'cache (c-value ~c)] 54 | ~@body))) 55 | 56 | (defmacro c-fn [& body] 57 | `(c-fn-var (~'slot-c#) ~@body)) 58 | 59 | (defmacro c? [& body] 60 | `(make-c-formula 61 | :code '~body 62 | :value unbound 63 | :rule (c-fn ~@body))) 64 | 65 | (defmacro c?+ [[& options] & body] 66 | `(make-c-formula 67 | ~@options 68 | :code '~body 69 | :value unbound 70 | :rule (c-fn ~@body))) 71 | 72 | (defmacro c?+n [& body] 73 | `(make-c-formula 74 | :input? true 75 | :code '~body 76 | :value unbound 77 | :rule (c-fn ~@body))) 78 | 79 | (defmacro c?n [& body] 80 | `(make-c-formula 81 | :code '(without-c-dependency ~@body) 82 | :input? true 83 | :value unbound 84 | :rule (c-fn (without-c-dependency ~@body)))) 85 | 86 | (defmacro c_?n [& body] 87 | `(make-c-formula 88 | :code '(without-c-dependency ~@body) 89 | :input? true 90 | :lazy :until-asked 91 | :value unbound 92 | :rule (c-fn (without-c-dependency ~@body)))) 93 | 94 | (defmacro c?n-dbg [& body] 95 | `(make-c-formula 96 | :code '(without-c-dependency ~@body) 97 | :input? true 98 | :debug true 99 | :value unbound 100 | :rule (c-fn (without-c-dependency ~@body)))) 101 | 102 | (defmacro c?n-until [args & body] 103 | `(make-c-formula 104 | :optimize :when-value-t 105 | :code '~body 106 | :input? true 107 | :value unbound 108 | :rule (c-fn ~@body) 109 | ~@args)) 110 | 111 | (defmacro c?once [& body] 112 | `(make-c-formula 113 | :code '(without-c-dependency ~@body) 114 | :input? nil 115 | :value unbound 116 | :rule (c-fn (without-c-dependency ~@body)))) 117 | 118 | (defmacro c_1 [& body] 119 | `(make-c-formula 120 | :code '(without-c-dependency ~@body) 121 | :input? nil 122 | :lazy true 123 | :value unbound 124 | :rule (c-fn (without-c-dependency ~@body)))) 125 | 126 | (defmacro c?1 [& body] 127 | `(c?once ~@body)) 128 | 129 | (defmacro c?dbg [& body] 130 | `(make-c-formula 131 | :code '~body 132 | :value unbound 133 | :debug true 134 | :rule (c-fn ~@body))) 135 | 136 | (defmacro c?_ [[& options] & body] 137 | `(make-c-formula 138 | ~@options 139 | :code '~body 140 | :value unbound 141 | :lazy true 142 | :rule (c-fn ~@body))) 143 | 144 | (defmacro c_? [[& options] & body] 145 | "Lazy until asked, then eagerly propagating" 146 | `(make-c-formula 147 | ~@options 148 | :code '~body 149 | :value unbound 150 | :lazy :until-asked 151 | :rule (c-fn ~@body))) 152 | 153 | (defmacro c_?dbg [& body] 154 | "Lazy until asked, then eagerly propagating" 155 | `(make-c-formula 156 | :code '~body 157 | :value unbound 158 | :lazy :until-asked 159 | :rule (c-fn ~@body) 160 | :debug true)) 161 | 162 | ;; hhhhack add validation somewhere of lazy option 163 | 164 | (defmacro c-formula [[& kvs] & body] 165 | `(make-c-formula 166 | :code '~body ;; debug aid 167 | :value unbound 168 | :rule (c-fn ~@body) 169 | ~@keys)) 170 | 171 | (defn c-in [value & option-kvs] 172 | (apply make-cell 173 | (list* :value value 174 | :input? true 175 | option-kvs))) 176 | 177 | ;; --- where change and animation begin ------- 178 | 179 | (defn c-reset! [c new-value] 180 | "The moral equivalent of a Common Lisp SETF, and indeed 181 | in the CL version of Cells SETF itself is the change API dunction." 182 | (assert c) 183 | (cond 184 | *defer-changes* 185 | (throw (Exception. "c-reset!> change to %s must be deferred by wrapping it in WITH-INTEGRITY" 186 | (c-slot c))) 187 | ;----------------------------------- 188 | (some #{(c-lazy c)} [:once-asked :always true]) 189 | (c-value-assume c new-value nil) 190 | ;------------------------------------------- 191 | :else 192 | (dosync 193 | (with-integrity (:change (c-slot c)) 194 | (c-value-assume c new-value nil))))) 195 | 196 | 197 | 198 | (defmacro c-reset-next! [f-c f-new-value] 199 | "Observers should have side-effects only outside the 200 | cell-mediated model, but it can be useful to have an observer 201 | kick off further change to the model. To achieve this we 202 | allow an observer to explicitly queue a c-reset! for 203 | execution as soon as the current change is manifested." 204 | `(cond 205 | (not *within-integrity*) 206 | (throw (Exception. "c-reset-next!> deferred change to %s not under WITH-INTEGRITY supervision." 207 | (c-slot ~f-c))) 208 | ;--------------------------------------------- 209 | :else 210 | (ufb-add :change 211 | [:c-reset-next! 212 | (fn [~'opcode ~'defer-info] 213 | (let [c# ~f-c 214 | new-value# ~f-new-value] 215 | (cond 216 | ;;----------------------------------- 217 | (some #{(c-lazy c#)} [:once-asked :always true]) 218 | (c-value-assume c# new-value# nil) 219 | ;;------------------------------------------- 220 | :else 221 | (dosync 222 | (c-value-assume c# new-value# nil)))))]))) 223 | 224 | :cells-ok 225 | 226 | -------------------------------------------------------------------------------- /src/tiltontec/its_alive/family.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.family 2 | (:require 3 | [clojure.set :refer [difference]] 4 | [tiltontec.its-alive.utility :refer :all] 5 | [tiltontec.its-alive.cell-types :refer :all :as cty] 6 | [tiltontec.its-alive.observer :refer :all] 7 | [tiltontec.its-alive.evaluate :refer :all] 8 | [tiltontec.its-alive.model-base :refer :all] 9 | [tiltontec.its-alive.family :refer :all :as fm] 10 | )) 11 | 12 | (derive cty/ia-types ::family ::cty/model) 13 | 14 | (def ^:dynamic *par* nil) 15 | 16 | (defn fget= [seek poss] 17 | (assert (any-ref? poss)) 18 | (cond 19 | (fn? seek) (seek poss) 20 | (keyword? seek)(do 21 | ;; (trx :fget=!!! seek @poss) 22 | (= seek (:name @poss))) 23 | :else (do ;; (trx :fget=-else! seek) 24 | (= seek poss)))) 25 | 26 | (defn fget [what where & options] 27 | ;;(trx :fget-entry what where) 28 | (when (and where what) 29 | (let [options (merge {:me? false 30 | , :inside? false 31 | , :up? true 32 | , :wocd? true ;; without-c-dependency 33 | } (apply hash-map options))] 34 | ;;(trx :fget-beef what (md-name where) options) 35 | (binding [*depender* (if (:wocd? options) nil *depender*)] 36 | (or (and (:me? options) 37 | (fget= what where) 38 | where) 39 | 40 | (and (:inside? options) 41 | (if-let [kids (md-get where :kids)] 42 | (do 43 | ;;(trx :fget-inside (:skip options)(doall (map md-name kids))) 44 | (if-let [netkids (remove #{(:skip options)} kids)] 45 | (do 46 | ;;(trx netkids!!! netkids) 47 | (some #(fget what % 48 | :me? true 49 | :inside? true 50 | :up? false) netkids)) 51 | (trx :no-net-kids))) 52 | (trx nil :inside-no-kids @where))) 53 | 54 | (and (:up? options) 55 | (when-let [par (:par @where)] 56 | ;; (trx :fget-up (:name @par)) 57 | (fget what par 58 | :up? true 59 | :me? true 60 | :skip where 61 | :inside? true))) 62 | 63 | (when (:must? options) 64 | (err :fget-must-failed what where options))))))) 65 | 66 | (defn fm! [what where] 67 | (fget what where :me? false :inside? true :must? true :up? true)) 68 | 69 | (defmacro mdv! [what slot & [me]] 70 | (let [me (or me 'me)] 71 | `(md-get (fm! ~what ~me) ~slot))) 72 | 73 | ;; (macroexpand-1 '(mdv! :aa :aa3)) 74 | 75 | (defmacro the-kids [& tree] 76 | `(binding [*par* ~'me] 77 | (remove nil? (flatten (list ~@tree))))) 78 | 79 | (defobserver :kids [::family][me newk oldk c] 80 | (when-not (= oldk unbound) 81 | (let [lostks (difference (set oldk)(set newk))] 82 | (trx :lostks (flz lostks)) 83 | (when-not (empty? lostks) 84 | (trx :bingo-lost! lostks) 85 | (doseq [k lostks] 86 | (trx :not-to-eing!!!!! k) 87 | (not-to-be k)))))) 88 | 89 | #_ 90 | (dosync 91 | (for [x #{(ref 1)}] 92 | (not-to-be x))) 93 | 94 | :family-ok 95 | -------------------------------------------------------------------------------- /src/tiltontec/its_alive/integrity.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.integrity 2 | (:require [tiltontec.its-alive.utility :refer :all] 3 | [tiltontec.its-alive.cell-types :refer :all])) 4 | 5 | 6 | ;; --- the pulse ------------------------------ 7 | 8 | (set! *print-level* 3) 9 | 10 | (def ^:dynamic *one-pulse?* false) 11 | 12 | (def ^:dynamic *dp-log* false) 13 | 14 | (defn data-pulse-next 15 | ([] (data-pulse-next :anon)) 16 | ([pulse-info] 17 | (unless *one-pulse?* 18 | (when *dp-log* 19 | (trx "dp-next> " (inc @+pulse+) pulse-info)) 20 | (alter +pulse+ inc)))) ;; hhack try as commute 21 | 22 | (defn c-current? [c] 23 | (= (c-pulse c) @+pulse+)) 24 | 25 | (defn c-pulse-update [c key] 26 | (when-not (c-optimized-away? c) 27 | (assert (>= @+pulse+ (c-pulse c)) 28 | (format "Current DP %s not GE pulse %s of cell %s" 29 | @+pulse+ (c-pulse c) @c)) 30 | (alter c assoc :pulse @+pulse+))) 31 | 32 | ;; --- ufb utils ---------------------------- 33 | 34 | (def +ufb-opcodes+ [:tell-dependents 35 | :awaken 36 | :client 37 | :ephemeral-reset 38 | :change]) 39 | 40 | (def unfin-biz 41 | ;; no nested finbiz allowed as of now, so just 42 | ;; build it and in use fill the queues, ufb -do them, and 43 | ;; ensure they are empty before continuing. 44 | (into {} (for [i +ufb-opcodes+] [i (ref [])]))) 45 | 46 | (defn ufb-queue [opcode] 47 | (or (opcode unfin-biz) 48 | (err format "ufb-queue> opcode %s unknown" opcode))) 49 | 50 | (defn ufb-queue-ensure [opcode] 51 | "vestigial" 52 | (or (ufb-queue opcode) 53 | (err format 54 | "ufb-queue-ensure now expects all queues to exist. %s does not. we have %s" 55 | opcode (keys unfin-biz)))) 56 | 57 | (defn ufb-add [opcode continuation] 58 | (fifo-add (ufb-queue-ensure opcode) continuation)) 59 | 60 | (defn ufb-assert-q-empty [opcode] 61 | (if-let [uqp (fifo-peek (ufb-queue-ensure opcode))] 62 | (do 63 | (err format "ufb queue %s not empty, viz %s" 64 | opcode uqp)) 65 | true)) 66 | 67 | ;; --- the ufb and integrity beef ---------------------- 68 | ;; proper ordering of state propagation 69 | 70 | 71 | (def ^:dynamic *ufb-do-q* nil) ;; debug aid 72 | 73 | (defn ufb-do 74 | ([opcode] 75 | (ufb-do (ufb-queue opcode) opcode)) 76 | 77 | ([q opcode] 78 | ;;(println :ufb-do opcode) 79 | (when-let [[defer-info task] (fifo-pop q)] 80 | (trx nil :ufb-do-yep defer-info task) 81 | (task opcode defer-info) 82 | (recur q opcode)))) 83 | 84 | (defn finish-business [] 85 | ;; (println :fbiz!!!!!) 86 | (un-stopped 87 | (loop [tag :tell-dependents] 88 | (case tag 89 | :tell-dependents 90 | (do (ufb-do :tell-dependents) 91 | (ufb-do :awaken) 92 | 93 | (recur 94 | (if (fifo-peek (ufb-queue-ensure :tell-dependents)) 95 | :tell-dependents 96 | :handle-clients))) 97 | 98 | :handle-clients 99 | (when-let [clientq (ufb-queue :client)] 100 | (if-let [cqh @+client-q-handler+] 101 | (cqh clientq) 102 | (ufb-do clientq :client)) 103 | 104 | (recur 105 | (if (fifo-peek (ufb-queue :client)) 106 | :handle-clients 107 | :ephemeral-reset))) 108 | 109 | :ephemeral-reset 110 | (do (ufb-do :ephemeral-reset) 111 | (recur :deferred-state-change)) 112 | 113 | :deferred-state-change 114 | (when-let [[defer-info task-fn] (fifo-pop (ufb-queue :change))] 115 | (data-pulse-next :def-state-chg) 116 | (task-fn :change defer-info) 117 | (recur :tell-dependents)))))) 118 | 119 | (defmacro with-integrity [[opcode info] & body] 120 | `(call-with-integrity 121 | ~opcode 122 | ~info 123 | (fn [~'opcode ~'defer-info] 124 | ~@body))) 125 | 126 | (defmacro with-cc [id &body body] 127 | `(with-integrity (:change ~id) 128 | ~@body)) 129 | 130 | (defmacro without-integrity [& body] 131 | `(binding 132 | [*within-integrity* false 133 | *defer-changes* false 134 | *call-stack* '()] 135 | ~@body)) 136 | 137 | (defn call-with-integrity [opcode defer-info action] 138 | (when opcode 139 | (assert (cl-find opcode +ufb-opcodes+) 140 | (format "Invalid opcode for with-integrity: %s. Allowed values: %s" 141 | opcode +ufb-opcodes+))) 142 | (do ;; wtrx (0 1000 "cwi-begin" opcode *within-integrity*) 143 | (un-stopped 144 | (dosync 145 | (cond 146 | (c-stopped) (println :cwi-sees-stop!!!!!!!!!!!) 147 | 148 | *within-integrity* 149 | (if opcode 150 | (prog1 151 | :deferred-to-ufb-1 152 | ;; SETF is supposed to return the value being installed 153 | ;; in the place, but if the SETF is deferred we return 154 | ;; something that will help someone who tries to use 155 | ;; the setf'ed value figure out what is going on: 156 | (ufb-add opcode [defer-info action])) 157 | 158 | ;; thus by not supplying an opcode one can get something 159 | ;; executed immediately, potentially breaking data integrity 160 | ;; but signifying by having coded the with-integrity macro 161 | ;; that one is aware of this. 162 | ;; 163 | ;; If you have read this comment. 164 | ;; 165 | (action opcode defer-info)) 166 | 167 | :else (binding [*within-integrity* true 168 | *defer-changes* false] 169 | (when (or (zero? @+pulse+) 170 | (= opcode :change)) 171 | (data-pulse-next :cwi)) 172 | (prog1 173 | (action opcode defer-info) 174 | (finish-business) 175 | (ufb-assert-q-empty :tell-dependents) 176 | (ufb-assert-q-empty :change)))))))) 177 | 178 | (defn ephemeral-reset [rc] 179 | ;; (trx :eph-reset?????? (:slot @rc)(:ephemeral? @rc)) 180 | (when (c-ephemeral? rc) ;; allow call on any cell, catch here 181 | ; 182 | ; as of Cells3 we defer resetting ephemerals because everything 183 | ; else gets deferred and we cannot /really/ reset it until 184 | ; within finish_business we are sure all callers have been recalculated 185 | ; and all observers completed (which happens with recalc). 186 | ; 187 | ;;(trx :ephh-reset!!! (:slot @rc)) 188 | (with-integrity (:ephemeral-reset rc) 189 | (when-let [me (:me @rc)] 190 | ;; presumption next is that model cells live in 191 | ;; their own internal slot of model FNYI 192 | (alter me assoc (:slot @rc) nil)) 193 | (alter rc assoc :value nil)))) 194 | :integrity-ok 195 | -------------------------------------------------------------------------------- /src/tiltontec/its_alive/model.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.model 2 | (:require 3 | [tiltontec.its-alive.utility :refer :all] 4 | [tiltontec.its-alive.cell-types :refer :all :as cty] 5 | [tiltontec.its-alive.evaluate :refer :all] 6 | [tiltontec.its-alive.integrity :refer :all] 7 | [tiltontec.its-alive.observer :refer :all] 8 | [tiltontec.its-alive.cells :refer :all] 9 | [tiltontec.its-alive.model-base :refer :all] 10 | [tiltontec.its-alive.family :refer :all] 11 | )) 12 | 13 | ;;; --- accessors ---- 14 | 15 | (defn md-reset! [me slot new-value] 16 | ;;(trx :md-reset!!!!!!! slot (md-name me) new-value) 17 | (if-let [c (md-cell me slot)] 18 | (c-reset! c new-value) 19 | (do 20 | (err format "change to slot %s not mediated by cell" slot) 21 | (rmap-setf [slot me] new-value)))) 22 | 23 | (defn make [& iargs] 24 | (cond 25 | (odd? (count iargs)) (apply make :type iargs) 26 | :else 27 | (dosync 28 | (let [me (ref (merge {:par *par*} 29 | (->> iargs 30 | (partition 2) 31 | (filter (fn [[slot v]] 32 | (not (= :type slot)))) 33 | (map (fn [[k v]] 34 | (vector k (if (c-ref? v) 35 | unbound 36 | v)))) 37 | (into {}))) 38 | :meta (merge {:state :nascent} 39 | (->> iargs 40 | (partition 2) 41 | (filter (fn [[slot v]] 42 | (= :type slot))) 43 | (map vec) 44 | (into {}))))] 45 | (assert (meta me)) 46 | (rmap-meta-setf 47 | [:cz me] 48 | (->> iargs 49 | (partition 2) 50 | (filter (fn [[slot v]] 51 | (md-install-cell me slot v))) 52 | (map vec) 53 | (into {}))) 54 | (with-integrity (:awaken me) 55 | (md-awaken me)) 56 | me)))) 57 | 58 | (def kwt "kenneth.tilton@ktilt.com") 59 | (apply str (reduce (fn [[& as][& xs]] 60 | (vec (map str as xs))) 61 | (partition 3 kwt))) 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /src/tiltontec/its_alive/model_base.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.model-base 2 | (:require 3 | [tiltontec.its-alive.utility :refer :all] 4 | [tiltontec.its-alive.cell-types :refer :all :as cty] 5 | [tiltontec.its-alive.evaluate :refer :all] 6 | [tiltontec.its-alive.integrity :refer :all] 7 | [tiltontec.its-alive.observer :refer :all] 8 | [tiltontec.its-alive.cells :refer :all] 9 | )) 10 | 11 | (def-rmap-slots md- 12 | name) 13 | 14 | (def-rmap-meta-slots md- 15 | state cz) 16 | 17 | (defn md-cell [me slot] 18 | (slot (:cz (meta me)))) 19 | 20 | ;;; --- md initialization --- 21 | 22 | (declare md-awaken) 23 | 24 | (defn md-install-cell [me slot c] 25 | ;; note that c (a misnomer) might not be a Cell 26 | (cond 27 | (c-ref? c) (do 28 | (alter c assoc 29 | :slot slot 30 | :me me) 31 | (rmap-setf [slot me] 32 | (when (c-input? c) 33 | (c-value c))) 34 | true) 35 | :else (do 36 | (rmap-setf [slot me] c) 37 | false))) 38 | 39 | (defn md-awaken 40 | "(1) do initial evaluation of all ruled slots 41 | (2) call observers of all slots" 42 | [me] 43 | 44 | 45 | (c-assert (= :nascent (md-state me))) 46 | (rmap-meta-setf [:state me] :awakening) 47 | ;;(trx :md-awk @me) 48 | (doall 49 | (for [slot (keys @me)] 50 | (let [c (slot (md-cz me))] 51 | (cond 52 | c (do ;(trx :slot-c slot c) 53 | (c-awaken c)) 54 | :else (do ;(trx :noslot slot (slot @me) me) 55 | (observe slot me (slot @me) unbound nil)))))) 56 | 57 | (rmap-meta-setf [:state me] :awake) 58 | me) 59 | 60 | (defn md-get [me slot] 61 | ;;(trx :md-get!!!!!!! slot (md-name me)) 62 | (if-let [c (md-cell me slot)] 63 | (c-get c) 64 | (slot @me))) 65 | 66 | 67 | -------------------------------------------------------------------------------- /src/tiltontec/its_alive/observer.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.observer 2 | (:use [tiltontec.its-alive.utility :refer :all] 3 | [tiltontec.its-alive.cell-types :refer :all])) 4 | 5 | 6 | (defmulti observe (fn [slot-name me new-val old-val c] 7 | [slot-name 8 | (type (when (md-ref? me) me)) 9 | (type new-val) 10 | (type old-val)])) 11 | 12 | #_ 13 | (obs-reset) 14 | 15 | (defn obs-reset [] 16 | (remove-all-methods observe) 17 | (defmethod observe :default [slot me new-val old-val c] 18 | ;; (println :obs-fall-thru slot (type @me) new-val old-val c) 19 | )) 20 | 21 | (defmethod observe :default [slot me new-val old-val c] 22 | #_(println :obs-fall-thru slot 23 | (cond 24 | (md-ref? me)(type me) 25 | :else me) 26 | new-val old-val c)) 27 | 28 | 29 | (defmacro defobserver [slot types params & body] 30 | (assert (keyword? slot) "defobserver> slot should be a keyword.") 31 | (let [ftypes (concat types (take-last (- 3 (count types)) 32 | '(::tiltontec.its-alive.cell-types/model Object Object))) 33 | fparams (concat params 34 | (take-last (- 4 (count params)) 35 | '(me new-value old-value c)))] 36 | `(defmethod tiltontec.its-alive.observer/observe [~slot ~@ftypes][~'slot ~@fparams] 37 | ~@body))) 38 | 39 | 40 | (defmacro fn-obs 41 | "Shortcut definer for cell-specific observers. 42 | body can be multiple sexprs with access to 43 | call parameters: slot, me, new, old, and c." 44 | [& body] 45 | `(fn [~'slot ~'me ~'new ~'old ~'c] 46 | ~@body)) 47 | 48 | (defn c-observe 49 | ([c why] 50 | (c-observe c unbound why)) 51 | ([c prior-value why] 52 | ;; (trx :cobs-3 (c-slot c) why) 53 | (assert (c-ref? c)) 54 | (rmap-setf [:pulse-observed c] @+pulse+) 55 | ;;(trx :c-obs-pulse! (c-slot c) why @+pulse+ (:obs @c)) 56 | ;;(trx :c-obs-value! why (c-slot c) (c-model c) (c-value c) prior-value c) 57 | ((or (:obs @c) observe) 58 | (c-slot c)(c-model c)(c-value c) prior-value c))) 59 | 60 | :observer-ok 61 | -------------------------------------------------------------------------------- /src/tiltontec/its_alive/utility.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.utility 2 | (:require [clojure.string :as $])) 3 | 4 | (set! *print-level* 2) ;; lose this if we lose recursive data structures 5 | 6 | (defmacro prog1 [& body] 7 | `(let [result# ~(first body)] 8 | ~@(rest body) 9 | result#)) 10 | 11 | (defmacro b-when [var form & body] 12 | `(when-let [~var ~form] 13 | ~@body)) 14 | 15 | (defn cl-find [sought coll] 16 | (some #{sought} coll)) 17 | 18 | (defmacro unless [form & body] 19 | `(when-not ~form 20 | ~@body)) 21 | 22 | (defn type-of [x] (type x)) 23 | 24 | (defn set-ify [x] 25 | (cond 26 | (nil? x) #{} 27 | (sequential? x) (set x) 28 | :else #{x})) 29 | 30 | ;; --- refs with maps conveniences ------------------- 31 | 32 | (defmacro def-rmap-slots [reader-prefix & slots] 33 | `(do 34 | ~@(map (fn [slot#] 35 | `(defn ~(symbol (str (or reader-prefix "") 36 | slot#)) 37 | [~'ref] 38 | (~(keyword slot#) @~'ref))) slots))) 39 | 40 | (defn any-ref? [x] 41 | (instance? clojure.lang.Ref x)) 42 | 43 | (defn rmap-setf [[slot ref] new-value] 44 | (assert (any-ref? ref)) 45 | (assert (map? @ref)) 46 | (alter ref assoc slot new-value) 47 | new-value) 48 | 49 | (defmacro def-rmap-meta-slots [reader-prefix & slots] 50 | `(do 51 | ~@(map (fn [slot#] 52 | `(defn ~(symbol (str (or reader-prefix "") 53 | slot#)) 54 | [~'ref] 55 | (~(keyword slot#) (meta ~'ref)))) slots))) 56 | 57 | 58 | (defn rmap-meta-setf [[slot ref] new-value] 59 | (assert (meta ref)) 60 | (alter-meta! ref assoc slot new-value) 61 | new-value) 62 | 63 | ;; --- error handling ----------------- 64 | 65 | (do 66 | (defmulti err (fn [a1 & args] (fn? a1))) 67 | 68 | (defmethod err true [fn & mas] 69 | (err (apply fn mas))) 70 | 71 | (defmethod err :default [& bits] 72 | (throw (Exception. ($/join " " (cons "jz/err>" bits)))))) 73 | 74 | 75 | 76 | ;; ---- debug print statement hacks --------------------- 77 | 78 | (def ^:dynamic *trx?* true) 79 | 80 | #_ 81 | (alter-var-root #'*trx?* not) 82 | 83 | (def ^:dynamic *trc-ensure* nil) 84 | (def ^:dynamic *trx-path-id* nil) 85 | (def ^:dynamic *trxdepth* 0) 86 | (def last-trc (atom 0)) ;; s/b universal time 87 | 88 | (defn call-trc$ [s bits] 89 | (str s ": " ($/join ", " bits))) 90 | 91 | ;; (call-trc$ nil (list :himom-shouldnot-appear 1 2 3)) 92 | ;; (call-trc$ "cool" (list :himom-shouldnot-appear 1 2 3)) 93 | 94 | (defn call-trc [s & os] 95 | ;; (break) ;; uncomment to escape loop 96 | (when *trx?* 97 | (when s 98 | (let [path (apply str (repeat *trxdepth* "."))] 99 | (println path (call-trc$ s os)))))) 100 | 101 | (defn flz [x] 102 | (if (isa? (type x) clojure.lang.LazySeq) 103 | (vec (doall x)) 104 | x)) 105 | #_ 106 | (flz (map even? [1 2 3])) 107 | 108 | (defmacro trx [label & vals] 109 | `(call-trc ~(when (not (nil? label)) 110 | (str label)) 111 | ~@vals)) 112 | 113 | (defmacro wtrx [[lo hi & trxargs] & body] 114 | `(binding [*trxdepth* (inc *trxdepth*)] 115 | (cond 116 | (<= ~lo *trxdepth* ~hi) 117 | (trx ~@trxargs) 118 | 119 | (> *trxdepth* ~hi) 120 | (throw (Exception. (str 121 | (format "wtrx exceeded max(%d): " ~hi) 122 | (call-trc$ '~(first trxargs) 123 | (list ~@(rest trxargs))))))) 124 | ~@body)) 125 | 126 | #_ 127 | (binding [*trxdepth* 5] 128 | (wtrx (0 100 "cool" 1 2 3) 129 | (println :body))) 130 | 131 | (defn wtrx-test [n] 132 | (wtrx (0 10 "test" n) 133 | (when (> n 0) 134 | (wtrx-test (dec n))))) 135 | 136 | ;; --- deftest support --------------------- 137 | ;; These next two are lame because they just 138 | ;; look at slots (ignoring models). Use only 139 | ;; in tests looking at one model or at least 140 | ;; slot names do not duplicate. 141 | ;; 142 | 143 | (defn slot-users [me slot] 144 | (set (map :slotq 145 | (map deref 146 | (:callers @(slot @me) #{}))))) 147 | 148 | (defn slot-useds [me slot] 149 | (set (map :slot 150 | (map deref 151 | (:useds @(slot @me) #{}))))) 152 | 153 | ;;; --- FIFO Queue ----------------------------- 154 | 155 | (defn make-fifo-queue [] 156 | (ref [])) 157 | 158 | (defn fifo-data [q] @q) 159 | (defn fifo-clear [q] 160 | (alter q empty)) 161 | (defn fifo-empty? [q] 162 | (empty? @q)) 163 | (defn fifo-peek [q] 164 | (first @q)) 165 | 166 | (defn fifo-add [q new] 167 | (alter q conj new)) 168 | 169 | (defn fifo-pop [q] 170 | (when-not (fifo-empty? q) 171 | (prog1 172 | (first @q) 173 | (alter q subvec 1)))) 174 | 175 | ;;; --- learning curve exercises 176 | ;; 177 | 178 | (comment 179 | (loop [[slot v & r] '(:a 0 :b 1 :c 9) 180 | acc (transient {})] 181 | (if (nil? slot) 182 | (persistent! acc) 183 | (recur r (assoc! acc 184 | slot 185 | (cond 186 | (typep v :jz) 187 | (merge {:slot slot} v) 188 | :else v))))) 189 | 190 | (into (hash-map) 191 | (map (fn [[k v]] (vector k (inc v))) 192 | (partition 2 '(:a 0 :b 1 :c 9)))) 193 | 194 | (reduce (fn [m [k v]] 195 | (assoc m k (inc v))) 196 | (hash-map) 197 | (partition 2 '(:a 0 :b 1 :c 9)))) 198 | 199 | :utility-ok 200 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/01-lesson.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:01-lesson (:use :cl :cells)) 2 | 3 | ;; 4 | ;; We will keep making new packages so we can incrementally develop the 5 | ;; same class without newer versions stomping on earlier versions (by 6 | ;; being in the same package and effectively redefining earlier versions). 7 | ;; 8 | (in-package #:01-lesson) 9 | 10 | #| 11 | 12 | (xxx :initarg :xxx :initform nil :accessor xxx) 13 | 14 | |# 15 | 16 | (defmodel rectangle () 17 | ((len :initarg :len :accessor len 18 | :initform (c? (* 2 (width self)))) 19 | (width :initarg :width :initform nil :accessor width)) 20 | (:default-initargs 21 | :width (c? (/ (len self) 2)))) 22 | 23 | (cells::ct-assert (eql 21 (width (make-instance 'rectangle :len 42))) 24 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/cell-types.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (defstruct (cell (:conc-name c-)) 13 | model 14 | slot-name 15 | value 16 | 17 | inputp ;; t for old c-variable class 18 | synaptic 19 | (caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO 20 | 21 | (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away 22 | (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :uncurrent | :valid} 23 | ; uncurrent (aka dirty) new for 06-10-15. we need this so 24 | ; c-quiesce can force a caller to update when asked 25 | ; in case the owner of the quiesced cell goes out of existence 26 | ; in a way the caller will not see via any kids dependency. Saw 27 | ; this one coming a long time ago: depending on cell X implies 28 | ; a dependency on the existence of instance owning X 29 | (pulse 0 :type fixnum) 30 | (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP 31 | (pulse-observed 0 :type fixnum) 32 | lazy 33 | (optimize t) 34 | debug 35 | md-info) 36 | 37 | 38 | 39 | ;_____________________ print __________________________________ 40 | 41 | #+sigh 42 | (defmethod print-object :before ((c cell) stream) 43 | (declare (ignorable stream)) 44 | #+shhh (unless (or *stop* *print-readably*) 45 | (format stream "[~a~a:" (if (c-inputp c) "i" "?") 46 | (cond 47 | ((null (c-model c)) #\0) 48 | ((eq :eternal-rest (md-state (c-model c))) #\_) 49 | ((not (c-currentp c)) #\#) 50 | (t #\space))))) 51 | 52 | (defmethod print-object ((c cell) stream) 53 | (declare (ignorable stream)) 54 | (if *stop* 55 | (format stream "<~d:~a ~a/~a = ~a>" 56 | (c-pulse c) 57 | (subseq (string (c-state c)) 0 1) 58 | (symbol-name (or (c-slot-name c) :anoncell)) 59 | (md-name (c-model c)) 60 | (type-of (c-value c))) 61 | (let ((*print-circle* t)) 62 | #+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c)) 63 | (if *print-readably* 64 | (call-next-method) 65 | (progn 66 | (c-print-value c stream) 67 | (format stream "<~a ~d:~a ~a/~a = ~a>" 68 | (type-of c) 69 | (c-pulse c) 70 | (subseq (string (c-state c)) 0 1) 71 | (symbol-name (or (c-slot-name c) :anoncell)) 72 | (print-cell-model (c-model c)) 73 | (if (consp (c-value c)) 74 | "LST" (c-value c)))))))) 75 | 76 | (export! print-cell-model) 77 | 78 | (defgeneric print-cell-model (md) 79 | (:method (other) (print-object other nil))) 80 | 81 | (defmethod trcp :around ((c cell)) 82 | (and ;*c-debug* 83 | (or (c-debug c) 84 | (call-next-method)))) 85 | 86 | (defun c-callers (c) 87 | "Make it easier to change implementation" 88 | (fifo-data (c-caller-store c))) 89 | 90 | (defun caller-ensure (used new-caller) 91 | (unless (find new-caller (c-callers used)) 92 | (trc nil "caller-ensure fifo-adding new-caller" new-caller :used used) 93 | (fifo-add (c-caller-store used) new-caller))) 94 | 95 | (defun caller-drop (used caller) 96 | (fifo-delete (c-caller-store used) caller)) 97 | 98 | ; --- ephemerality -------------------------------------------------- 99 | ; 100 | ; Not a type, but an option to the :cell parameter of defmodel 101 | ; 102 | (defun ephemeral-p (c) 103 | (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c)))) 104 | 105 | (defun ephemeral-reset (c) 106 | (when (ephemeral-p c) ;; so caller does not need to worry about this 107 | ; 108 | ; as of Cells3 we defer resetting ephemerals because everything 109 | ; else gets deferred and we cannot /really/ reset it until 110 | ; within finish_business we are sure all callers have been recalculated 111 | ; and all outputs completed. 112 | ; 113 | ; ;; good q: what does (setf 'x) return? historically nil, but...? 114 | ; 115 | ;;(trcx bingo-ephem c) 116 | (with-integrity (:ephemeral-reset c) 117 | (trc nil "!!!!!!!!!!!!!! ephemeral-reset resetting:" c) 118 | (md-slot-value-store (c-model c) (c-slot-name c) nil) 119 | (setf (c-value c) nil)))) 120 | 121 | ; ----------------------------------------------------- 122 | 123 | (defun c-validate (self c) 124 | (when (not (and (c-slot-name c) (c-model c))) 125 | (format t "~&unadopted cell: ~s md:~s" c self) 126 | (c-break "unadopted cell ~a ~a" self c) 127 | (error 'c-unadopted :cell c))) 128 | 129 | (defstruct (c-ruled 130 | (:include cell) 131 | (:conc-name cr-)) 132 | (code nil :type list) ;; /// feature this out on production build 133 | rule) 134 | 135 | (defun c-optimized-away-p (c) 136 | (eq :optimized-away (c-state c))) 137 | 138 | ;---------------------------- 139 | 140 | (defmethod trcp-slot (self slot-name) 141 | (declare (ignore self slot-name))) 142 | 143 | (defstruct (c-dependent 144 | (:include c-ruled) 145 | (:conc-name cd-)) 146 | ;; chop (synapses nil :type list) 147 | (useds nil :type list) 148 | (usage (blank-usage-mask))) 149 | 150 | (defun blank-usage-mask () 151 | (make-array 64 :element-type 'bit 152 | :initial-element 0)) 153 | 154 | #+xxxx 155 | (cd-usage nil) 156 | #+xxx 157 | (test-xxx) 158 | (defun test-xxx () 159 | (let ((u (blank-usage-mask))) 160 | (setf (sbit u 25) 1))) 161 | 162 | (defstruct (c-drifter 163 | (:include c-dependent))) 164 | 165 | (defstruct (c-drifter-absolute 166 | (:include c-drifter))) 167 | 168 | ;_____________________ accessors __________________________________ 169 | 170 | (defmethod c-useds (other) (declare (ignore other))) 171 | (defmethod c-useds ((c c-dependent)) (cd-useds c)) 172 | 173 | (defun c-validp (c) 174 | (eql (c-value-state c) :valid)) 175 | 176 | (defun c-unboundp (c) 177 | (eql :unbound (c-value-state c))) 178 | 179 | 180 | ;__________________ 181 | 182 | (defmethod c-print-value ((c c-ruled) stream) 183 | (format stream "~a" (cond ((c-validp c) (cons (c-value c) "")) 184 | ((c-unboundp c) "") 185 | ((not (c-currentp c)) "dirty") 186 | (t "")))) 187 | 188 | (defmethod c-print-value (c stream) 189 | (declare (ignore c stream))) 190 | 191 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/constructors.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (eval-now! 13 | (export '(.cache-bound-p 14 | 15 | ;; Cells Constructors 16 | c?n 17 | c?once 18 | c?n-until 19 | c?1 20 | c_1 21 | c?+n 22 | 23 | ;; Debug Macros and Functions 24 | c?dbg 25 | c_?dbg 26 | c-input-dbg 27 | 28 | ))) 29 | 30 | ;___________________ constructors _______________________________ 31 | 32 | (defmacro c-lambda (&body body) 33 | `(c-lambda-var (slot-c) ,@body)) 34 | 35 | (defmacro c-lambda-var ((c) &body body) 36 | `(lambda (,c &aux (self (c-model ,c)) 37 | (.cache (c-value ,c)) 38 | (.cache-bound-p (cache-bound-p ,c))) 39 | (declare (ignorable .cache .cache-bound-p self)) 40 | ,@body)) 41 | 42 | (defmacro with-c-cache ((fn) &body body) 43 | (let ((new (gensym))) 44 | `(or (bwhen (,new (progn ,@body)) 45 | (funcall ,fn ,new .cache)) 46 | .cache))) 47 | 48 | ;----------------------------------------- 49 | 50 | (defmacro c? (&body body) 51 | `(make-c-dependent 52 | :code #+live nil #-live ',body 53 | :value-state :unevaluated 54 | :rule (c-lambda ,@body))) 55 | 56 | (defmacro c?+n (&body body) 57 | `(make-c-dependent 58 | :inputp t 59 | :code #+live nil #-live ',body 60 | :value-state :unevaluated 61 | :rule (c-lambda ,@body))) 62 | 63 | (defmacro c?n (&body body) 64 | `(make-c-dependent 65 | :code '(without-c-dependency ,@body) 66 | :inputp t 67 | :value-state :unevaluated 68 | :rule (c-lambda (without-c-dependency ,@body)))) 69 | 70 | (defmacro c_?n (&body body) 71 | `(make-c-dependent 72 | :code '(without-c-dependency ,@body) 73 | :inputp t 74 | :lazy :until-asked 75 | :value-state :unevaluated 76 | :rule (c-lambda (without-c-dependency ,@body)))) 77 | 78 | (export! c?n-dbg c_?n) 79 | 80 | (defmacro c?n-dbg (&body body) 81 | `(make-c-dependent 82 | :code '(without-c-dependency ,@body) 83 | :inputp t 84 | :debug t 85 | :value-state :unevaluated 86 | :rule (c-lambda (without-c-dependency ,@body)))) 87 | 88 | (defmacro c?n-until (args &body body) 89 | `(make-c-dependent 90 | :optimize :when-value-t 91 | :code #+live nil #-live ',body 92 | :inputp t 93 | :value-state :unevaluated 94 | :rule (c-lambda ,@body) 95 | ,@args)) 96 | 97 | (defmacro c?once (&body body) 98 | `(make-c-dependent 99 | :code '(without-c-dependency ,@body) 100 | :inputp nil 101 | :value-state :unevaluated 102 | :rule (c-lambda (without-c-dependency ,@body)))) 103 | 104 | (defmacro c_1 (&body body) 105 | `(make-c-dependent 106 | :code '(without-c-dependency ,@body) 107 | :inputp nil 108 | :lazy t 109 | :value-state :unevaluated 110 | :rule (c-lambda (without-c-dependency ,@body)))) 111 | 112 | (defmacro c?1 (&body body) 113 | `(c?once ,@body)) 114 | 115 | (defmacro c?dbg (&body body) 116 | `(make-c-dependent 117 | :code #+live nil #-live ',body 118 | :value-state :unevaluated 119 | :debug t 120 | :rule (c-lambda ,@body))) 121 | 122 | (defmacro c?_ (&body body) 123 | `(make-c-dependent 124 | :code #+live nil #-live ',body 125 | :value-state :unevaluated 126 | :lazy t 127 | :rule (c-lambda ,@body))) 128 | 129 | (defmacro c_? (&body body) 130 | "Lazy until asked, then eagerly propagating" 131 | `(make-c-dependent 132 | :code #+live nil #-live ',body 133 | :value-state :unevaluated 134 | :lazy :until-asked 135 | :rule (c-lambda ,@body))) 136 | 137 | (defmacro c_?dbg (&body body) 138 | "Lazy until asked, then eagerly propagating" 139 | `(make-c-dependent 140 | :code #+live nil #-live ',body 141 | :value-state :unevaluated 142 | :lazy :until-asked 143 | :rule (c-lambda ,@body) 144 | :debug t)) 145 | 146 | (defmacro c?? ((&key (tagp nil) (in nil) (out t))&body body) 147 | (let ((result (copy-symbol 'result)) 148 | (thetag (gensym))) 149 | `(make-c-dependent 150 | :code #+live nil #-live ',body 151 | :value-state :unevaluated 152 | :rule (c-lambda 153 | (let ((,thetag (gensym "tag")) 154 | (*trcdepth* (1+ *trcdepth*)) 155 | ) 156 | (declare (ignorable self ,thetag)) 157 | ,(when in 158 | `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag))) 159 | (count-it :c?? (c-slot-name c) (md-name (c-model c))) 160 | (let ((,result (progn ,@body))) 161 | ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag))) 162 | ,result)))))) 163 | 164 | (defmacro c-formula ((&rest keys &key lazy &allow-other-keys) &body forms) 165 | (assert (member lazy '(nil t :once-asked :until-asked :always))) 166 | `(make-c-dependent 167 | :code ',forms 168 | :value-state :unevaluated 169 | :rule (c-lambda ,@forms) 170 | ,@keys)) 171 | 172 | (defmacro c-input ((&rest keys) &optional (value nil valued-p)) 173 | `(make-cell 174 | :inputp t 175 | :value-state ,(if valued-p :valid :unbound) 176 | :value ,value 177 | ,@keys)) 178 | 179 | (defmacro c-in (value) 180 | `(make-cell 181 | :inputp t 182 | :value-state :valid 183 | :value ,value)) 184 | 185 | (export! c-in-lazy c_in) 186 | 187 | (defmacro c-in-lazy (&body body) 188 | `(c-input (:lazy :once-asked) (progn ,@body))) 189 | 190 | (defmacro c_in (&body body) 191 | `(c-input (:lazy :once-asked) (progn ,@body))) 192 | 193 | (defmacro c-input-dbg (&optional (value nil valued-p)) 194 | `(make-cell 195 | :inputp t 196 | :debug t 197 | :value-state ,(if valued-p :valid :unbound) 198 | :value ,value)) 199 | 200 | (defmacro c... ((value) &body body) 201 | `(make-c-drifter 202 | :code #+live nil #-live ',body 203 | :value-state :valid 204 | :value ,value 205 | :rule (c-lambda ,@body))) 206 | 207 | (defmacro c-abs (value &body body) 208 | `(make-c-drifter-absolute 209 | :code #+live nil #-live ',body 210 | :value-state :valid 211 | :value ,value 212 | :rule (c-lambda ,@body))) 213 | 214 | 215 | (defmacro c-envalue (&body body) 216 | `(make-c-envaluer 217 | :envalue-rule (c-lambda ,@body))) 218 | 219 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/defpackage.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | ;;; 3 | ;;; Copyright (c) 1995,2010 by Kenneth William Tilton. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;;; of this software and associated documentation files (the "Software"), to deal 7 | ;;; in the Software without restriction, including without limitation the rights 8 | ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;;; copies of the Software, and to permit persons to whom the Software is furnished 10 | ;;; to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 21 | ;;; IN THE SOFTWARE. 22 | 23 | (in-package :common-lisp-user) 24 | 25 | (eval-when (:compile-toplevel :load-toplevel :execute) 26 | (require :safeseq)) 27 | 28 | (defpackage :cells 29 | (:use #:common-lisp #:utils-kt) 30 | (:nicknames :cz) 31 | (:import-from 32 | ;; MOP 33 | #+allegro #:excl 34 | #+clisp #:clos 35 | #+cmu #:mop 36 | #+cormanlisp #:common-lisp 37 | #+lispworks #:clos 38 | #+sbcl #:sb-mop 39 | #+openmcl-partial-mop #:openmcl-mop 40 | #+(and mcl (not openmcl-partial-mop)) #:ccl 41 | 42 | #-(or allegro clisp cmu cormanlisp lispworks mcl sbcl) 43 | #.(cerror "Provide a package name." 44 | "Don't know how to find the MOP package for this Lisp.") 45 | 46 | #:class-precedence-list 47 | #-(and mcl (not openmcl-partial-mop)) #:class-slots 48 | #:slot-definition-name 49 | #:class-direct-subclasses 50 | ) 51 | (:export #:cell #:.md-name 52 | #:c-input #:c-in #:c-in8 53 | #:c-formula #:c? #:c_? #:c?8 #:c?_ #:c?? 54 | #:with-integrity #:without-c-dependency #:self #:*parent* 55 | #:.cache #:.with-c-cache #:c-lambda 56 | #:defmodel #:defmd #:defobserver #:slot-value-observe #:def-c-unchanged-test 57 | #:new-value #:old-value #:old-value-boundp #:c... 58 | #:md-awaken 59 | #:mkpart #:make-kid #:the-kids #:nsib #:value #:^value #:.value #:kids #:^kids #:.kids 60 | #:cells-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot 61 | #:def-kid-slots #:find-prior #:fm-pos #:kid-no #:fm-includes #:fm-ascendant-common 62 | #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib 63 | #:not-to-be #:ssibno 64 | #:c-debug #:c-break #:c-assert #:c-stop #:c-stopped #:c-assert #:.stop #:delta-diff 65 | #:wtrc #:wnotrc #:eko-if #:trc #:wtrc #:eko #:ekx #:trcp #:trcx) 66 | #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) 67 | ) 68 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/family-values.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (eval-when (:compile-toplevel :load-toplevel :execute) 13 | (export '(family-values family-values-sorted 14 | sort-index sort-direction sort-predicate sort-key 15 | ^sort-index ^sort-direction ^sort-predicate ^sort-key))) 16 | 17 | (defmodel family-values (family) 18 | ( 19 | (kv-collector :initarg :kv-collector 20 | :initform #'identity 21 | :reader kv-collector) 22 | 23 | (kid-values :initform (c? (when (kv-collector self) 24 | (funcall (kv-collector self) (^value)))) 25 | :accessor kid-values 26 | :initarg :kid-values) 27 | 28 | (kv-key :initform #'identity 29 | :initarg :kv-key 30 | :reader kv-key) 31 | 32 | (kv-key-test :initform #'equal 33 | :initarg :kv-key-test 34 | :reader kv-key-test) 35 | 36 | (kid-factory :initform #'identity 37 | :initarg :kid-factory 38 | :reader kid-factory) 39 | 40 | (.kids :initform (c? (c-assert (listp (kid-values self))) 41 | (let ((new-kids (mapcan (lambda (kid-value) 42 | (list (or (find kid-value .cache 43 | :key (kv-key self) 44 | :test (kv-key-test self)) 45 | (trc nil "family-values forced to make new kid" 46 | self .cache kid-value) 47 | (funcall (kid-factory self) self kid-value)))) 48 | (^kid-values)))) 49 | (nconc (mapcan (lambda (old-kid) 50 | (unless (find old-kid new-kids) 51 | (when (fv-kid-keep self old-kid) 52 | (list old-kid)))) 53 | .cache) 54 | new-kids))) 55 | :accessor kids 56 | :initarg :kids))) 57 | 58 | (defmethod fv-kid-keep (family old-kid) 59 | (declare (ignorable family old-kid)) 60 | nil) 61 | 62 | (defmodel family-values-sorted (family-values) 63 | ((sorted-kids :initarg :sorted-kids :accessor sorted-kids 64 | :initform nil) 65 | (sort-map :initform (c-in nil) :initarg :sort-map :accessor sort-map) 66 | (.kids :initform (c? (c-assert (listp (kid-values self))) 67 | (mapsort (^sort-map) 68 | (the-kids 69 | (mapcar (lambda (kid-value) 70 | (trc "making kid" kid-value) 71 | (or (find kid-value .cache :key (kv-key self) :test (kv-key-test self)) 72 | (trc nil "family-values forced to make new kid" self .cache kid-value) 73 | (funcall (kid-factory self) self kid-value))) 74 | (^kid-values))))) 75 | :accessor kids 76 | :initarg :kids))) 77 | 78 | (defun mapsort (map data) 79 | ;;(trc "mapsort map" map) 80 | (if map 81 | (stable-sort data #'< :key (lambda (datum) (or (position datum map) 82 | ;(trc "mapsort datum not in map" datum) 83 | (1+ (length data))))) 84 | data)) 85 | 86 | (defobserver sorted-kids () 87 | (setf (sort-map self) new-value)) ;; cellular trick to avoid cyclicity -------------------------------------------------------------------------------- /src/tiltontec/lisp/initialize.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | Copyright (C) 1995, 2006 by Kenneth Tilton 7 | 8 | 9 | 10 | |# 11 | 12 | (in-package :cells) 13 | 14 | (eval-when (compile eval load) 15 | (export '(c-envalue))) 16 | 17 | (defstruct (c-envaluer (:conc-name nil)) 18 | envalue-rule) 19 | 20 | (defmethod awaken-cell (c) 21 | (declare (ignorable c))) 22 | 23 | (defmethod awaken-cell ((c cell)) 24 | (assert (c-inputp c)) 25 | ; 26 | ; nothing to calculate, but every cellular slot should be output 27 | ; 28 | (when (> *data-pulse-id* (c-pulse-observed c)) 29 | ;(trc nil "awaken-pulsing" :*dpid* *data-pulse-id* :cdpid (c-pulse-observed c) c) 30 | (setf (c-pulse-observed c) *data-pulse-id*) 31 | (trc nil "awaken cell observing" c *data-pulse-id*) 32 | (let ((*observe-why* :awaken-cell)) 33 | (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil c)) 34 | (ephemeral-reset c))) 35 | 36 | (defmethod awaken-cell ((c c-ruled)) 37 | (let (*depender*) 38 | (calculate-and-set c :fn-awaken-cell nil))) 39 | 40 | #+cormanlisp ; satisfy CormanCL bug 41 | (defmethod awaken-cell ((c c-dependent)) 42 | (let (*depender*) 43 | (trc nil "awaken-cell c-dependent clearing *depender*" c) 44 | (calculate-and-set c :fn-awaken-cell nil))) 45 | 46 | (defmethod awaken-cell ((c c-drifter)) 47 | ; 48 | ; drifters *begin* valid, so the derived version's test for unbounditude 49 | ; would keep (drift) rule ever from being evaluated. correct solution 50 | ; (for another day) is to separate awakening (ie, linking to independent 51 | ; cs) from evaluation, tho also evaluating if necessary during 52 | ; awakening, because awakening's other role is to get an instance up to speed 53 | ; at once upon instantiation 54 | ; 55 | (calculate-and-set c :fn-awaken-cell nil) 56 | (cond ((c-validp c) (c-value c)) 57 | ((c-unboundp c) nil) 58 | (t "illegal state!!!"))) 59 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/link.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | Copyright (C) 1995, 2006 by Kenneth Tilton 7 | 8 | 9 | 10 | |# 11 | 12 | (in-package :cells) 13 | 14 | (defun record-caller (used) 15 | (assert used) 16 | (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell 17 | (trc nil "depender not being recorded because used optimized away" *depender* (c-value used) :used used) 18 | (return-from record-caller nil)) 19 | #+shhh (trc *depender* "record-caller depender entry: used=" used :caller *depender*) 20 | (assert *depender*) 21 | #+shhh (trc used "record-caller caller entry: used=" (qci used) 22 | :caller *depender*) 23 | 24 | (multiple-value-bind (used-pos useds-len) 25 | (loop with u-pos 26 | for known in (cd-useds *depender*) 27 | counting known into length 28 | when (eq used known) 29 | do 30 | (count-it :known-used) 31 | (setf u-pos length) 32 | finally (return (values (when u-pos (- length u-pos)) length))) 33 | 34 | (when (null used-pos) 35 | (trc nil "c-link > new caller,used " *depender* used) 36 | (count-it :new-used) 37 | (setf used-pos useds-len) 38 | (push used (cd-useds *depender*)) 39 | (caller-ensure used *depender*) ;; 060604 experiment was in unlink 40 | ) 41 | 42 | (when (c-debug *depender*) 43 | (trx rec-caller-sets-usage!!!!!!!!!!!!!!!!!!!! *depender* used used-pos)) 44 | (set-usage-bit *depender* used-pos) 45 | ) 46 | used) 47 | 48 | (defun set-usage-bit (c n) ;; c is caller 49 | ;(trc c "set-usage-bit entry!!!!" c n (array-dimension (cd-usage c) 0)) 50 | #+xxxx(when (> n 32) 51 | (loop for u in (cd-useds c) 52 | do (trc "sub-used" u)) 53 | (trc "set-usage-bit entry > 10!!!!" c n (array-dimension (cd-usage c) 0))) 54 | (unless (< n (array-dimension (cd-usage c) 0)) 55 | ;(trc c "set-usage-bit growing!!!!!" c n (+ n 16)) 56 | (setf (cd-usage c)(adjust-array (cd-usage c) (+ n 16) :initial-element 0))) 57 | (setf (sbit (cd-usage c) n) 1)) 58 | 59 | ;--- unlink unused -------------------------------- 60 | 61 | (defun c-unlink-unused (c &aux (usage (cd-usage c)) 62 | (usage-size (array-dimension (cd-usage c) 0)) 63 | (dbg nil)) 64 | (declare (ignorable dbg usage-size)) 65 | (when (cd-useds c) 66 | (let (rev-pos) 67 | (labels ((nail-unused (useds) 68 | (flet ((handle-used (rpos) 69 | (if (or (>= rpos usage-size) 70 | (zerop (sbit usage rpos))) 71 | (progn 72 | (count-it :unlink-unused) 73 | (trc nil "c-unlink-unused" c :dropping-used (car useds)) 74 | (c-unlink-caller (car useds) c) 75 | (rplaca useds nil)) 76 | (progn 77 | ;; moved into record-caller 060604 (caller-ensure (car useds) c) 78 | ) 79 | ))) 80 | (if (cdr useds) 81 | (progn 82 | (nail-unused (cdr useds)) 83 | (handle-used (incf rev-pos))) 84 | (handle-used (setf rev-pos 0)))))) 85 | (trc nil "cd-useds length" (length (cd-useds c)) c) 86 | 87 | (nail-unused (cd-useds c)) 88 | (setf (cd-useds c) (delete nil (cd-useds c))) 89 | (trc nil "useds of" c :now (mapcar 'qci (cd-useds c))))))) 90 | 91 | (defun c-caller-path-exists-p (from-used to-caller) 92 | (count-it :caller-path-exists-p) 93 | (or (find to-caller (c-callers from-used)) 94 | (find-if (lambda (from-used-caller) 95 | (c-caller-path-exists-p from-used-caller to-caller)) 96 | (c-callers from-used)))) 97 | 98 | ; --------------------------------------------- 99 | 100 | (defun cd-usage-clear-all (c) 101 | (setf (cd-usage c) (blank-usage-mask))) 102 | 103 | 104 | ;--- unlink from used ---------------------- 105 | 106 | (defmethod c-unlink-from-used ((caller c-dependent)) 107 | (dolist (used (cd-useds caller)) 108 | (trc nil "unlinking from used" caller used) 109 | (c-unlink-caller used caller)) 110 | ;; shouldn't be necessary (setf (cd-useds caller) nil) 111 | ) 112 | 113 | (defmethod c-unlink-from-used (other) 114 | (declare (ignore other))) 115 | 116 | ;---------------------------------------------------------- 117 | 118 | (defun c-unlink-caller (used caller) 119 | (trc nil "(1) caller unlinking from (2) used" caller used) 120 | (caller-drop used caller) 121 | (c-unlink-used caller used)) 122 | 123 | (defun c-unlink-used (caller used) 124 | (setf (cd-useds caller) (delete used (cd-useds caller)))) 125 | 126 | ;----------------- link debugging --------------------- 127 | 128 | (defun dump-callers (c &optional (depth 0)) 129 | (format t "~&~v,4t~s" depth c) 130 | (dolist (caller (c-callers c)) 131 | (dump-callers caller (+ 1 depth)))) 132 | 133 | (defun dump-useds (c &optional (depth 0)) 134 | ;(c.trc "dump-useds> entry " c (+ 1 depth)) 135 | (when (zerop depth) 136 | (format t "x~&")) 137 | (format t "~&|usd> ~v,8t~s" depth c) 138 | (when (typep c 'c-ruled) 139 | ;(c.trc "its ruled" c) 140 | (dolist (used (cd-useds c)) 141 | (dump-useds used (+ 1 depth))))) 142 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/slot-utilities.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (defun c-setting-debug (self slot-name c new-value) 13 | (declare (ignorable new-value)) 14 | (cond 15 | ((null c) 16 | (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (c-in nil)" 17 | slot-name self) 18 | 19 | (c-break "setting-const-cell") 20 | (error "setting-const-cell")) 21 | ((c-inputp c)) 22 | (t 23 | (let ((self (c-model c)) 24 | (slot-name (c-slot-name c))) 25 | ;(trc "c-setting-debug sees" c newvalue self slot-name) 26 | (when (and c (not (and slot-name self))) 27 | ;; cv-test handles errors, so don't set *stop* (c-stop) 28 | (c-break "unadopted ~a for self ~a spec ~a" c self slot-name) 29 | (error 'c-unadopted :cell c)) 30 | #+whocares (typecase c 31 | (c-dependent 32 | ;(trc "setting c-dependent" c newvalue) 33 | (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed" 34 | (c-slot-name c) self) 35 | 36 | (c-break "setting-ruled-cell") 37 | (error "setting-ruled-cell")) 38 | ))))) 39 | 40 | (defun c-absorb-value (c value) 41 | (typecase c 42 | (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true 43 | (c-drifter (c-value-incf c (c-value c) value)) 44 | (t value))) 45 | 46 | (eval-when (:compile-toplevel :load-toplevel :execute) 47 | (export '(c-value-incf))) 48 | 49 | (defmethod c-value-incf (c (envaluer c-envaluer) delta) 50 | (c-assert (c-model c)) 51 | (c-value-incf c (funcall (envalue-rule envaluer) c) 52 | delta)) 53 | 54 | (defmethod c-value-incf (c (base number) delta) 55 | (declare (ignore c)) 56 | (if delta 57 | (+ base delta) 58 | base)) 59 | 60 | 61 | ;---------------------------------------------------------------------- 62 | 63 | (defun bd-slot-value (self slot-name) 64 | (slot-value self slot-name)) 65 | 66 | (defun (setf bd-slot-value) (new-value self slot-name) 67 | (setf (slot-value self slot-name) new-value)) 68 | 69 | (defun bd-bound-slot-value (self slot-name caller-id) 70 | (declare (ignorable caller-id)) 71 | (when (bd-slot-boundp self slot-name) 72 | (bd-slot-value self slot-name))) 73 | 74 | (defun bd-slot-boundp (self slot-name) 75 | (slot-boundp self slot-name)) 76 | 77 | (defun bd-slot-makunbound (self slot-name) 78 | (if slot-name ;; not in def-c-variable 79 | (slot-makunbound self slot-name) 80 | (makunbound self))) 81 | 82 | #| sample incf 83 | (defmethod c-value-incf ((base fpoint) delta) 84 | (declare (ignore model)) 85 | (if delta 86 | (fp-add base delta) 87 | base)) 88 | |# 89 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/synapse-types.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (export! f-find) 13 | 14 | (defmacro f-find (synapse-id sought where) 15 | `(call-f-find ,synapse-id ,sought ,where)) 16 | 17 | (defun call-f-find (synapse-id sought where) 18 | (with-synapse synapse-id () 19 | (bif (k (progn 20 | (find sought where))) 21 | (values k :propagate) 22 | (values nil :no-propagate)))) 23 | 24 | (defmacro f-sensitivity (synapse-id (sensitivity &optional subtypename) &body body) 25 | `(call-f-sensitivity ,synapse-id ,sensitivity ,subtypename (lambda () ,@body))) 26 | 27 | (defun call-f-sensitivity (synapse-id sensitivity subtypename body-fn) 28 | (with-synapse synapse-id (prior-fire-value) 29 | (let ((new-value (funcall body-fn))) 30 | ;(trc "f-sensitivity fire-p decides new" new-value :from-prior prior-fire-value :sensi sensitivity) 31 | (let ((prop-code (if (or (xor prior-fire-value new-value) 32 | (eko (nil "sens fire-p decides" new-value prior-fire-value sensitivity) 33 | (delta-greater-or-equal 34 | (delta-abs (delta-diff new-value prior-fire-value subtypename) 35 | subtypename) 36 | (delta-abs sensitivity subtypename) 37 | subtypename))) 38 | :propagate 39 | :no-propagate))) 40 | (values (if (eq prop-code :propagate) 41 | (progn 42 | (trc nil "sense prior fire value now" new-value) 43 | (setf prior-fire-value new-value)) 44 | new-value) prop-code))))) 45 | 46 | (defmacro f-delta (synapse-id (&key sensitivity (type 'number)) &body body) 47 | `(call-f-delta ,synapse-id ,sensitivity ',type (lambda () ,@body))) 48 | 49 | (defun call-f-delta (synapse-id sensitivity type body-fn) 50 | (with-synapse synapse-id (last-relay-basis last-bound-p delta-cum) 51 | (let* ((new-basis (funcall body-fn)) 52 | (threshold sensitivity) 53 | (tdelta (delta-diff new-basis 54 | (if last-bound-p 55 | last-relay-basis 56 | (delta-identity new-basis type)) 57 | type))) 58 | (trc nil "tdelta, threshhold" tdelta threshold) 59 | (setf delta-cum tdelta) 60 | (let ((propagation-code 61 | (when threshold 62 | (if (delta-exceeds tdelta threshold type) 63 | (progn 64 | (setf last-bound-p t) 65 | (setf last-relay-basis new-basis) 66 | :propagate) 67 | :no-propagate)))) 68 | (trc nil "f-delta returns values" delta-cum propagation-code) 69 | (values delta-cum propagation-code))))) 70 | 71 | (defmacro f-plusp (key &rest body) 72 | `(with-synapse ,key (prior-fire-value) 73 | (let ((new-basis (progn ,@body))) 74 | (values new-basis (if (xor prior-fire-value (plusp new-basis)) 75 | (progn 76 | (setf prior-fire-value (plusp new-basis)) 77 | :propagate) 78 | :no-propagate))))) 79 | 80 | (defmacro f-zerop (key &rest body) 81 | `(with-synapse ,key (prior-fire-value) 82 | (let ((new-basis (progn ,@body))) 83 | (values new-basis (if (xor prior-fire-value (zerop new-basis)) 84 | (progn 85 | (setf prior-fire-value (zerop new-basis)) 86 | :propagate) 87 | :no-propagate))))) 88 | 89 | 90 | 91 | ;;;(defun f-delta-list (&key (test #'true)) 92 | ;;; (with-synapse (prior-list) 93 | ;;; :fire-p (lambda (syn new-list) 94 | ;;; (declare (ignorable syn)) 95 | ;;; (or (find-if (lambda (new) 96 | ;;; ;--- gaining one? ---- 97 | ;;; (and (not (member new prior-list)) 98 | ;;; (funcall test new))) 99 | ;;; new-list) 100 | ;;; (find-if (lambda (old) 101 | ;;; ;--- losing one? ---- 102 | ;;; (not (member old new-list))) ;; all olds have passed test, so skip test here 103 | ;;; prior-list))) 104 | ;;; 105 | ;;; :fire-value (lambda (syn new-list) 106 | ;;; (declare (ignorable syn)) 107 | ;;; ;/// excess consing on long lists 108 | ;;; (setf prior-list (remove-if-not test new-list))))) 109 | 110 | ;;;(defun f-find-once (finder-fn) 111 | ;;; (mk-synapse (bingo bingobound) 112 | ;;; 113 | ;;; :fire-p (lambda (syn new-list) 114 | ;;; (declare (ignorable syn)) 115 | ;;; (unless bingo ;; once found, yer done 116 | ;;; (setf bingobound t 117 | ;;; bingo (find-if finder-fn new-list)))) 118 | ;;; 119 | ;;; :fire-value (lambda (syn new-list) 120 | ;;; (declare (ignorable syn)) 121 | ;;; (or bingo 122 | ;;; (and (not bingobound) ;; don't bother if fire? already looked 123 | ;;; (find-if finder-fn new-list)))))) 124 | 125 | ;;;(defun fdifferent () 126 | ;;; (mk-synapse (prior-object) 127 | ;;; :fire-p (lambda (syn new-object) 128 | ;;; (declare (ignorable syn)) 129 | ;;; (trc nil "fDiff: prior,new" (not (eql new-object prior-object)) 130 | ;;; prior-object new-object) 131 | ;;; (not (eql new-object prior-object))) 132 | ;;; 133 | ;;; :fire-value (lambda (syn new-object) 134 | ;;; (declare (ignorable syn)) 135 | ;;; (unless (eql new-object prior-object) 136 | ;;; (setf prior-object new-object))) 137 | ;;; )) 138 | 139 | 140 | ;;;(defun f-boolean (&optional (sensitivity 't)) 141 | ;;; (f-delta :sensitivity sensitivity :type 'boolean)) 142 | 143 | 144 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/synapse.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | 7 | 8 | |# 9 | 10 | (in-package :cells) 11 | 12 | (eval-when (:compile-toplevel :load-toplevel :execute) 13 | (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent with-synapse))) 14 | 15 | (defmacro with-synapse (synapse-id (&rest closure-vars) &body body) 16 | (let ((syn-id (gensym))) 17 | `(let* ((,syn-id ,synapse-id) 18 | (synapse (or (find ,syn-id (cd-useds *depender*) :key 'c-slot-name) 19 | (let ((new-syn 20 | (let (,@closure-vars) 21 | (make-c-dependent 22 | :model (c-model *depender*) 23 | :slot-name ,syn-id 24 | :code #+live nil #-live ',body 25 | :synaptic t 26 | :rule (c-lambda ,@body))))) 27 | (record-caller new-syn) 28 | new-syn)))) 29 | (prog1 30 | (multiple-value-bind (v p) 31 | (with-integrity () 32 | (ensure-value-is-current synapse :synapse *depender*)) 33 | (values v p)) 34 | (record-caller synapse))))) 35 | 36 | 37 | ;__________________________________________________________________________________ 38 | ; 39 | 40 | (defmethod delta-exceeds (bool-delta sensitivity (subtypename (eql 'boolean))) 41 | (unless (eql bool-delta :unchanged) 42 | (or (eq sensitivity t) 43 | (eq sensitivity bool-delta)))) 44 | 45 | (defmethod delta-diff ((new number) (old number) subtypename) 46 | (declare (ignore subtypename)) 47 | (- new old)) 48 | 49 | (defmethod delta-identity ((dispatcher number) subtypename) 50 | (declare (ignore subtypename)) 51 | 0) 52 | 53 | (defmethod delta-abs ((n number) subtypename) 54 | (declare (ignore subtypename)) 55 | (abs n)) 56 | 57 | (defmethod delta-exceeds ((d1 number) (d2 number) subtypename) 58 | (declare (ignore subtypename)) 59 | (> d1 d2)) 60 | 61 | (defmethod delta-greater-or-equal ((d1 number) (d2 number) subtypename) 62 | (declare (ignore subtypename)) 63 | (>= d1 d2)) 64 | 65 | ;_________________________________________________________________________________ 66 | ; 67 | (defmethod delta-diff (new old (subtypename (eql 'boolean))) 68 | (if new 69 | (if old 70 | :unchanged 71 | :on) 72 | (if old 73 | :off 74 | :unchanged))) 75 | 76 | 77 | (defmethod delta-identity (dispatcher (subtypename (eql 'boolean))) 78 | (declare (ignore dispatcher)) 79 | :unchanged) 80 | 81 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/test-cc.lisp: -------------------------------------------------------------------------------- 1 | ;; 2 | 3 | (in-package :cells) 4 | 5 | (defmd tcc () 6 | (tccversion 1) 7 | (tcc-a (c-in nil)) 8 | (tcc-2a (c-in nil))) 9 | 10 | (defobserver tcc-a () 11 | (case (^tccversion) 12 | (1 (when new-value 13 | (with-cc :tcc-a-obs 14 | (setf (tcc-2a self) (* 2 new-value)) 15 | (with-cc :aha!2 16 | (assert (eql (tcc-2a self) (* 2 new-value)) 17 | () "one") 18 | (trc "one happy"))) 19 | (with-cc :aha! 20 | (assert (eql (tcc-2a self) (* 2 new-value)) 21 | () "two")))) 22 | (2 (when new-value 23 | (with-cc :tcc-a-obs 24 | (setf (tcc-2a self) (* 2 new-value)) 25 | (with-cc :aha!2 26 | (assert (eql (tcc-2a self) (* 2 new-value)) 27 | () "one") 28 | (trc "one happy"))))))) 29 | 30 | 31 | (defun test-with-cc () 32 | (let ((self (make-instance 'tcc 33 | :tccversion 2 ;:tcc-2a 34 | ))) 35 | (trcx cool 42) 36 | (setf (tcc-a self) 42) 37 | (assert (eql (tcc-2a self) 84)))) 38 | 39 | #+test 40 | (test-with-cc) 41 | 42 | (defmd ccproc () ccp obs drv) 43 | 44 | (defobserver ccp () 45 | (trcx obs-cpp new-value old-value) 46 | (with-cc :obs-cpp 47 | (setf (^obs) (+ (* 10 (^drv)) new-value)))) 48 | 49 | (dbgobserver obs) 50 | 51 | (defun test-ccproc () 52 | (cells-reset) 53 | (let ((x (make-instance 'ccproc 54 | :ccp (c-in 0) 55 | :obs (c-in 0) 56 | :drv (c? (+ 10 (^ccp)))))) 57 | (trcx see-0-10 100 (ccp x)(drv x)(obs x)) 58 | 59 | (setf (ccp x) 1) 60 | (trcx see-1-11-101 (ccp x)(drv x)(obs x)) 61 | 62 | (trcx now-see-1-11-101 (ccp x)(drv x)(obs x)) 63 | (setf (ccp x) 2) 64 | 65 | (trcx see-2-12-102 (ccp x)(drv x)(obs x)) 66 | (trcx see-2-12-102 (ccp x)(drv x)(obs x)))) 67 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/test-cycle.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | ;;; 3 | ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;;; of this software and associated documentation files (the "Software"), to deal 7 | ;;; in the Software without restriction, including without limitation the rights 8 | ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;;; copies of the Software, and to permit persons to whom the Software is furnished 10 | ;;; to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 21 | ;;; IN THE SOFTWARE. 22 | 23 | (in-package :cells) 24 | 25 | 26 | 27 | (defmodel m-cyc () 28 | ((m-cyc-a :initform (c-in nil) :initarg :m-cyc-a :accessor m-cyc-a) 29 | (m-cyc-b :initform (c-in nil) :initarg :m-cyc-b :accessor m-cyc-b))) 30 | 31 | (def-c-output m-cyc-a () 32 | (print `(output m-cyc-a ,self ,new-value ,old-value)) 33 | (setf (m-cyc-b self) new-value)) 34 | 35 | (def-c-output m-cyc-b () 36 | (print `(output m-cyc-b ,self ,new-value ,old-value)) 37 | (setf (m-cyc-a self) new-value)) 38 | 39 | (defun m-cyc () ;;def-cell-test m-cyc 40 | (let ((m (make-be 'm-cyc))) 41 | (print `(start ,(m-cyc-a m))) 42 | (setf (m-cyc-a m) 42) 43 | (assert (= (m-cyc-a m) 42)) 44 | (assert (= (m-cyc-b m) 42)))) 45 | 46 | #+(or) 47 | (m-cyc) 48 | 49 | (defmodel m-cyc2 () 50 | ((m-cyc2-a :initform (c-in 0) :initarg :m-cyc2-a :accessor m-cyc2-a) 51 | (m-cyc2-b :initform (c? (1+ (^m-cyc2-a))) 52 | :initarg :m-cyc2-b :accessor m-cyc2-b))) 53 | 54 | (def-c-output m-cyc2-a () 55 | (print `(output m-cyc2-a ,self ,new-value ,old-value)) 56 | #+(or) (when (< new-value 45) 57 | (setf (m-cyc2-b self) (1+ new-value)))) 58 | 59 | (def-c-output m-cyc2-b () 60 | (print `(output m-cyc2-b ,self ,new-value ,old-value)) 61 | (when (< new-value 45) 62 | (setf (m-cyc2-a self) (1+ new-value)))) 63 | 64 | (def-cell-test m-cyc2 65 | (cell-reset) 66 | (let ((m (make-be 'm-cyc2))) 67 | (print '(start)) 68 | (setf (m-cyc2-a m) 42) 69 | (describe m) 70 | (assert (= (m-cyc2-a m) 44)) 71 | (assert (= (m-cyc2-b m) 45)) 72 | )) 73 | 74 | #+(or) 75 | (m-cyc2) 76 | 77 | 78 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/test-ephemeral.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | ;;; 3 | ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;;; of this software and associated documentation files (the "Software"), to deal 7 | ;;; in the Software without restriction, including without limitation the rights 8 | ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;;; copies of the Software, and to permit persons to whom the Software is furnished 10 | ;;; to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 21 | ;;; IN THE SOFTWARE. 22 | 23 | (in-package :cells) 24 | 25 | 26 | (defmodel m-ephem () 27 | ((m-ephem-a :cell :ephemeral :initform nil :initarg :m-ephem-a :accessor m-ephem-a) 28 | (m-test-a :cell nil :initform nil :initarg :m-test-a :accessor m-test-a) 29 | (m-ephem-b :cell :ephemeral :initform nil :initarg :m-ephem-b :accessor m-ephem-b) 30 | (m-test-b :cell nil :initform nil :initarg :m-test-b :accessor m-test-b))) 31 | 32 | (def-c-output m-ephem-a () 33 | (setf (m-test-a self) new-value)) 34 | 35 | (def-c-output m-ephem-b () 36 | (setf (m-test-b self) new-value)) 37 | 38 | (def-cell-test m-ephem 39 | (let ((m (make-be 'm-ephem :m-ephem-a (c-in nil) :m-ephem-b (c? (* 2 (or (^m-ephem-a) 0)))))) 40 | (ct-assert (null (slot-value m 'm-ephem-a))) 41 | (ct-assert (null (m-ephem-a m))) 42 | (ct-assert (null (m-test-a m))) 43 | (ct-assert (null (slot-value m 'm-ephem-b))) 44 | (ct-assert (null (m-ephem-b m))) 45 | (ct-assert (zerop (m-test-b m))) 46 | (setf (m-ephem-a m) 3) 47 | (ct-assert (null (slot-value m 'm-ephem-a))) 48 | (ct-assert (null (m-ephem-a m))) 49 | (ct-assert (eql 3 (m-test-a m))) 50 | ; 51 | (ct-assert (null (slot-value m 'm-ephem-b))) 52 | (ct-assert (null (m-ephem-b m))) 53 | (ct-assert (eql 6 (m-test-b m))) 54 | )) 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/test-propagation.lisp: -------------------------------------------------------------------------------- 1 | ;; 2 | 3 | (in-package :cells) 4 | 5 | (defmd tcp () 6 | (left (c-in 0)) 7 | (top (c-in 0)) 8 | (right (c-in 0)) 9 | (bottom (c-in 0)) 10 | (area (c? (trc "area running") 11 | (* (- (^right)(^left)) 12 | (- (^top)(^bottom)))))) 13 | 14 | (defobserver area () 15 | (trc "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) 16 | 17 | (defobserver bottom () 18 | (trc "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*) 19 | (with-integrity (:change 'bottom-tells-left) 20 | (setf (^left) new-value))) 21 | 22 | (defobserver left () 23 | (trc "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*)) 24 | 25 | (defun tcprop () 26 | (untrace) 27 | (ukt:test-prep) 28 | (let ((box (make-instance 'tcp))) 29 | (trc "changing top to 10" *data-pulse-id*) 30 | (setf (top box) 10) 31 | (trc "not changing top" *data-pulse-id*) 32 | (setf (top box) 10) 33 | (trc "changing right to 10" *data-pulse-id*) 34 | (setf (right box) 10) 35 | (trc "not changing right" *data-pulse-id*) 36 | (setf (right box) 10) 37 | (trc "changing bottom to -1" *data-pulse-id*) 38 | (decf (bottom box)) 39 | (with-one-datapulse () 40 | (loop repeat 5 do 41 | (trc "changing bottom by -1" *data-pulse-id*) 42 | (decf (bottom box)))))) 43 | 44 | 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/test-synapse.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | ;;; 3 | ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;;; of this software and associated documentation files (the "Software"), to deal 7 | ;;; in the Software without restriction, including without limitation the rights 8 | ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;;; copies of the Software, and to permit persons to whom the Software is furnished 10 | ;;; to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 21 | ;;; IN THE SOFTWARE. 22 | 23 | (in-package :cells) 24 | 25 | 26 | (defmodel m-syn () 27 | ((m-syn-a :initform nil :initarg :m-syn-a :accessor m-syn-a) 28 | (m-syn-b :initform nil :initarg :m-syn-b :accessor m-syn-b) 29 | (m-syn-factor :initform nil :initarg :m-syn-factor :accessor m-syn-factor) 30 | (m-sens :initform nil :initarg :m-sens :accessor m-sens) 31 | (m-plus :initform nil :initarg :m-plus :accessor m-plus) 32 | )) 33 | 34 | (def-c-output m-syn-b () 35 | (print `(output m-syn-b ,self ,new-value ,old-value))) 36 | 37 | 38 | 39 | (def-cell-test m-syn 40 | (progn (cell-reset) 41 | (let* ((delta-ct 0) 42 | (sens-ct 0) 43 | (plus-ct 0) 44 | (m (make-be 'm-syn 45 | :m-syn-a (c-in 0) 46 | :m-syn-b (c? (incf delta-ct) 47 | (trc nil "syn-b rule firing!!!!!!!!!!!!!!" delta-ct) 48 | (eko (nil "syn-b rule returning") 49 | (f-delta :syna-1 (:sensitivity 2) 50 | (^m-syn-a)))) 51 | :m-syn-factor (c-in 1) 52 | :m-sens (c? (incf sens-ct) 53 | (trc nil "m-sens rule firing ~d !!!!!!!!!!!!!!" sens-ct) 54 | (* (^m-syn-factor) 55 | (f-sensitivity :sensa (3) (^m-syn-a)))) 56 | :m-plus (c? (incf plus-ct) 57 | (trc nil "m-plus rule firing!!!!!!!!!!!!!!" plus-ct) 58 | (f-plusp :syna-2 (- 2 (^m-syn-a))))))) 59 | (ct-assert (= 1 delta-ct)) 60 | (ct-assert (= 1 sens-ct)) 61 | (ct-assert (= 1 plus-ct)) 62 | (ct-assert (= 0 (m-sens m))) 63 | (trc "make-be complete. about to incf m-syn-a") 64 | (incf (m-syn-a m)) 65 | (ct-assert (= 1 delta-ct)) 66 | (ct-assert (= 1 sens-ct)) 67 | (ct-assert (= 1 plus-ct)) 68 | (ct-assert (= 0 (m-sens m))) 69 | (trc "about to incf m-syn-a 2") 70 | (incf (m-syn-a m) 2) 71 | (trc nil "syn-b now" (m-syn-b m)) 72 | (ct-assert (= 2 delta-ct)) 73 | (ct-assert (= 2 sens-ct)) 74 | (ct-assert (= 2 plus-ct)) 75 | 76 | (ct-assert (= 3 (m-sens m))) 77 | (trc "about to incf m-syn-a") 78 | (incf (m-syn-a m)) 79 | (ct-assert (= 2 delta-ct)) 80 | (ct-assert (= 2 sens-ct)) 81 | (trc "about to incf m-syn-factor") 82 | (incf (m-syn-factor m)) 83 | (ct-assert (= 3 sens-ct)) 84 | (ct-assert (= (m-sens m) (* (m-syn-factor m) (m-syn-a m)))) 85 | (trc "about to incf m-syn-a xxx") 86 | (incf (m-syn-a m)) 87 | (ct-assert (= 2 delta-ct)) 88 | (ct-assert (= 3 sens-ct)) 89 | (trc "about to incf m-syn-a yyyy") 90 | (incf (m-syn-a m)) 91 | (ct-assert (= 3 delta-ct)) 92 | (ct-assert (= 4 sens-ct)) 93 | (ct-assert (= 2 plus-ct)) 94 | (describe m) 95 | (print '(start))))) 96 | 97 | (Def-c-output m-syn-a () 98 | (trc "!!! M-SYN-A now =" new-value)) 99 | 100 | #+(or) 101 | (m-syn) 102 | 103 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/test.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | ;;; 3 | ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;;; of this software and associated documentation files (the "Software"), to deal 7 | ;;; in the Software without restriction, including without limitation the rights 8 | ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;;; copies of the Software, and to permit persons to whom the Software is furnished 10 | ;;; to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 21 | ;;; IN THE SOFTWARE. 22 | 23 | #| Synapse Cell Unification Notes 24 | 25 | - start by making Cells synapse-y 26 | 27 | - make sure outputs show right old and new values 28 | - make sure outputs fire when they should 29 | 30 | - wow: test the Cells II dictates: no output callback sees stale data, no rule 31 | sees stale data, etc etc 32 | 33 | - test a lot of different synapses 34 | 35 | - make sure they fire when they should, and do not when they should not 36 | 37 | - make sure they survive an evaluation by the caller which does not branch to 38 | them (ie, does not access them) 39 | 40 | - make sure they optimize away 41 | 42 | - test with forms which access multiple other cells 43 | 44 | - look at direct alteration of a caller 45 | 46 | - does SETF honor not propagating, as well as a c-ruled after re-calcing 47 | 48 | - do diff unchanged tests such as string-equal work 49 | 50 | |# 51 | 52 | #| do list 53 | 54 | -- can we lose the special handling of the .kids slot? 55 | 56 | -- test drifters (and can they be handled without creating a special 57 | subclass for them?) 58 | 59 | |# 60 | 61 | (eval-when (compile load) 62 | (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) 63 | 64 | (in-package :cells) 65 | 66 | (defvar *cell-tests* nil) 67 | 68 | 69 | #+go 70 | (test-cells) 71 | 72 | (defun test-cells () 73 | (loop for test in (reverse *cell-tests*) 74 | do (cell-test-init test) 75 | (funcall test))) 76 | 77 | (defun cell-test-init (name) 78 | (print (make-string 40 :initial-element #\!)) 79 | (print `(starting test ,name)) 80 | (print (make-string 40 :initial-element #\!)) 81 | (cell-reset)) 82 | 83 | (defmacro def-cell-test (name &rest body) 84 | `(progn 85 | (pushnew ',name *cell-tests*) 86 | (defun ,name () 87 | (cell-reset) 88 | ,@body))) 89 | 90 | (defmacro ct-assert (form &rest stuff) 91 | `(progn 92 | (print `(attempting ,',form)) 93 | (assert ,form () "Error with ~a >> ~a" ',form (list ,@stuff)))) 94 | 95 | ;; test huge number of useds by one rule 96 | 97 | (defmodel m-index (family) 98 | () 99 | (:default-initargs 100 | :value (c? (bwhen (ks (^kids)) 101 | (apply '+ (mapcar 'value ks)))))) 102 | 103 | (def-cell-test many-useds 104 | (let ((i (make-instance 'm-index))) 105 | (loop for n below 100 106 | do (push (make-instance 'model 107 | :value (c-in n)) 108 | (kids i))) 109 | (trc "index total" (value i)))) 110 | 111 | (defmodel m-null () 112 | ((aa :initform nil :cell nil :initarg :aa :accessor aa))) 113 | 114 | (def-cell-test m-null 115 | (let ((m (make-be 'm-null :aa 42))) 116 | (ct-assert (= 42 (aa m))) 117 | (ct-assert (= 21 (decf (aa m) 21))) 118 | :okay-m-null)) 119 | 120 | (defmodel m-solo () 121 | ((m-solo-a :initform nil :initarg :m-solo-a :accessor m-solo-a) 122 | (m-solo-b :initform nil :initarg :m-solo-b :accessor m-solo-b))) 123 | 124 | (def-cell-test m-solo 125 | (let ((m (make-be 'm-solo 126 | :m-solo-a (c-in 42) 127 | :m-solo-b (c? (* 2 (^m-solo-a)))))) 128 | (ct-assert (= 42 (m-solo-a m))) 129 | (ct-assert (= 84 (m-solo-b m))) 130 | (decf (m-solo-a m)) 131 | (ct-assert (= 41 (m-solo-a m))) 132 | (ct-assert (= 82 (m-solo-b m))) 133 | :okay-m-null)) 134 | 135 | (defmodel m-var () 136 | ((m-var-a :initform nil :initarg :m-var-a :accessor m-var-a) 137 | (m-var-b :initform nil :initarg :m-var-b :accessor m-var-b))) 138 | 139 | (def-c-output m-var-b () 140 | (print `(output m-var-b ,self ,new-value ,old-value))) 141 | 142 | (def-cell-test m-var 143 | (let ((m (make-be 'm-var :m-var-a (c-in 42) :m-var-b 1951))) 144 | (ct-assert (= 42 (m-var-a m))) 145 | (ct-assert (= 21 (decf (m-var-a m) 21))) 146 | (ct-assert (= 21 (m-var-a m))) 147 | :okay-m-var)) 148 | 149 | (defmodel m-var-output () 150 | ((cbb :initform nil :initarg :cbb :accessor cbb) 151 | (aa :cell nil :initform nil :initarg :aa :accessor aa))) 152 | 153 | (def-c-output cbb () 154 | (trc "output cbb" self) 155 | (setf (aa self) (- new-value (if old-value-boundp 156 | old-value 0)))) 157 | 158 | (def-cell-test m-var-output 159 | (let ((m (make-be 'm-var-output :cbb (c-in 42)))) 160 | (ct-assert (eql 42 (cbb m))) 161 | (ct-assert (eql 42 (aa m))) 162 | (ct-assert (eql 27 (decf (cbb m) 15))) 163 | (ct-assert (eql 27 (cbb m))) 164 | (ct-assert (eql -15 (aa m))) 165 | (list :okay-m-var (aa m)))) 166 | 167 | (defmodel m-var-linearize-setf () 168 | ((ccc :initform nil :initarg :ccc :accessor ccc) 169 | (ddd :initform nil :initarg :ddd :accessor ddd))) 170 | 171 | (def-c-output ccc () 172 | (with-deference 173 | (setf (ddd self) (- new-value (if old-value-boundp 174 | old-value 0))))) 175 | 176 | (def-cell-test m-var-linearize-setf 177 | (let ((m (make-be 'm-var-linearize-setf 178 | :ccc (c-in 42) 179 | :ddd (c-in 1951)))) 180 | 181 | (ct-assert (= 42 (ccc m))) 182 | (ct-assert (= 42 (ddd m))) 183 | (ct-assert (= 27 (decf (ccc m) 15))) 184 | (ct-assert (= 27 (ccc m))) 185 | (ct-assert (= -15 (ddd m))) 186 | :okay-m-var)) 187 | 188 | ;;; ------------------------------------------------------- 189 | 190 | (defmodel m-ruled () 191 | ((eee :initform nil :initarg :eee :accessor eee) 192 | (fff :initform (c? (floor (^ccc) 2)) :initarg :fff :accessor fff))) 193 | 194 | (def-c-output eee () 195 | (print `(output> eee ,new-value old ,old-value))) 196 | 197 | (def-c-output fff () 198 | (print `(output> eee ,new-value old ,old-value))) 199 | 200 | (def-cell-test m-ruled 201 | (let ((m (make-be 'm-ruled 202 | :eee (c-in 42) 203 | :fff (c? (floor (^eee) 2))))) 204 | (trc "___Initial TOBE done____________________") 205 | (print `(pulse ,*data-pulse-id*)) 206 | (ct-assert (= 42 (eee m))) 207 | (ct-assert (= 21 (fff m))) 208 | (ct-assert (= 36 (decf (eee m) 6))) 209 | (print `(pulse ,*data-pulse-id*)) 210 | (ct-assert (= 36 (eee m))) 211 | (ct-assert (= 18 (fff m)) m) 212 | :okay-m-ruled)) 213 | 214 | (defmodel m-worst-case () 215 | ((wc-x :accessor wc-x :initform (c-input () 2)) 216 | (wc-a :accessor wc-a :initform (c? (when (oddp (wc-x self)) 217 | (wc-c self)))) 218 | (wc-c :accessor wc-c :initform (c? (evenp (wc-x self)))) 219 | (wc-h :accessor wc-h :initform (c? (or (wc-c self)(wc-a self)))))) 220 | 221 | (def-cell-test m-worst-case 222 | (let ((m (make-be 'm-worst-case))) 223 | (trc "___Initial TOBE done____________________") 224 | (ct-assert (eql t (wc-c m))) 225 | (ct-assert (eql nil (wc-a m))) 226 | (ct-assert (eql t (wc-h m))) 227 | (ct-assert (eql 3 (incf (wc-x m)))))) 228 | 229 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/trc-eko.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | The Newly Cells-aware trc trace and EKO value echo facilities 5 | 6 | |# 7 | 8 | 9 | (in-package :cells) 10 | 11 | ;----------- trc ------------------------------------------- 12 | (defparameter *last-trc* (get-internal-real-time)) 13 | (defparameter *trcdepth* 0) 14 | 15 | (defun trcdepth-reset () 16 | (setf *trcdepth* 0)) 17 | 18 | (defmacro trc (tgt-form &rest os) 19 | (if (eql tgt-form 'nil) 20 | '(progn) 21 | (if (stringp tgt-form) 22 | `(without-c-dependency 23 | (call-trc t ,tgt-form ,@os)) 24 | (let ((tgt (gensym))) 25 | ;(brk "slowww? ~a" tgt-form) 26 | `(without-c-dependency 27 | (bif (,tgt ,tgt-form) 28 | (if (trcp ,tgt) 29 | (progn 30 | (assert (stringp ,(car os)) () "trc with test expected string second, got ~a" ,(car os)) 31 | (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) 32 | (progn 33 | ;(trc "trcfailed") 34 | (count-it :trcfailed))) 35 | (count-it :tgtnileval))))))) 36 | 37 | (defparameter *trc-path-id* nil) 38 | (defparameter *trc-path-id-filter* nil) 39 | (defparameter *trc-path-max* 0) 40 | (defparameter *trc-path-max-path* nil) 41 | (defparameter *trc-suppress* nil) 42 | (export! *trc-path-max* trcap) 43 | 44 | (defmacro trcap (&rest args) 45 | `(let (*trc-path-id-filter*) 46 | (trc ,@args))) 47 | 48 | (defun trc-pathp (path) 49 | (when (> (length path) *trc-path-max*) 50 | ;;(print `(new-*trc-path-max* ,(length path) ,path)) 51 | (setf *trc-path-max* (length path) 52 | *trc-path-max-path* path)) 53 | 54 | #+good-for-test-one 55 | (when (> (- *trc-path-max* (length path)) 4) 56 | (break "big path delta for new path ~s agin max ~a" path *trc-path-max-path*)) 57 | 58 | (or (null *trc-path-id-filter*) 59 | (if (> (length path)(length *trc-path-id-filter*)) 60 | (eql 0 (search *trc-path-id-filter* path )) 61 | (eql 0 (search path *trc-path-id-filter*))))) 62 | 63 | (export! *trc-path-id-filter* trc-pathp *trc-suppress* trx-zero) 64 | 65 | #-allegro-v9.0 66 | (defun curr-thread () 67 | (excl:current-thread)) 68 | 69 | #+allegro-v9.0 70 | (defun curr-thread () 71 | sys:*current-thread*) 72 | 73 | (defun thread-pid () 74 | (or 75 | ;;#+cthread-mess 76 | (b-when thd (curr-thread) 77 | ;(print `(thread-name ,(slot-value thd 'sys::name))) 78 | (b-when p (slot-value thd 'sys::process) 79 | (mp:process-os-id p))) 80 | 0)) 81 | 82 | (defun thread-name () 83 | ;;#+cthread-mess 84 | (b-when thd (curr-thread) 85 | (slot-value thd 'sys::name))) 86 | 87 | (defparameter *trx-zero* 0) 88 | 89 | (defun trx-zero () 90 | (setf *trx-zero* (get-internal-real-time))) 91 | 92 | (defun call-trc (stream s &rest os) 93 | ;; (break) 94 | 95 | (when *trc-suppress* (return-from call-trc)) 96 | 97 | (let ((path (cond 98 | (*trc-path-id* 99 | (unless (trc-pathp *trc-path-id*) 100 | (return-from call-trc)) 101 | *trc-path-id*) 102 | ((and (boundp '*trcdepth*) 103 | *trcdepth*) 104 | (format nil "~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)) 105 | ("")))) 106 | (format stream "~&~@[~a ~]~@[~a:~]~@[<~a> ~]~a: " 107 | (round (- (get-internal-real-time) *trx-zero*) 100) 108 | nil #+slow? (left$ (thread-name) 8) 109 | nil #+xxx .dpid path)) 110 | ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10)) 111 | (setf *last-trc* (get-internal-real-time)) 112 | 113 | (format stream "~a ~{~s ~}~%" s os) 114 | 115 | (force-output stream) 116 | (values)) 117 | 118 | 119 | (export! trx trx! brk brkx .bgo bgo *trc-path-id* ntrcx *trx-tag*) 120 | 121 | (define-symbol-macro .bgo (brk "go")) 122 | 123 | (defmacro bgo (msg) 124 | `(brk "BGO ~a" ',msg)) 125 | 126 | (defmacro brkx (msg) 127 | `(brk "At ~a: OK?" ',msg)) 128 | 129 | (defmacro trcx (tgt-form &rest os) 130 | (if (eql tgt-form 'nil) 131 | '(progn) 132 | `(without-c-dependency 133 | (call-trc t (format nil "TX[~d]> ~(~s~)" 134 | (thread-pid) ',tgt-form) 135 | ,@(loop for obj in (or os (list tgt-form)) 136 | nconcing (list (intern (format nil "~a" obj) :keyword) obj)))))) 137 | 138 | (defmacro trx! (tag &rest os) 139 | `(let ((*trc-suppress* nil)) 140 | (trx ,tag ,@os))) 141 | 142 | 143 | (defparameter *trx-tag* "") 144 | 145 | (defmacro trx (tgt-form &rest os) 146 | (if (eql tgt-form 'nil) 147 | '(progn) 148 | `(without-c-dependency 149 | (call-trc t (format nil "> ~a" ;; "TX[~a]> ~a" 150 | ;; *trx-tag* ;; (ukt::irt-mshh$) 151 | ,(string tgt-form)) 152 | ,@(loop for obj in (or os (list tgt-form)) 153 | nconcing (list (intern (format nil "~a" obj) :keyword) obj)))))) 154 | 155 | (defmacro ntrcx (&rest os) 156 | (declare (ignore os)) 157 | '(progn)) 158 | 159 | (defun call-trc-to-string (fmt$ &rest fmt-args) 160 | (let ((o$ (make-array '(0) :element-type 'base-char 161 | :fill-pointer 0 :adjustable t))) 162 | (with-output-to-string (os-stream o$) 163 | (apply 'call-trc os-stream fmt$ fmt-args)) 164 | o$)) 165 | 166 | #+findtrcevalnils 167 | (defmethod trcp :around (other) 168 | (unless (call-next-method other)(brk))) 169 | 170 | (defmethod trcp (other) 171 | (eq other t)) 172 | 173 | (defmethod trcp (($ string)) 174 | t) 175 | 176 | (defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) 177 | `(let ((*trcdepth* (if *trcdepth* 178 | (1+ *trcdepth*) 179 | 0))) 180 | ,(when banner `(when (>= *trcdepth* ,min) 181 | (if (< *trcdepth* ,max) 182 | (trc ,@banner) 183 | (progn 184 | (brk "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) 185 | nil)))) 186 | (when (< *trcdepth* ,max) 187 | ,@body))) 188 | 189 | (defmacro wtrcx ((&key (min 1) (max 50) (on? t))(&rest banner) &body body ) 190 | `(let ((*trcdepth* (if *trcdepth* 191 | (1+ *trcdepth*) 192 | 0))) 193 | ,(when banner `(when (and (>= *trcdepth* ,min) ,on?) 194 | (if (< *trcdepth* ,max) 195 | (trc ,@banner) 196 | (progn 197 | (brk "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) 198 | nil)))) 199 | (when (< *trcdepth* ,max) 200 | ,@body))) 201 | 202 | (defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body ) 203 | (declare (ignore min max banner)) 204 | `(progn ,@body)) 205 | 206 | ;------ eko -------------------------------------- 207 | 208 | (defmacro eko ((&rest trcargs) &rest body) 209 | (let ((result (gensym))) 210 | `(let ((,result ,@body)) 211 | ,(if (stringp (car trcargs)) 212 | `(trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) 213 | `(trc ,(car trcargs) ,(cadr trcargs) :=> ,result ,@(cddr trcargs))) 214 | ,result))) 215 | 216 | (defmacro ekx (ekx-id &rest body) 217 | (let ((result (gensym))) 218 | `(let ((,result (,@body))) 219 | (trc ,(string-downcase (symbol-name ekx-id)) :=> ,result) 220 | ,result))) 221 | 222 | (defmacro eko-if ((&rest trcargs) &rest body) 223 | (let ((result (gensym))) 224 | `(let ((,result ,@body)) 225 | (when ,result 226 | (trc ,(car trcargs) :res ,result ,@(cdr trcargs))) 227 | ,result))) 228 | 229 | (defmacro ek (label &rest body) 230 | (let ((result (gensym))) 231 | `(let ((,result (,@body))) 232 | (when ,label 233 | (trc ,label ,result)) 234 | ,result))) 235 | 236 | -------------------------------------------------------------------------------- /src/tiltontec/lisp/variables.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- 2 | #| 3 | 4 | Cells -- Automatic Dataflow Managememnt 5 | 6 | Copyright (C) 1995, 2006 by Kenneth Tilton 7 | 8 | This library is free software; you can redistribute it and/or 9 | modify it under the terms of the Lisp Lesser GNU Public License 10 | (http://opensource.franz.com/preamble.html), known as the LLGPL. 11 | 12 | This library is distributed WITHOUT ANY WARRANTY; without even 13 | the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 14 | 15 | See the Lisp Lesser GNU Public License for more details. 16 | 17 | |# 18 | 19 | (in-package :cells) 20 | 21 | (defun c-variable-accessor (symbol) 22 | (assert (symbolp symbol)) 23 | (c-variable-reader symbol)) 24 | 25 | (defun (setf c-variable-accessor) (value symbol) 26 | (assert (symbolp symbol)) 27 | (c-variable-writer value symbol)) 28 | 29 | (defun c-variable-reader (symbol) 30 | (assert (symbolp symbol)) 31 | (assert (get symbol 'cell)) 32 | (cell-read (get symbol 'cell))) 33 | 34 | (defun c-variable-writer (value symbol) 35 | (assert (symbolp symbol)) 36 | (setf (md-slot-value nil symbol) value) 37 | (setf (symbol-value symbol) value)) 38 | 39 | (export! def-c-variable) 40 | 41 | (defmacro def-c-variable (v-name cell &key ephemeral owning unchanged-if) 42 | (declare (ignore unchanged-if)) 43 | (let ((c 'whathef)) ;;(gensym))) 44 | `(progn 45 | (eval-when (:compile-toplevel :load-toplevel) 46 | (define-symbol-macro ,v-name (c-variable-accessor ',v-name)) 47 | (setf (md-slot-cell-type 'null ',v-name) (when ,ephemeral :ephemeral)) 48 | (when ,owning 49 | (setf (md-slot-owning 'null ',v-name) t))) 50 | (eval-when (:load-toplevel) 51 | (let ((,c ,cell)) 52 | (md-install-cell nil ',v-name ,c) 53 | (awaken-cell ,c))) 54 | ',v-name))) 55 | 56 | 57 | (defobserver *kenny* () 58 | (trcx kenny-obs new-value old-value old-value-boundp)) 59 | 60 | #+test 61 | (def-c-variable *kenny* (c-in nil)) 62 | 63 | 64 | #+test 65 | (defmd kenny-watcher () 66 | (twice (c? (bwhen (k *kenny*) 67 | (* 2 k))))) 68 | 69 | (defobserver twice () 70 | (trc "twice kenny is:" new-value self old-value old-value-boundp)) 71 | 72 | #+test-ephem 73 | (progn 74 | (cells-reset) 75 | (let ((tvw (make-instance 'kenny-watcher))) 76 | (trcx twice-read (twice tvw)) 77 | (setf *c-debug* nil) 78 | (setf *kenny* 42) 79 | (setf *kenny* 42) 80 | (trcx post-setf-kenny *kenny*) 81 | (trcx print-twice (twice tvw)) 82 | )) 83 | 84 | #+test 85 | (let ((*kenny* 13)) (print *kenny*)) 86 | 87 | #+test 88 | (let ((c (c-in 42))) 89 | (md-install-cell '*test-c-variable* '*test-c-variable* c) 90 | (awaken-cell c) 91 | (let ((tvw (make-instance 'test-var-watcher))) 92 | (trcx twice-read (twice tvw)) 93 | (setf *test-c-variable* 69) 94 | (trcx print-testvar *test-c-variable*) 95 | (trcx print-twice (twice tvw)) 96 | (unless (eql (twice tvw) 138) 97 | (inspect (md-slot-cell tvw 'twice)) 98 | (inspect c) 99 | )) 100 | ) 101 | 102 | #+test2 103 | (let ((tvw (make-instance 'test-var-watcher :twice (c-in 42)))) 104 | (let ((c (c? (trcx joggggggggging!!!!!!!!!!!!!!!) 105 | (floor (twice tvw) 2)))) 106 | (md-install-cell '*test-c-variable* '*test-c-variable* c) 107 | (awaken-cell c) 108 | (trcx print-testvar *test-c-variable*) 109 | (trcx twice-read (twice tvw)) 110 | (setf (twice tvw) 138) 111 | (trcx print-twice (twice tvw)) 112 | (trcx print-testvar *test-c-variable*) 113 | (unless (eql *test-c-variable* 69) 114 | (inspect (md-slot-cell tvw 'twice)) 115 | (inspect c) 116 | )) 117 | ) 118 | 119 | -------------------------------------------------------------------------------- /test/tiltontec/its_alive/cell_types_test.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.cell-types-test 2 | (:require [clojure.test :refer :all] 3 | [tiltontec.its-alive.cell-types :refer :all :as cty] 4 | )) 5 | 6 | (set! *print-level* 3) 7 | 8 | (deftest nada-much 9 | (is (isa? ia-types ::cty/c-formula ::cty/cell))) 10 | -------------------------------------------------------------------------------- /test/tiltontec/its_alive/cells_test.clj: -------------------------------------------------------------------------------- 1 | 2 | (ns tiltontec.its-alive.cells-test 3 | (:require [clojure.test :refer :all] 4 | [tiltontec.its-alive.utility :refer :all] 5 | [tiltontec.its-alive.cell-types :refer :all :as cty] 6 | [tiltontec.its-alive.observer :refer :all] 7 | [tiltontec.its-alive.evaluate :refer :all] 8 | [tiltontec.its-alive.cells :refer :all] 9 | )) 10 | 11 | (set! *print-level* 3) 12 | 13 | (deftest test-input 14 | (let [c (make-cell 15 | :slot :mol 16 | :value 42)] 17 | (is (isa? ia-types (type c) ::cty/cell)) 18 | (is (= (c-value c) 42)) 19 | (is (= (c-value-state c) :valid)) 20 | (is (= #{} (c-callers c))) 21 | (is (c-input? c)) 22 | (is (nil? (c-model c))) 23 | (is (= :mol (c-slot c))) 24 | )) 25 | 26 | (deftest test-c-in 27 | (let [c (c-in 42)] 28 | (is (isa? ia-types (type c) ::cty/cell)) 29 | (is (= (c-value c) 42)) 30 | (is (= (c-value-state c) :valid)) 31 | (is (= #{} (c-callers c))) 32 | (is (c-input? c)) 33 | (is (c-valid? c)) 34 | (is (nil? (c-model c))) 35 | )) 36 | 37 | (deftest test-c-in+ 38 | (let [c (c-in 42 :slot :cool)] 39 | (is (isa? ia-types (type c) ::cty/cell)) 40 | (is (c-ref? c)) 41 | (is (= (c-value c) 42)) 42 | (is (= (c-value-state c) :valid)) 43 | (is (= #{} (c-callers c))) 44 | (is (c-input? c)) 45 | (is (nil? (c-model c))) 46 | (is (= :cool (c-slot c)(c-slot-name c))) 47 | )) 48 | 49 | (deftest test-c-formula 50 | (let [c (c? (+ 40 2))] 51 | (is (isa? ia-types (type c) ::cty/c-formula)) 52 | (is (fn? (c-rule c))) 53 | (is (= (c-value c) unbound)) 54 | (is (= (c-value-state c) :unbound)) 55 | (is (= #{} (c-callers c))) 56 | (is (= #{} (c-useds c))) 57 | (is (not (c-input? c))) 58 | (is (nil? (c-model c))) 59 | )) 60 | 61 | (deftest t-c?+ 62 | (let [c (c?+ (:optimize false :slot :bingo) 63 | (trx nil :cool) 64 | (+ 40 2))] 65 | (is (isa? ia-types (type c) ::cty/c-formula)) 66 | (is (c-ref? c)) 67 | (is (fn? (c-rule c))) 68 | (is (= (c-value c) unbound)) 69 | (is (= (c-value-state c) :unbound)) 70 | (is (= #{} (c-callers c))) 71 | (is (= #{} (c-useds c))) 72 | (is (not (c-input? c))) 73 | (is (nil? (c-model c))) 74 | (is (not (c-optimize c))) 75 | (is (= :bingo (c-slot c)(c-slot-name c))))) 76 | 77 | 78 | (deftest t-eph-1 79 | (cells-init) 80 | (let [boct (atom 0) 81 | b (c-in nil 82 | :slot :b 83 | :obs (fn-obs (swap! boct inc)) 84 | :ephemeral? true) 85 | crun (atom 0) 86 | cobs (atom 0) 87 | c (c?+ [:slot :c 88 | :obs (fn-obs (swap! cobs inc))] 89 | (trx nil :bingo) 90 | (swap! crun inc) 91 | (prog1 92 | (str "Hi " (c-get b)) 93 | (trx nil :cellread!! @b)))] 94 | (assert (c-rule c) "Early no rule") 95 | (is (nil? (c-value b))) 96 | (trx nil :valstate (c-value-state b)) 97 | (is (= :valid (c-value-state b))) 98 | (is (c-valid? b)) 99 | (trx nil b) 100 | (trx nil @b) 101 | (is (c-valid? b)) 102 | (is (= "Hi " (c-get c))) 103 | (is (= 1 @boct)) 104 | (is (= 1 @crun @cobs)) 105 | (is (nil? (:value @b))) 106 | 107 | (do 108 | (trx nil :first-b-reset!!!!!!!!!!!) 109 | (c-reset! b "Mom") 110 | (is (= "Hi Mom" (c-get c))) 111 | (is (= 2 @boct)) 112 | (is (= 2 @crun @cobs)) 113 | (is (nil? (c-value b))) 114 | (is (nil? (:value @b)))) 115 | 116 | (do 117 | (trx nil :second-b-reset!!!!!!!!!!!) 118 | (c-reset! b "Mom") 119 | (is (= "Hi Mom" (c-get c))) 120 | (is (= 3 @boct)) 121 | (is (= 3 @crun)) 122 | (is (= 2 @cobs)) 123 | (is (nil? (c-value b))) 124 | (is (nil? (:value @b)))) 125 | )) 126 | 127 | 128 | (deftest t-c?n 129 | (let [a (c-in 42 :slot :aa) 130 | b (c?n [:slot :bb] 131 | (/ (c-get a) 2)) 132 | c (c? (+ 1 (c-get b)))] 133 | (is (= 21 (c-get b))) 134 | (is (= 22 (c-get c))) 135 | (c-reset! b 42) 136 | (is (= 42 (c-get b))) 137 | (is (= 43 (c-get c))))) 138 | 139 | (deftest t-c?once 140 | (let [a (c-in 42 :slot :aa) 141 | b (c?once [:slot :bb] 142 | (/ (c-get a) 2))] 143 | (println :bbb b) 144 | (is (= 21 (c-get b))) 145 | 146 | (comment 147 | (c-reset! a 2) 148 | 149 | (is (= 2 (c-get a))) 150 | (is (= 21 (c-get b)))))) 151 | -------------------------------------------------------------------------------- /test/tiltontec/its_alive/family_test.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.family-test 2 | (:require 3 | [clojure.test :refer :all] 4 | ;;[clojure.set :refer [difference]] 5 | [tiltontec.its-alive.utility :refer :all] 6 | [tiltontec.its-alive.cell-types :refer :all :as cty] 7 | [tiltontec.its-alive.evaluate :refer :all] 8 | [tiltontec.its-alive.cells :refer :all :as cz] 9 | [tiltontec.its-alive.model-base :refer :all] 10 | [tiltontec.its-alive.model :refer :all :as md] 11 | [tiltontec.its-alive.family :refer :all :as fm] 12 | )) 13 | 14 | (deftest fm-0 15 | (cells-init) 16 | (let [u (md/make 17 | :kon (c-in false :slot :kon) 18 | :kids (c? (trx :kids-run! *depender*) 19 | (when (md-get me :kon) 20 | (vector 21 | (md/make 22 | :par me 23 | :name :konzo 24 | :kzo (c-in 3))))))] 25 | (is (nil? (:kids @u))) 26 | (let [kc (md-cell u :kids) 27 | kon (md-cell u :kon)] 28 | (c-reset! kon true) 29 | (is (= 1 (count (:kids @u)))) 30 | (is (fget :konzo u :inside? true)) 31 | ))) 32 | 33 | (deftest fm-1 34 | (is (fget= :bob (ref {:name :bob}))) 35 | (is (not (fget= :bobby (ref {:name :bob})))) 36 | (is (fget= #(do (println %) 37 | (even? @%)) (ref 0))) 38 | (is (not (fget= #(do (println %) 39 | (odd? @%)) (ref 0)))) 40 | ) 41 | 42 | 43 | (deftest fm-2 44 | (let [u (md/make 45 | :name :uni 46 | :kids (c? (vector 47 | (md/make 48 | :par me 49 | :name :aa) 50 | (md/make 51 | :par me 52 | :name :bb 53 | :kids (c? (vector 54 | (md/make 55 | :par me 56 | :name :bba) 57 | 58 | (md/make 59 | :par me 60 | :name :bbb)))))))] 61 | ;; (is (fget :bba u :inside? true :must? true)) 62 | ;; (is (thrown-with-msg? 63 | ;; Exception #"fget-must-failed" 64 | ;; (fget :bbax u :inside? true :must? true))) 65 | ;; (is (nil? (fget :bbax u :inside? true :must? false))) 66 | (let [bba (fget :bba u :inside? true :must? true)] 67 | (is bba) 68 | (is (fm/fget :uni bba :inside? true :up? true)) 69 | (is (fget :aa bba :inside? false :up? true)) 70 | (is (fget :bb bba :inside? true :up? true)) 71 | (is (fget :bbb bba :inside? false :up? true)) 72 | ) 73 | )) 74 | 75 | (deftest fm-3 76 | (let [u (md/make 77 | :u63 (c? (+ (mdv! :aa :aa42) 78 | (mdv! :bb :bb21))) 79 | :kon (c-in false) 80 | :kids (c? (trx :kids-run!!!!!!!!!!!! me) 81 | (remove nil? 82 | (vector 83 | (md/make 84 | :par me 85 | :name :aa 86 | :aa42 (c? (* 2 (mdv! :bb :bb21))) 87 | :aa3 (c-in 3)) 88 | (when (md-get me :kon) 89 | (md/make 90 | :par me 91 | :name :konzo 92 | :kzo (c-in 3))) 93 | (md/make 94 | :par me 95 | :name :bb 96 | :bb21 (c? (* 7 (mdv! :aa :aa3))))))))] 97 | (is (= 63 (md-get u :u63))) 98 | (is (= 42 (mdv! :aa :aa42 u))) 99 | (is (= 21 (mdv! :bb :bb21 u))) 100 | (is (nil? (fget :konzo u :must? false))) 101 | (c-reset! (md-cell u :kon) true) 102 | (is (:kon @u)) 103 | (is (md-cell u :kon)) 104 | (is (= 3 (count (:kids @u)))) 105 | (is (fget :konzo u :inside? true)) 106 | )) 107 | 108 | (deftest fm-3x 109 | (let [u (md/make 110 | :u63 (c? (+ (mdv! :aa :aa42) 111 | (mdv! :bb :bb21))) 112 | :kon (c-in false) 113 | :kids (c? (the-kids 114 | (md/make 115 | :name :aa 116 | :aa42 (c? (* 2 (mdv! :bb :bb21))) 117 | :aa3 (c-in 3)) 118 | (when (md-get me :kon) 119 | (md/make 120 | :name :konzo 121 | :kzo (c-in 3))) 122 | (md/make 123 | :name :bb 124 | :bb21 (c? (* 7 (mdv! :aa :aa3)))))))] 125 | (is (= 63 (md-get u :u63))) 126 | (is (= 42 (mdv! :aa :aa42 u))) 127 | (is (= 21 (mdv! :bb :bb21 u))) 128 | (is (nil? (fget :konzo u :must? false))) 129 | (c-reset! (md-cell u :kon) true) 130 | (is (:kon @u)) 131 | (is (md-cell u :kon)) 132 | (is (= 3 (count (:kids @u)))) 133 | (is (fget :konzo u :inside? true)) 134 | )) 135 | -------------------------------------------------------------------------------- /test/tiltontec/its_alive/hello_world_test.clj: -------------------------------------------------------------------------------- 1 | 2 | (ns tiltontec.its-alive.hello-world-test 3 | (:require [clojure.test :refer :all] 4 | [tiltontec.its-alive.utility :refer :all] 5 | [tiltontec.its-alive.cell-types :refer :all :as cty] 6 | [tiltontec.its-alive.observer :refer :all] 7 | [tiltontec.its-alive.evaluate :refer :all] 8 | [tiltontec.its-alive.cells :refer :all] 9 | [tiltontec.its-alive.model-base :refer :all] 10 | [tiltontec.its-alive.model :refer :all :as md] 11 | [tiltontec.its-alive.family :refer :all :as fm] 12 | )) 13 | 14 | (deftest hw-01 15 | (let [v ;;"visitor" 16 | {:name "World" 17 | :action (make-cell :value "knocks" 18 | :input? true)}] 19 | 20 | (println (c-get (:name v)) 21 | (c-get (:action v))) 22 | 23 | (is (= (c-get (:name v)) "World")) 24 | (is (= (c-get (:action v)) "knocks")))) 25 | 26 | (deftest hw-02 27 | (let [obs-action (atom nil) 28 | v ;;"visitor" 29 | {:name "World" 30 | :action (c-in "knocks" 31 | :slot :v-action 32 | :obs ;; short for observer 33 | (fn [slot me new old c] 34 | (reset! obs-action new) 35 | (println :observing slot new old)))}] 36 | (is (= (c-get (:name v)) "World")) 37 | (is (= (c-get (:action v)) "knocks")) 38 | (is (= "knocks" @obs-action)))) 39 | 40 | (deftest hw-03 41 | (let [action (atom nil) 42 | obs-action (fn [slot me new old c] 43 | (reset! action new) 44 | (println :observing slot new old)) 45 | v {:name "World" 46 | :action (c-in nil :slot :v-action 47 | :obs obs-action)}] 48 | 49 | (is (nil? (c-get (:action v)))) 50 | (is (nil? @action)) 51 | 52 | (c-reset! (:action v) "knock-knock") 53 | (is (= "knock-knock" @action)) 54 | (is (= (c-get (:action v)) "knock-knock")))) 55 | 56 | (defn gobs 57 | [slot me new old c] 58 | (println :gobs> slot new old)) 59 | 60 | (deftest hw-04 61 | (let [r-action (c-in nil 62 | :slot :r-action 63 | :obs gobs) 64 | r-loc (make-c-formula 65 | :slot :r-loc 66 | :obs gobs 67 | :rule (fn [c] 68 | (case (c-get r-action) 69 | :leave :away 70 | :return :at-home 71 | :missing)))] 72 | (c-awaken r-loc) 73 | (is (= :missing (:value @r-loc))) 74 | (println :---about-to-leave------------------) 75 | (c-reset! r-action :leave) 76 | (println :---left------------------) 77 | (is (= :away (c-get r-loc))))) 78 | 79 | (deftest hw-5 80 | (println :--go------------------) 81 | (let [obs-action (fn [slot me new old c] 82 | (println slot new old)) 83 | v {:name "World" 84 | :action (c-in nil :slot :v-action 85 | :obs obs-action)} 86 | r-action (c-in nil) 87 | r-loc (c?+ [:obs (fn-obs (when new (trx :honey-im new)))] 88 | (case (c-get r-action) 89 | :leave :away 90 | :return :home 91 | :missing)) 92 | r-response (c?+ [:obs (fn-obs (trx :r-resp new))] 93 | (when (= :home (c-get r-loc)) 94 | (when-let [act (c-get (:action v))] 95 | (case act 96 | :knock-knock "hello, world"))))] 97 | (is (nil? (c-get r-response))) 98 | (c-reset! (:action v) :knock-knock) 99 | (c-reset! r-action :return) 100 | (is (= :home (c-get r-loc))))) 101 | 102 | (deftest hello-world 103 | (println :--go------------------) 104 | (let [obs-action (fn [slot me new old c] 105 | (println slot new old)) 106 | v {:name "World" 107 | :action (c-in nil 108 | :slot :v-action 109 | :ephemeral? true 110 | :obs obs-action)} 111 | r-action (c-in nil) 112 | r-loc (c?+ [:obs (fn-obs (when new (trx :honey-im new)))] 113 | (case (c-get r-action) 114 | :leave :away 115 | :return :home 116 | :missing)) 117 | r-response (c?+ [:obs (fn-obs (trx :r-response new)) 118 | :ephemeral? true] 119 | (when (= :home (c-get r-loc)) 120 | (when-let [act (c-get (:action v))] 121 | (case act 122 | :knock-knock "hello, world"))))] 123 | (is (nil? (c-get r-response))) 124 | (c-reset! (:action v) :knock-knock) 125 | (c-reset! r-action :return) 126 | (is (= :home (c-get r-loc))) 127 | (c-reset! (:action v) :knock-knock))) 128 | 129 | (deftest hello-world-2 130 | (println :--go------------------) 131 | (let [obs-action (fn [slot me new old c] 132 | (when new (trx visitor-did new))) 133 | v {:name "World" 134 | :action (c-in nil 135 | :slot :v-action 136 | :ephemeral? true 137 | :obs obs-action)} 138 | r-action (c-in nil) 139 | r-loc (c?+ [:obs (fn-obs (when new (trx :honey-im new)))] 140 | (case (c-get r-action) 141 | :leave :away 142 | :return :home 143 | :missing)) 144 | r-response (c?+ [:obs (fn-obs (when new 145 | (trx :r-response new))) 146 | :ephemeral? true 147 | ] 148 | (when (= :home (c-get r-loc)) 149 | (when-let [act (c-get (:action v))] 150 | (case act 151 | :knock-knock "hello, world")))) 152 | alarm (c?+ [:obs (fn-obs 153 | (trx :telling-alarm-api new))] 154 | (if (= :home (c-get r-loc)) :off :on)) 155 | alarm-do (c?+ [:obs (fn-obs 156 | (case new 157 | :call-police (trx :auto-dialing-911) 158 | nil))] 159 | (when (= :on (c-get alarm)) 160 | (when-let [action (c-get (:action v))] 161 | (case action 162 | :smashing-window :call-police 163 | nil))))] 164 | (c-awaken [alarm-do r-response r-loc (:action v)]) 165 | (is (= :missing (:value @r-loc))) 166 | (c-reset! (:action v) :knock-knock) 167 | (c-reset! (:action v) :smashing-window) 168 | (c-reset! r-action :return) 169 | (is (= :home (c-get r-loc))) 170 | (c-reset! (:action v) :knock-knock) 171 | )) 172 | 173 | -------------------------------------------------------------------------------- /test/tiltontec/its_alive/integrity_test.clj: -------------------------------------------------------------------------------- 1 | 2 | (ns tiltontec.its-alive.integrity-test 3 | (:require [clojure.test :refer :all] 4 | [tiltontec.its-alive.utility :refer :all] 5 | [tiltontec.its-alive.cell-types :refer :all :as cty] 6 | [tiltontec.its-alive.observer :refer :all] 7 | [tiltontec.its-alive.evaluate :refer :all] 8 | [tiltontec.its-alive.cells :refer :all] 9 | [tiltontec.its-alive.integrity :refer :all])) 10 | 11 | (deftest integ-1 12 | (is (= 4 (+ 2 2)))) 13 | 14 | (defn obsdbg [] 15 | (fn-obs (trx :obsdbg slot new old (type-of c)))) 16 | 17 | 18 | (deftest obs-setf 19 | (cells-init) 20 | (is (zero? @+pulse+)) 21 | (do ;;binding [*dp-log* true] 22 | (let [alarm (c-in :undefined :obs (obsdbg)) 23 | act (c-in nil :obs (obsdbg)) 24 | loc (c?+ [:obs (fn-obs (trx :loc-obs-runs!!!!) 25 | 26 | (when-not (= new :missing) 27 | (assert (= @+pulse+ 2)) 28 | (c-reset-next! alarm 29 | (case new 30 | :home :off 31 | :away :on 32 | (err format "unexpected loc %s" new)))))] 33 | (case (c-get act) 34 | :leave :away 35 | :return :home 36 | :missing)) 37 | alarm-speak (c?+ [:obs (fn-obs 38 | (trx :alarm-speak (c-get act) :sees (c-get alarm) (c-get loc)) 39 | (is (= (c-get alarm) (case (c-get act) 40 | :return :off 41 | :leave :on 42 | :undefined))) 43 | (is (= +pulse+ 44 | (c-pulse act) 45 | (c-pulse loc) 46 | (c-pulse c))))] 47 | (str "alarm-speak sees act " (c-get act)))] 48 | (is (= (c-get alarm) :undefined)) 49 | (is (= 1 @+pulse+)) 50 | (is (= (c-get loc) :missing)) 51 | (is (= 1 @+pulse+)) 52 | 53 | (c-reset! act :leave) 54 | (is (= 3 @+pulse+)) 55 | ))) 56 | 57 | ;; ----------------------------------------------------------------- 58 | 59 | 60 | (deftest obs-setf-bad-caught 61 | (cells-init) 62 | 63 | (let [alarm (c-in :undefined :obs (obsdbg)) 64 | act (c-in nil :obs (obsdbg)) 65 | loc (c?+ [:obs (fn-obs (trx :loc-obs-runs!!!!) 66 | (is (thrown-with-msg? 67 | Exception 68 | #"c-reset!> change" 69 | (c-reset! act :leave))) 70 | (when-not (= new :missing) 71 | (c-reset-next! alarm (case new 72 | :home :off 73 | :away :on 74 | (err format "unexpected loc %s" new)))))] 75 | (case (c-get act) 76 | :leave :away 77 | :return :home 78 | :missing)) 79 | alarm-speak (c?+ [:obs (fn-obs 80 | (trx :alarm-speak (c-get act) :sees (c-get alarm) (c-get loc)) 81 | (is (= (c-get alarm) (case (c-get act) 82 | :return :off 83 | :leave :on 84 | :undefined))) 85 | (is (= +pulse+ 86 | (c-pulse act) 87 | (c-pulse loc) 88 | (c-pulse c))))] 89 | (str "alarm-speak sees act " (c-get act)))] 90 | (is (= (c-get alarm) :undefined)) 91 | (is (= 1 @+pulse+)) 92 | (is (= (c-get loc) :missing)) 93 | (is (= 1 @+pulse+)) 94 | 95 | 96 | )) 97 | 98 | ;; -------------------------------------------------------- 99 | 100 | (deftest see-into-fn 101 | (let [sia (c-in 0) 102 | rsic (atom false) 103 | sic (c? (reset! rsic true) 104 | (+ 42 (c-get sia))) 105 | fsia #(c-get sia) 106 | sib (c? (or (+ 1 (fsia)) 107 | (c-get sic)))] 108 | (is (= (c-get sib) 1)) 109 | (is (= (:useds @sib) #{sia})) 110 | (is (not @rsic)) 111 | (c-reset! sia 1) 112 | (is (= 2 (:value @sib))) 113 | (is (= (c-get sib) 2)))) 114 | 115 | 116 | (deftest no-prop-no-obs 117 | (let [sia (c-in 0) 118 | obs (atom false) 119 | sib (c?+ [:obs (fn-obs (reset! obs true))] 120 | (if (even? (c-get sia)) 121 | 42 122 | 10)) 123 | run (atom false) 124 | sic (c? (reset! run true) 125 | (/ (c-get sib) 2))] 126 | (is (= (c-get sib) 42)) 127 | (is (= (c-get sic) 21)) 128 | (is @obs) 129 | (is @run) 130 | (dosync 131 | (reset! obs false) 132 | (reset! run false)) 133 | (c-reset! sia 2) 134 | (is (= (c-get sib) 42)) 135 | (is (= (c-get sic) 21)) 136 | (is (not @obs)) 137 | (is (not @run)))) 138 | 139 | 140 | 141 | 142 | -------------------------------------------------------------------------------- /test/tiltontec/its_alive/kids_test.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.kids-test 2 | (:require 3 | [clojure.test :refer :all] 4 | [clojure.set :refer [difference]] 5 | [tiltontec.its-alive.utility :refer :all] 6 | [tiltontec.its-alive.cell-types :refer :all :as cty] 7 | [tiltontec.its-alive.evaluate :refer :all] 8 | [tiltontec.its-alive.cells :refer :all :as cz] 9 | [tiltontec.its-alive.model-base :refer :all] 10 | [tiltontec.its-alive.model :refer :all :as md] 11 | [tiltontec.its-alive.family :refer :all :as fm] 12 | )) 13 | 14 | (deftest k-notq2be 15 | (let [f (md/make ::fm/family 16 | :ee (c-in 2) 17 | :kids (c? (the-kids 18 | (when (odd? (md-get me :ee)) 19 | (md/make 20 | :name :yep 21 | :value (c? (* 14 (md-get (:par @me) :ee))))))))] 22 | (is (ia-type? f ::fm/family)) 23 | (is (empty? (md-get f :kids))) 24 | 25 | (do 26 | (md-reset! f :ee 3) 27 | (is (not (empty? (md-get f :kids)))) 28 | (is (= 42 (mdv! :yep :value f))) 29 | 30 | (let [dmw (first (md-get f :kids))] 31 | (assert (md-ref? dmw)) 32 | (md-reset! f :ee 0) 33 | (is (empty? (md-get f :kids))) 34 | (trx :dmw dmw @dmw) 35 | (is (nil? @dmw)) 36 | (is (= :dead (:state (meta dmw)))))))) 37 | -------------------------------------------------------------------------------- /test/tiltontec/its_alive/lazy_cells_test.clj: -------------------------------------------------------------------------------- 1 | 2 | (ns tiltontec.its-alive.lazy-cells-test 3 | (:require [clojure.test :refer :all] 4 | [tiltontec.its-alive.utility :refer :all] 5 | [tiltontec.its-alive.cell-types :refer :all :as cty] 6 | [tiltontec.its-alive.observer :refer :all] 7 | [tiltontec.its-alive.evaluate :refer :all] 8 | [tiltontec.its-alive.cells :refer :all] 9 | )) 10 | 11 | (deftest solid-lazy 12 | (cells-init) 13 | (let [xo (atom 0) 14 | a (c-in 0) 15 | x (c?_ [:obs (fn-obs (swap! xo inc))] 16 | (+ (c-get a) 40))] 17 | (is (= unbound (:value @x))) 18 | (is (= 0 @xo)) 19 | (is (= 40 (c-get x))) 20 | (is (= 1 @xo)) 21 | (c-reset! a 100) 22 | (is (= 1 @xo)) 23 | (is (= 40 (:value @x))) 24 | (is (= 140 (c-get x))) 25 | (is (= 2 @xo)) 26 | )) 27 | 28 | (deftest lazy-until-asked 29 | (cells-init) 30 | (let [xo (atom 0) 31 | xr (atom 0) 32 | a (c-in 0) 33 | x (c_? [:obs (fn-obs (swap! xo inc))] 34 | (swap! xr inc) 35 | (+ (c-get a) 40))] 36 | (is (= unbound (:value @x))) 37 | (is (= 0 @xo)) 38 | (is (= 0 @xr)) 39 | (is (= 40 (c-get x))) 40 | (is (= 1 @xo)) 41 | (is (= 1 @xr)) 42 | (c-reset! a 100) 43 | (is (= 2 @xo)) 44 | (is (= 2 @xr)) 45 | (is (= 140 (:value @x))) 46 | (is (= 140 (c-get x))) 47 | (is (= 2 @xo)) 48 | (is (= 2 @xr)) 49 | )) 50 | 51 | (deftest optimize-when-value-t 52 | (cells-init) 53 | (let [xo (atom 0) 54 | xr (atom 0) 55 | a (c-in 0 :slot :aaa) 56 | x (c?+ [:slot :xxx 57 | :obs (fn-obs (swap! xo inc)) 58 | :optimize :when-value-t] 59 | (swap! xr inc) 60 | (trx nil :reading-a!!!) 61 | (when-let [av (c-get a)] 62 | (when (> av 1) 63 | (+ av 40))))] 64 | (is (nil? (c-get x))) 65 | (is (= #{a} (c-useds x))) 66 | (c-reset! a 1) 67 | (trx nil :reset-finished!!!!!!!!!!) 68 | (is (nil? (c-get x))) 69 | (is (= #{a} (c-useds x))) 70 | (trx nil :reset-2-beginning!!!!!!!!!!!!) 71 | (c-reset! a 2) 72 | (trx nil :reset-2-finished!!!!!!!!!!) 73 | (is (= 42 (c-get x))) 74 | (is (empty? (c-useds x))) 75 | (trx nil :useds (c-useds x)) 76 | (is (empty? (c-callers x))) 77 | )) 78 | 79 | -------------------------------------------------------------------------------- /test/tiltontec/its_alive/model_base_test.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.model-base-test 2 | (:require [clojure.test :refer :all] 3 | [tiltontec.its-alive.utility :refer :all] 4 | [tiltontec.its-alive.cell-types :refer :all :as cty] 5 | ;[tiltontec.its-alive.observer :refer :all] 6 | [tiltontec.its-alive.evaluate :refer :all] 7 | [tiltontec.its-alive.cells :refer :all] 8 | [tiltontec.its-alive.model-base :refer :all :as md])) 9 | 10 | (deftest puh-leaze 11 | (is (= 4 (+ 2 2)))) 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /test/tiltontec/its_alive/model_test.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.model-test 2 | (:require [clojure.test :refer :all] 3 | [tiltontec.its-alive.utility :refer :all] 4 | [tiltontec.its-alive.cell-types :refer :all :as cty] 5 | [tiltontec.its-alive.observer :refer :all] 6 | [tiltontec.its-alive.evaluate :refer :all] 7 | [tiltontec.its-alive.cells :refer :all] 8 | [tiltontec.its-alive.model-base :refer :all] 9 | [tiltontec.its-alive.model :refer :all :as md] 10 | [tiltontec.its-alive.family :refer :all :as fm])) 11 | 12 | 13 | (derive cty/ia-types ::typetest ::cty/model) 14 | 15 | (deftest mm-typed 16 | (let [me (md/make 17 | :type ::typetest 18 | :x2 (c-in 2) 19 | :age (c? (* (md-get me :x2) 20 | 21)))] 21 | (is (= 42 (md-get me :age))) 22 | (is (ia-type? me ::typetest)))) 23 | 24 | (deftest mm-opti-1 25 | (let [me (md/make 26 | :x2 2 27 | :age (c? (* 21 (md-get me :x2))) 28 | )] 29 | (println :meta (meta me)) 30 | (is (= 2 (md-get me :x2))) 31 | (is (= 42 (md-get me :age))) 32 | (is (nil? (md-cell me :age))) 33 | )) 34 | 35 | (deftest mm-install-alive 36 | (let [bct (atom 0) 37 | res (do ;; sync 38 | (md/make 39 | :name "Bob" 40 | :action (c-in nil 41 | :ephemeral? true) 42 | :bogus (c? (if-let [be (md-get me :bogus-e)] 43 | (do 44 | (trx :bingo-e!!!!!!!! be @bct) 45 | (swap! bct inc) 46 | (* 2 be)) 47 | (trx :bogus-no-e (:bogus-e @me)))) 48 | :bogus-e (c-in 21 :ephemeral? true) 49 | :loc (c? (case (md-get me :action) 50 | :leave :away 51 | :return :home 52 | :missing))))] 53 | (println :meta (meta res)) 54 | (is (= (:cz (meta res)) (md-cz res))) 55 | (is (= 4 (count (md-cz res)))) 56 | (is (every? c-ref? (vals (md-cz res)))) 57 | (is (= #{:action :loc :bogus :bogus-e} (set (keys (md-cz res))))) 58 | (is (every? #(= res (c-me %)) (vals (md-cz res)))) 59 | (is (= #{:action :loc :bogus :bogus-e} 60 | (set (map #(c-slot %) 61 | (vals (md-cz res)))))) 62 | (is (= "Bob" (:name @res))) 63 | (is (= "Bob" (md-name res))) 64 | (println :res @res) 65 | (is (= 42 (:bogus @res))) 66 | (is (= nil (:bogus-e @res))) ;; ephemeral, so reset to nil silently 67 | (is (= nil (:action @res))) 68 | (println :loc (:loc @res)) 69 | (is (= :missing (:loc @res))) 70 | (is (= 1 @bct)) 71 | (reset! bct 0) 72 | (md-reset! res :action :return) 73 | (is (= :home (:loc @res))) 74 | (is (zero? @bct)) 75 | )) 76 | 77 | 78 | 79 | 80 | (deftest hello-model 81 | (let [uni (md/make 82 | ::fm/family 83 | :kids (c? (the-kids 84 | (md/make 85 | :name :visitor 86 | :moniker "World" 87 | :action (c-in nil 88 | :ephemeral? true 89 | :obs (fn [slot me new old c] 90 | (when new (trx visitor-did new))))) 91 | (md/make 92 | :name :resident 93 | :action (c-in nil :ephemeral? true) 94 | :location (c?+ [:obs (fn-obs (when new (trx :honey-im new)))] 95 | (case (md-get me :action) 96 | :leave :away 97 | :return :home 98 | :missing)) 99 | :response (c?+ [:obs (fn-obs (when new 100 | (trx :r-response new))) 101 | :ephemeral? true] 102 | (when (= :home (md-get me :location)) 103 | (when-let [act (mdv! :visitor :action)] 104 | (case act 105 | :knock-knock "hello, world"))))) 106 | (md/make 107 | :name :alarm 108 | :on-off (c?+ [:obs (fn-obs 109 | (trx :telling-alarm-api new))] 110 | (if (= :home (mdv! :resident :location)) :off :on)) 111 | :activity (c?+ [:obs (fn-obs 112 | (case new 113 | :call-police (trx :auto-dialing-911) 114 | nil))] 115 | (when (= :on (md-get me :on-off)) 116 | (when-let [action (mdv! :visitor :action)] 117 | (case action 118 | :smashing-window :call-police 119 | nil))))))))] 120 | (let [viz (fm! :visitor uni) 121 | rez (fm! :resident uni)] 122 | (is (not (nil? viz))) 123 | (is (not (nil? rez))) 124 | (is (not (nil? (md-cell rez :action)))) 125 | (is (= :missing (mdv! :resident :location uni))) 126 | (md-reset! viz :action :knock-knock) 127 | (md-reset! viz :action :smashing-window) 128 | (is (not (nil? (md-cell rez :action)))) 129 | (md-reset! rez :action :return) 130 | (is (= :home (mdv! :resident :location uni))) 131 | (md-reset! viz :action :knock-knock)))) 132 | -------------------------------------------------------------------------------- /test/tiltontec/its_alive/observer_test.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.observer-test 2 | (:require [clojure.test :refer :all] 3 | [tiltontec.its-alive.utility :refer :all] 4 | [tiltontec.its-alive.cell-types :refer :all :as cty] 5 | [tiltontec.its-alive.integrity :refer [with-integrity]] 6 | [tiltontec.its-alive.evaluate :refer [c-get]] 7 | [tiltontec.its-alive.observer :refer [defobserver fn-obs]] 8 | [tiltontec.its-alive.cells :refer :all] 9 | )) 10 | 11 | (set! *print-level* 3) 12 | 13 | (deftest t-formula 14 | (let [bingo (atom false) 15 | c (c?+ [:slot :bingo 16 | :obs (fn-obs 17 | (reset! bingo true))] 18 | (+ 40 2))] 19 | (is (ia-type? c ::cty/cell)) 20 | (is (ia-type? c ::cty/c-formula)) 21 | (is (= (c-value-state c) :unbound)) 22 | (is (= #{} (c-callers c))) 23 | (is (= #{} (c-useds c))) 24 | (is (not (c-input? c))) 25 | (is (not (c-valid? c))) 26 | (is (nil? (c-model c))) 27 | (is (= (c-get c) 42)) 28 | (is (= 42 @c)) ;; ie, optimized-away 29 | (is @bingo) 30 | )) 31 | 32 | (def bingo2 (atom false)) 33 | 34 | (defobserver :bingo2 [nil][] 35 | ;; (trx nil :bingoo2222222222!!!!! me new-value old-value c) 36 | (reset! bingo2 true)) 37 | 38 | 39 | (deftest test-input 40 | (let [c (c-in 42 :slot :bingo2)] 41 | (is (ia-type? c ::cty/cell)) 42 | (is (= (c-value-state c) :valid)) 43 | (is (= #{} (c-callers c))) 44 | (is (c-input? c)) 45 | (is (c-valid? c)) 46 | (is (nil? (c-model c))) 47 | (is (= :bingo2 (c-slot c) (c-slot-name c))) 48 | (is (= (c-get c) 42)) 49 | (is @bingo2) 50 | )) 51 | 52 | 53 | (deftest t-custom-obs 54 | (let [bobs (atom nil) 55 | b (c-in 2 :slot :bb 56 | :obs (fn-obs 57 | (trx nil slot me new old) 58 | (reset! bobs new))) 59 | cobs (atom nil) 60 | c (c?+ [:obs (fn-obs [slot me new old c] 61 | (trx slot me new old) 62 | (reset! cobs new))] 63 | (* 10 (c-get b)))] 64 | (dosync 65 | (is (= (c-get b) 2)) 66 | (is (= @bobs 2)) 67 | (is (= (c-get c) 20)) 68 | ;; (is (= @cobs 20)) 69 | ;; (c-reset! b 3) 70 | ;; (is (= 3 @bobs)) 71 | ;; (is (= 30 (c-get c))) 72 | ;; (is (= 30 @cobs)) 73 | ))) 74 | 75 | 76 | 77 | (def obj Object) 78 | 79 | (defmacro get-obj [] 80 | `obj) 81 | 82 | (defmulti speak (fn [one two] [(type one)(type two)])) 83 | 84 | (derive ::dog ::animal) 85 | (derive ::cat ::animal) 86 | 87 | (defmethod speak [::dog Object] [_ _] 88 | (println :woof)) 89 | 90 | (speak (atom nil :meta {:type ::dog}) 42) 91 | 92 | (defmethod speak [::cat obj] [_ _] 93 | (println :meow)) 94 | 95 | (speak (atom nil :meta {:type ::cat}) 42) 96 | 97 | ;; (def gotten-obj (obj/get-obj)) 98 | -------------------------------------------------------------------------------- /test/tiltontec/its_alive/utility_test.clj: -------------------------------------------------------------------------------- 1 | (ns tiltontec.its-alive.utility-test 2 | (:require [clojure.test :refer :all] 3 | [clojure.set :refer [difference]] 4 | [tiltontec.its-alive.utility :refer :all])) 5 | 6 | (set! *print-level* 3) 7 | 8 | (deftest fake-cl 9 | (is (= 42 (prog1 42 43 44))) 10 | (is (= 42 (b-when x (+ 21 21) 11 | x))) 12 | (is (nil? (b-when x false 13 | 42))) 14 | (are [lst] (= 42 (cl-find 42 lst)) 15 | '(41 42 43) 16 | '(42 43 44) 17 | '(40 41 42)) 18 | 19 | (is (= 42 (unless (= 2 3) 42))) 20 | (is (nil? (unless (= 2 2) 42)))) 21 | 22 | (deftest setify 23 | (is (= #{1 2 3} (set-ify [1 1 2 2 3 3]))) 24 | (is (= #{1 2 3} (set-ify (list 1 1 2 2 3 3)))) 25 | (is (= #{} (set-ify nil))) 26 | (is (= #{42} (set-ify 42))) 27 | (is (= #{"bob"} (set-ify "bob"))) 28 | (is (= #{{:a 13}} (set-ify {:a 13}))) 29 | (is (= #{42} 30 | (difference (set-ify [1 2 42]) 31 | (set-ify (list 1 2)))))) 32 | 33 | (def-rmap-slots jj- boom) 34 | 35 | (deftest test-rmap 36 | (let [x (ref {:value 0 :boom 42})] 37 | (is (= 42 (jj-boom x))) 38 | (is (= 0 (:value @x))) 39 | (dosync (rmap-setf [:value x] 42)) 40 | (trx nil :xxx x @x (:value @x)) 41 | (is (= 42 (:value @x))) 42 | (is (let [j (dosync (rmap-setf [:value x] 43))] 43 | ;(trx nil :xxx x @x (:value @x)) 44 | ;(trx nil :j j (type j)) 45 | (= 43 j))) 46 | (is (= 44 (dosync (rmap-setf [:value x] 44)))) 47 | )) 48 | 49 | (deftest err-handling 50 | (is (thrown? Exception 51 | (err "boom"))) 52 | (is (thrown-with-msg? 53 | Exception 54 | #"oom" 55 | (err "boom"))) 56 | (is (thrown-with-msg? 57 | Exception 58 | #"Hi mom" 59 | (err format "Hi %s" 'mom))) 60 | (is (any-ref? (ref 42))) 61 | (are [x] (not (any-ref? x)) 62 | nil 63 | 42 64 | [] 65 | (atom 42)) 66 | (is (= "...... cool: 1, 2, 3\n:bingo\n" 67 | (with-out-str 68 | (binding [*trxdepth* 5] 69 | (wtrx (0 100 "cool" 1 2 3) 70 | (println :bingo)))))) 71 | (is (= ". test: 3\n.. test: 2\n... test: 1\n.... test: 0\n" 72 | (with-out-str 73 | (wtrx-test 3)))) 74 | ) 75 | 76 | (deftest fifo-build 77 | (let [q (make-fifo-queue)] 78 | (is (fifo-empty? q)) 79 | (is (nil? (fifo-peek q))) 80 | (is (nil? (fifo-pop q))) 81 | (is (empty? (fifo-data q))) 82 | (dosync 83 | (fifo-add q 1) 84 | (is (not (fifo-empty? q))) 85 | (is (= 1 (fifo-peek q))) 86 | (is (= 1 (fifo-pop q))) 87 | (is (fifo-empty? q))) 88 | (dosync 89 | (fifo-add q 1) 90 | (fifo-add q 2) 91 | (is (not (fifo-empty? q))) 92 | (is (= 1 (fifo-peek q))) 93 | (is (= 1 (fifo-pop q))) 94 | (is (= 2 (fifo-pop q))) 95 | (is (fifo-empty? q))))) 96 | 97 | 98 | #_ 99 | (deftest add-x-to-y-a-using-are 100 | (are [x y] (= 5 (add x y)) 101 | 2 3 102 | 1 4 103 | 3 2)) 104 | 105 | (deftest fifo-build 106 | (let [q (make-fifo-queue)] 107 | (is (fifo-empty? q)) 108 | (is (nil? (fifo-peek q))) 109 | (is (nil? (fifo-pop q))) 110 | (is (empty? (fifo-data q))) 111 | (dosync 112 | (fifo-add q 1) 113 | (is (not (fifo-empty? q))) 114 | (is (= 1 (fifo-peek q))) 115 | (is (= 1 (fifo-pop q))) 116 | (is (fifo-empty? q))) 117 | (dosync 118 | (fifo-add q 1) 119 | (fifo-add q 2) 120 | (is (not (fifo-empty? q))) 121 | (is (= 1 (fifo-peek q))) 122 | (is (= 1 (fifo-pop q))) 123 | (is (= 2 (fifo-pop q))) 124 | (is (fifo-empty? q))))) 125 | --------------------------------------------------------------------------------