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@nyc.rr.com" :version "05-Nov-2003" :maintainer "Kenny Tilton ktilton@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@nyc.rr.com" :version "18-Oct-2004" :maintainer "Kenny Tilton ktilton@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$ ,@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*) ,@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]
-
pdenno