[cells-cvs] CVS cells/cells-test
ktilton
ktilton at common-lisp.net
Tue Jun 20 14:16:45 UTC 2006
Update of /project/cells/cvsroot/cells/cells-test
In directory clnet:/tmp/cvs-serv24993/cells-test
Modified Files:
hello-world.lisp test-kid-slotting.lisp test.lisp
Log Message:
--- /project/cells/cvsroot/cells/cells-test/hello-world.lisp 2006/03/16 05:22:08 1.3
+++ /project/cells/cvsroot/cells/cells-test/hello-world.lisp 2006/06/20 14:16:45 1.4
@@ -24,15 +24,13 @@
(in-package :cells)
-(defmodel computer ()
- ((happen :cell :ephemeral :initform (c-in nil) :accessor happen)
- (location :cell t
- :initform (c? (case (^happen)
- (:leave :away)
- (:arrive :at-home)
- (t .cache))) ;; ie, unchanged
- :accessor location)
- (response :cell :ephemeral :initform nil :initarg :response :accessor response)))
+(defmd computer ()
+ (happen (c-in nil) :ephemeral)
+ (location (c? (case (^happen)
+ (:leave :away)
+ (:arrive :at-home)
+ (t .cache)))) ;; ie, unchanged
+ (response nil :ephemeral))
(defobserver response(self new-response old-response)
(when new-response
--- /project/cells/cvsroot/cells/cells-test/test-kid-slotting.lisp 2006/03/16 05:22:08 1.2
+++ /project/cells/cvsroot/cells/cells-test/test-kid-slotting.lisp 2006/06/20 14:16:45 1.3
@@ -24,33 +24,28 @@
(in-package :cells)
-(defmodel image (family)
- ((left :initform nil :initarg :left :accessor left)
- (top :initform nil :initarg :top :accessor top)
- (width :initform nil :initarg :width :accessor width)
- (height :initform nil :initarg :height :accessor height)
- ))
+(defmd image (family) left top width height)
(defun right (x) (+ (left x) (width x)))
(defun bottom (x) (+ (top x) (height x)))
-(defmodel stack (image)
- ((justify :initform :left :initarg :justify :accessor justify)
- (.kid-slots :initform (lambda (self)
- (declare (ignore self))
- (list
- (mk-kid-slot (left :if-missing t)
- (c? (+ (left .parent)
- (ecase (justify .parent)
- (:left 0)
- (:center (floor (- (width .parent) (^width)) 2))
- (:right (- (width .parent) (^width)))))))
- (mk-kid-slot (top)
- (c? (bif (psib (psib))
- (bottom psib)
- (top .parent))))))
- :accessor kid-slots
- :initarg :kid-slots)))
+(defmd stack (image)
+ justify
+ (.kid-slots :initform (lambda (self)
+ (declare (ignore self))
+ (list
+ (mk-kid-slot (left :if-missing t)
+ (c? (+ (left .parent)
+ (ecase (justify .parent)
+ (:left 0)
+ (:center (floor (- (width .parent) (^width)) 2))
+ (:right (- (width .parent) (^width)))))))
+ (mk-kid-slot (top)
+ (c? (bif (psib (psib))
+ (bottom psib)
+ (top .parent))))))
+ :accessor kid-slots
+ :initarg :kid-slots))
;;
;; kid-slotting exists largely so graphical containers can be defined which arrange their
;; component parts without those parts' cooperation. so a stack class can be defined as shown
--- /project/cells/cvsroot/cells/cells-test/test.lisp 2006/06/13 05:05:14 1.6
+++ /project/cells/cvsroot/cells/cells-test/test.lisp 2006/06/20 14:16:45 1.7
@@ -65,7 +65,6 @@
(defvar *cell-tests* nil)
-
#+go
(test-cells)
@@ -99,12 +98,10 @@
;; test huge number of useds by one rule
-(defmodel m-index (family)
- ()
- (:default-initargs
- :md-value (c? (bwhen (ks (^kids))
- ;(trc "chya" (mapcar 'md-value ks))
- (apply '+ (mapcar 'md-value ks))))))
+(defmd m-index (family)
+ :md-value (c? (bwhen (ks (^kids))
+ ;(trc "chya" (mapcar 'md-value ks))
+ (apply '+ (mapcar 'md-value ks)))))
(def-cell-test many-useds
(let ((i (make-instance 'm-index)))
@@ -119,18 +116,18 @@
#+test
(many-useds)
-(defmodel m-null ()
- ((aa :initform nil :cell nil :initarg :aa :accessor aa)))
+(defmd m-null ()
+ (aa :cell nil :initform nil :initarg :aa :accessor aa))
+
(def-cell-test m-null
(let ((m (make-instance 'm-null :aa 42)))
(ct-assert (= 42 (aa m)))
- (ct-assert (= 21 (decf (aa m) 21)))
+ (ct-assert (= 21 (let ((slot 'aa))
+ (funcall (fdefinition `(setf ,slot)) (- (aa m) 21) m))))
:okay-m-null))
-(defmodel m-solo ()
- ((m-solo-a :initform nil :initarg :m-solo-a :accessor m-solo-a)
- (m-solo-b :initform nil :initarg :m-solo-b :accessor m-solo-b)))
+(defmd m-solo () m-solo-a m-solo-b)
(def-cell-test m-solo
(let ((m (make-instance 'm-solo
@@ -143,9 +140,7 @@
(ct-assert (= 82 (m-solo-b m)))
:okay-m-null))
-(defmodel m-var ()
- ((m-var-a :initform nil :initarg :m-var-a :accessor m-var-a)
- (m-var-b :initform nil :initarg :m-var-b :accessor m-var-b)))
+(defmd m-var () m-var-a m-var-b)
(defobserver m-var-b ()
(print `(output m-var-b ,self ,new-value ,old-value)))
@@ -157,9 +152,9 @@
(ct-assert (= 21 (m-var-a m)))
:okay-m-var))
-(defmodel m-var-output ()
- ((cbb :initform nil :initarg :cbb :accessor cbb)
- (aa :cell nil :initform nil :initarg :aa :accessor aa)))
+(defmd m-var-output ()
+ cbb
+ (aa :cell nil :initform nil :initarg :aa :accessor aa))
(defobserver cbb ()
(trc "output cbb" self)
@@ -175,9 +170,7 @@
(ct-assert (eql -15 (aa m)))
(list :okay-m-var (aa m))))
-(defmodel m-var-linearize-setf ()
- ((ccc :initform nil :initarg :ccc :accessor ccc)
- (ddd :initform nil :initarg :ddd :accessor ddd)))
+(defmd m-var-linearize-setf () ccc ddd)
(defobserver ccc ()
(with-integrity (:change)
@@ -198,9 +191,9 @@
;;; -------------------------------------------------------
-(defmodel m-ruled ()
- ((eee :initform nil :initarg :eee :accessor eee)
- (fff :initform (c? (floor (^ccc) 2)) :initarg :fff :accessor fff)))
+(defmd m-ruled ()
+ eee
+ (fff (c? (floor (^ccc) 2))))
(defobserver eee ()
(print `(output> eee ,new-value old ,old-value)))
@@ -222,15 +215,15 @@
(ct-assert (= 18 (fff m)) m)
:okay-m-ruled))
-(defmodel m-worst-case ()
- ((wc-x :accessor wc-x :initform (c-input () 2))
- (wc-a :accessor wc-a :initform (c? (prog2
- (trc "Start A")
- (when (oddp (wc-x self))
- (wc-c self))
- (trc "Stop A"))))
- (wc-c :accessor wc-c :initform (c? (evenp (wc-x self))))
- (wc-h :accessor wc-h :initform (c? (or (wc-c self)(wc-a self))))))
+(defmd m-worst-case ()
+ (wc-x (c-input () 2))
+ (wc-a (c? (prog2
+ (trc "Start A")
+ (when (oddp (wc-x self))
+ (wc-c self))
+ (trc "Stop A"))))
+ (wc-c (c? (evenp (wc-x self))))
+ (wc-h (c? (or (wc-c self)(wc-a self)))))
(defun dependency-dump (self)
(let ((slot-cells (loop for esd in (class-slots (class-of self))
@@ -252,10 +245,9 @@
(dependency-dump m)
(ct-assert (eql 3 (incf (wc-x m))))))
-(defmodel c?n-class ()
- ((aaa :initarg :aaa :accessor aaa)
- (bbb :initarg :bbb :accessor bbb)
- (sum :initarg :sum :accessor sum :initform (c? (+ (^aaa) (^bbb))))))
+(defmd c?n-class ()
+ aaa bbb
+ (sum (c? (+ (^aaa) (^bbb)))))
(def-cell-test test-c?n ()
(let ((self (make-instance 'c?n-class
More information about the Cells-cvs
mailing list