[cells-gtk-cvs] CVS cells/cells-test
pdenno
pdenno at common-lisp.net
Wed Jun 7 16:28:57 UTC 2006
Update of /project/cells-gtk/cvsroot/cells/cells-test
In directory clnet:/tmp/cvs-serv32368/cells-test
Added Files:
boiler-examples.lisp build-sys.lisp df-interference.lisp
echo-setf.lisp hello-world-q.lisp hello-world.lisp
internal-combustion.lisp lazy-propagation.lisp
output-setf.lisp person.lisp synapse-testing.lisp
test-cyclicity.lisp test-family.lisp test-kid-slotting.lisp
test-lazy.lisp test.lisp
Log Message:
new files
--- /project/cells-gtk/cvsroot/cells/cells-test/boiler-examples.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/boiler-examples.lisp 2006/06/07 16:28:57 1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
;;;
;;;
;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is furnished
;;; to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;; IN THE SOFTWARE.
(in-package :cells)
;;
;; OK, nothing new here, just some old example code I found lying around. FWIW...
;;
(defmodel boiler1 ()
((id :cell nil :initarg :id :accessor id :initform (random 1000000))
(status :initarg :status :accessor status :initform nil) ;; vanilla cell
(temp :initarg :temp :accessor temp :initform nil)
(vent :initarg :vent :accessor vent :initform nil)
))
(defun boiler-1 ()
;; resets debugging/testing specials
(cell-reset)
(let ((b (make-instance 'boiler1
:temp (c-in 20)
:status (c? (if (< (temp self) 100)
:on
:off))
:vent (c? (ecase (^status) ;; expands to (status self) and also makes coding synapses convenient
(:on :open)
(:off :closed))))))
(cv-assert (eql 20 (temp b)))
(cv-assert (eql :on (status b)))
(cv-assert (eql :open (vent b)))
(setf (temp b) 100) ;; triggers the recalculation of status and then of vent
(cv-assert (eql 100 (temp b)))
(cv-assert (eql :off (status b)))
(cv-assert (eql :closed (vent b)))
))
#+test
(boiler-1)
;
; now let's see how output functions can be used...
; and let's also demonstrate inter-object dependency by
; separating out the thermometer
;
;;; note that thermometer is just a regular slot, it is
;;; not cellular.
(defmodel boiler2 ()
((status :initarg :status :accessor status :initform nil)
(vent :initarg :vent :accessor vent :initform nil)
(thermometer :cell nil :initarg :thermometer :accessor thermometer :initform nil)
))
;;; def-c-output ((slot-name) (&optional method-args) &body body
;;; the def-c-output macro defines a method with
;;; three arguments -- by default, these arguments are named
;;; self -- bound to the instance being operated on
;;; old-value -- bound to the previous value of the cellular slot
;;; named slot-name, of the instance being operated on.
;;; new-value -- bound to the new value of said cellular slot
;;; (this is why the variables self, old-value, and new-value can exist
;;; below in the body, when it appears they are not defined in any
;;; lexical scope)
;;; the body of the macro defines code which is executed
;;; when the the slot-name slot is initialized or changed.
(def-c-output status ((self boiler2))
(trc "output> boiler status" self :oldstatus= old-value :newstatus= new-value)
;
; << in real life call boiler api here to actually turn it on or off >>
;
)
(def-c-output vent ((self boiler2))
(trc "output> boiler vent changing from" old-value :to new-value)
;
; << in real life call boiler api here to actually open or close it >>
;
)
(defmodel quiet-thermometer ()
((temp :initarg :temp :accessor temp :initform nil)
))
(defmodel thermometer (quiet-thermometer)())
;;; notice instead of oldvalue and newvalue, here the
;;; old and new values are bound to parameters called oldtemp
;;; and newtemp
(def-c-output temp ((self thermometer) newtemp oldtemp)
(trc "output> thermometer temp changing from" oldtemp :to newtemp))
;--------------------------
;;; here we introduce the to-be-primary construct, which causes
;;; immediate initialization of cellular slots.
;;; notice how the status cell of a boiler2 can depend
;;; on the temp slot of a thermometer, illustrating how
;;; dependencies can be made between the cellular slots of
;;; instances of different classes.
(defun boiler-2 ()
(cell-reset)
(let ((b (make-instance 'boiler2
:status (c? (eko ("boiler2 status c?")
(if (< (temp (thermometer self)) 100)
:on :off)))
:vent (c? (ecase (^status)
(:on :open)
(:off :closed)))
:thermometer (make-instance 'thermometer
:temp (c-in 20)))))
(cv-assert (eql 20 (temp (thermometer b))))
(cv-assert (eql :on (status b)))
(cv-assert (eql :open (vent b)))
(setf (temp (thermometer b)) 100)
(cv-assert (eql 100 (temp (thermometer b))))
(cv-assert (eql :off (status b)))
(cv-assert (eql :closed (vent b)))
))
#+test
(boiler-2)
;;; ***********************************************
;;; ***********************************************
;;; ***********************************************
#| intro to cells, example 3 |#
;;; ***********************************************
;;; ***********************************************
;;; ***********************************************
;;; note: we use boiler2 and thermometer from example 2 in example 3,
;;; along with their def-output methods defined in example 2.
;;;
;;; also: these do not use cv-assert to perform automatic testing, but
;;; they do illustrate a possible real-world application of synapses. to
;;; observe the difference made by synapses, one must look at the trace output
;
; now let's look at synapses, which mediate a dependency between two cells.
; the example here has an input argument (sensitivity-enabled) which when
; enables gives the temp cell an (fsensitivity 0.05) clause.
; the example simulates a thermometer perhaps
; malfunctioning which is sending streams of values randomly plus or minus
; two-hundredths of a degree. does not sound serious, except...
;
; if you run the example as is, when the temperature gets to our on/off threshhold
; of 100, chances are you will see the boiler toggle itself on and off several times
; before the temperature moves away from 100.
;
; building maintenance personel will report this odd behavior, probably hearing the
; vent open and shut and open again several times in quick succession.
; the problem is traced to the cell rule which reacts too slavishly to the stream
; of temperature values. a work order is cut to replace the thermometer, and to reprogram
; the controller not to be so slavish. there are lots of ways to solve this; here if
; you enable sensitivity by running example 4 you can effectively place a synapse between the
; temperature cell of the thermometer and the status cell of the boiler which
; does not even trigger the status cell unless the received value differs by the
; specified amount from the last value which was actually relayed.
; now the boiler simply cuts off as the temperature passes 100, and stays off even if
; the thermometer temperature goes to 99.98. the trace output shows that although the temperature
; of the thermometer is changing, only occasionally does the rule to decide the boiler
; status get kicked off.
;
(defun boiler-3 (&key (sensitivity-enabled t))
(declare (ignorable sensitivity-enabled))
(cell-reset)
#+soon
(let ((b (make-instance 'boiler2
:status (c? (let ((temp (if sensitivity-enabled
(temp (thermometer self) (f-sensitivity 0.05))
(temp (thermometer self)))))
;;(trc "status c? sees temp" temp)
(if (< temp 100) :on :off)
))
:vent (c? (ecase (^status) (:on :open) (:off :closed)))
:thermometer (make-instance 'quiet-thermometer :temp (c-in 20))
)))
;
; let's simulate a thermometer which, when the temperature is actually
; any given value t will indicate randomly anything in the range
; t plus/minus 0.02. no big deal unless the actual is exactly our
; threshold point of 100...
;
(dotimes (x 4)
;;(trc "top> ----------- set base to" (+ 98 x))
(dotimes (y 10)
(let ((newtemp (+ 98 x (random 0.04) -.02))) ;; force random variation around (+ 98 x)
;;(trc "top> ----------- set temp to" newtemp)
(setf (temp (thermometer b)) newtemp))))))
(defun boiler-4 () (boiler-3 :sensitivity-enabled t))
;;
;; de-comment 'trc statements above to see what is happening
;;
#+test
(boiler-3)
#+test
(boiler-4)
(defun boiler-5 ()
(cell-reset)
#+soon
(let ((b (make-instance 'boiler2
:status (c-in :off)
:vent (c? (trc "caculating vent" (^status))
(if (eq (^status) :on)
(if (> (temp (thermometer self) (f-debug 3)) 100)
:open :closed)
:whatever-off))
:thermometer (make-instance 'quiet-thermometer
:temp (c-in 20)))))
(dotimes (x 4)
(dotimes (n 4)
(incf (temp (thermometer b))))
(setf (status b) (case (status b) (:on :off)(:off :on))))))
#+test
(boiler-5)
(defun f-debug (sensitivity &optional subtypename)
(declare (ignore sensitivity subtypename))
#+soon
(mk-synapse (prior-fire-value)
:fire-p (lambda (syn new-value)
(declare (ignorable syn))
(eko ("fire-p decides" prior-fire-value sensitivity)
(delta-greater-or-equal
(delta-abs (delta-diff new-value prior-fire-value subtypename) subtypename)
(delta-abs sensitivity subtypename)
subtypename)))
:fire-value (lambda (syn new-value)
(declare (ignorable syn))
(eko ("f-sensitivity relays")
(setf prior-fire-value new-value)) ;; no modulation of value, but do record for next time
)))--- /project/cells-gtk/cvsroot/cells/cells-test/build-sys.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/build-sys.lisp 2006/06/07 16:28:57 1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*-
;;;
;;; Copyright © 1995,2003 by Kenneth William Tilton.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is furnished
;;; to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;; IN THE SOFTWARE.
(defpackage #:cells-build-package
(:use #:cl))
(in-package #:cells-build-package)
(defun build-sys (system$ &key source-directory force)
(let (
;;; --------------------------------------
;;; Step 2: Implementation-specific issues
;;;
;;; Let's assume this is fixed in CMUCL 19a, and fix it later if need be.
#+cmu18
(ext:*derive-function-types* nil)
#+lispworks
(hcl::*handle-existing-defpackage* (list :add))
)
;;----------------------------------------
;; source-directory validation...
;;
(assert (pathnamep source-directory)
(source-directory)
"source-directory not supplied, please edit build.lisp to specify the location of the source.")
(let ((project-asd (merge-pathnames (format nil "~a.asd" system$)
source-directory)))
(unless (probe-file project-asd)
(error "~a not found. revise build.lisp if asd file is somewhere else." project-asd)))
;;;----------------------------------
;;; ok. build...
;;;
(push source-directory asdf:*central-registry*)
(asdf:operate 'asdf:load-op (intern system$ :keyword) :force force)))--- /project/cells-gtk/cvsroot/cells/cells-test/df-interference.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/df-interference.lisp 2006/06/07 16:28:57 1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
;;;
;;;
;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is furnished
;;; to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;; IN THE SOFTWARE.
(in-package :cells)
(defvar *eex* 0)
(defmodel xx3 ()
((aa :initform (c-in 0) :initarg :aa :accessor aa)
(dd :initform (c? (min 0 (+ (^cc) (^bb)))) :initarg :dd :accessor dd)
(ddx :initform (c? (+ (^cc) (^bb))) :initarg :ddx :accessor ddx)
(cc :initform (c? (+ (^aa) (^bb))) :initarg :cc :reader cc)
(bb :initform (c? (* 2 (^aa))) :initarg :bb :accessor bb)
(ee :initform (c? (+ (^aa) (^dd))) :initarg :ee :reader ee)
(eex :initform (c? (trc "in rule of eex, *eex* now" *eex*)
(+ (^aa) (^ddx))) :initarg :eex :reader eex)
))
(def-c-output aa ((self xx3))
(trc nil "output aa:" new-value))
(def-c-output bb ((self xx3))
(trc nil "output bb:" new-value))
(def-c-output cc ((self xx3))
(trc nil "output cc:" new-value))
(def-c-output dd ((self xx3))
(trc nil "output dd:" new-value))
(def-c-output ee ((self xx3))
(trc nil "output ee:" new-value))
[66 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/echo-setf.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/echo-setf.lisp 2006/06/07 16:28:57 1.1
[113 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/hello-world-q.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/hello-world-q.lisp 2006/06/07 16:28:57 1.1
[194 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/hello-world.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/hello-world.lisp 2006/06/07 16:28:57 1.1
[272 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/internal-combustion.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/internal-combustion.lisp 2006/06/07 16:28:57 1.1
[632 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/lazy-propagation.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/lazy-propagation.lisp 2006/06/07 16:28:57 1.1
[714 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/output-setf.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/output-setf.lisp 2006/06/07 16:28:57 1.1
[771 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/person.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/person.lisp 2006/06/07 16:28:57 1.1
[1077 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/synapse-testing.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/synapse-testing.lisp 2006/06/07 16:28:57 1.1
[1154 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/test-cyclicity.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/test-cyclicity.lisp 2006/06/07 16:28:57 1.1
[1248 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/test-family.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/test-family.lisp 2006/06/07 16:28:57 1.1
[1406 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/test-kid-slotting.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/test-kid-slotting.lisp 2006/06/07 16:28:57 1.1
[1495 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/test-lazy.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/test-lazy.lisp 2006/06/07 16:28:57 1.1
[1614 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/test.lisp 2006/06/07 16:28:57 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/test.lisp 2006/06/07 16:28:57 1.1
[1754 lines skipped]
More information about the Cells-gtk-cvs
mailing list