/[cells-gtk]/cells/cell-types.lisp
ViewVC logotype

Contents of /cells/cell-types.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed Jun 7 16:23:31 2006 UTC (7 years, 10 months ago) by pdenno
Branch: MAIN
CVS Tags: HEAD
new files
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 (defstruct (cell (:conc-name c-))
26 model
27 slot-name
28 value
29
30 inputp ;; t for old c-variable class
31 cyclicp ;; t if OK for setf to cycle back (ending cycle)
32 synaptic
33 changed
34 (users nil :type list)
35
36 (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away
37 (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :valid}
38 (pulse 0 :type fixnum)
39 debug
40 md-info)
41
42 (defun c-unboundp (c)
43 (eql :unbound (c-value-state c)))
44
45 ; -----------------------------------------------------
46
47 (defun c-validate (self c)
48 (when (not (and (c-slot-name c) (c-model c)))
49 (format t "~&unadopted cell: ~s md:~s" c self)
50 (c-break "unadopted cell ~a ~a" self c)
51 (error 'c-unadopted :cell c)))
52
53 (defstruct (c-ruled
54 (:include cell)
55 (:conc-name cr-))
56 lazy
57 (code nil :type list) ;; /// feature this out on production build
58 rule)
59
60 (defun c-optimized-away-p (c)
61 (eql :optimized-away (c-state c)))
62
63 (defmethod c-lazy ((c c-ruled)) (cr-lazy c))
64 (defmethod c-lazy (c) (declare (ignore c)) nil)
65
66 ;----------------------------
67
68 (defmethod trcp-slot (self slot-name)
69 (declare (ignore self slot-name)))
70
71 (define-constant *cd-usagect* 64)
72
73 (defstruct (c-dependent
74 (:include c-ruled)
75 (:conc-name cd-))
76 (synapses nil :type list)
77 (useds nil :type list)
78 (usage (make-array *cd-usagect* :element-type 'bit
79 :initial-element 0) :type vector))
80
81 (defstruct (c-stream
82 (:include c-dependent)
83 (:conc-name cs-))
84 values)
85
86 (defstruct streamer from stepper donep to)
87
88 #+notyet
89 (defmacro c~~~ (&key (from 0)
90 stepper
91 (donep (c-lambda (> .cache (streamer-to slot-c))))
92 to)
93 `(make-c-stream
94 :rule (c-lambda (make-streamer
95 :from ,from
96 :stepper ,stepper
97 :to ,to :donep ,donep))))
98
99 (defmethod md-slot-value-assume :around ((c c-stream) (s streamer))
100 (bif (to (streamer-to s))
101 (loop for slot-value = (streamer-from s)
102 then (bIf (stepper (streamer-stepper s))
103 (funcall stepper c)
104 (incf slot-value))
105 until (bIf (to (streamer-to s))
106 (> slot-value to)
107 (bwhen (donep-test (streamer-donep s))
108 (funcall donep-test c)))
109 do (progn
110 (print `(assume doing ,slot-value))
111 (call-next-method c slot-value))))
112 (c-optimize-away?! c))
113
114 #+test
115 (progn
116 (defmodel streamertest ()
117 ((val :accessor val :initform (c~~~ :from 0 :to (^oval)))
118 (oval :initarg :oval :accessor oval :initform (c-in 0))))
119
120 (def-c-output val ((self streamertest))
121 (print `(streamertest old ,old-value new ,new-value)))
122
123 (cell-reset)
124 (let ((it (make-be 'streamertest :oval 5)))
125 ;;(setf (oval it) 5)
126 it))
127
128 (defstruct (c-drifter
129 (:include c-dependent)))
130
131 (defstruct (c-drifter-absolute
132 (:include c-drifter)))
133
134 ;_____________________ accessors __________________________________
135
136 (defmethod c-useds (other) (declare (ignore other)))
137 (defmethod c-useds ((c c-dependent)) (cd-useds c))
138
139
140
141 (defun c-validp (c)
142 (eql (c-value-state c) :valid))
143
144 ;_____________________ print __________________________________
145
146 (defmethod print-object :before ((c cell) stream)
147 (declare (ignorable c))
148 (format stream "[~a~a:" (if (c-inputp c) "i" "?")
149 (cond
150 ((null (c-model c)) #\0)
151 ((eq :eternal-rest (md-state (c-model c))) #\_)
152 ((not (c-currentp c)) #\#)
153 (t #\space))))
154
155 (defmethod print-object ((c cell) stream)
156 (c-print-value c stream)
157 (format stream "=[~d]~a/~a]"
158 (c-pulse c)
159 (symbol-name (or (c-slot-name c) :anoncell))
160 (or (c-model c) :anonmd)))
161
162 ;__________________
163
164 (defmethod c-print-value ((c c-ruled) stream)
165 (format stream "~a" (cond ((c-validp c) "<vld>")
166 ((c-unboundp c) "<unb>")
167 ((not (c-currentp c)) "<obs>")
168 (t "<err>"))))
169
170 (defmethod c-print-value (c stream)
171 (declare (ignore c stream)))

  ViewVC Help
Powered by ViewVC 1.1.5