[cells-gtk-cvs] CVS cells
pdenno
pdenno at common-lisp.net
Wed Jun 7 16:23:32 UTC 2006
Update of /project/cells-gtk/cvsroot/cells
In directory clnet:/tmp/cvs-serv32090
Added Files:
cell-types.lisp cells-test.asd cells.asd 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 optimization.lisp
propagate.lisp slot-utilities.lisp synapse-types.lisp
synapse.lisp test.lisp
Log Message:
new files
--- /project/cells-gtk/cvsroot/cells/cell-types.lisp 2006/06/07 16:23:31 NONE
+++ /project/cells-gtk/cvsroot/cells/cell-types.lisp 2006/06/07 16:23:31 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)
(defstruct (cell (:conc-name c-))
model
slot-name
value
inputp ;; t for old c-variable class
cyclicp ;; t if OK for setf to cycle back (ending cycle)
synaptic
changed
(users nil :type list)
(state :nascent :type symbol) ;; :nascent, :awake, :optimized-away
(value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :valid}
(pulse 0 :type fixnum)
debug
md-info)
(defun c-unboundp (c)
(eql :unbound (c-value-state c)))
; -----------------------------------------------------
(defun c-validate (self c)
(when (not (and (c-slot-name c) (c-model c)))
(format t "~&unadopted cell: ~s md:~s" c self)
(c-break "unadopted cell ~a ~a" self c)
(error 'c-unadopted :cell c)))
(defstruct (c-ruled
(:include cell)
(:conc-name cr-))
lazy
(code nil :type list) ;; /// feature this out on production build
rule)
(defun c-optimized-away-p (c)
(eql :optimized-away (c-state c)))
(defmethod c-lazy ((c c-ruled)) (cr-lazy c))
(defmethod c-lazy (c) (declare (ignore c)) nil)
;----------------------------
(defmethod trcp-slot (self slot-name)
(declare (ignore self slot-name)))
(define-constant *cd-usagect* 64)
(defstruct (c-dependent
(:include c-ruled)
(:conc-name cd-))
(synapses nil :type list)
(useds nil :type list)
(usage (make-array *cd-usagect* :element-type 'bit
:initial-element 0) :type vector))
(defstruct (c-stream
(:include c-dependent)
(:conc-name cs-))
values)
(defstruct streamer from stepper donep to)
#+notyet
(defmacro c~~~ (&key (from 0)
stepper
(donep (c-lambda (> .cache (streamer-to slot-c))))
to)
`(make-c-stream
:rule (c-lambda (make-streamer
:from ,from
:stepper ,stepper
:to ,to :donep ,donep))))
(defmethod md-slot-value-assume :around ((c c-stream) (s streamer))
(bif (to (streamer-to s))
(loop for slot-value = (streamer-from s)
then (bIf (stepper (streamer-stepper s))
(funcall stepper c)
(incf slot-value))
until (bIf (to (streamer-to s))
(> slot-value to)
(bwhen (donep-test (streamer-donep s))
(funcall donep-test c)))
do (progn
(print `(assume doing ,slot-value))
(call-next-method c slot-value))))
(c-optimize-away?! c))
#+test
(progn
(defmodel streamertest ()
((val :accessor val :initform (c~~~ :from 0 :to (^oval)))
(oval :initarg :oval :accessor oval :initform (c-in 0))))
(def-c-output val ((self streamertest))
(print `(streamertest old ,old-value new ,new-value)))
(cell-reset)
(let ((it (make-be 'streamertest :oval 5)))
;;(setf (oval it) 5)
it))
(defstruct (c-drifter
(:include c-dependent)))
(defstruct (c-drifter-absolute
(:include c-drifter)))
;_____________________ accessors __________________________________
(defmethod c-useds (other) (declare (ignore other)))
(defmethod c-useds ((c c-dependent)) (cd-useds c))
(defun c-validp (c)
(eql (c-value-state c) :valid))
;_____________________ print __________________________________
(defmethod print-object :before ((c cell) stream)
(declare (ignorable c))
(format stream "[~a~a:" (if (c-inputp c) "i" "?")
(cond
((null (c-model c)) #\0)
((eq :eternal-rest (md-state (c-model c))) #\_)
((not (c-currentp c)) #\#)
(t #\space))))
(defmethod print-object ((c cell) stream)
(c-print-value c stream)
(format stream "=[~d]~a/~a]"
(c-pulse c)
(symbol-name (or (c-slot-name c) :anoncell))
(or (c-model c) :anonmd)))
;__________________
(defmethod c-print-value ((c c-ruled) stream)
(format stream "~a" (cond ((c-validp c) "<vld>")
((c-unboundp c) "<unb>")
((not (c-currentp c)) "<obs>")
(t "<err>"))))
(defmethod c-print-value (c stream)
(declare (ignore c stream)))
--- /project/cells-gtk/cvsroot/cells/cells-test.asd 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test.asd 2006/06/07 16:23:32 1.1
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
#+(or allegro lispworks cmu mcl clisp cormanlispx sbcl scl)
(progn
(asdf:defsystem :cells-test
:name "cells-test"
:author "Kenny Tilton <ktilton at nyc.rr.com>"
:version "05-Nov-2003"
:maintainer "Kenny Tilton <ktilton at nyc.rr.com>"
:licence "MIT Style"
:description "Cells Regression Test/Documentation"
:long-description "Informatively-commented regression tests for Cells"
:serial t
:depends-on (:cells)
:components ((:module "cells-test"
:components ((:file "test")
(:file "hello-world")
(:file "internal-combustion")
(:file "boiler-examples")
(:file "person")
(:file "df-interference")
(:file "test-family")
(:file "test-kid-slotting")
(:file "lazy-propagation")
(:file "output-setf")
(:file "test-lazy")
(:file "synapse-testing")))))
(defmethod perform :after ((op load-op) (system (eql (find-system :cells-test))))
(cells::cv-test))
)--- /project/cells-gtk/cvsroot/cells/cells.asd 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/cells.asd 2006/06/07 16:23:32 1.1
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
#+(or allegro lispworks cmu mcl clisp cormanlisp sbcl scl)
(progn
(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
(asdf:defsystem :cells
:name "cells"
:author "Kenny Tilton <ktilton at nyc.rr.com>"
:version "18-Oct-2004"
:maintainer "Kenny Tilton <ktilton at nyc.rr.com>"
:licence "MIT Style"
:description "Cells"
:long-description "The Cells dataflow extension to CLOS."
:components ((:module "utils-kt"
:components ((:file "defpackage")
(:file "debug")
(:file "detritus")
(:file "flow-control")
(:file "strings")))
(:file "defpackage" :depends-on ("utils-kt"))
(:file "cells" :depends-on ("defpackage"))
(:file "cell-types" :depends-on ("defpackage"))
(:file "integrity" :depends-on ("cell-types" "cells"))
(:file "constructors" :depends-on ("integrity" "cells"))
(:file "initialize" :depends-on ("cells" "cell-types"))
(:file "md-slot-value" :depends-on ("integrity" "cell-types"))
(:file "slot-utilities" :depends-on ("cells"))
(:file "optimization" :depends-on ("cells"))
(:file "link" :depends-on ("cells"))
(:file "propagate" :depends-on ("cells" "integrity"))
(:file "synapse" :depends-on ("cells"))
(:file "synapse-types" :depends-on ("cells"))
(:file "model-object" :depends-on ("defpackage"))
(:file "defmodel" :depends-on ("model-object" "propagate" "constructors"))
(:file "md-utilities" :depends-on ("cells"))
(:file "family" :depends-on ("defmodel"))
(:file "fm-utilities" :depends-on ("cells"))
(:file "family-values" :depends-on ("family" "propagate" "defmodel" ))
(:file "test" :depends-on ("family"))
))
(defmethod perform ((o load-op) (c (eql (find-system :cells))))
(pushnew :cells *features*))
(defmethod perform ((o test-op) (c (eql (find-system :cells))))
(oos 'load-op :cells-test))
(defmethod perform ((o test-op) (c (eql :cells)))
(oos 'load-op :cells-test))
)--- /project/cells-gtk/cvsroot/cells/cells.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/cells.lisp 2006/06/07 16:23:32 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.
;;;(eval-when (compile load)
;;; (proclaim '(optimize (speed 1) (safety 1) (space 1) (debug 2))))
(eval-when (compile load)
(proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))))
(in-package :cells)
(define-constant *c-optimizep* t)
(defparameter *c-prop-depth* 0)
(defparameter *causation* nil)
(defparameter *data-pulse-id* 0)
(defparameter *data-pulses* nil)
(defparameter *unfinished-business* nil)
(defparameter *c-debug* nil)
(defun cell-reset ()
(utils-kt-reset)
(setf
*c-debug* nil
*c-prop-depth* 0
*data-pulse-id* 0
*data-pulses* nil
*unfinished-business* nil)
(trc nil "------ cell reset ----------------------------"))
(defun c-stop (&optional why)
(format t "~&C-STOP> stopping because ~a" why)
(setf *stop* t))
(define-symbol-macro .stop
(c-stop :user))
(defun c-stopped ()
*stop*)
(defmacro c-assert (assertion &optional places fmt$ &rest fmt-args)
(declare (ignore places))
`(unless *stop*
(unless ,assertion
,(if fmt$
`(c-break ,fmt$ , at fmt-args)
`(c-break "failed assertion: ~a" ',assertion)))))
(defvar *c-calculators* nil)
(defmacro s-sib-no () `(position self (kids .parent)))
(defmacro gpar ()
`(fm-grandparent self))
(defmacro nearest (self-form type)
(let ((self (gensym)))
`(bwhen (,self ,self-form)
(if (typep ,self ',type) ,self (upper ,self ,type)))))
(defmacro def-c-trace (model-type &optional slot cell-type)
`(defmethod trcp ((self ,(case cell-type
(:c? 'c-dependent)
(otherwise 'cell))))
(and (typep (c-model self) ',model-type)
,(if slot
`(eq (c-slot-name self) ',slot)
`t))))
(defmacro without-c-dependency (&body body)
`(let (*c-calculators*) , at body))
(define-symbol-macro .cause
(car *causation*))
(define-condition unbound-cell (unbound-slot) ())
(defgeneric c-output-slot-name (slotname self new old old-boundp)
#-(or cormanlisp clisp)
(:method-combination progn))
#-cells-testing
(defmethod c-output-slot-name #-(or cormanlisp clisp) progn
(slot-name self new old old-boundp)
(declare (ignorable slot-name self new old old-boundp)))
; -------- cell conditions (not much used) ---------------------------------------------
(define-condition xcell () ;; new 2k0227
((cell :initarg :cell :reader cell :initform nil)
(app-func :initarg :app-func :reader app-func :initform 'bad-cell)
(error-text :initarg :error-text :reader error-text :initform "<???>")
(other-data :initarg :other-data :reader other-data :initform "<nootherdata>"))
(:report (lambda (c s)
(format s "~& trouble with cell ~a in function ~s,~s: ~s"
(cell c) (app-func c) (error-text c) (other-data c)))))
(define-condition c-enabling ()
((name :initarg :name :reader name)
(model :initarg :model :reader model)
(cell :initarg :cell :reader cell))
(:report (lambda (condition stream)
(format stream "~&unhandled <c-enabling>: ~s" condition)
(break "~&i say, unhandled <c-enabling>: ~s" condition))))
(define-condition c-fatal (xcell)
((name :initarg :name :reader name)
(model :initarg :model :reader model)
(cell :initarg :cell :reader cell))
(:report (lambda (condition stream)
(format stream "~&fatal cell programming error: ~s" condition)
(format stream "~& : ~s" (name condition))
(format stream "~& : ~s" (model condition))
(format stream "~& : ~s" (cell condition)))))
(define-condition c-unadopted (c-fatal)
()
(:report
(lambda (condition stream)
(format stream "~&unadopted cell >: ~s" (cell condition))
(format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error"))))
(defun c-break (&rest args)
[8 lines skipped]
--- /project/cells-gtk/cvsroot/cells/constructors.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/constructors.lisp 2006/06/07 16:23:32 1.1
[145 lines skipped]
--- /project/cells-gtk/cvsroot/cells/defmodel.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/defmodel.lisp 2006/06/07 16:23:32 1.1
[270 lines skipped]
--- /project/cells-gtk/cvsroot/cells/defpackage.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/defpackage.lisp 2006/06/07 16:23:32 1.1
[333 lines skipped]
--- /project/cells-gtk/cvsroot/cells/family-values.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/family-values.lisp 2006/06/07 16:23:32 1.1
[434 lines skipped]
--- /project/cells-gtk/cvsroot/cells/family.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/family.lisp 2006/06/07 16:23:32 1.1
[677 lines skipped]
--- /project/cells-gtk/cvsroot/cells/fm-utilities.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/fm-utilities.lisp 2006/06/07 16:23:32 1.1
[1234 lines skipped]
--- /project/cells-gtk/cvsroot/cells/initialize.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/initialize.lisp 2006/06/07 16:23:32 1.1
[1331 lines skipped]
--- /project/cells-gtk/cvsroot/cells/integrity.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/integrity.lisp 2006/06/07 16:23:32 1.1
[1493 lines skipped]
--- /project/cells-gtk/cvsroot/cells/link.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/link.lisp 2006/06/07 16:23:32 1.1
[1646 lines skipped]
--- /project/cells-gtk/cvsroot/cells/md-slot-value.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/md-slot-value.lisp 2006/06/07 16:23:32 1.1
[1858 lines skipped]
--- /project/cells-gtk/cvsroot/cells/md-utilities.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/md-utilities.lisp 2006/06/07 16:23:32 1.1
[1964 lines skipped]
--- /project/cells-gtk/cvsroot/cells/model-object.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/model-object.lisp 2006/06/07 16:23:32 1.1
[2126 lines skipped]
--- /project/cells-gtk/cvsroot/cells/optimization.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/optimization.lisp 2006/06/07 16:23:32 1.1
[2191 lines skipped]
--- /project/cells-gtk/cvsroot/cells/propagate.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/propagate.lisp 2006/06/07 16:23:32 1.1
[2372 lines skipped]
--- /project/cells-gtk/cvsroot/cells/slot-utilities.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/slot-utilities.lisp 2006/06/07 16:23:32 1.1
[2469 lines skipped]
--- /project/cells-gtk/cvsroot/cells/synapse-types.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/synapse-types.lisp 2006/06/07 16:23:32 1.1
[2617 lines skipped]
--- /project/cells-gtk/cvsroot/cells/synapse.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/synapse.lisp 2006/06/07 16:23:32 1.1
[2718 lines skipped]
--- /project/cells-gtk/cvsroot/cells/test.lisp 2006/06/07 16:23:32 NONE
+++ /project/cells-gtk/cvsroot/cells/test.lisp 2006/06/07 16:23:32 1.1
[2885 lines skipped]
More information about the Cells-gtk-cvs
mailing list