git.fiddlerwoaroof.com
Browse code

add sbcl ported version of OPS5

Brian Guarraci authored on 04/04/2011 05:22:19
Showing 20 changed files
README
History View file @ 5092d8a
... ... 
@@ -0,0 +1,132 @@
1 
+;;; ****************************************************************
2 
+;;; VPS2 -- Interpreter for OPS5 ***********************************
3 
+;;; ****************************************************************
4 
+;;;
5 
+;;; Ops5 is a programming language for production systems.
6 
+;;;
7 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
8 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
9 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
10 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
11 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
12 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
13 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
14 
+;;; Mark Kantrowitz on 14-OCT-92. The auto.ops and reactor.ops demo files
15 
+;;; were provided by Michael Mauldin.
16 
+;;;
17 
+;;; This code is made available is, and without warranty of any kind by the
18 
+;;; authors or by Carnegie-Mellon University.
19 
+;;;
20 
+;;; This code has been tested in Allegro v4.1, Lucid v4.1, IBCL, and
21 
+;;; CMU CL.
22 
+;;;
23 
+;;; Source code:
24 
+;;;    ops.lisp, ops-globals.lisp, ops-backup.lisp, ops-compile.lisp,
25 
+;;;    ops-init.lisp, ops-io.lisp, ops-main.lisp, ops-match.lisp,
26 
+;;;    ops-rhs.lisp, ops-util.lisp
27 
+;;;
28 
+;;; Demo Files:
29 
+;;;    ops-demo-mab.lisp and ops-demo-ttt.lisp
30 
+;;;    auto.ops and reactor.ops
31 
+;;;
32 
+;;; Documentation for OPS may be found in the OPS5 User's Manual, July 1981,
33 
+;;; by Forgy, CMU CSD.
34 
+;;;
35 
+;;; This version of OPS5 was obtained by anonymous ftp from
36 
+;;;    ftp.cs.cmu.edu:/user/ai/areas/expert/systems/ops5/ops5_cl.tgz
37 
+
38 
+;;; ********************************
39 
+;;; Usage **************************
40 
+;;; ********************************
41 
+;;;
42 
+;;; Before loading:
43 
+;;;    Change the global variable *ops-code-directory* to refer to the
44 
+;;;    directory where the OPS5 sources are kept. You may also need to
45 
+;;;    change the definition of OPS-PATHNAME depending on your lisp.
46 
+;;;
47 
+;;;
48 
+;;; To use:
49 
+;;;    1. From Lisp, load the file "ops":
50 
+;;;          (load "ops")
51 
+;;;    2. Go into the OPS package:
52 
+;;;          (in-package "OPS")
53 
+;;;    3. To compile the OPS sources, use compile-ops:
54 
+;;;          (compile-ops)
55 
+;;;    4. To load the OPS sources, use load-ops:
56 
+;;;          (load-ops)
57 
+;;; Now you can load your OPS5 code or start typing in productions.
58 
+;;; If you want to load in a new set of productions, call (reset-ops)
59 
+;;; between rule sets. For a nice REP Loop, run (ops).
60 
+;;;
61 
+;;; Demos:
62 
+;;;
63 
+;;; There are two demos
64 
+;;;    interactive tic-tac-toe
65 
+;;;    the monkey and banana problem
66 
+;;; To run the former, just load it and call (run). For the latter,
67 
+;;; load it, enter (make start 1) and then call (run).
68 
+
69 
+;;; ********************************
70 
+;;; Known Bugs *********************
71 
+;;; ********************************
72 
+;;;
73 
+;;; Loading new rule-sets clobbers the state of the interpreter. To use
74 
+;;; a new rule-set, exit lisp and restart OPS.
75 
+;;;
76 
+;;; Although this implementation has been put into its own package, only
77 
+;;; a few interfaces have been exported. You must run in the OPS package.
78 
+
79 
+;;; ********************************
80 
+;;; Sample Run *********************
81 
+;;; ********************************
82 
+> (load "ops")
83 
+;;; Loading binary file "ops.hbin"
84 
+#P"/afs/andrew.cmu.edu/scs/cs/15-381/ops5v1/ops.hbin"
85 
+> (in-package "OPS")
86 
+#<Package "OPS" 40242A7E>
87 
+> (load-ops)
88 
+;;; Loading binary file "/afs/andrew.cmu.edu/scs/cs/15-381/ops5/ops-globals.hbin"
89 
+;;; Loading binary file "/afs/andrew.cmu.edu/scs/cs/15-381/ops5/ops-util.hbin"
90 
+;;; Loading binary file "/afs/andrew.cmu.edu/scs/cs/15-381/ops5/ops-backup.hbin"
91 
+;;; Loading binary file "/afs/andrew.cmu.edu/scs/cs/15-381/ops5/ops-compile.hbin"
92 
+;;; Loading binary file "/afs/andrew.cmu.edu/scs/cs/15-381/ops5/ops-main.hbin"
93 
+;;; Loading binary file "/afs/andrew.cmu.edu/scs/cs/15-381/ops5/ops-match.hbin"
94 
+;;; Loading binary file "/afs/andrew.cmu.edu/scs/cs/15-381/ops5/ops-io.hbin"
95 
+;;; Loading binary file "/afs/andrew.cmu.edu/scs/cs/15-381/ops5/ops-rhs.hbin"
96 
+NIL
97 
+> (load "../ops/auto.ops")
98 
+;;; Loading source file "../ops/auto.ops"
99 
+;;; Warning: File "../ops/auto.ops" does not begin with IN-PACKAGE.  Loading into package "OPS"
100 
+******************
101 
+#P"/afs/andrew.cmu.edu/scs/cs/15-381/ops/auto.ops"
102 
+> (make ready)
103 
+NIL
104 
+> (run)
105 
+
106 
+
107 
+Automobile Diagnosis
108 
+
109 
+
110 
+Is this true: key is off [no]  y
111 
+
112 
+Concluding you must turn the key to start the car
113 
+*End of diagnosis*
114 
+
115 
+
116 
+Is this true: key is off [no]
117 
+
118 
+Is this true: engine is turning [no]  yes
119 
+
120 
+Concluding problem is in fuel or ignition system
121 
+
122 
+Is this true: headlights are dim or dead [no]  q
123 
+
124 
+end -- explicit halt
125 
+ 18 productions (108 // 200 nodes)
126 
+ 19 firings (42 rhs actions)
127 
+  5 mean working memory size (8 maximum)
128 
+  4 mean conflict set size (7 maximum)
129 
+ 10 mean token memory size (17 maximum)
130 
+NIL
131 
+>
132 
+;;; *EOF*
demo/auto.ops
History View file @ 5092d8a
0 133 
new file mode 100644
... ... 
@@ -0,0 +1,176 @@
1 
+;;; Sample OPS5 program: Automobile diagnosis
2 
+;;; Provided by Michael Mauldin, mlm@cs.cmu.edu.
3 
+
4 
+(reset-ops)
5 
+
6 
+(watch 0)
7 
+(strategy lex)
8 
+
9 
+(literalize task
10 
+	goal)			; Task name
11 
+
12 
+(literalize fact
13 
+	name			; Question to ask user [Y/N]
14 
+	value)			; Answer to question
15 
+
16 
+(p start
17 
+    (ready)
18 
+    -->
19 
+    (Remove 1)
20 
+    (make task ^goal start)
21 
+    (write (crlf) (crlf) "Automobile Diagnosis" (crlf) (crlf)))
22 
+
23 
+(p initialize
24 
+    (task ^goal start)
25 
+    -->
26 
+    (modify 1 ^goal diagnose)
27 
+    (make fact ^name |spark at spark plugs|)
28 
+    (make fact ^name |carburetor smells like gasoline|)
29 
+    (make fact ^name |fuel gauge shows empty|)
30 
+    (make fact ^name |headlights are dim or dead|)
31 
+    (make fact ^name |engine is turning|)
32 
+    (make fact ^name |key is off|))
33 
+
34 
+;;; ask-user: Ask the user about a fact
35 
+
36 
+(p ask-user
37 
+    (task ^goal diagnose)
38 
+    (fact ^name <name> ^value nil)
39 
+    -->
40 
+    (write (crlf) "Is this true:" <name> "[no] ")
41 
+    (bind <input> (acceptline no))
42 
+    (modify 2 ^value <input>))
43 
+
44 
+;;; make-yes-answer: Force a yes answer to be 'yes'
45 
+
46 
+(p make-yes-answer
47 
+    (task ^goal diagnose)
48 
+    (fact ^value << y >>)
49 
+    -->
50 
+    (modify 2 ^value yes))
51 
+
52 
+;;; make-no-answer: Force a no answer to be 'no'
53 
+
54 
+(p make-no-answer
55 
+    (task ^goal diagnose)
56 
+    (fact ^value << n >>)
57 
+    -->
58 
+    (modify 2 ^value no))
59 
+
60 
+;;; force-yes-or-no: Wipe out bad answers
61 
+
62 
+(p force-yes-answer
63 
+    (task ^goal diagnose)
64 
+    (fact ^value {<> nil <> yes <> y <> no <> n <> q <> quit})
65 
+    -->
66 
+    (write (crlf) "Please answer yes or no")
67 
+    (modify 2 ^value nil))
68 
+
69 
+;;; quit: Quit
70 
+
71 
+(p quit
72 
+    (task ^goal diagnose)
73 
+    (fact ^value << q quit >>)
74 
+    -->
75 
+    (halt))
76 
+
77 
+(p key-is-off
78 
+    (task ^goal diagnose)
79 
+    (fact ^name |key is off| ^value yes)
80 
+    -->
81 
+    (bind <x> |you must turn the key to start the car|)
82 
+    (make fact ^name <x> ^value yes)
83 
+    (write (crlf) "Concluding" <x> (crlf))
84 
+    (modify 1 ^goal clean))
85 
+
86 
+(p ignition-or-fuel
87 
+    (task ^goal diagnose)
88 
+    (fact ^name |key is off| ^value no)
89 
+    (fact ^name |engine is turning| ^value yes)
90 
+    -->
91 
+    (bind <x> |problem is in fuel or ignition system|)
92 
+    (make fact ^name <x> ^value yes)
93 
+    (write (crlf) "Concluding" <x> (crlf)))
94 
+
95 
+(p bad-starting-system
96 
+    (task ^goal diagnose)
97 
+    (fact ^name |key is off| ^value no)
98 
+    (fact ^name |engine is turning| ^value no)
99 
+    -->
100 
+    (bind <x> |problem is in starting system|)
101 
+    (make fact ^name <x> ^value yes)
102 
+    (write (crlf) "Concluding" <x> (crlf)))
103 
+
104 
+(p out-of-gas
105 
+    (task ^goal diagnose)
106 
+    (fact ^name |fuel gauge shows empty| ^value yes)
107 
+    -->
108 
+    (bind <x> |out of gas|)
109 
+    (make fact ^name <x> ^value yes)
110 
+    (write (crlf) "Concluding" <x> (crlf))
111 
+    (modify 1 ^goal clean))
112 
+
113 
+(p engine-flooded
114 
+    (task ^goal diagnose)
115 
+    (fact ^name |problem is in fuel or ignition system| ^value yes)
116 
+    (fact ^name |carburetor smells like gasoline| ^value yes)
117 
+    (fact ^name |spark at spark plugs| ^value yes)
118 
+    -->
119 
+    (bind <x> |engine is flooded: wait 15 minutes|)
120 
+    (make fact ^name <x> ^value yes)
121 
+    (write (crlf) "Concluding" <x> (crlf))
122 
+    (modify 1 ^goal clean))
123 
+
124 
+(p bad-ignition
125 
+    (task ^goal diagnose)
126 
+    (fact ^name |problem is in fuel or ignition system| ^value yes)
127 
+    (fact ^name |headlights are dim or dead| ^value no)
128 
+    (fact ^name |spark at spark plugs| ^value no)
129 
+    -->
130 
+    (bind <x> |you have a bad ignition system|)
131 
+    (make fact ^name <x> ^value yes)
132 
+    (write (crlf) "Concluding" <x> (crlf))
133 
+    (modify 1 ^goal clean))
134 
+
135 
+(p bad-battery
136 
+    (task ^goal diagnose)
137 
+    (fact ^name |headlights are dim or dead| ^value yes)
138 
+    -->
139 
+    (bind <x> |you have a dead battery|)
140 
+    (make fact ^name <x> ^value yes)
141 
+    (write (crlf) "Concluding" <x> (crlf))
142 
+    (modify 1 ^goal clean))
143 
+
144 
+(p bad-starter
145 
+    (task ^goal diagnose)
146 
+    (fact ^name |problem is in starting system| ^value yes)
147 
+    (fact ^name |headlights are dim or dead| ^value no)
148 
+    -->
149 
+    (bind <x> |you have a bad starter|)
150 
+    (make fact ^name <x> ^value yes)
151 
+    (write (crlf) "Concluding" <x> (crlf))
152 
+    (modify 1 ^goal clean))
153 
+
154 
+(p bad-fuel-pump
155 
+    (task ^goal diagnose)
156 
+    (fact ^name |problem is in fuel or ignition system| ^value yes)
157 
+    (fact ^name |carburetor smells like gasoline| ^value no)
158 
+    (fact ^name |fuel gauge shows empty| ^value no)
159 
+    -->
160 
+    (bind <x> |problem in fuel system: bad fuel pump or filter|)
161 
+    (make fact ^name <x> ^value yes)
162 
+    (write (crlf) "Concluding" <x> (crlf))
163 
+    (modify 1 ^goal clean))
164 
+
165 
+(p clean-up-old-fact
166 
+    (task ^goal clean)
167 
+    (fact)
168 
+    -->
169 
+    (Remove 2))
170 
+
171 
+(p done-cleaning
172 
+    (task ^goal clean)
173 
+   -(fact)
174 
+    -->
175 
+    (modify 1 ^goal start)
176 
+    (write "*End of diagnosis*" (crlf) (crlf)))
demo/auto.run
History View file @ 5092d8a
0 177 
new file mode 100644
... ... 
@@ -0,0 +1,59 @@
1 
+> (load "demo/auto.ops")
2 
+;;; Loading source file "demo/auto.ops"
3 
+;;; Warning: File "demo/auto.ops" does not begin with IN-PACKAGE.  Loading into package "OPS"
4 
+Common Lisp OPS5 interpreter, version 14-OCT-92.
5 
+******************
6 
+#P"/afs/andrew.cmu.edu/scs/cs/15-381/ops5/demo/auto.ops"
7 
+> (make ready)
8 
+NIL
9 
+> (run)
10 
+
11 
+
12 
+Automobile Diagnosis
13 
+
14 
+
15 
+Is this true: key is off [no]  yes
16 
+
17 
+Concluding you must turn the key to start the car
18 
+*End of diagnosis*
19 
+
20 
+
21 
+Is this true: key is off [no]  no
22 
+
23 
+Is this true: engine is turning [no]  yes
24 
+
25 
+Concluding problem is in fuel or ignition system
26 
+
27 
+Is this true: headlights are dim or dead [no]  no
28 
+
29 
+Is this true: fuel gauge shows empty [no]  no
30 
+
31 
+Is this true: carburetor smells like gasoline [no]  yes
32 
+
33 
+Is this true: spark at spark plugs [no]  yes
34 
+
35 
+Concluding engine is flooded: wait 15 minutes
36 
+*End of diagnosis*
37 
+
38 
+
39 
+Is this true: key is off [no]  no
40 
+
41 
+Is this true: engine is turning [no]  n
42 
+
43 
+Concluding problem is in starting system
44 
+
45 
+Is this true: headlights are dim or dead [no]  n
46 
+
47 
+Concluding you have a bad starter
48 
+*End of diagnosis*
49 
+
50 
+
51 
+Is this true: key is off [no]  q
52 
+
53 
+end -- explicit halt
54 
+ 18 productions (108 // 200 nodes)
55 
+ 50 firings (101 rhs actions)
56 
+  5 mean working memory size (9 maximum)
57 
+  4 mean conflict set size (8 maximum)
58 
+ 11 mean token memory size (19 maximum)
59 
+NIL
demo/ops-demo-mab.lisp
History View file @ 5092d8a
0 60 
new file mode 100644
... ... 
@@ -0,0 +1,196 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+(reset-ops)
18 
+
19 
+(literalize monkey
20 
+	at
21 
+	on
22 
+	holds)
23 
+
24 
+(literalize object
25 
+	name
26 
+	at
27 
+	weight
28 
+	on)
29 
+
30 
+(literalize goal
31 
+	status
32 
+	type
33 
+	object
34 
+	to)
35 
+
36 
+(p mb1
37 
+	(goal ^status active ^type holds ^object <w>)
38 
+	(object ^name <w> ^at <p> ^on ceiling)
39 
+    -->
40 
+	(make goal ^status active ^type move ^object ladder ^to <p>))
41 
+
42 
+
43 
+(p mb2
44 
+	(goal ^status active ^type holds ^object <w>)
45 
+	(object ^name <w> ^at <p> ^on ceiling)
46 
+	(object ^name ladder ^at <p>)
47 
+    -->
48 
+	(make goal ^status active ^type on ^object ladder))
49 
+
50 
+
51 
+(p mb3
52 
+	(goal ^status active ^type holds ^object <w>)
53 
+	(object ^name <w> ^at <p> ^on ceiling)
54 
+	(object ^name ladder ^at <p>)
55 
+	(monkey ^on ladder)
56 
+    -->
57 
+	(make goal ^status active ^type holds ^object nil))
58 
+
59 
+
60 
+(p mb4
61 
+	(goal ^status active ^type holds ^object <w>)
62 
+	(object ^name <w> ^at <p> ^on ceiling)
63 
+	(object ^name ladder ^at <p>)
64 
+	(monkey ^on ladder ^holds nil)
65 
+    -->
66 
+	(write (crlf) "grab" <w>)
67 
+	(modify 4 ^holds <w>)
68 
+	(modify 1 ^status satified))
69 
+
70 
+
71 
+
72 
+(p mb5
73 
+	(goal ^status active ^type holds ^object <w>)
74 
+	(object ^name <w> ^at <p> ^on floor)
75 
+    -->
76 
+	(make goal ^status active ^type walk-to ^object <p>))
77 
+
78 
+
79 
+(p mb6
80 
+	(goal ^status active ^type holds ^object <w>)
81 
+	(object ^name <w> ^at <p> ^on floor)
82 
+	(monkey ^at <p>)
83 
+    -->
84 
+	(make goal ^status active ^type holds ^object nil))
85 
+
86 
+
87 
+(p mb7
88 
+	(goal ^status active ^type holds ^object <w>)
89 
+	(object ^name <w> ^at <p> ^on floor)
90 
+	(monkey ^at <p> ^holds nil)
91 
+    -->
92 
+	(write (crlf) "grab" <w>)
93 
+	(modify 3 ^holds <w>)
94 
+	(modify 1 ^status satisfied))
95 
+
96 
+(p mb8
97 
+	(goal ^status active ^type move ^object <o> ^to <p>)
98 
+	(object ^name <o> ^weight light ^at <> <p>)
99 
+    -->
100 
+	(make goal ^status active ^type holds ^object <o>))
101 
+
102 
+
103 
+(p mb9
104 
+	(goal ^status active ^type move ^object <o> ^to <p>)
105 
+	(object ^name <o> ^weight light ^at <> <p>)
106 
+	(monkey ^holds <o>)
107 
+    -->
108 
+	(make goal ^status active ^type walk-to ^object <p>))
109 
+
110 
+
111 
+(p mb10
112 
+	(goal ^status active ^type move ^object <o> ^to <p>)
113 
+	(object ^name <o> ^weight light ^at <p>)
114 
+    -->
115 
+	(modify 1 ^status satisfied))
116 
+
117 
+
118 
+(p mb11
119 
+	(goal ^status active ^type walk-to ^object <p>)
120 
+    -->
121 
+	(make goal ^status active ^type on ^object floor))
122 
+
123 
+(p mb12
124 
+	(goal ^status active ^type walk-to ^object <p>)
125 
+	(monkey ^on floor ^at {<c> <> <p>} ^holds nil)
126 
+    -->
127 
+	(write (crlf) "walk to" <p>)
128 
+	(modify 2 ^at <p>)
129 
+	(modify 1 ^status satisfied))
130 
+
131 
+
132 
+(p mb13
133 
+	(goal ^status active ^type walk-to ^object <p>)
134 
+	(monkey ^on floor ^at {<c> <> <p>} ^holds <w> <> nil)
135 
+	(object ^name <w>)
136 
+    -->
137 
+	(write (crlf) "walk to" <p>)
138 
+	(modify 2 ^at <p>)
139 
+	(modify 3 ^at <p>)
140 
+	(modify 1 ^status satisfied))
141 
+
142 
+(p mb14
143 
+	(goal ^status active ^type on ^object floor)
144 
+	(monkey ^on {<x> <> floor})
145 
+    -->
146 
+	(write (crlf) "jump onto the floor")
147 
+	(modify 2 ^on floor)
148 
+	(modify 1 ^status satisfied))
149 
+
150 
+(p mb15
151 
+	(goal ^status active ^type on ^object <o>)
152 
+	(object ^name <o> ^at <p>)
153 
+    -->
154 
+	(make goal ^status active ^type walk-to ^object <p>))
155 
+
156 
+
157 
+
158 
+(p mb16
159 
+	(goal ^status active ^type on ^object <o>)
160 
+	(object ^name <o> ^at <p>)
161 
+	(monkey ^at <p>)
162 
+    -->
163 
+	(make goal ^status active ^type holds ^object nil))
164 
+
165 
+
166 
+(p mb17
167 
+	(goal ^status active ^type on ^object <o>)
168 
+	(object ^name <o> ^at <p>)
169 
+	(monkey ^at <p> ^holds nil)
170 
+    -->
171 
+	(write (crlf) "climb onto" <o>)
172 
+	(modify 3 ^on <o>)
173 
+	(modify 1 ^status satisfied))
174 
+
175 
+(p mb18
176 
+	(goal ^status active ^type holds ^object nil)
177 
+	(monkey ^holds {<x> <> nil})
178 
+    -->
179 
+	(write (crlf) "drop" <x>)
180 
+	(modify 2 ^holds nil)
181 
+	(modify 1 ^status satisfied))
182 
+
183 
+(p mb19
184 
+	(goal ^status active)
185 
+    -->
186 
+	(modify 1 ^status not-processed))
187 
+
188 
+(p t1
189 
+	(start 1)
190 
+    -->
191 
+	(make monkey ^at 5-7 ^on couch)
192 
+	(make object ^name couch ^at 5-7 ^weight heavy)
193 
+	(make object ^name bananas ^on ceiling ^at 2-2)
194 
+	(make object ^name ladder ^on floor ^at 9-5 ^weight light)
195 
+	(make goal ^status active ^type holds ^object bananas))
196 
+
demo/ops-demo-ttt.lisp
History View file @ 5092d8a
0 197 
new file mode 100644
... ... 
@@ -0,0 +1,326 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+(reset-ops)
18 
+
19 
+(strategy mea)
20 
+(watch 0)
21 
+
22 
+
23 
+(literalize task
24 
+	actor)
25 
+(literalize position
26 
+	row column value identity)
27 
+(literalize opposite
28 
+	of is)
29 
+(literalize player
30 
+	with-mark is)
31 
+(literalize move
32 
+	status whose-turn input)
33 
+(vector-attribute input)
34 
+
35 
+
36 
+
37 
+(p start
38 
+;	 generate the wm-elements defining the "board" and find out whether
39 
+;	 the human wants his mark to be x or o
40 
+	 (ready)
41 
+	-->
42 
+	 (make task ^actor referee)
43 
+	 (make position ^row 1 ^column 1 ^value | | ^identity top-left)
44 
+	 (make position ^row 1 ^column 2 ^value | | ^identity top-middle)
45 
+	 (make position ^row 1 ^column 3 ^value | | ^identity top-right)
46 
+	 (make position ^row 2 ^column 1 ^value | | ^identity middle-left)
47 
+	 (make position ^row 2 ^column 2 ^value | | ^identity center)
48 
+	 (make position ^row 2 ^column 3 ^value | | ^identity middle-right)
49 
+	 (make position ^row 3 ^column 1 ^value | | ^identity bottom-left)
50 
+	 (make position ^row 3 ^column 2 ^value | | ^identity bottom-middle)
51 
+	 (make position ^row 3 ^column 3 ^value | | ^identity bottom-right)
52 
+	 (make opposite ^of x ^is o)
53 
+	 (make opposite ^of o ^is x)
54 
+	 (write (crlf) "Do you want to be x or o?  " )
55 
+	 (make player ^with-mark (accept) ^is human) )
56 
+
57 
+(make ready)
58 
+
59 
+(p pop
60 
+	 ; if there is nothing more to do in the most recently generated task,
61 
+	 ; delete the task
62 
+	 (task)
63 
+	-->
64 
+	 (remove 1) )
65 
+
66 
+
67 
+(p referee--display-the-board
68 
+	 ; after each move, display the board
69 
+	 (task ^actor referee)
70 
+	 (move ^status made ^whose-turn <mark>)
71 
+	 (opposite ^of <mark> ^is <opponent-mark>)
72 
+	 (position ^row 1 ^column 1 ^value <l1>)
73 
+	 (position ^row 1 ^column 2 ^value <m1>)
74 
+	 (position ^row 1 ^column 3 ^value <r1>)
75 
+	 (position ^row 2 ^column 1 ^value <l2>)
76 
+	 (position ^row 2 ^column 2 ^value <m2>)
77 
+	 (position ^row 2 ^column 3 ^value <r2>)
78 
+	 (position ^row 3 ^column 1 ^value <l3>)
79 
+	 (position ^row 3 ^column 2 ^value <m3>)
80 
+	 (position ^row 3 ^column 3 ^value <r3>)
81 
+	-->
82 
+	 (modify 2 ^status unmade ^whose-turn <opponent-mark>)
83 
+	 (write (crlf) (crlf) (crlf)
84 
+		(tabto 12) <l1> (tabto 15) "|" (tabto 18) <m1>
85 
+		(tabto 21) "|" (tabto 24) <r1>
86 
+		(tabto 10) -----------------
87 
+		(tabto 12) <l2> (tabto 15) "|" (tabto 18) <m2>
88 
+		(tabto 21) "|" (tabto 24) <r2>
89 
+		(tabto 10) -----------------
90 
+		(tabto 12) <l3> (tabto 15) "|" (tabto 18) <m3>
91 
+		(tabto 21) "|" (tabto 24) <r3>) )
92 
+
93 
+(p referee--prepare-for-first-move
94 
+;	 identify the mark of the computer and create the move wm-element that
95 
+;	 will drive the game
96 
+	 (task ^actor referee)
97 
+	 (player ^with-mark <mark> ^is human)
98 
+	 (opposite ^of <mark> ^is <other-mark>)
99 
+	-->
100 
+	 (write (crlf) (crlf)
101 
+  	   "When you are asked where you want your mark, enter two numbers."
102 
+		(crlf)
103 
+            "The first number should be the row you want, the second number, the column.")
104 
+	 (make player ^with-mark <other-mark> ^is computer)
105 
+	 (make move ^status unmade ^whose-turn x) )
106 
+
107 
+(p referee--get-a-good-mark
108 
+;	 if the human says he wants to be something other than x or o, make
109 
+;	 him x
110 
+	 (task ^actor referee)
111 
+	 (player ^with-mark <mark> ^is human)
112 
+	 - (opposite ^of <mark>)
113 
+	-->
114 
+	 (modify 2 ^with-mark x)
115 
+	 (write (crlf) (crlf) "Try to remember that you're x.") )
116 
+
117 
+(p referee--next-move
118 
+;	 if it's time for the next move to be made, generate the appropriate
119 
+;	 subtask
120 
+	 (task ^actor referee)
121 
+	 (move ^status unmade ^whose-turn <mark>)
122 
+	 (player ^with-mark <mark> ^is <who>)
123 
+	-->
124 
+	 (make task ^actor <who>) )
125 
+
126 
+(p referee--recognize-column-win
127 
+;	 if someone has filled a column, note that fact
128 
+	 (task ^actor referee)
129 
+	 (move ^status unmade ^whose-turn <mark>)
130 
+	 (opposite ^of <mark> ^is <other-mark>)
131 
+	 (player ^with-mark <other-mark>)
132 
+	 (position ^column <c> ^value <other-mark>)
133 
+	 - (position ^column <c> ^value <> <other-mark>)
134 
+	-->
135 
+	 (remove 2)
136 
+	 (make player ^with-mark <other-mark> ^is winner) )
137 
+
138 
+(p referee--recognize-row-win
139 
+;	 if someone has filled a row, note that fact
140 
+	 (task ^actor referee)
141 
+	 (move ^status unmade ^whose-turn <mark>)
142 
+	 (opposite ^of <mark> ^is <other-mark>)
143 
+	 (player ^with-mark <other-mark>)
144 
+	 (position ^row <r> ^value <other-mark>)
145 
+	 - (position ^row <r> ^value <> <other-mark>)
146 
+	-->
147 
+	 (remove 2)
148 
+	 (make player ^with-mark <other-mark> ^is winner) )
149 
+
150 
+(p referee--recognize-diagonal-win
151 
+;	 if someone has filled a diagonal, note that fact
152 
+	 (task ^actor referee)
153 
+	 (move ^status unmade ^whose-turn <mark>)
154 
+	 (opposite ^of <mark> ^is <other-mark>)
155 
+	 (player ^with-mark <other-mark>)
156 
+	 (position ^row 2 ^column 2 ^value <other-mark>)
157 
+	 (position ^row {<r> <> 2} ^column {<c> <> 2}
158 
+		   ^identity <id> ^value <other-mark>)
159 
+	 (position ^row <c> ^column <r>
160 
+		   ^identity <> <id> ^value <other-mark>)
161 
+	-->
162 
+	 (remove 2)
163 
+	 (make player ^with-mark <other-mark> ^is winner) )
164 
+
165 
+(p referee--human-wins
166 
+;	 if the human won, let him know
167 
+	 (task ^actor referee)
168 
+	 (player ^with-mark <other-mark> ^is winner)
169 
+	 (player ^with-mark <other-mark> ^is human)
170 
+	-->
171 
+	 (write (crlf) (crlf) "You win." (crlf) (crlf)) )
172 
+
173 
+(p referee--computer-wins
174 
+;	 if the computer won, let the human know
175 
+	 (task ^actor referee)
176 
+	 (player ^with-mark <other-mark> ^is winner)
177 
+	 (player ^with-mark <other-mark> ^is computer)
178 
+	-->
179 
+	 (write (crlf) (crlf) "I win." (crlf) (crlf)) )
180 
+
181 
+(p referee--draw
182 
+;	 if there are no empty spaces, the game is a draw
183 
+	 (task ^actor referee)
184 
+	 (move ^status unmade ^whose-turn <mark>)
185 
+	 (player ^with-mark <mark>)
186 
+	 - (position ^value | |)
187 
+	-->
188 
+	 (write (crlf) (crlf) "We drew." (crlf) (crlf))
189 
+	 (remove 2) )
190 
+
191 
+(p referee--cleanup
192 
+;	 if the game is over, delete all of the wm-elements
193 
+	 (task ^actor referee)
194 
+	 - (move)
195 
+	 (<> task)
196 
+	-->
197 
+	 (remove 2) )
198 
+
199 
+
200 
+(p human--ask-for-next-move
201 
+	 ; get the position (row and column) where the human wants his mark
202 
+	 (task ^actor human)
203 
+	 (move ^status unmade ^input nil)
204 
+	-->
205 
+ 	 (write (crlf) (crlf) "Where do you want your mark?  ")
206 
+	 (modify 2 ^input (acceptline)) )
207 
+
208 
+(p human--accept-move
209 
+	 ; if the move is legal, accept it
210 
+	 ; the move wm-element is remade so that the value of ^input becomes
211 
+	 ; nil (there are 2 simpler but less educational ways of achieving
212 
+	 ; this same end)
213 
+	 (task ^actor human)
214 
+	 (move ^status unmade ^whose-turn <mark>
215 
+	       ^input {<row> >= 0 <= 3} {<column> >= 0 <= 3} nil)
216 
+	 (position ^row <row> ^column <column> ^value | |)
217 
+	-->
218 
+	 (remove 2)
219 
+	 (make move (substr 2 2 input) ^status made ^input nil)
220 
+	 (modify 3 ^value <mark>) )
221 
+
222 
+(p human--reject-attempt-to-overwrite
223 
+	 ; if the position specified is not empty, complain
224 
+	 ; the move condition element in this rule differs from the move
225 
+	 ; condition in the previous rule only so you can see two equivalent
226 
+	 ; ways of expressing the same condition
227 
+	 (task ^actor human)
228 
+	 (move ^status unmade
229 
+	       ^input <row> <column> nil ^input << 1 2 3 >> << 1 2 3 >>)
230 
+	 (position ^row <row> ^column <column> ^value {<mark> <> | |})
231 
+	-->
232 
+	 (write (crlf) (crlf) "There is already an " <mark> " in " <row> <column>)
233 
+	 (modify 2 ^input nil nil) )
234 
+
235 
+(p human--reject-out-of-bounds-move
236 
+	 ; if the row or column specified is not within bounds or if more than
237 
+	 ; two numbers have been entered, complain
238 
+	 ; the move wm-element is remade so that the value of ^input becomes
239 
+	 ; nil (there is a simpler but less educational way of achieving this
240 
+	 ; same end)
241 
+	 (task ^actor human)
242 
+	 (move ^status unmade ^input <> nil)
243 
+	-->
244 
+	 (write (crlf) (crlf) (substr 2 input inf) "is not a legal move.")
245 
+	 (remove 2)
246 
+	 (make move (substr 2 2 input) ^input nil) )
247 
+
248 
+
249 
+(p computer--select-move
250 
+	 ; select any empty position
251 
+	 (task ^actor computer)
252 
+	 (move ^status unmade ^whose-turn <mark>)
253 
+	 - (position ^row 2 ^column 2 ^value | |)
254 
+	 (position ^row <r> ^column <c> ^value | |)
255 
+	-->
256 
+	 (modify 2 ^status made)
257 
+	 (modify 3 ^value <mark>) )
258 
+
259 
+(p computer--select-center
260 
+	 ; select the center if it's available
261 
+	 (task ^actor computer)
262 
+	 (move ^status unmade ^whose-turn <mark>)
263 
+	 (position ^row 2 ^column 2 ^value | |)
264 
+	-->
265 
+	 (modify 2 ^status made)
266 
+	 (modify 3 ^value <mark>) )
267 
+
268 
+(p computer--block-column-win
269 
+	 ; if the human has two in a column, block
270 
+	 (task ^actor computer)
271 
+	 (move ^status unmade ^whose-turn <mark>)
272 
+	 (position ^row <r> ^column <c>
273 
+		   ^value {<other-mark> <> <mark> <> | |})
274 
+	 (position ^column <c> ^value | |)
275 
+	 (position ^row <> <r> ^column <c> ^value <other-mark>)
276 
+	-->
277 
+	 (modify 2 ^status made)
278 
+	 (modify 4 ^value <mark>) )
279 
+
280 
+(p computer--block-row-win
281 
+	 ; if the human has two in a row, block
282 
+	 (task ^actor computer)
283 
+	 (move ^status unmade ^whose-turn <mark>)
284 
+	 (position ^row <r> ^column <c>
285 
+		   ^value {<other-mark> <> <mark> <> | |})
286 
+	 (position ^row <r> ^value | |)
287 
+	 (position ^row <r> ^column <> <c> ^value <other-mark>)
288 
+	-->
289 
+	 (modify 2 ^status made)
290 
+	 (modify 4 ^value <mark>) )
291 
+
292 
+(p computer--block-diagonal-win
293 
+	 ; if the human has two on a diagonal, block
294 
+	 (task ^actor computer)
295 
+	 (move ^status unmade ^whose-turn <mark>)
296 
+	 (position ^row 2 ^column 2
297 
+		   ^value {<other-mark> <> <mark> <> | |})
298 
+	 (position ^row {<r> <> 2} ^column {<c> <> 2} ^value | |)
299 
+	 (position ^row <c> ^column <r> ^value <other-mark>)
300 
+	-->
301 
+	 (modify 2 ^status made)
302 
+	 (modify 4 ^value <mark>) )
303 
+
304 
+(p computer--possible-column
305 
+	 ; if the computer has one mark in an otherwise empty column, put
306 
+	 ; another mark in that column
307 
+	 (task ^actor computer)
308 
+	 (move ^status unmade ^whose-turn <mark>)
309 
+	 (position ^row <r> ^column <c> ^value <mark>)
310 
+	 - (position ^row <> <r> ^column <c> ^value <> | |)
311 
+	 (position ^row <> <r> ^column <c> ^value | |)
312 
+	-->
313 
+	 (modify 2 ^status made)
314 
+	 (modify 4 ^value <mark>) )
315 
+
316 
+(p computer--possible-row
317 
+	 ; if the computer has one mark in an otherwise empty row, put
318 
+	 ; another mark in that row
319 
+	 (task ^actor computer)
320 
+	 (move ^status unmade ^whose-turn <mark>)
321 
+	 (position ^row <r> ^column <c> ^value <mark>)
322 
+	 - (position ^row <r> ^column <> <c> ^value <> | |)
323 
+	 (position ^row <r> ^column <> <c> ^value | |)
324 
+	-->
325 
+	 (modify 2 ^status made)
326 
+	 (modify 4 ^value <mark>) )
demo/reactor.ops
History View file @ 5092d8a
0 327 
new file mode 100644
... ... 
@@ -0,0 +1,318 @@
1 
+;;; Sample OPS5 expanded program
2 
+;;;
3 
+;;; Author: Michael Mauldin 3/23/84
4 
+;;;
5 
+;;; References: These rules are based on rules from Nelson, William R.,
6 
+;;; "REACTOR: An Expert System for Diagnosis and Treatment of Nuclear
7 
+;;; Reactor Accidents," Proceedings of AAAI 1982.
8 
+
9 
+(reset-ops)
10 
+
11 
+(strategy lex)
12 
+(watch 0)
13 
+(literalize fact
14 
+    system name value trend status raw-value change)
15 
+
16 
+(literalize task
17 
+    goal subgoal query)
18 
+
19 
+(literalize accident
20 
+    type id)
21 
+
22 
+(literalize trace
23 
+    elt)
24 
+
25 
+(vector-attribute
26 
+    elt)
27 
+
28 
+(p start				; Start the diagnosis
29 
+    (ready)
30 
+    -->
31 
+    (write (crlf) "Enter id number for this run:  ")
32 
+    (bind <id> (accept))
33 
+    (make task ^goal input)
34 
+    (make accident ^id <id>)
35 
+    (make fact ^system containment ^name pressure ^trend unknown)
36 
+    (make fact ^system containment ^name radiation ^value unknown)
37 
+    (make fact ^system feedwater ^name flow ^value unknown)
38 
+    (make fact ^system pcs ^name pressure ^trend unknown)
39 
+    (make fact ^system pcs ^name temperature ^trend unknown)
40 
+    (make fact ^system sg ^name level ^trend unknown)
41 
+    (make fact ^system steam ^name flow ^value unknown)
42 
+    (make fact ^system hpis ^status unknown)
43 
+    (write (crlf)))
44 
+
45 
+;;; Get  numeric values for variables that require a high/steady/low
46 
+;;; determination.   Store in the raw-value slot.
47 
+
48 
+(p get-value
49 
+    (task ^goal input)
50 
+    (fact ^system <system> ^name <name> ^value unknown ^raw-value nil)
51 
+    -->
52 
+    (write "Enter value for" <system> <name> "[1..100]: ")
53 
+    (bind <value> (accept))
54 
+    (modify 2 ^raw-value <value>))
55 
+
56 
+;;; Get old and new values for variables which have a trend
57 
+;;; increasing/decreasing/steady.  Store the difference in the change
58 
+;;; slot.
59 
+
60 
+(p get-trend
61 
+    (task ^goal input)
62 
+    (fact ^system <system> ^name <name> ^trend unknown ^change nil)
63 
+    -->
64 
+    (write "Enter old value for" <system> <name> "[1..100]: ")
65 
+    (bind <old> (accept))
66 
+    (write "Enter new value for" <system> <name> "[1..100]: ")
67 
+    (bind <new> (accept))
68 
+    (modify 2 ^change (compute <new> - <old>)))
69 
+
70 
+;;; get the status for systems
71 
+
72 
+(p get-status
73 
+    (task ^goal input)
74 
+    (fact ^system <system> ^name nil ^status unknown)
75 
+    -->
76 
+    (write "Enter value for" <system> "[on, off]: ")
77 
+    (bind <value> (accept))
78 
+    (modify 2 ^status <value>))
79 
+
80 
+;;; After all variables requiring user input have been set, set the
81 
+;;; goal to classify the inputs in terms of low/high/nominal,
82 
+;;; increasing/decreasing/steady.
83 
+
84 
+(p end-of-input
85 
+    (task ^goal input)
86 
+    -->
87 
+    (modify 1 ^goal classify)
88 
+    (write (crlf) "Starting classification..." (crlf)))
89 
+
90 
+;;; The next three rules set the value slot based on the raw numeric
91 
+;;; value.  Rather than define various nominal values, I have used a
92 
+;;; dimensionless numeric scale where 1-32 are low, 33-66 are nominal,
93 
+;;; and 67-100 are high.
94 
+
95 
+(p classify-low
96 
+    (task ^goal classify)
97 
+    (fact ^system <system> ^name <name> ^raw-value < 33 ^value unknown)
98 
+    -->
99 
+    (modify 2 ^value low)
100 
+    (write "Rule classify-low concludes that" <system> <name>
101 
+           "is low" (crlf)))
102 
+
103 
+(p classify-high
104 
+    (task ^goal classify)
105 
+    (fact ^system <system> ^name <name> ^raw-value > 66 ^value unknown)
106 
+    -->
107 
+    (modify 2 ^value high)
108 
+    (write "Rule classify-high concludes that" <system> <name>
109 
+           "is high" (crlf)))
110 
+
111 
+(p classify-nominal
112 
+    (task ^goal classify)
113 
+    (fact ^system <system> ^name <name> ^value unknown)
114 
+    -->
115 
+    (modify 2 ^value nominal)
116 
+    (write "Rule classify-nominal concludes that" <system> <name>
117 
+            "is nominal" (crlf)))
118 
+
119 
+;;; The next three rules classify a trend. If the change from the old
120 
+;;; value to the new one is 3 units or less, the variable is labelled
121 
+;;; 'steady,' otherwise it is marked as either increasing or decreasing.
122 
+(p classify-decreasing
123 
+    (task ^goal classify)
124 
+    (fact ^system <system> ^name <name> ^trend unknown ^change {<change> < -3})
125 
+    -->
126 
+    (modify 2 ^trend decreasing)
127 
+    (write "Rule classify-decreasing concludes that" <system> <name>
128 
+           "is decreasing" (crlf)))
129 
+
130 
+(p classify-increasing
131 
+    (task ^goal classify)
132 
+    (fact ^system <system> ^name <name> ^trend unknown ^change {<change> > 3})
133 
+    -->
134 
+    (modify 2 ^trend increasing)
135 
+    (write "Rule classify-increasing concludes that" <system> <name>
136 
+           "is increasing" (crlf)))
137 
+
138 
+(p classify-steady
139 
+    (task ^goal classify)
140 
+    (fact ^system <system> ^name <name> ^trend unknown)
141 
+    -->
142 
+    (modify 2 ^trend steady)
143 
+    (write "Rule classify-steady concludes that" <system> <name>
144 
+           "is steady" (crlf)))
145 
+
146 
+;;; After all variables have been classified, start the diagnosis
147 
+
148 
+(p start-diagnosis
149 
+    (task ^goal classify)
150 
+    -->
151 
+    (modify 1 ^goal diagnose)
152 
+    (write (crlf) "Starting diagnosis..." (crlf)))
153 
+
154 
+(p rule-1				; PCS Integrity challenged?
155 
+    (task ^goal diagnose)
156 
+    (fact ^system pcs ^name pressure ^trend decreasing)
157 
+    (fact ^system hpis ^status on)
158 
+    -->
159 
+    (make fact ^system pcs ^name integrity ^status challenged)
160 
+    (write "Rule 1 concludes:    "  pcs integrity challenged (crlf))
161 
+    (make trace rule-1 used pcs pressure decreasing)
162 
+    (make trace rule-1 used hpis on))
163 
+
164 
+(p rule-2				; Heat transfer inadequate?
165 
+    (task ^goal diagnose)
166 
+    (fact ^system pcs ^name temperature ^trend increasing)
167 
+    -->
168 
+    (make fact ^system pcs ^name heat-transfer ^status inadequate)
169 
+    (write "Rule 2 concludes:    "  pcs heat-transfer inadequate (crlf))
170 
+    (make trace rule-2 used pcs temperature increasing))
171 
+
172 
+(p rule-3				; SG inventory inadequate?
173 
+    (task ^goal diagnose)
174 
+    (fact ^system sg ^name level ^trend decreasing)
175 
+    -->
176 
+    (make fact ^system sg ^name inventory ^status inadequate)
177 
+    (write "Rule 3 concludes:    "  sg inventory inadequate (crlf))
178 
+    (make trace rule-3 used sg level decreasing))
179 
+
180 
+(p rule-4				; Containment integrity challenged?
181 
+    (task ^goal diagnose)
182 
+    (fact ^system containment ^name radiation ^value high)
183 
+    (fact ^system containment ^name pressure ^value high)
184 
+    -->
185 
+    (make fact ^system containment ^name integrity ^status challenged)
186 
+    (write "Rule 4 concludes:    "  containment integrity challenged (crlf))
187 
+    (make trace rule-4 used containment radiation high)
188 
+    (make trace rule-4 used containment pressure high))
189 
+
190 
+(p rule-5				; Loss of feedwater?
191 
+    (task ^goal diagnose)
192 
+    (accident ^id <id>)
193 
+    (fact ^system pcs ^name heat-transfer ^status inadequate)
194 
+    (fact ^system feedwater ^name flow ^value low)
195 
+    -->
196 
+    (modify 2 ^type loss-of-feedwater)
197 
+    (write "Rule 5 concludes accident is loss of feedwater" (crlf))
198 
+    (modify 1 ^goal explain)
199 
+    (make trace rule-5 used pcs heat-transfer inadequate)
200 
+    (make trace rule-5 used feedwater flow low))
201 
+
202 
+(p rule-6				; Loss of feedwater?
203 
+    (task ^goal diagnose)
204 
+    (accident ^id <id>)
205 
+    (fact ^system sg ^name inventory ^status inadequate)
206 
+    (fact ^system feedwater ^name flow ^value low)
207 
+    -->
208 
+    (modify 2 ^type loss-of-feedwater)
209 
+    (write "Rule 6 concludes accident is loss of feedwater" (crlf))
210 
+    (modify 1 ^goal explain)
211 
+    (make trace rule-6 used sg inventory inadequate)
212 
+    (make trace rule-6 used feedwater flow low))
213 
+
214 
+(p rule-7				; Loss of coolant?
215 
+    (task ^goal diagnose)
216 
+    (accident ^id <id>)
217 
+    (fact ^system pcs ^name integrity ^status challenged)
218 
+    (fact ^system containment ^name integrity ^status challenged)
219 
+    -->
220 
+    (modify 2 ^type loca)
221 
+    (write "Rule 7 concludes accident is loss of coolant" (crlf))
222 
+    (modify 1 ^goal explain)
223 
+    (make trace rule-7 used pcs integrity challenged)
224 
+    (make trace rule-7 used containment integrity challenged))
225 
+
226 
+(p rule-8				; SG tube rupture?
227 
+    (task ^goal diagnose)
228 
+    (accident ^id <id>)
229 
+    (fact ^system pcs ^name integrity ^status challenged)
230 
+    (fact ^system sg ^name level ^trend increasing)
231 
+    -->
232 
+    (modify 2 ^type sg-tube-rupture)
233 
+    (write "Rule 8 concludes accident is steam generator tube rupture" (crlf))
234 
+    (modify 1 ^goal explain)
235 
+    (make trace rule-8 used pcs integrity challenged)
236 
+    (make trace rule-8 used sg level increasing))
237 
+
238 
+(p rule-9				; Steam line break?
239 
+    (task ^goal diagnose)
240 
+    (accident ^id <id>)
241 
+    (fact ^system sg ^name inventory ^status inadequate)
242 
+    (fact ^system steam ^name flow ^value high)
243 
+    -->
244 
+    (modify 2 ^type steam-line-break)
245 
+    (write "Rule 9 concludes accident is steam line break" (crlf))
246 
+    (modify 1 ^goal explain)
247 
+    (make trace rule-9 used sg inventory inadequate)
248 
+    (make trace rule-9 used steam flow high))
249 
+
250 
+(p no-diagnosis
251 
+    (task ^goal diagnose)
252 
+    -->
253 
+    (write "No diagnosis" (crlf))
254 
+    (modify 1 ^goal explain))
255 
+
256 
+;;; Explanation:  Get a single word from the user, and then reply to
257 
+;;; those words we recognize.  Currently we recognize the following
258 
+;;; questions:
259 
+;;;
260 
+;;; facts:	prints the facts used during diagnosis
261 
+;;; high:	prints variables which are high
262 
+;;; low:	prints variables which are low
263 
+;;; nominal:	prints variables which are nominal
264 
+;;; increasing:	prints variables which are increasing
265 
+;;; decreasing:	prints variables which are decreasing
266 
+;;; steady:	prints variables which are steady
267 
+
268 
+(p start-questions
269 
+    (task ^goal explain ^subgoal nil)
270 
+    -->
271 
+    (modify 1 ^subgoal prompt)
272 
+    (write (crlf) Starting explanations (crlf))
273 
+)
274 
+
275 
+(p get-user-query
276 
+    (task ^goal explain ^subgoal prompt)
277 
+    -->
278 
+    (write "Explanations [facts, high/low, none]: ")
279 
+    (modify 1 ^subgoal reply ^query (acceptline none)))
280 
+
281 
+;;; Print a line for each trace element
282 
+
283 
+(p explain-facts
284 
+    (task ^goal explain ^subgoal reply ^query facts)
285 
+    (trace)
286 
+    -->
287 
+    (write "    Fact used: " (substr 2 2 inf) (crlf)))
288 
+
289 
+;;; Print system values
290 
+
291 
+(p explain-value
292 
+    (task ^goal explain ^subgoal reply ^query {<type> <> nil})
293 
+    (fact ^system <system> ^name <name> ^raw-value <value> ^value = <type>)
294 
+    -->
295 
+    (write "   " <type> ":" <system> <name> <value> (crlf)))
296 
+
297 
+;;; Print trends
298 
+
299 
+(p explain-trends
300 
+    (task ^goal explain ^subgoal reply ^query {<type> <> nil})
301 
+    (fact ^system <system> ^name <name> ^change <change> ^trend = <type>)
302 
+    -->
303 
+    (write "   " <type> ":" <system> <name> changed <change> (crlf)))
304 
+
305 
+;;; Having answered the query, set up to ask for another
306 
+
307 
+(p finish-this-query
308 
+    (task ^goal explain ^subgoal reply ^query <> none)
309 
+    -->
310 
+    (modify 1 ^subgoal prompt))
311 
+
312 
+;;; No more queries, mark the task finished
313 
+
314 
+(p quit
315 
+    (task ^goal explain ^subgoal reply ^query none)
316 
+    -->
317 
+    (modify 1 ^goal finished))
318 
+
demo/reactor.run
History View file @ 5092d8a
0 319 
new file mode 100644
... ... 
@@ -0,0 +1,65 @@
1 
+> (load "demo/reactor.ops")
2 
+;;; Loading source file "demo/reactor.ops"
3 
+;;; Warning: File "demo/reactor.ops" does not begin with IN-PACKAGE.  Loading into package "OPS"
4 
+Common Lisp OPS5 interpreter, version 14-OCT-92.
5 
+*****************************
6 
+#P"/afs/andrew.cmu.edu/scs/cs/15-381/ops5/demo/reactor.ops"
7 
+> (make ready)
8 
+NIL
9 
+> (run)
10 
+
11 
+Enter id number for this run:   12
12 
+
13 
+Enter value for HPIS [on, off]:  on
14 
+Enter value for STEAM FLOW [1..100]:  52
15 
+Enter old value for SG LEVEL [1..100]:  46
16 
+Enter new value for SG LEVEL [1..100]:  32
17 
+Enter old value for PCS TEMPERATURE [1..100]:  57
18 
+Enter new value for PCS TEMPERATURE [1..100]:  59
19 
+Enter old value for PCS PRESSURE [1..100]:  45
20 
+Enter new value for PCS PRESSURE [1..100]:  67
21 
+Enter value for FEEDWATER FLOW [1..100]:  11
22 
+Enter value for CONTAINMENT RADIATION [1..100]:  52
23 
+Enter old value for CONTAINMENT PRESSURE [1..100]:  56
24 
+Enter new value for CONTAINMENT PRESSURE [1..100]:  67
25 
+
26 
+Starting classification...
27 
+Rule classify-increasing concludes that CONTAINMENT PRESSURE is increasing
28 
+Rule classify-nominal concludes that CONTAINMENT RADIATION is nominal
29 
+Rule classify-low concludes that FEEDWATER FLOW is low
30 
+Rule classify-increasing concludes that PCS PRESSURE is increasing
31 
+Rule classify-steady concludes that PCS TEMPERATURE is steady
32 
+Rule classify-decreasing concludes that SG LEVEL is decreasing
33 
+Rule classify-nominal concludes that STEAM FLOW is nominal
34 
+
35 
+Starting diagnosis...
36 
+Rule 3 concludes:     SG INVENTORY INADEQUATE
37 
+Rule 6 concludes accident is loss of feedwater
38 
+
39 
+STARTING EXPLANATIONS
40 
+Explanations [facts, high/low, none]:  facts
41 
+    Fact used:  RULE-6 USED FEEDWATER FLOW LOW
42 
+    Fact used:  RULE-6 USED SG INVENTORY INADEQUATE
43 
+    Fact used:  RULE-3 USED SG LEVEL DECREASING
44 
+Explanations [facts, high/low, none]:  high
45 
+Explanations [facts, high/low, none]:  low
46 
+    LOW : FEEDWATER FLOW 11
47 
+Explanations [facts, high/low, none]:  steady
48 
+    STEADY : PCS TEMPERATURE CHANGED 2
49 
+Explanations [facts, high/low, none]:  nominal
50 
+    NOMINAL : STEAM FLOW 52
51 
+    NOMINAL : CONTAINMENT RADIATION 52
52 
+Explanations [facts, high/low, none]:  decreasing
53 
+    DECREASING : SG LEVEL CHANGED -14
54 
+Explanations [facts, high/low, none]:  increasing
55 
+    INCREASING : PCS PRESSURE CHANGED 22
56 
+    INCREASING : CONTAINMENT PRESSURE CHANGED 11
57 
+Explanations [facts, high/low, none]:  none
58 
+
59 
+end -- no production true
60 
+ 29 productions (150 // 293 nodes)
61 
+ 47 firings (87 rhs actions)
62 
+ 13 mean working memory size (15 maximum)
63 
+  3 mean conflict set size (12 maximum)
64 
+ 18 mean token memory size (25 maximum)
65 
+NIL
doc/lang.doc
History View file @ 5092d8a
0 66 
new file mode 100644
... ... 
@@ -0,0 +1,215 @@
1 
+                          OPS5 LANGUAGE INTRODUCTION
2 
+
3 
+                                MICHAEL MAULDIN
4 
+                                 OCTOBER, 1992
5 
+
6 
+  This  document  contains  a  sketchy  description  of OPS5 language features,
7 
+syntax and semantics of conditions and actions.  For more information,  consult
8 
+the OPS5 manual.
9 
+
10 
+1 Production Memory
11 
+  create rules with p (production) or build (later)
12 
+
13 
+  an OPS5 production-rule definition is a list containing
14 
+
15 
+   - a function call to p
16 
+
17 
+   - LHS  =  one  or  more condition elements (first not negated), each in
18 
+     Lisp list format.
19 
+
20 
+   - a separator = -->
21 
+
22 
+   - RHS = one or more actions, each in Lisp list format.
23 
+
24 
+2 Sample Rule
25 
+;; IF    the key is on AND the engine is not turning
26 
+;; THEN  conclude that the problem is in the starting system
27 
+(p bad-starting-system
28 
+    (task ^goal diagnose)
29 
+    (fact ^name |key is off| ^value no)
30 
+    (fact ^name |engine is turning| ^value no)
31 
+    -->
32 
+    (bind <x> |problem is in starting system|)
33 
+    (make fact ^name <x> ^value yes)
34 
+    (write (crlf) Concluding <x> (crlf)))
35 
+
36 
+3 Left-Hand Side
37 
+  LHS is collection of patterns to be matched against  working  memory.    Each
38 
+pattern  contains  an  element-class name followed by some number of LHS terms.
39 
+Each term consists  of  an  ^attribute-name  followed  by  a  LHS-value.    The
40 
+LHS-value can be a
41 
+
42 
+constant        in  pattern ^on couch, ``couch'' is a constant; in pattern ^GRE
43 
+                100, ``100'' is a constant;
44 
+
45 
+variable        in pattern, ^Status <n1>, ``<n1>'' is  variable  that  will  be
46 
+                bound  during  matching  to an actual value for some element in
47 
+                working memory;
48 
+
49 
+predicate operator
50 
+                one  of seven operators may precede a constant or variable:  =,
51 
+                <>, <=>, <, <=, >=, >; the =  is  assumed  if  no  operator  is
52 
+                present;
53 
+
54 
+disjunction     in  the  pattern  ^weight << light medium >>, ``<< light medium
55 
+                >>'' specifies that only one of the set of  values,  light  and
56 
+                medium,  must  match;  any  LHS-values  may be contained in the
57 
+                disjunction; warning leave  spaces  between  values  and  angle
58 
+                brackets to avoid confusing them with variable brackets;
59 
+
60 
+conjunction     in  pattern ^GRE { > 600 < 800 }, ``{ > 600 < 800 }'' specifies
61 
+                a set of value  restrictions  all  of  which  must  match;  any
62 
+                LHS-values may be contained in the conjunction;
63 
+
64 
+  Restrictions to predicate operators:
65 
+
66 
+   - <,  <=,  >=  and > used only with numbers and with variables bound to
67 
+     numbers.  <=> means same type, and <> means not equal.
68 
+
69 
+   - first occurrence of a variable cannot be preceded  by  any  predicate
70 
+     other than = (first occurrence establishes binding)
71 
+
72 
+  A  condition  pattern  in  LHS (other than first) may be negated by putting a
73 
+``-'' in front of the normal pattern
74 
+
75 
+  Ordering of condition  elements  is  significant  in  variable  binding,  for
76 
+conflict resolution and for match efficiency
77 
+
78 
+4 RHS of OPS5 Rules
79 
+
80 
+   - The RHS of the OPS5 rule consists of an ordered sequence of actions.
81 
+
82 
+   - The  primitive  actions  that affect working memory are make, modify,
83 
+     and remove.
84 
+
85 
+   - The write action is used to output information.
86 
+
87 
+   - The halt action provides a way of explicitly stopping the  firing  of
88 
+     production rules.
89 
+
90 
+   - RHS can also contain functions that return values within the actions.
91 
+     For example, the compute function allows OPS5 to do arithmetic.    It
92 
+     provides  for  infix  evaluation  of  +,-,*, //, and \\ (respectively
93 
+     addition,  subtraction,  multiplication,  division,   and   modulus).
94 
+     Operations are performed from right to left.
95 
+
96 
+   - These  and  other  actions  and  functions  will  be  demonstrated by
97 
+     example.
98 
+
99 
+5 Specific Commands
100 
+
101 
+                               The WATCH Command
102 
+
103 
+no argument     Print current watch level (initialized to 1) unchanged
104 
+
105 
+(watch 0)       No report of firings or changes to working memory
106 
+
107 
+(watch 1)       Report rule name and time tags of each working  memory  element
108 
+                for each instantiation fired
109 
+
110 
+(watch 2)       In  addition  to  level  1  reports,  give  each change (add or
111 
+                delete) to working memory
112 
+
113 
+                                The RUN Command
114 
+
115 
+(run)           run until a break or halt or no rules in conflict set
116 
+
117 
+(run N)         run N steps unless early stop as above
118 
+
119 
+(run 1)         for single stepping
120 
+
121 
+                           [The WM and PPWM Commands
122 
+
123 
+  (wm) -- list the contents of working memory, optional arguments specify  time
124 
+tags; if no time tags are given, shows all elements.
125 
+
126 
+  (ppwm  <pat>)  --  <pat> is pattern (in LHS condition form), prints all wme's
127 
+that match <pat>.  No variables, predicates or special characters  are  allowed
128 
+in in <pat>.  If pattern is null, all elements are printed.
129 
+
130 
+  use  with cs and matches to determine why a rule failed to be instantiated at
131 
+the right time.
132 
+
133 
+                                The PM Command
134 
+
135 
+  (pm <args>) -- <args> any number of rule names
136 
+
137 
+                                The CS Command
138 
+
139 
+  (cs) -- lists each instantiated rule in conflict set, one to a line, followed
140 
+by  currently  dominant  instantiation  (that  is,  the one to be fired on next
141 
+cycle)
142 
+
143 
+                              The MATCHES Command
144 
+
145 
+  (matches <rules>) --  prints  partial  matches  for  rules  whose  names  are
146 
+arguments.    For  each  condition  element  of  specified  rules, time tags of
147 
+matching wme's are listed, as well as intersections of partial matches.
148 
+
149 
+        (literalize number value)
150 
+
151 
+        (p example-rule
152 
+           (number ^value { <number-1> > 100 } )
153 
+           (number ^value { <number-2> <> <number-1> } )
154 
+           (number ^value { <number-3> < 50 } )
155 
+           -->
156 
+           (write (crlf) <number-1> <number-2> <number-3> ) )
157 
+
158 
+        (make number ^value 101)  ; given time-tag 1
159 
+
160 
+        (make number ^value 102)  ; given time-tag 2
161 
+
162 
+        (make number ^value  11)  ; given time-tag 3
163 
+        =>(matches example-rule)
164 
+
165 
+        example-rule
166 
+         ** matches for (1) **
167 
+         2
168 
+         1
169 
+         ** matches for (2) **
170 
+         3
171 
+         2
172 
+         1
173 
+         ** matches for (2 1) **
174 
+         3  1
175 
+         3  2
176 
+         1  2
177 
+         2  1
178 
+         ** matches for (3)
179 
+         3
180 
+        nil
181 
+The final intersection, which in this example would be matches for (3 2 1),  is
182 
+not included.
183 
+
184 
+  Uses:
185 
+
186 
+   - a given condition element is never matched,
187 
+
188 
+   - the  intersection of two or more condition elements, each of which is
189 
+     matched, fails to be satisfied, or
190 
+
191 
+   - a negated condition element is matched.
192 
+
193 
+                              The PBREAK Command
194 
+
195 
+   - (pbreak <rules>) -- toggles break/nobreak status of rules
196 
+
197 
+   - (pbreak) -- says which rules are broken
198 
+
199 
+   - breaks after rule fires
200 
+                               The BACK Command
201 
+
202 
+   - (back <n>) undoes the effects of up  to  32  rule  firings,  provided
203 
+     there are no external references (user-defined functions) in any RHS
204 
+
205 
+                         The MAKE and REMOVE Commands
206 
+
207 
+   - (remove *) deletes everything from working memory.
208 
+
209 
+   - (remove  <args>)  deletes  working  memory elements with time tags in
210 
+     <args>
211 
+
212 
+                              The EXCISE Command
213 
+
214 
+  (excise <rules>) -- prevents rules from firing (still in network), reload  to
215 
+recall, but won't be current on wm.
doc/lang.mss
History View file @ 5092d8a
0 216 
new file mode 100644
... ... 
@@ -0,0 +1,259 @@
1 
+@Make[Report]
2 
+@Disable[Contents]
3 
+
4 
+@comment{================================================================}
5 
+
6 
+@Begin[Heading]
7 
+OPS5 Language Introduction
8 
+
9 
+Michael Mauldin
10 
+October, 1992
11 
+@End[Heading]
12 
+
13 
+
14 
+This document contains a sketchy description of OPS5 language features,
15 
+syntax and semantics of conditions and actions.  For more information,
16 
+consult the OPS5 manual.
17 
+
18 
+@Section[Production Memory]
19 
+
20 
+create rules with @B[p] (production) or @b[build] (later)
21 
+
22 
+an OPS5 production-rule definition is a list containing
23 
+@Begin[Itemize]
24 
+a function call to @b[p]
25 
+
26 
+LHS = one or more condition elements (first not negated), each in Lisp
27 
+list format.
28 
+
29 
+a separator = @t{-->}
30 
+
31 
+RHS = one or more actions, each in Lisp list format.
32 
+@End[Itemize]
33 
+
34 
+@Section[Sample Rule]
35 
+@Begin[Verbatim]
36 
+@Tabclear
37 
+@Tabdivide[8]
38 
+;; IF    the key is on AND the engine is not turning
39 
+;; THEN  conclude that the problem is in the starting system
40 
+(p bad-starting-system
41 
+    (task ^goal diagnose)
42 
+    (fact ^name |key is off| ^value no)
43 
+    (fact ^name |engine is turning| ^value no)
44 
+    -->
45 
+    (bind <x> |problem is in starting system|)
46 
+    (make fact ^name <x> ^value yes)
47 
+    (write (crlf) Concluding <x> (crlf)))
48 
+@End[Verbatim]
49 
+
50 
+@Section[Left-Hand Side]
51 
+
52 
+LHS is collection of patterns to be matched against working memory.  Each
53 
+pattern contains an element-class name followed by some number of LHS terms.
54 
+Each term consists of an @t{^attribute-name} followed by a LHS-value.  The
55 
+LHS-value can be a
56 
+
57 
+@Begin[Description]
58 
+constant@\in pattern @t{^on couch}, ``couch'' is a constant;
59 
+in pattern @t{^GRE 100}, ``100'' is a constant;
60 
+
61 
+variable@\in pattern, @t{^Status <n1>}, ``<n1>'' is variable that will be
62 
+bound during matching to an actual value for some element in
63 
+working memory;
64 
+
65 
+predicate operator @\one of seven operators may precede
66 
+a constant or variable:
67 
+=, <>, <=>, <, <=, >=, >; the = is assumed if no operator is present;
68 
+
69 
+disjunction@\in the pattern @t{^weight << light medium >>}, ``<< light
70 
+medium >>'' specifies that only one of the set of values, light and
71 
+medium, must match; any LHS-values may be contained in the disjunction;
72 
+@I[warning] leave spaces between values and angle brackets
73 
+to avoid confusing them with variable brackets;
74 
+
75 
+conjunction@\in pattern @t[^GRE { > 600 < 800 }], ``{ > 600 < 800 }''
76 
+specifies a set of value restrictions all of which must match; any
77 
+LHS-values may be contained in the conjunction;
78 
+
79 
+@End[Description]
80 
+
81 
+Restrictions to predicate operators:
82 
+
83 
+@Begin[Itemize]
84 
+<, <=, >= and >
85 
+used only with numbers and with variables bound to numbers.
86 
+<=> means same type, and <> means not equal.
87 
+
88 
+first occurrence of a variable cannot be
89 
+preceded by any predicate other than = (first occurrence establishes binding)
90 
+
91 
+@End[Itemize]
92 
+
93 
+A condition pattern in LHS (other than first) may be negated by putting
94 
+a ``-'' in front of the normal pattern
95 
+
96 
+Ordering of condition elements is significant in variable binding,
97 
+for conflict resolution and for match efficiency
98 
+
99 
+@Section[RHS of OPS5 Rules]
100 
+
101 
+@Begin[Itemize]
102 
+The RHS of the OPS5 rule consists of an ordered sequence of actions.
103 
+
104 
+The primitive actions that affect working memory are @b[make], @b[modify],
105 
+and @b[remove].
106 
+
107 
+The @b[write] action is used to output information.
108 
+
109 
+The @b[halt] action provides a way of explicitly stopping the firing of
110 
+production rules.
111 
+
112 
+RHS can also contain functions
113 
+that return values within the actions.  For example, the @B[compute]
114 
+function allows OPS5 to do arithmetic.  It provides for infix evaluation of
115 
++,-,*, //, and \\ (respectively addition, subtraction, multiplication,
116 
+division, and modulus).  Operations are performed from right to left.
117 
+
118 
+These and other actions and functions will be demonstrated by example.
119 
+@End[Itemize]
120 
+
121 
+
122 
+@Section[Specific Commands]
123 
+
124 
+@Center[@b[The WATCH Command]]
125 
+
126 
+@Begin[description]
127 
+no argument@\Print current watch level (initialized to 1) unchanged
128 
+
129 
+@t{(watch 0)}@\No report of firings or changes to working memory
130 
+
131 
+@t{(watch 1)}@\Report rule name and time tags of each working memory
132 
+element for each instantiation fired
133 
+
134 
+@t{(watch 2)}@\In addition to level 1 reports, give each change (add
135 
+or delete) to working memory
136 
+@End[description]
137 
+
138 
+@Center[@b[The RUN Command]]
139 
+
140 
+@Begin[Description]
141 
+@t{(run)}@\run until a break or halt or no rules in conflict set
142 
+
143 
+@t{(run N)}@\run N steps unless early stop as above
144 
+
145 
+@t{(run 1)}@\for single stepping
146 
+@end[Description]
147 
+
148 
+@center[@b[[The WM and PPWM Commands]]
149 
+
150 
+@b[(wm)] -- list the contents of working memory,
151 
+optional arguments specify time tags;
152 
+if no time tags are given, shows all elements.
153 
+
154 
+@t{(ppwm <pat>)} -- <pat> is pattern (in LHS condition form),
155 
+prints all wme's that match <pat>.
156 
+No variables, predicates or special characters are allowed in in <pat>.
157 
+If pattern is null, all elements are printed.
158 
+
159 
+use with @b[cs] and @b[matches]
160 
+to determine why a rule failed to be instantiated at the right time.
161 
+
162 
+@Center[@b[The PM Command]]
163 
+
164 
+@t{(pm <args>)} -- <args> any number of rule names
165 
+
166 
+@Center[@b[The CS Command]]
167 
+
168 
+@t{(cs)} -- lists each instantiated rule in conflict set, one to a
169 
+line, followed by currently dominant instantiation (that is, the one to
170 
+be fired on next cycle)
171 
+
172 
+@Center[@b[The MATCHES Command]]
173 
+
174 
+@t{(matches <rules>)} -- prints partial matches for rules whose names are
175 
+arguments.  For each condition element of specified rules, time tags of
176 
+matching wme's are listed, as well as intersections of partial matches.
177 
+@Begin[Verbatim]
178 
+
179 
+	(literalize number value)
180 
+
181 
+	(p example-rule
182 
+	   (number ^value { <number-1> > 100 } )
183 
+	   (number ^value { <number-2> <> <number-1> } )
184 
+	   (number ^value { <number-3> < 50 } )
185 
+	   -->
186 
+	   (write (crlf) <number-1> <number-2> <number-3> ) )
187 
+
188 
+	(make number ^value 101)  ; given time-tag 1
189 
+
190 
+	(make number ^value 102)  ; given time-tag 2
191 
+
192 
+	(make number ^value  11)  ; given time-tag 3
193 
+@End[Verbatim]
194 
+
195 
+@Begin[Verbatim]
196 
+	=>(matches example-rule)
197 
+
198 
+	example-rule
199 
+	 ** matches for (1) **
200 
+	 2
201 
+	 1
202 
+	 ** matches for (2) **
203 
+	 3
204 
+	 2
205 
+	 1
206 
+	 ** matches for (2 1) **
207 
+	 3  1
208 
+	 3  2
209 
+	 1  2
210 
+	 2  1
211 
+	 ** matches for (3)
212 
+	 3
213 
+	nil
214 
+@End[Verbatim]
215 
+The final intersection, which in this example would be @t{matches for (3 2 1)},
216 
+is not included.
217 
+
218 
+Uses:
219 
+@Begin[itemize]
220 
+a given condition element is never matched,
221 
+
222 
+the intersection of two or more condition elements, each of which is matched,
223 
+fails to be satisfied, or
224 
+
225 
+a negated condition element is matched.
226 
+@End[itemize]
227 
+
228 
+@Center[@b[The PBREAK Command]]
229 
+
230 
+@Begin[Itemize]
231 
+@t{(pbreak <rules>)} -- toggles break/nobreak status of rules
232 
+
233 
+@t{(pbreak)} -- says which rules are broken
234 
+
235 
+breaks after rule fires
236 
+@End[Itemize]
237 
+
238 
+@Center[@b[The BACK Command]]
239 
+
240 
+@Begin[Itemize]
241 
+@t{(back <n>)} undoes the effects of up to 32 rule firings, provided
242 
+there are no external references (user-defined functions) in any RHS
243 
+@End[Itemize]
244 
+
245 
+@Center[@b[The MAKE and REMOVE Commands]]
246 
+
247 
+@Begin[Itemize]
248 
+@t{(remove *)} deletes everything from working memory.
249 
+
250 
+@t{(remove <args>)} deletes working memory elements with time tags in <args>
251 
+@End[Itemize]
252 
+
253 
+@Center[@b[The EXCISE Command]]
254 
+
255 
+@t{(excise <rules>)} --  prevents rules from firing (still in network),
256 
+reload to recall, but won't be current on wm.
257 
+
258 
+
259 
+
doc/lang.ps
History View file @ 5092d8a
0 260 
new file mode 100644
... ... 
@@ -0,0 +1,675 @@
1 
+%!PS-Adobe-2.0
2 
+%%Title: lang.mss
3 
+%%DocumentFonts: (atend)
4 
+%%Creator: Michael Mauldin and Scribe 7(1700)
5 
+%%CreationDate: 15 October 1992 02:31
6 
+%%Pages: (atend)
7 
+%%EndComments
8 
+% PostScript Prelude for Scribe.
9 
+/BS {/SV save def 0.0 792.0 translate .01 -.01 scale} bind def
10 
+/ES {showpage SV restore} bind def
11 
+/SC {setrgbcolor} bind def
12 
+/FMTX matrix def
13 
+/RDF {WFT SLT 0.0 eq
14 
+  {SSZ 0.0 0.0 SSZ neg 0.0 0.0 FMTX astore}
15 
+  {SSZ 0.0 SLT neg sin SLT cos div SSZ mul SSZ neg 0.0 0.0 FMTX astore}
16 
+  ifelse makefont setfont} bind def
17 
+/SLT 0.0 def
18 
+/SI { /SLT exch cvr def RDF} bind def
19 
+/WFT /Courier findfont def
20 
+/SF { /WFT exch findfont def RDF} bind def
21 
+/SSZ 1000.0 def
22 
+/SS { /SSZ exch 100.0 mul def RDF} bind def
23 
+/AF { /WFT exch findfont def /SSZ exch 100.0 mul def RDF} bind def
24 
+/MT /moveto load def
25 
+/XM {currentpoint exch pop moveto} bind def
26 
+/UL {gsave newpath moveto dup 2.0 div 0.0 exch rmoveto
27 
+   setlinewidth 0.0 rlineto stroke grestore} bind def
28 
+/LH {gsave newpath moveto setlinewidth
29 
+   0.0 rlineto
30 
+   gsave stroke grestore} bind def
31 
+/LV {gsave newpath moveto setlinewidth
32 
+   0.0 exch rlineto
33 
+   gsave stroke grestore} bind def
34 
+/BX {gsave newpath moveto setlinewidth
35 
+   exch
36 
+   dup 0.0 rlineto
37 
+   exch 0.0 exch neg rlineto
38 
+   neg 0.0 rlineto
39 
+   closepath
40 
+   gsave stroke grestore} bind def
41 
+/BX1 {grestore} bind def
42 
+/BX2 {setlinewidth 1 setgray stroke grestore} bind def
43 
+/PB {/PV save def newpath translate
44 
+    100.0 -100.0 scale pop /showpage {} def} bind def
45 
+/PE {PV restore} bind def
46 
+/GB {/PV save def newpath translate rotate
47 
+    div dup scale 100.0 -100.0 scale /showpage {} def} bind def
48 
+/GE {PV restore} bind def
49 
+/FB {dict dup /FontMapDict exch def begin} bind def
50 
+/FM {cvn exch cvn exch def} bind def
51 
+/FE {end /original-findfont /findfont load def  /findfont
52 
+   {dup FontMapDict exch known{FontMapDict exch get} if
53 
+   original-findfont} def} bind def
54 
+/BC {gsave moveto dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto closepath clip} bind def
55 
+/EC /grestore load def
56 
+/SH /show load def
57 
+/MX {exch show 0.0 rmoveto} bind def
58 
+/W {0 32 4 -1 roll widthshow} bind def
59 
+/WX {0 32 5 -1 roll widthshow 0.0 rmoveto} bind def
60 
+/RC {100.0 -100.0 scale
61 
+612.0 0.0 translate
62 
+-90.0 rotate
63 
+.01 -.01 scale} bind def
64 
+/URC {100.0 -100.0 scale
65 
+90.0 rotate
66 
+-612.0 0.0 translate
67 
+.01 -.01 scale} bind def
68 
+/RCC {100.0 -100.0 scale
69 
+0.0 -792.0 translate 90.0 rotate
70 
+.01 -.01 scale} bind def
71 
+/URCC {100.0 -100.0 scale
72 
+-90.0 rotate 0.0 792.0 translate
73 
+.01 -.01 scale} bind def
74 
+%%EndProlog
75 
+%%Page: 0 1
76 
+BS
77 
+0 SI
78 
+13 /Helvetica-Bold AF
79 
+21645 8148 MT
80 
+(OPS5 Language Introduction)SH
81 
+25580 11510 MT
82 
+(Michael Mauldin)SH
83 
+26301 13191 MT
84 
+(October, 1992)SH
85 
+10 /Helvetica AF
86 
+8312 15724 MT
87 
+(This document contains a sketchy)
88 
+146 W( description of OPS5 language features, syntax and semantics of)145 W
89 
+7200 17150 MT
90 
+(conditions and actions.  For more information, consult the OPS5 manual.)SH
91 
+12 /Helvetica-Bold AF
92 
+7200 20905 MT
93 
+(1 Production Memory)SH
94 
+10 /Helvetica AF
95 
+8312 22331 MT
96 
+(create rules with)SH
97 
+/Helvetica-Bold SF
98 
+15870 XM
99 
+(p)SH
100 
+/Helvetica SF
101 
+16759 XM
102 
+(\050production\051 or)SH
103 
+/Helvetica-Bold SF
104 
+23539 XM
105 
+(build)SH
106 
+/Helvetica SF
107 
+26206 XM
108 
+(\050later\051)SH
109 
+8312 24898 MT
110 
+(an OPS5 production-rule definition is a list containing)SH
111 
+/Symbol SF
112 
+9242 26370 MT
113 
+(\267)SH
114 
+/Helvetica SF
115 
+9980 XM
116 
+(a function call to)SH
117 
+/Helvetica-Bold SF
118 
+17484 XM
119 
+(p)SH
120 
+/Symbol SF
121 
+9242 28185 MT
122 
+(\267)SH
123 
+/Helvetica SF
124 
+9980 XM
125 
+(LHS = one or more condition elements \050first not negated\051, each in Lisp list format.)SH
126 
+/Symbol SF
127 
+9242 30000 MT
128 
+(\267)SH
129 
+/Helvetica SF
130 
+9980 XM
131 
+(a separator =)SH
132 
+/Courier SF
133 
+16178 XM
134 
+(-->)SH
135 
+/Symbol SF
136 
+9242 31815 MT
137 
+(\267)SH
138 
+/Helvetica SF
139 
+9980 XM
140 
+(RHS = one or more actions, each in Lisp list format.)SH
141 
+12 /Helvetica-Bold AF
142 
+7200 35570 MT
143 
+(2 Sample Rule)SH
144 
+10 /Courier-Bold AF
145 
+7200 37832 MT
146 
+(;; IF)
147 
+SH( the)
148 
+1800 W( key is on AND the engine is not turning)SH
149 
+7200 38963 MT
150 
+(;; THEN  conclude that the problem is in the starting system)SH
151 
+7200 40094 MT
152 
+(\050p bad-starting-system)SH
153 
+9600 41225 MT
154 
+(\050task ^goal diagnose\051)SH
155 
+9600 42356 MT
156 
+(\050fact ^name |key is off| ^value no\051)SH
157 
+9600 43487 MT
158 
+(\050fact ^name |engine is turning| ^value no\051)SH
159 
+9600 44618 MT
160 
+(-->)SH
161 
+9600 45749 MT
162 
+(\050bind <x> |problem is in starting system|\051)SH
163 
+9600 46880 MT
164 
+(\050make fact ^name <x> ^value yes\051)SH
165 
+9600 48011 MT
166 
+(\050write \050crlf\051 Concluding <x> \050crlf\051\051\051)SH
167 
+12 /Helvetica-Bold AF
168 
+7200 51766 MT
169 
+(3 Left-Hand Side)SH
170 
+10 /Helvetica AF
171 
+8312 53192 MT
172 
+(LHS is collection of patterns to be)
173 
+244 W( matched against working memory.  Each pattern contains an)245 W
174 
+7200 54618 MT
175 
+(element-class name followed by some number of LHS terms.  Each term consists)
176 
+592 W( of an)591 W
177 
+/Courier SF
178 
+7200 56044 MT
179 
+(^attribute-name)SH
180 
+/Helvetica SF
181 
+16478 XM
182 
+(followed by a LHS-value.  The LHS-value can be a)SH
183 
+7200 57916 MT
184 
+(constant)SH
185 
+16096 XM
186 
+(in pattern)236 W
187 
+/Courier SF
188 
+21015 XM
189 
+(^on couch)236 W
190 
+/Helvetica SF
191 
+(, ``couch'' is a constant; in pattern)236 W
192 
+/Courier SF
193 
+43310 XM
194 
+(^GRE 100)236 W
195 
+/Helvetica SF
196 
+(, ``100'' is a)236 W
197 
+16096 59059 MT
198 
+(constant;)SH
199 
+7200 60685 MT
200 
+(variable)SH
201 
+16096 XM
202 
+(in pattern,)71 W
203 
+/Courier SF
204 
+20963 XM
205 
+(^Status <n1>)70 W
206 
+/Helvetica SF
207 
+(, ``<n1>'' is variable that will be bound during matching to)70 W
208 
+16096 61828 MT
209 
+(an actual value for some element in working memory;)SH
210 
+7200 63454 MT
211 
+(predicate operator)SH
212 
+16096 XM
213 
+(one of seven operators may precede a constant or variable:  =, <>, <=>, <, <=, >=,)
214 
+19 W( >;)20 W
215 
+16096 64597 MT
216 
+(the = is assumed if no operator is present;)SH
217 
+7200 66223 MT
218 
+(disjunction)SH
219 
+16096 XM
220 
+(in the pattern)6 W
221 
+/Courier SF
222 
+22229 XM
223 
+(^weight << light medium)
224 
+6 W( >>)5 W
225 
+/Helvetica SF
226 
+(, ``<< light medium >>'' specifies that)5 W
227 
+16096 67366 MT
228 
+(only one of the)
229 
+25 W( set of values, light and medium, must match; any LHS-values may be)26 W
230 
+16096 68509 MT
231 
+(contained in the disjunction;)378 W
232 
+/Helvetica-Oblique SF
233 
+30226 XM
234 
+(warning)SH
235 
+/Helvetica SF
236 
+34383 XM
237 
+(leave spaces between values and angle)377 W
238 
+16096 69652 MT
239 
+(brackets to avoid confusing them with variable brackets;)SH
240 
+7200 71278 MT
241 
+(conjunction)SH
242 
+16096 XM
243 
+(in pattern)160 W
244 
+/Courier SF
245 
+20863 XM
246 
+(^GRE { > 600 < 800 })161 W
247 
+/Helvetica SF
248 
+(, ``{ > 600 < 800 }'' specifies a set of value)161 W
249 
+ES
250 
+%%Page: 1 2
251 
+BS
252 
+0 SI
253 
+10 /Helvetica-Bold AF
254 
+30322 4329 MT
255 
+(1)SH
256 
+/Helvetica SF
257 
+16096 7929 MT
258 
+(restrictions all of which)
259 
+325 W( must match; any LHS-values may be contained in the)324 W
260 
+16096 9072 MT
261 
+(conjunction;)SH
262 
+8312 11639 MT
263 
+(Restrictions to predicate operators:)SH
264 
+/Symbol SF
265 
+9242 13111 MT
266 
+(\267)SH
267 
+/Helvetica SF
268 
+9980 XM
269 
+(<, <=, >= and > used)
270 
+66 W( only with numbers and with variables bound to numbers.  <=> means)67 W
271 
+9980 14254 MT
272 
+(same type, and <> means not equal.)SH
273 
+/Symbol SF
274 
+9242 16069 MT
275 
+(\267)SH
276 
+/Helvetica SF
277 
+9980 XM
278 
+(first occurrence of a variable cannot be preceded by any)
279 
+292 W( predicate other than = \050first)291 W
280 
+9980 17212 MT
281 
+(occurrence establishes binding\051)SH
282 
+8312 19779 MT
283 
+(A condition pattern in LHS \050other than first\051 may be negated by putting a ``-'' in front of)
284 
+152 W( the normal)153 W
285 
+7200 21205 MT
286 
+(pattern)SH
287 
+8312 23772 MT
288 
+(Ordering of condition)
289 
+136 W( elements is significant in variable binding, for conflict resolution and for match)135 W
290 
+7200 25198 MT
291 
+(efficiency)SH
292 
+12 /Helvetica-Bold AF
293 
+7200 28953 MT
294 
+(4 RHS of OPS5 Rules)SH
295 
+10 /Symbol AF
296 
+9242 30425 MT
297 
+(\267)SH
298 
+/Helvetica SF
299 
+9980 XM
300 
+(The RHS of the OPS5 rule consists of an ordered sequence of actions.)SH
301 
+/Symbol SF
302 
+9242 32240 MT
303 
+(\267)SH
304 
+/Helvetica SF
305 
+9980 XM
306 
+(The primitive actions that affect working memory are)SH
307 
+/Helvetica-Bold SF
308 
+33432 XM
309 
+(make)SH
310 
+/Helvetica SF
311 
+(,)SH
312 
+/Helvetica-Bold SF
313 
+36545 XM
314 
+(modify)SH
315 
+/Helvetica SF
316 
+(, and)SH
317 
+/Helvetica-Bold SF
318 
+42325 XM
319 
+(remove)SH
320 
+/Helvetica SF
321 
+(.)SH
322 
+/Symbol SF
323 
+9242 34055 MT
324 
+(\267)SH
325 
+/Helvetica SF
326 
+9980 XM
327 
+(The)SH
328 
+/Helvetica-Bold SF
329 
+11981 XM
330 
+(write)SH
331 
+/Helvetica SF
332 
+14593 XM
333 
+(action is used to output information.)SH
334 
+/Symbol SF
335 
+9242 35870 MT
336 
+(\267)SH
337 
+/Helvetica SF
338 
+9980 XM
339 
+(The)SH
340 
+/Helvetica-Bold SF
341 
+11981 XM
342 
+(halt)SH
343 
+/Helvetica SF
344 
+14037 XM
345 
+(action provides a way of explicitly stopping the firing of production rules.)SH
346 
+/Symbol SF
347 
+9242 37685 MT
348 
+(\267)SH
349 
+/Helvetica SF
350 
+9980 XM
351 
+(RHS can also contain functions that return values within the actions.)
352 
+218 W( For)
353 
+716 W( example, the)219 W
354 
+/Helvetica-Bold SF
355 
+9980 38828 MT
356 
+(compute)SH
357 
+/Helvetica SF
358 
+14542 XM
359 
+(function allows OPS5 to do arithmetic.  It provides for infix)
360 
+117 W( evaluation of +,-,*, //,)116 W
361 
+9980 39971 MT
362 
+(and \134\134 \050respectively addition,)
363 
+105 W( subtraction, multiplication, division, and modulus\051.  Operations)106 W
364 
+9980 41114 MT
365 
+(are performed from right to left.)SH
366 
+/Symbol SF
367 
+9242 42929 MT
368 
+(\267)SH
369 
+/Helvetica SF
370 
+9980 XM
371 
+(These and other actions and functions will be demonstrated by example.)SH
372 
+12 /Helvetica-Bold AF
373 
+7200 46684 MT
374 
+(5 Specific Commands)SH
375 
+10 SS
376 
+25128 48367 MT
377 
+(The WATCH Command)SH
378 
+/Helvetica SF
379 
+7200 50239 MT
380 
+(no argument)SH
381 
+16096 XM
382 
+(Print current watch level \050initialized to 1\051 unchanged)SH
383 
+/Courier SF
384 
+7200 51865 MT
385 
+(\050watch 0\051)SH
386 
+/Helvetica SF
387 
+16096 XM
388 
+(No report of firings or changes to working memory)SH
389 
+/Courier SF
390 
+7200 53491 MT
391 
+(\050watch 1\051)SH
392 
+/Helvetica SF
393 
+16096 XM
394 
+(Report rule name and time tags of each working memory element)
395 
+417 W( for each)416 W
396 
+16096 54634 MT
397 
+(instantiation fired)SH
398 
+/Courier SF
399 
+7200 56260 MT
400 
+(\050watch 2\051)SH
401 
+/Helvetica SF
402 
+16096 XM
403 
+(In addition to level 1 reports, give each change \050add or delete\051 to working memory)SH
404 
+/Helvetica-Bold SF
405 
+25905 58132 MT
406 
+(The RUN Command)SH
407 
+/Courier SF
408 
+7200 60004 MT
409 
+(\050run\051)SH
410 
+/Helvetica SF
411 
+16096 XM
412 
+(run until a break or halt or no rules in conflict set)SH
413 
+/Courier SF
414 
+7200 61630 MT
415 
+(\050run N\051)SH
416 
+/Helvetica SF
417 
+16096 XM
418 
+(run N steps unless early stop as above)SH
419 
+/Courier SF
420 
+7200 63256 MT
421 
+(\050run 1\051)SH
422 
+/Helvetica SF
423 
+16096 XM
424 
+(for single stepping)SH
425 
+/Helvetica-Bold SF
426 
+22933 65128 MT
427 
+([The WM and PPWM Commands)SH
428 
+8312 67695 MT
429 
+(\050wm\051)SH
430 
+/Helvetica SF
431 
+10991 XM
432 
+(-- list the contents of working memory, optional arguments specify time tags; if no time tags are)69 W
433 
+7200 69121 MT
434 
+(given, shows all elements.)SH
435 
+/Courier SF
436 
+8312 71688 MT
437 
+(\050ppwm <pat>\051)149 W
438 
+/Helvetica SF
439 
+16088 XM
440 
+(-- <pat> is pattern \050in LHS condition form\051, prints all wme's that)
441 
+149 W( match <pat>.  No)148 W
442 
+ES
443 
+%%Page: 2 3
444 
+BS
445 
+0 SI
446 
+10 /Helvetica-Bold AF
447 
+30322 4329 MT
448 
+(2)SH
449 
+/Helvetica SF
450 
+7200 7929 MT
451 
+(variables, predicates or special characters are allowed in in)
452 
+150 W( <pat>.  If pattern is null, all elements are)151 W
453 
+7200 9355 MT
454 
+(printed.)SH
455 
+8312 11922 MT
456 
+(use with)SH
457 
+/Helvetica-Bold SF
458 
+12258 XM
459 
+(cs)SH
460 
+/Helvetica SF
461 
+13648 XM
462 
+(and)SH
463 
+/Helvetica-Bold SF
464 
+15594 XM
465 
+(matches)SH
466 
+/Helvetica SF
467 
+19929 XM
468 
+(to determine why a rule failed to be instantiated at the right time.)SH
469 
+/Helvetica-Bold SF
470 
+26238 13605 MT
471 
+(The PM Command)SH
472 
+/Courier SF
473 
+8312 16172 MT
474 
+(\050pm <args>\051)SH
475 
+/Helvetica SF
476 
+15190 XM
477 
+(-- <args> any number of rule names)SH
478 
+/Helvetica-Bold SF
479 
+26294 17855 MT
480 
+(The CS Command)SH
481 
+/Courier SF
482 
+8312 20422 MT
483 
+(\050cs\051)SH
484 
+/Helvetica SF
485 
+11268 XM
486 
+(-- lists each instantiated rule in)
487 
+278 W( conflict set, one to a line, followed by currently dominant)277 W
488 
+7200 21848 MT
489 
+(instantiation \050that is, the one to be fired on next cycle\051)SH
490 
+/Helvetica-Bold SF
491 
+24516 23531 MT
492 
+(The MATCHES Command)SH
493 
+/Courier SF
494 
+8312 26098 MT
495 
+(\050matches <rules>\051)208 W
496 
+/Helvetica SF
497 
+19206 XM
498 
+(-- prints partial matches)
499 
+208 W( for rules whose names are arguments.  For each)209 W
500 
+7200 27524 MT
501 
+(condition element of specified rules, time tags of matching wme's are listed, as well as intersections)
502 
+108 W( of)107 W
503 
+7200 28950 MT
504 
+(partial matches.)SH
505 
+/Courier-Bold SF
506 
+12000 31212 MT
507 
+(\050literalize number value\051)SH
508 
+12000 33474 MT
509 
+(\050p example-rule)SH
510 
+13800 34605 MT
511 
+(\050number ^value { <number-1> > 100 } \051)SH
512 
+13800 35736 MT
513 
+(\050number ^value { <number-2> <> <number-1> } \051)SH
514 
+13800 36867 MT
515 
+(\050number ^value { <number-3> < 50 } \051)SH
516 
+13800 37998 MT
517 
+(-->)SH
518 
+13800 39129 MT
519 
+(\050write \050crlf\051 <number-1> <number-2> <number-3> \051 \051)SH
520 
+12000 41391 MT
521 
+(\050make number ^value 101\051  ; given time-tag 1)SH
522 
+12000 43653 MT
523 
+(\050make number ^value 102\051  ; given time-tag 2)SH
524 
+12000 45915 MT
525 
+(\050make number ^value  11\051  ; given time-tag 3)SH
526 
+12000 47720 MT
527 
+(=>\050matches example-rule\051)SH
528 
+12000 49982 MT
529 
+(example-rule)SH
530 
+12600 51113 MT
531 
+(** matches for \0501\051 **)SH
532 
+12600 52244 MT
533 
+(2)SH
534 
+12600 53375 MT
535 
+(1)SH
536 
+12600 54506 MT
537 
+(** matches for \0502\051 **)SH
538 
+12600 55637 MT
539 
+(3)SH
540 
+12600 56768 MT
541 
+(2)SH
542 
+12600 57899 MT
543 
+(1)SH
544 
+12600 59030 MT
545 
+(** matches for \0502 1\051 **)SH
546 
+12600 60161 MT
547 
+(3 1)600 W
548 
+12600 61292 MT
549 
+(3 2)600 W
550 
+12600 62423 MT
551 
+(1 2)600 W
552 
+12600 63554 MT
553 
+(2 1)600 W
554 
+12600 64685 MT
555 
+(** matches for \0503\051)SH
556 
+12600 65816 MT
557 
+(3)SH
558 
+12000 66947 MT
559 
+(nil)SH
560 
+/Helvetica SF
561 
+7200 68807 MT
562 
+(The final intersection, which in this example would be)SH
563 
+/Courier SF
564 
+31043 XM
565 
+(matches for \0503 2 1\051)SH
566 
+/Helvetica SF
567 
+(, is not included.)SH
568 
+8312 71374 MT
569 
+(Uses:)SH
570 
+ES
571 
+%%Page: 3 4
572 
+BS
573 
+0 SI
574 
+10 /Helvetica-Bold AF
575 
+30322 4329 MT
576 
+(3)SH
577 
+/Symbol SF
578 
+9242 8000 MT
579 
+(\267)SH
580 
+/Helvetica SF
581 
+9980 XM
582 
+(a given condition element is never matched,)SH
583 
+/Symbol SF
584 
+9242 9815 MT
585 
+(\267)SH
586 
+/Helvetica SF
587 
+9980 XM
588 
+(the intersection of two or more condition elements, each of)
589 
+170 W( which is matched, fails to be)171 W
590 
+9980 10958 MT
591 
+(satisfied, or)SH
592 
+/Symbol SF
593 
+9242 12773 MT
594 
+(\267)SH
595 
+/Helvetica SF
596 
+9980 XM
597 
+(a negated condition element is matched.)SH
598 
+/Helvetica-Bold SF
599 
+24877 14456 MT
600 
+(The PBREAK Command)SH
601 
+/Symbol SF
602 
+9242 16210 MT
603 
+(\267)SH
604 
+/Courier SF
605 
+9980 XM
606 
+(\050pbreak <rules>\051)SH
607 
+/Helvetica SF
608 
+19858 XM
609 
+(-- toggles break/nobreak status of rules)SH
610 
+/Symbol SF
611 
+9242 18025 MT
612 
+(\267)SH
613 
+/Courier SF
614 
+9980 XM
615 
+(\050pbreak\051)SH
616 
+/Helvetica SF
617 
+15058 XM
618 
+(-- says which rules are broken)SH
619 
+/Symbol SF
620 
+9242 19840 MT
621 
+(\267)SH
622 
+/Helvetica SF
623 
+9980 XM
624 
+(breaks after rule fires)SH
625 
+/Helvetica-Bold SF
626 
+25544 21523 MT
627 
+(The BACK Command)SH
628 
+/Symbol SF
629 
+9242 23277 MT
630 
+(\267)SH
631 
+/Courier SF
632 
+9980 XM
633 
+(\050back <n>\051)200 W
634 
+/Helvetica SF
635 
+16658 XM
636 
+(undoes the effects of up to 32 rule firings, provided there are no external)200 W
637 
+9980 24420 MT
638 
+(references \050user-defined functions\051 in any RHS)SH
639 
+/Helvetica-Bold SF
640 
+21904 26103 MT
641 
+(The MAKE and REMOVE Commands)SH
642 
+/Symbol SF
643 
+9242 27857 MT
644 
+(\267)SH
645 
+/Courier SF
646 
+9980 XM
647 
+(\050remove *\051)SH
648 
+/Helvetica SF
649 
+16258 XM
650 
+(deletes everything from working memory.)SH
651 
+/Symbol SF
652 
+9242 29672 MT
653 
+(\267)SH
654 
+/Courier SF
655 
+9980 XM
656 
+(\050remove <args>\051)SH
657 
+/Helvetica SF
658 
+19258 XM
659 
+(deletes working memory elements with time tags in <args>)SH
660 
+/Helvetica-Bold SF
661 
+25154 31355 MT
662 
+(The EXCISE Command)SH
663 
+/Courier SF
664 
+8312 33922 MT
665 
+(\050excise <rules>\051)11 W
666 
+/Helvetica SF
667 
+18212 XM
668 
+(-- prevents rules)
669 
+11 W( from firing \050still in network\051, reload to recall, but won't be current)12 W
670 
+7200 35348 MT
671 
+(on wm.)SH
672 
+ES
673 
+%%Trailer
674 
+%%Pages: 4
675 
+%%DocumentFonts: Helvetica Helvetica-Bold Symbol Courier Courier-Bold Helvetica-Oblique
ops-backup.lisp
History View file @ 5092d8a
0 676 
new file mode 100644
... ... 
@@ -0,0 +1,195 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+;;;; Definitions and functions for backing up.
18 
+
19 
+(in-package "OPS")
20 
+
21 
+
22 
+;;; Internal Global Variables
23 
+
24 
+(defvar *refracts*)
25 
+(defvar *record*)
26 
+(defvar *record-array*)
27 
+(defvar *recording*)
28 
+(defvar *max-record-index*)
29 
+(defvar *record-index*)
30 
+
31 
+
32 
+
33 
+(defun backup-init ()
34 
+  (setq *recording* nil)
35 
+  (setq *refracts* nil)
36 
+  (setq *record-array* (make-array 256 :initial-element ()))  ;jgk
37 
+  (initialize-record))
38 
+
39 
+
40 
+(defun back (k)
41 
+  (dotimes (i k)
42 
+    (declare (ignore i))
43 
+    (let ((r (aref *record-array* *record-index*))) ; (('))
44 
+      (when (null r) (return '|nothing more stored|))
45 
+      (setf (aref *record-array* *record-index*) nil)
46 
+      (record-index-plus -1.)
47 
+      (undo-record r))))
48 
+
49 
+
50 
+; *max-record-index* holds the maximum legal index for record-array
51 
+; so it and the following must be changed at the same time
52 
+
53 
+(defun begin-record (p data)
54 
+  (setq *recording* t)
55 
+  (setq *record* (list '=>refract p data)))
56 
+
57 
+(defun end-record ()
58 
+  (when *recording*
59 
+    (setq *record*
60 
+	  (cons *cycle-count* (cons *p-name* *record*)))
61 
+    (record-index-plus 1.)
62 
+    (setf (aref *record-array* *record-index*) *record*)
63 
+    (setq *record* nil)
64 
+    (setq *recording* nil)))
65 
+
66 
+(defun record-change (direct time elm)
67 
+  (when *recording*
68 
+    (setq *record*
69 
+	  (cons direct (cons time (cons elm *record*))))))
70 
+
71 
+; to maintain refraction information, need keep only one piece of information:
72 
+; need to record all unsuccessful attempts to delete things from the conflict
73 
+; set.  unsuccessful deletes are caused by attempting to delete refracted
74 
+; instantiations.  when backing up, have to avoid putting things back into the
75 
+; conflict set if they were not deleted when running forward
76 
+
77 
+(defun record-refract (rule data)
78 
+  (when *recording*
79 
+    (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
80 
+
81 
+(defun refracted (rule data)
82 
+  (when *refracts*
83 
+    (let ((z (cons rule data)))
84 
+      (member z *refracts* :test #'equal)))
85 
+  #|(prog (z)
86 
+    (and (null *refracts*) (return nil))
87 
+    (setq z (cons rule data))
88 
+    (return (member z *refracts* :test #'equal)))|#
89 
+  )
90 
+
91 
+
92 
+(defun record-index-plus (k)
93 
+  (incf *record-index* k)
94 
+  (cond ((< *record-index* 0.)
95 
+	 (setq *record-index* *max-record-index*))
96 
+	((> *record-index* *max-record-index*)
97 
+	 (setq *record-index* 0.))))
98 
+
99 
+; the following routine initializes the record.  putting nil in the
100 
+; first slot indicates that that the record does not go back further
101 
+; than that.  (when the system backs up, it writes nil over the used
102 
+; records so that it will recognize which records it has used.  thus
103 
+; the system is set up anyway never to back over a nil.)
104 
+
105 
+(defun initialize-record nil
106 
+  (setq *record-index* 0.)
107 
+  (setq *recording* nil)
108 
+  (setq *max-record-index* 31.)
109 
+  (setf (aref *record-array* 0.) nil))
110 
+
111 
+
112 
+;; replaced per jcp
113 
+;;; Commented out
114 
+#|
115 
+(defun undo-record (r)
116 
+  (prog (save act a b rate)
117 
+    ;###	(comment *recording* must be off during back up)
118 
+    (setq save *recording*)
119 
+    (setq *refracts* nil)
120 
+    (setq *recording* nil)
121 
+    (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
122 
+    (setq r (cddr r))
123 
+    top  (and (atom r) (go fin))
124 
+    (setq act (car r))
125 
+    (setq a (cadr r))
126 
+    (setq b (caddr r))
127 
+    (setq r (cdddr r))
128 
+    (and *wtrace* (back-print (list '|undo:| act a)))
129 
+    (cond ((eq act '<=wm) (add-to-wm b a))
130 
+	  ((eq act '=>wm) (remove-from-wm b))
131 
+	  ((eq act '<=refract)
132 
+	   (setq *refracts* (cons (cons a b) *refracts*)))
133 
+	  ((and (eq act '=>refract) (still-present b))
134 
+	   (setq *refracts* (delete (cons a b) *refracts*))
135 
+	   (setq rate (rating-part (gethash a *topnode-table*)))
136 
+	   (removecs a b)
137 
+	   (insertcs a b rate))
138 
+	  (t (%warn '|back: cannot undo action| (list act a))))
139 
+    (go top)
140 
+    fin  (setq *recording* save)
141 
+    (setq *refracts* nil)
142 
+    (return nil)))
143 
+;;; End commented out
144 
+|#
145 
+
146 
+
147 
+(defun undo-record (r)
148 
+  (prog (save act a b rate)
149 
+    ;###	(comment *recording* must be off during back up)
150 
+    (setq save *recording*)
151 
+    (setq *refracts* nil)
152 
+    (setq *recording* nil)
153 
+    (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
154 
+    (setq r (cddr r))
155 
+    top  (and (atom r) (go fin))
156 
+    (setq act (car r))
157 
+    (setq a (cadr r))
158 
+    (setq b (caddr r))
159 
+    (setq r (cdddr r))
160 
+    (and *wtrace* (back-print (list '|undo:| act a)))
161 
+    (cond ((eq act '<=wm) (add-to-wm b a))
162 
+	  ((eq act '=>wm) (remove-from-wm b))
163 
+	  ((eq act '<=refract)
164 
+	   (setq *refracts* (cons (cons a b) *refracts*)))
165 
+	  ((and (eq act '=>refract) (still-present b))
166 
+	   (setq *refracts* (tree-remove (cons a b) *refracts*))
167 
+	   (setq rate (rating-part (gethash a *topnode-table*)))
168 
+	   (removecs a b)
169 
+	   (insertcs a b rate))
170 
+	  (t (%warn '|back: cannot undo action| (list act a))))
171 
+    (go top)
172 
+    fin  (setq *recording* save)
173 
+    (setq *refracts* nil)
174 
+    (return nil)))
175 
+
176 
+
177 
+
178 
+; still-present makes sure that the user has not deleted something
179 
+; from wm which occurs in the instantiation about to be restored; it
180 
+; makes the check by determining whether each wme still has a time tag.
181 
+
182 
+(defun still-present (data)
183 
+  (prog nil
184 
+    loop
185 
+    (cond ((atom data) (return t))
186 
+	  ((creation-time (car data))
187 
+	   (setq data (cdr data))
188 
+	   (go loop))
189 
+	  (t (return nil)))))
190 
+
191 
+(defun back-print (x)
192 
+  (let ((stream (trace-file)))
193 
+    (format stream "~&~S" x)))
194 
+
195 
+;;; *EOF*
ops-compile.lisp
History View file @ 5092d8a
0 196 
new file mode 100644
... ... 
@@ -0,0 +1,824 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+;;;; This file contains functions compile productions.
18 
+
19 
+(in-package "OPS")
20 
+;(shadow '(remove write))    ; Should get this by requiring ops-rhs
21 
+;(export '--> )
22 
+
23 
+
24 
+;;; External global variables
25 
+
26 
+(defvar *real-cnt*)
27 
+(defvar *virtual-cnt*)
28 
+(defvar *last-node*)
29 
+(defvar *first-node*)
30 
+(defvar *pcount*)
31 
+
32 
+
33 
+;;; Internal global variables
34 
+
35 
+(defvar *matrix*)
36 
+(defvar *curcond*)
37 
+(defvar *feature-count*)
38 
+(defvar *ce-count*)
39 
+(defvar *vars*)
40 
+(defvar *ce-vars*)
41 
+(defvar *rhs-bound-vars*)
42 
+(defvar *rhs-bound-ce-vars*)
43 
+(defvar *last-branch*)
44 
+(defvar *subnum*)
45 
+(defvar *cur-vars*)
46 
+(defvar *action-type*)
47 
+
48 
+
49 
+
50 
+(defun compile-init ()
51 
+  (setq *real-cnt* (setq *virtual-cnt* 0.))
52 
+  (setq *pcount* 0.)
53 
+  (make-bottom-node))
54 
+
55 
+
56 
+;;; LHS Compiler
57 
+
58 
+(defun ops-p (z)
59 
+  (finish-literalize)
60 
+  (princ '*)
61 
+  ;(drain) commented out temporarily
62 
+  (force-output)			;@@@ clisp drain?
63 
+  (compile-production (car z) (cdr z)))
64 
+
65 
+
66 
+(defun compile-production (name matrix)
67 
+  ;; jgk inverted args to catch and quoted tag
68 
+  (setq *p-name* name)
69 
+  (catch '!error! (cmp-p name matrix))
70 
+  (setq *p-name* nil))
71 
+#|
72 
+(defun compile-production (name matrix) ;jgk inverted args to catch
73 
+  (prog (erm)				;and quoted tag
74 
+    (setq *p-name* name)
75 
+    (setq erm (catch '!error! (cmp-p name matrix)))
76 
+    (setq *p-name* nil)))
77 
+|#
78 
+
79 
+(defun peek-lex ()
80 
+  (car *matrix*))
81 
+
82 
+(defun lex ()
83 
+  (pop *matrix*))
84 
+
85 
+(defun end-of-p () (atom *matrix*))
86 
+
87 
+(defun rest-of-p () *matrix*)
88 
+
89 
+(defun prepare-lex (prod) (setq *matrix* prod))
90 
+
91 
+
92 
+(defun peek-sublex () (car *curcond*))
93 
+
94 
+(defun sublex ()
95 
+  (pop *curcond*))
96 
+
97 
+(defun end-of-ce () (atom *curcond*))
98 
+
99 
+(defun rest-of-ce () *curcond*)
100 
+
101 
+(defun prepare-sublex (ce) (setq *curcond* ce))
102 
+
103 
+(defun make-bottom-node ()
104 
+  (setq *first-node* (list '&bus nil)))
105 
+
106 
+(defun cmp-p (name matrix)
107 
+  (prog (m bakptrs)
108 
+    (cond ((or (null name) (consp  name))	;dtpr\consp gdw
109 
+	   (%error '|illegal production name| name))
110 
+	  ((equal (gethash name *production-table*) matrix)
111 
+	   (return nil)))
112 
+    (prepare-lex matrix)
113 
+    (excise-p name)
114 
+    (setq bakptrs nil)
115 
+    (incf *pcount*)		;"plus" changed to "+" by gdw
116 
+    (setq *feature-count* 0.)
117 
+    (setq *ce-count* 0)
118 
+    (setq *vars* nil)
119 
+    (setq *ce-vars* nil)
120 
+    (setq *rhs-bound-vars* nil)
121 
+    (setq *rhs-bound-ce-vars* nil)
122 
+    (setq *last-branch* nil)
123 
+    (setq m (rest-of-p))
124 
+    l1   (and (end-of-p) (%error '|no '-->' in production| m))
125 
+    (cmp-prin)
126 
+    (setq bakptrs (cons *last-branch* bakptrs))
127 
+    (or (eq '--> (peek-lex)) (go l1))
128 
+    (lex)
129 
+    (check-rhs (rest-of-p))
130 
+    (link-new-node (list '&p
131 
+			 *feature-count*
132 
+			 name
133 
+			 (encode-dope)
134 
+			 (encode-ce-dope)
135 
+			 (cons 'progn (rest-of-p))))
136 
+    (setf (gethash name *backpointers-table*) (cdr (nreverse bakptrs)))
137 
+    (setf (gethash name *production-table*) matrix)
138 
+    (setf (gethash name *topnode-table*) *last-node*)))
139 
+
140 
+(defun rating-part (pnode) (cadr pnode))
141 
+
142 
+(defun var-part (pnode) (car (cdddr pnode)))
143 
+
144 
+(defun ce-var-part (pnode) (cadr (cdddr pnode)))
145 
+
146 
+(defun rhs-part (pnode) (caddr (cdddr pnode)))
147 
+
148 
+(defun cmp-prin nil
149 
+  (setq *last-node* *first-node*)
150 
+  (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
151 
+	((eq (peek-lex) '-) (cmp-negce) (cmp-not))
152 
+	(t (cmp-posce) (cmp-and))))
153 
+
154 
+(defun cmp-negce nil (lex) (cmp-ce))
155 
+
156 
+(defun cmp-posce nil
157 
+  (setq *ce-count* (1+ *ce-count*))		;"plus" changed to "+" by gdw
158 
+  (cond ((eq (peek-lex) '\{) (cmp-ce+cevar))	;"plus" changed to "+" by gdw
159 
+	(t (cmp-ce))))
160 
+
161 
+(defun cmp-ce+cevar ()
162 
+  (prog (z)
163 
+    (lex)
164 
+    (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
165 
+	  (t (cmp-ce) (cmp-cevar)))
166 
+    (setq z (lex))
167 
+    (or (eq z '\}) (%error '|missing '}'| z))))
168 
+
169 
+(defun new-subnum (k)
170 
+  (or (numberp k) (%error '|tab must be a number| k))
171 
+  (setq *subnum* (floor k)))
172 
+
173 
+(defun incr-subnum ()
174 
+  (incf *subnum*))
175 
+
176 
+(defun cmp-ce ()
177 
+  (prog (z)
178 
+    (new-subnum 0.)
179 
+    (setq *cur-vars* nil)
180 
+    (setq z (lex))
181 
+    (and (atom z)
182 
+	 (%error '|atomic conditions are not allowed| z))
183 
+    (prepare-sublex z)
184 
+    la   (and (end-of-ce) (return nil))
185 
+    (incr-subnum)
186 
+    (cmp-element)
187 
+    (go la)))
188 
+
189 
+(defun cmp-element nil
190 
+  (when (eq (peek-sublex) '^)
191 
+    (cmp-tab))
192 
+  (cond ((eq (peek-sublex) '\{) (cmp-product))
193 
+	(t (cmp-atomic-or-any))))
194 
+
195 
+(defun cmp-atomic-or-any ()
196 
+  (cond ((eq (peek-sublex) '<<) (cmp-any))
197 
+	(t (cmp-atomic))))
198 
+
199 
+(defun cmp-any ()
200 
+  (prog (a z)
201 
+    (sublex)
202 
+    (setq z nil)
203 
+    la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
204 
+    (setq a (sublex))
205 
+    (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
206 
+    (link-new-node (list '&any nil (current-field) z))))
207 
+
208 
+(defun cmp-tab nil
209 
+  (prog (r)
210 
+    (sublex)
211 
+    (setq r (sublex))
212 
+    (setq r ($litbind r))
213 
+    (new-subnum r)))
214 
+
215 
+(defun get-bind (x)
216 
+  (when (symbolp x)
217 
+    (literal-binding-of x)))
218 
+
219 
+(defun cmp-atomic nil
220 
+  (prog (test x)
221 
+    (setq x (peek-sublex))
222 
+    (cond ((eq x '= ) (setq test 'eq) (sublex))
223 
+	  ((eq x '<>) (setq test 'ne) (sublex))
224 
+	  ((eq x '<) (setq test 'lt) (sublex))
225 
+	  ((eq x '<=) (setq test 'le) (sublex))
226 
+	  ((eq x '>) (setq test 'gt) (sublex))
227 
+	  ((eq x '>=) (setq test 'ge) (sublex))
228 
+	  ((eq x '<=>) (setq test 'xx) (sublex))
229 
+	  (t (setq test 'eq)))
230 
+    (cmp-symbol test)))
231 
+
232 
+(defun cmp-product ()
233 
+  (prog (save)
234 
+    (setq save (rest-of-ce))
235 
+    (sublex)
236 
+    la   (cond ((end-of-ce)
237 
+		(cond ((member '\} save :test #'equal)
238 
+		       (%error '|wrong contex for '}'| save))
239 
+		      (t (%error '|missing '}'| save))))
240 
+	       ((eq (peek-sublex) '\}) (sublex) (return nil)))
241 
+    (cmp-atomic-or-any)
242 
+    (go la)))
243 
+
244 
+(defun cmp-symbol (test)
245 
+  (let ((flag t))
246 
+    (when (eq (peek-sublex) '//)
247 
+      (sublex)
248 
+      (setq flag nil))
249 
+    (cond ((and flag (variablep (peek-sublex)))
250 
+	   (cmp-var test))
251 
+	  ((numberp (peek-sublex)) (cmp-number test))
252 
+	  ((symbolp (peek-sublex)) (cmp-constant test))
253 
+	  (t (%error '|unrecognized symbol| (sublex))))))
254 
+
255 
+(defun cmp-constant (test)   ;jgk inserted concatenate form
256 
+  (or (member test '(eq ne xx))
257 
+      (%error '|non-numeric constant after numeric predicate| (sublex)))
258 
+  (link-new-node (list (intern (concatenate 'string
259 
+					    "T"
260 
+					    (symbol-name  test)
261 
+					    "A"))
262 
+		       nil
263 
+		       (current-field)
264 
+		       (sublex))))
265 
+
266 
+(defun cmp-number (test)		;jgk inserted concatenate form
267 
+  (link-new-node (list (intern (concatenate 'string
268 
+					    "T"
269 
+					    (symbol-name  test)
270 
+;@@@ error? reported by laird fix\	    "A"
271 
+					    "N"))
272 
+		       nil
273 
+		       (current-field)
274 
+		       (sublex))))
275 
+
276 
+(defun current-field () (field-name *subnum*))
277 
+
278 
+(defun field-name (num)
279 
+  (if (< 0 num 127)
280 
+      (svref '#(nil *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9* *c10* *c11*
281 
+		    *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* *c20* *c21*
282 
+		    *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* *c30* *c31*
283 
+		    *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* *c40* *c41*
284 
+		    *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* *c50* *c51*
285 
+		    *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* *c60* *c61*
286 
+		    *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* *c70* *c71*
287 
+		    *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* *c80* *c81*
288 
+		    *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* *c90* *c91*
289 
+		    *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* *c100*
290 
+		    *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108*
291 
+		    *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116*
292 
+		    *c117* *c118* *c119* *c120* *c121* *c122* *c123* *c124*
293 
+		    *c125* *c126* *c127*)
294 
+	     num)
295 
+      (%error '|condition is too long| (rest-of-ce))))
296 
+
297 
+;;; Compiling variables
298 
+;
299 
+;
300 
+;
301 
+; *cur-vars* are the variables in the condition element currently
302 
+; being compiled.  *vars* are the variables in the earlier condition
303 
+; elements.  *ce-vars* are the condition element variables.  note
304 
+; that the interpreter will not confuse condition element and regular
305 
+; variables even if they have the same name.
306 
+;
307 
+; *cur-vars* is a list of triples: (name predicate subelement-number)
308 
+; eg:		( (<x> eq 3)
309 
+;		  (<y> ne 1)
310 
+;		  . . . )
311 
+;
312 
+; *vars* is a list of triples: (name ce-number subelement-number)
313 
+; eg:		( (<x> 3 3)
314 
+;		  (<y> 1 1)
315 
+;		  . . . )
316 
+;
317 
+; *ce-vars* is a list of pairs: (name ce-number)
318 
+; eg:		( (ce1 1)
319 
+;		  (<c3> 3)
320 
+;		  . . . )
321 
+
322 
+;;; used only in this file.
323 
+(defmacro var-dope (var) `(assoc ,var *vars*))
324 
+
325 
+(defmacro ce-var-dope (var) `(assoc ,var *ce-vars*))
326 
+
327 
+(defun cmp-var (test)
328 
+  (let* ((name (sublex))
329 
+	 (old (assoc name *cur-vars*)))
330 
+    (cond ((and old (eq (cadr old) 'eq))
331 
+	   (cmp-old-eq-var test old))
332 
+	  ((and old (eq test 'eq)) (cmp-new-eq-var name old))
333 
+	  (t (cmp-new-var name test)))))
334 
+
335 
+(defun cmp-new-var (name test)
336 
+  (push (list name test *subnum*)
337 
+	*cur-vars*))
338 
+
339 
+(defun cmp-old-eq-var (test old)	; jgk inserted concatenate form
340 
+  (link-new-node (list (intern (concatenate 'string
341 
+					    "T"
342 
+					    (symbol-name  test)
343 
+					    "S"))
344 
+		       nil
345 
+		       (current-field)
346 
+		       (field-name (caddr old)))))
347 
+
348 
+(defun cmp-new-eq-var (name old)	;jgk inserted concatenate form
349 
+  (prog (pred next)
350 
+    (setq *cur-vars* (delete old *cur-vars* :test #'eq))
351 
+    (setq next (assoc name *cur-vars*))
352 
+    (cond (next (cmp-new-eq-var name next))
353 
+	  (t (cmp-new-var name 'eq)))
354 
+    (setq pred (cadr old))
355 
+    (link-new-node (list (intern (concatenate 'string
356 
+					      "T"
357 
+					      (symbol-name  pred)
358 
+					      "S"))
359 
+			 nil
360 
+			 (field-name (caddr old))
361 
+			 (current-field)))))
362 
+
363 
+(defun cmp-cevar nil
364 
+  (let* ((name (lex))
365 
+	 (old (assoc name *ce-vars*)))
366 
+    (when old
367 
+      (%error '|condition element variable used twice| name))
368 
+    (push (list name 0.)
369 
+	  *ce-vars*)))
370 
+
371 
+(defun cmp-not nil (cmp-beta '&not))
372 
+
373 
+(defun cmp-nobeta nil (cmp-beta nil))
374 
+
375 
+(defun cmp-and nil (cmp-beta '&and))
376 
+
377 
+(defun cmp-beta (kind)
378 
+  (prog (tlist vdope vname #|vpred vpos|# old)
379 
+    (setq tlist nil)
380 
+    la   (and (atom *cur-vars*) (go lb))
381 
+    (setq vdope (car *cur-vars*))
382 
+    (setq *cur-vars* (cdr *cur-vars*))
383 
+    (setq vname (car vdope))
384 
+    ;;  (setq vpred (cadr vdope))    Dario - commented out (unused)
385 
+    ;;  (setq vpos (caddr vdope))
386 
+    (setq old (assoc vname *vars*))
387 
+    (cond (old (setq tlist (add-test tlist vdope old)))
388 
+	  ((not (eq kind '&not)) (promote-var vdope)))
389 
+    (go la)
390 
+    lb   (and kind (build-beta kind tlist))
391 
+    (or (eq kind '&not) (fudge))
392 
+    (setq *last-branch* *last-node*)))
393 
+
394 
+(defun add-test (list new old) ; jgk inserted concatenate form
395 
+  (prog (ttype lloc rloc)
396 
+    (incf *feature-count*)
397 
+    (setq ttype (intern (concatenate 'string "T"
398 
+				     (symbol-name (cadr new))
399 
+				     "B")))
400 
+    (setq rloc (encode-singleton (caddr new)))
401 
+    (setq lloc (encode-pair (cadr old) (caddr old)))
402 
+    (return (cons ttype (cons lloc (cons rloc list))))))
403 
+
404 
+; the following two functions encode indices so that gelm can
405 
+; decode them as fast as possible
406 
+
407 
+(defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b)))
408 
+;"plus" changed to "+" by gdw
409 
+
410 
+(defun encode-singleton (a) (1- a))
411 
+
412 
+(defun promote-var (dope)
413 
+  (prog (vname vpred vpos new)
414 
+    (setq vname (car dope))
415 
+    (setq vpred (cadr dope))
416 
+    (setq vpos (caddr dope))
417 
+    (or (eq 'eq vpred)
418 
+	(%error '|illegal predicate for first occurrence|
419 
+		(list vname vpred)))
420 
+    (setq new (list vname 0. vpos))
421 
+    (setq *vars* (cons new *vars*))))
422 
+
423 
+(defun fudge nil
424 
+  (mapc #'fudge* *vars*)
425 
+  (mapc #'fudge* *ce-vars*))
426 
+
427 
+(defun fudge* (z)
428 
+  (let ((a (cdr z)))
429 
+    (incf (car a))))
430 
+
431 
+(defun build-beta (type tests)
432 
+  (prog (rpred lpred lnode lef)
433 
+    (link-new-node (list '&mem nil nil (protomem)))
434 
+    (setq rpred *last-node*)
435 
+    (cond ((eq type '&and)
436 
+	   (setq lnode (list '&mem nil nil (protomem))))
437 
+	  (t (setq lnode (list '&two nil nil))))
438 
+    (setq lpred (link-to-branch lnode))
439 
+    (cond ((eq type '&and) (setq lef lpred))
440 
+	  (t (setq lef (protomem))))
441 
+    (link-new-beta-node (list type nil lef rpred tests))))
442 
+
443 
+(defun protomem nil (list nil))
444 
+
445 
+(defun memory-part (mem-node) (car (cadddr mem-node)))
446 
+
447 
+(defun encode-dope nil
448 
+  (prog (r all z k)
449 
+    (setq r nil)
450 
+    (setq all *vars*)
451 
+    la   (and (atom all) (return r))
452 
+    (setq z (car all))
453 
+    (setq all (cdr all))
454 
+    (setq k (encode-pair (cadr z) (caddr z)))
455 
+    (setq r (cons (car z) (cons k r)))
456 
+    (go la)))
457 
+
458 
+(defun encode-ce-dope nil
459 
+  (prog (r all z k)
460 
+    (setq r nil)
461 
+    (setq all *ce-vars*)
462 
+    la   (and (atom all) (return r))
463 
+    (setq z (car all))
464 
+    (setq all (cdr all))
465 
+    (setq k (cadr z))
466 
+    (setq r (cons (car z) (cons k r)))
467 
+    (go la)))
468 
+
469 
+
470 
+
471 
+;;; Linking the nodes
472 
+
473 
+(defun link-new-node (r)
474 
+  (cond ((not (member (car r) '(&p &mem &two &and &not) :test #'equal))
475 
+	 (setq *feature-count* (1+ *feature-count*))))
476 
+  (setq *virtual-cnt* (1+ *virtual-cnt*))
477 
+  (setq *last-node* (link-left *last-node* r)))
478 
+
479 
+(defun link-to-branch (r)
480 
+  (setq *virtual-cnt* (1+ *virtual-cnt*))
481 
+  (setq *last-branch* (link-left *last-branch* r)))
482 
+
483 
+(defun link-new-beta-node (r)
484 
+  (setq *virtual-cnt* (1+ *virtual-cnt*))
485 
+  (setq *last-node* (link-both *last-branch* *last-node* r))
486 
+  (setq *last-branch* *last-node*))
487 
+
488 
+(defun link-left (pred succ)
489 
+  (prog (a r)
490 
+    (setq a (left-outs pred))
491 
+    (setq r (find-equiv-node succ a))
492 
+    (and r (return r))
493 
+    (setq *real-cnt* (1+ *real-cnt*))
494 
+    (attach-left pred succ)
495 
+    (return succ)))
496 
+
497 
+(defun link-both (left right succ)
498 
+  (prog (a r)
499 
+    (setq a (intersection (left-outs left) (right-outs right)))
500 
+    (setq r (find-equiv-beta-node succ a))
501 
+    (and r (return r))
502 
+    (setq *real-cnt* (1+ *real-cnt*))
503 
+    (attach-left left succ)
504 
+    (attach-right right succ)
505 
+    (return succ)))
506 
+
507 
+(defun attach-right (old new)
508 
+  (rplaca (cddr old) (cons new (caddr old))))
509 
+
510 
+(defun attach-left (old new)
511 
+  (rplaca (cdr old) (cons new (cadr old))))
512 
+
513 
+(defun right-outs (node) (caddr node))
514 
+
515 
+(defun left-outs (node) (cadr node))
516 
+
517 
+(defun find-equiv-node (node list)
518 
+  (prog (a)
519 
+    (setq a list)
520 
+    l1   (cond ((atom a) (return nil))
521 
+	       ((equiv node (car a)) (return (car a))))
522 
+    (setq a (cdr a))
523 
+    (go l1)))
524 
+
525 
+(defun find-equiv-beta-node (node list)
526 
+  (prog (a)
527 
+    (setq a list)
528 
+    l1   (cond ((atom a) (return nil))
529 
+	       ((beta-equiv node (car a)) (return (car a))))
530 
+    (setq a (cdr a))
531 
+    (go l1)))
532 
+
533 
+; do not look at the predecessor fields of beta nodes; they have to be
534 
+; identical because of the way the candidate nodes were found
535 
+
536 
+(defun equiv (a b)
537 
+  (and (eq (car a) (car b))
538 
+       (or (eq (car a) '&mem)
539 
+	   (eq (car a) '&two)
540 
+	   (equal (caddr a) (caddr b)))
541 
+       (equal (cdddr a) (cdddr b))))
542 
+
543 
+(defun beta-equiv (a b)
544 
+  (and (eq (car a) (car b))
545 
+       (equal (cddddr a) (cddddr b))
546 
+       (or (eq (car a) '&and) (equal (caddr a) (caddr b)))))
547 
+
548 
+; the equivalence tests are set up to consider the contents of
549 
+; node memories, so they are ready for the build action
550 
+
551 
+
552 
+
553 
+;;; Check the RHSs of productions
554 
+
555 
+
556 
+(defun check-rhs (rhs) (mapc #'check-action rhs))
557 
+
558 
+(defun check-action (x)
559 
+  (if (atom x)
560 
+      (%warn '|atomic action| x)
561 
+      (let ((a (car x)))
562 
+	(setq *action-type* a)
563 
+	(case a
564 
+	  (bind (check-bind x))
565 
+	  (cbind (check-cbind x))
566 
+	  (make (check-make x))
567 
+	  (modify (check-modify x))
568 
+	  (remove (check-remove x))
569 
+	  (write (check-write x))
570 
+	  (call (check-call x))
571 
+	  (halt (check-halt x))
572 
+	  (openfile (check-openfile x))
573 
+	  (closefile (check-closefile x))
574 
+	  (default (check-default x))
575 
+	  (build (check-build x))
576 
+	  (t (%warn '|undefined rhs action| a))))))
577 
+
578 
+
579 
+;(defun chg-to-write (x)
580 
+;	(setq x (cons 'write (cdr x))))
581 
+
582 
+(defun check-build (z)
583 
+  (when (null (cdr z))
584 
+    (%warn '|needs arguments| z))
585 
+  (check-build-collect (cdr z)))
586 
+
587 
+(defun check-build-collect (args)
588 
+  (prog (r)
589 
+    top	(and (null args) (return nil))
590 
+    (setq r (car args))
591 
+    (setq args (cdr args))
592 
+    (cond ((consp  r) (check-build-collect r))	;dtpr\consp gdw
593 
+	  ((eq r '\\)
594 
+	   (and (null args) (%warn '|nothing to evaluate| r))
595 
+	   (check-rhs-value (car args))
596 
+	   (setq args (cdr args))))
597 
+    (go top)))
598 
+
599 
+(defun check-remove (z) 				;@@@ kluge by gdw
600 
+  (when (null (cdr z))
601 
+    (%warn '|needs arguments| z))
602 
+  (mapc (function check-rhs-ce-var) (cdr z)))
603 
+
604 
+;(defun check-remove (z) 					;original
605 
+   ; (and (null (cdr z)) (%warn '|needs arguments| z))
606 
+   ;(mapc (function check-rhs-ce-var) (cdr z)))
607 
+
608 
+(defun check-make (z)
609 
+  (when (null (cdr z))
610 
+    (%warn '|needs arguments| z))
611 
+  (check-change& (cdr z)))
612 
+
613 
+(defun check-openfile (z)
614 
+  (when (null (cdr z))
615 
+    (%warn '|needs arguments| z))
616 
+  (check-change& (cdr z)))
617 
+
618 
+(defun check-closefile (z)
619 
+  (when (null (cdr z))
620 
+    (%warn '|needs arguments| z))
621 
+  (check-change& (cdr z)))
622 
+
623 
+(defun check-default (z)
624 
+  (when (null (cdr z))
625 
+    (%warn '|needs arguments| z))
626 
+  (check-change& (cdr z)))
627 
+
628 
+(defun check-modify (z)
629 
+  (when (null (cdr z))
630 
+    (%warn '|needs arguments| z))
631 
+  (check-rhs-ce-var (cadr z))
632 
+  (when (null (cddr z))
633 
+    (%warn '|no changes to make| z))
634 
+  (check-change& (cddr z)))
635 
+
636 
+(defun check-write (z)				;note this works w/write
637 
+  (when (null (cdr z))
638 
+    (%warn '|needs arguments| z))
639 
+  (check-change& (cdr z)))
640 
+
641 
+(defun check-call (z)
642 
+  (when (null (cdr z))
643 
+    (%warn '|needs arguments| z))
644 
+  (let ((f (cadr z)))
645 
+    (when (variablep f)
646 
+      (%warn '|function name must be a constant| z))
647 
+    (unless (symbolp f)
648 
+      (%warn '|function name must be a symbolic atom| f))
649 
+    (unless (externalp f)
650 
+      (%warn '|function name not declared external| f))
651 
+    (check-change& (cddr z))))
652 
+
653 
+(defun check-halt (z)
654 
+  (unless (null (cdr z))
655 
+    (%warn '|does not take arguments| z)))
656 
+
657 
+(defun check-cbind (z)
658 
+  (unless (= (length z) 2.)
659 
+    (%warn '|takes only one argument| z))
660 
+  (let ((v (cadr z)))
661 
+    (unless (variablep v)
662 
+      (%warn '|takes variable as argument| z))
663 
+    (note-ce-variable v)))
664 
+
665 
+(defun check-bind (z)
666 
+  (unless (> (length z) 1.)
667 
+    (%warn '|needs arguments| z))
668 
+  (let ((v (cadr z)))
669 
+    (unless (variablep v)
670 
+      (%warn '|takes variable as argument| z))
671 
+    (note-variable v)
672 
+    (check-change& (cddr z))))
673 
+
674 
+(defun check-change& (z)
675 
+  (prog (r tab-flag)
676 
+    (setq tab-flag nil)
677 
+    la   (and (atom z) (return nil))
678 
+    (setq r (car z))
679 
+    (setq z (cdr z))
680 
+    (cond ((eq r '^)
681 
+	   (and tab-flag
682 
+		(%warn '|no value before this tab| (car z)))
683 
+	   (setq tab-flag t)
684 
+	   (check-tab-index (car z))
685 
+	   (setq z (cdr z)))
686 
+	  ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
687 
+	  (t (setq tab-flag nil) (check-rhs-value r)))
688 
+    (go la)))
689 
+
690 
+(defun check-rhs-ce-var (v)
691 
+  (cond ((and (not (numberp v)) (not (ce-bound? v)))
692 
+	 (%warn '|unbound element variable| v))
693 
+	((and (numberp v) (or (< v 1.) (> v *ce-count*)))
694 
+	 (%warn '|numeric element designator out of bounds| v))))
695 
+
696 
+(defun check-rhs-value (x)
697 
+  (if (consp x)				;dtpr\consp gdw
698 
+      (check-rhs-function x)
699 
+      (check-rhs-atomic x)))
700 
+
701 
+(defun check-rhs-atomic (x)
702 
+  (when (and (variablep x)
703 
+	     (not (bound? x)))
704 
+    (%warn '|unbound variable| x)))
705 
+
706 
+(defun check-rhs-function (x)
707 
+  (let ((a (car x)))
708 
+    (case a
709 
+      (compute (check-compute x))
710 
+      (arith (check-compute x))
711 
+      (substr (check-substr x))
712 
+      (accept (check-accept x))
713 
+      (acceptline (check-acceptline x))
714 
+      (crlf (check-crlf x))
715 
+      (genatom (check-genatom x))
716 
+      (litval (check-litval x))
717 
+      (tabto (check-tabto x))
718 
+      (rjust (check-rjust x))
719 
+      (otherwise
720 
+       (when (not (externalp a))
721 
+	 (%warn '"rhs function not declared external" a))))))
722 
+
723 
+(defun externalp (x)
724 
+  ;  (cond ((symbolp x) (gethash x *external-routine-table*)) 	;) @@@
725 
+  ;ok, I'm eliminating this temporarily @@@@
726 
+  (cond ((symbolp x) t)
727 
+	(t (%warn '|not a legal function name| x) nil)))
728 
+
729 
+(defun check-litval (x)
730 
+  (unless (= (length x) 2)
731 
+    (%warn '|wrong number of arguments| x))
732 
+  (check-rhs-atomic (cadr x)))
733 
+
734 
+(defun check-accept (x)
735 
+  (cond ((= (length x) 1) nil)
736 
+	((= (length x) 2) (check-rhs-atomic (cadr x)))
737 
+	(t (%warn '|too many arguments| x))))
738 
+
739 
+(defun check-acceptline (x)
740 
+  (mapc #'check-rhs-atomic (cdr x)))
741 
+
742 
+(defun check-crlf (x)
743 
+  (check-0-args x))
744 
+
745 
+(defun check-genatom (x) (check-0-args x))
746 
+
747 
+(defun check-tabto (x)
748 
+  (unless (= (length x) 2)
749 
+    (%warn '|wrong number of arguments| x))
750 
+  (check-print-control (cadr x)))
751 
+
752 
+(defun check-rjust (x)
753 
+  (unless (= (length x) 2)
754 
+    (%warn '|wrong number of arguments| x))
755 
+  (check-print-control (cadr x)))
756 
+
757 
+(defun check-0-args (x)
758 
+  (unless (= (length x) 1.)
759 
+    (%warn '|should not have arguments| x)))
760 
+
761 
+(defun check-substr (x)
762 
+  (unless (= (length x) 4.)
763 
+    (%warn '|wrong number of arguments| x))
764 
+  (check-rhs-ce-var (cadr x))
765 
+  (check-substr-index (caddr x))
766 
+  (check-last-substr-index (cadddr x)))
767 
+
768 
+(defun check-compute (x) (check-arithmetic (cdr x)))
769 
+
770 
+(defun check-arithmetic (l)
771 
+  (cond ((atom l)
772 
+	 (%warn '|syntax error in arithmetic expression| l))
773 
+	((atom (cdr l)) (check-term (car l)))
774 
+	;; "plus" changed to "+" by gdw
775 
+	;; "quotient" added by mk, for backward compatability with the
776 
+	;; old definition of //.
777 
+	((not (member (cadr l) '(+ - * // \\ quotient)))
778 
+	 (%warn '|unknown operator| l))
779 
+	(t (check-term (car l)) (check-arithmetic (cddr l)))))
780 
+
781 
+(defun check-term (x)
782 
+  (if (consp x)				;dtpr\consp gdw
783 
+      (check-arithmetic x)
784 
+      (check-rhs-atomic x)))
785 
+
786 
+(defun check-last-substr-index (x)
787 
+  (or (eq x 'inf) (check-substr-index x)))
788 
+
789 
+(defun check-substr-index (x)
790 
+  (if (bound? x) x
791 
+      (let ((v ($litbind x)))
792 
+	(cond ((not (numberp v))
793 
+	       (%warn '|unbound symbol used as index in substr| x))
794 
+	      ((or (< v 1.) (> v 127.))
795 
+	       (%warn '|index out of bounds in tab| x))))))
796 
+
797 
+(defun check-print-control (x)
798 
+  (cond ((bound? x) x)
799 
+	((or (not (numberp x)) (< x 1.) (> x 127.))
800 
+	 (%warn '|illegal value for printer control| x))))
801 
+
802 
+(defun check-tab-index (x)
803 
+  (if (bound? x) x
804 
+      (let ((v ($litbind x)))
805 
+	(cond ((not (numberp v))
806 
+	       (%warn '|unbound symbol occurs after ^| x))
807 
+	      ((or (< v 1.) (> v 127.))
808 
+	       (%warn '|index out of bounds after ^| x))))))
809 
+
810 
+(defun note-variable (var)
811 
+  (push var *rhs-bound-vars*))
812 
+
813 
+(defun bound? (var)
814 
+  (or (member var *rhs-bound-vars*)
815 
+      (var-dope var)))
816 
+
817 
+(defun note-ce-variable (ce-var)
818 
+  (push ce-var *rhs-bound-ce-vars*))
819 
+
820 
+(defun ce-bound? (ce-var)
821 
+  (or (member ce-var *rhs-bound-ce-vars*)
822 
+      (ce-var-dope ce-var)))
823 
+
824 
+;;; *EOF*
ops-globals.lisp
History View file @ 5092d8a
0 825 
new file mode 100644
... ... 
@@ -0,0 +1,61 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+(in-package "OPS")
18 
+
19 
+;;; Global variables also used by OPS modules.
20 
+
21 
+(defvar *halt-flag*)
22 
+(defvar *cycle-count*)
23 
+(defvar *p-name*)
24 
+(defvar *ptrace*)
25 
+(defvar *wtrace*)
26 
+
27 
+;;; Hash Tables.
28 
+
29 
+(defvar *conflicts-table* (make-hash-table))
30 
+
31 
+(defvar *vector-attribute-table* (make-hash-table))
32 
+(defun set-vector-attribute (att)
33 
+  (setf (gethash att *vector-attribute-table*) t))
34 
+(defun is-vector-attribute (att)
35 
+  (gethash att *vector-attribute-table*))
36 
+
37 
+(defvar *att-list-table* (make-hash-table))
38 
+(defvar *ppdat-table* (make-hash-table))
39 
+(defvar *wmpart*-table* (make-hash-table))
40 
+(defvar *inputfile-table* (make-hash-table))
41 
+(defvar *outputfile-table* (make-hash-table))
42 
+(defvar *backpointers-table* (make-hash-table))
43 
+(defvar *ops-bind-table* (make-hash-table))
44 
+(defvar *production-table* (make-hash-table))
45 
+(defvar *topnode-table* (make-hash-table))
46 
+(defvar *external-routine-table* (make-hash-table))
47 
+
48 
+(defun clear-ops-hash-tables ()
49 
+  (clrhash *conflicts-table*)
50 
+  (clrhash *vector-attribute-table*)
51 
+  (clrhash *att-list-table*)
52 
+  (clrhash *ppdat-table*)
53 
+  (clrhash *wmpart*-table*)
54 
+  (clrhash *inputfile-table*)
55 
+  (clrhash *outputfile-table*)
56 
+  (clrhash *backpointers-table*)
57 
+  (clrhash *ops-bind-table*)
58 
+  (clrhash *production-table*)
59 
+  (clrhash *topnode-table*)
60 
+  (clrhash *external-routine-table*))
61 
+
ops-init.lisp
History View file @ 5092d8a
0 62 
new file mode 100644
... ... 
@@ -0,0 +1,57 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+;;; 15-OCT-92 mk    Modified definition of RESET-OPS.
18 
+
19 
+(in-package "OPS")
20 
+
21 
+(defparameter *ops-version* "19-OCT-92")
22 
+
23 
+(defun ops-init ()
24 
+  ; Allows ^ , { , and } operators to be right next to another symbol.
25 
+  (set-macro-character #\{ #'(lambda (s c)
26 
+			       (declare (ignore s c))
27 
+			       '\{))
28 
+  (set-macro-character #\} #'(lambda (s c)
29 
+			       (declare (ignore s c))
30 
+			       '\}))
31 
+  (set-macro-character #\^ #'(lambda (s c)
32 
+			       (declare (ignore s c))
33 
+			       '\^))
34 
+  (backup-init)
35 
+  (compile-init)
36 
+  (main-init)
37 
+  (match-init)
38 
+  (io-init)
39 
+  (rhs-init)
40 
+  (format t "~&Common Lisp OPS5 interpreter, version ~A.~&"
41 
+	  *ops-version*))
42 
+
43 
+(defun reset-ops ()
44 
+  "Clears the state of OPS to allow a new rule set to be loaded."
45 
+
46 
+  ;; Tell the user what we're doing.
47 
+  (format t "~&Resetting OPS5 interpreter: ~
48 
+             ~&   deleting productions, working memory, etc.")
49 
+  (remove *)
50 
+  (ops-init)
51 
+  (clear-ops-hash-tables)
52 
+  ;; (i-g-v)
53 
+  (setq *class-list* nil
54 
+	*pcount* 0))
55 
+
56 
+;;; *EOF*
57 
+
ops-io.lisp
History View file @ 5092d8a
0 58 
new file mode 100644
... ... 
@@ -0,0 +1,529 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+;;;; This file contains all the functions pertaining to I/O.
18 
+
19 
+(in-package "OPS")
20 
+;; (shadow '(write))    ; Should get this by requiring ops-rhs
21 
+
22 
+
23 
+;;; Internal global variables.
24 
+
25 
+(defvar *write-file*)
26 
+(defvar *trace-file*)
27 
+(defvar *accept-file*)
28 
+(defvar *ppline*)
29 
+(defvar *filters*)
30 
+
31 
+
32 
+
33 
+;;; Initialization
34 
+
35 
+(defun io-init ()
36 
+  (setq *write-file* nil)
37 
+  (setq *trace-file* nil)
38 
+  (setq *accept-file* nil))
39 
+
40 
+
41 
+
42 
+;;; User I/O commands
43 
+;;; Dario Giuse - rewrote the (write) function to follow OPS-5 specifications.
44 
+;;; Michael Huhns fixed a few bugs in this rewrttien functions some years later.
45 
+
46 
+
47 
+;;; used only in this file.
48 
+(defmacro append-string (x)
49 
+  `(setq wrstring (concatenate 'simple-string wrstring ,x)))
50 
+
51 
+
52 
+(defun ops-write (z)
53 
+  (if (not *in-rhs*)
54 
+      (%warn '|cannot be called at top level| 'write)
55 
+      (prog (port max k x)
56 
+	($reset)
57 
+	(eval-args z)
58 
+	(setq max ($parametercount))
59 
+	(when (< max 1)
60 
+	  (%warn '|write: nothing to print| z)
61 
+	  (return nil))
62 
+	(setq x ($parameter 1))
63 
+	(cond ((and (symbolp x) ($ofile x))
64 
+	       (setq port ($ofile x))
65 
+	       (setq k 2))
66 
+	      (t
67 
+	       (setq port (default-write-file))
68 
+	       (setq k 1)))
69 
+	;; Analyze and output all the parameters (write) was passed.
70 
+	(do* ((wrstring "")
71 
+	      (x ($parameter k) ($parameter k))
72 
+	      (field-width))
73 
+	     ((> k max)
74 
+	      (format port wrstring)
75 
+	      (force-output))		; Dario Giuse - added to force output
76 
+	  (incf k)
77 
+	  (case x
78 
+	    (|=== C R L F ===|
79 
+	     (format port "~A~%" wrstring) ; Flush the previous line
80 
+	     (setq wrstring ""))
81 
+	    (|=== R J U S T ===|
82 
+	     (setq field-width ($parameter k)) ; Number following (tabto)
83 
+	     (incf k)
84 
+	     (setq x (format nil "~A" ($parameter k))) ; Next field to print
85 
+	     (when (<= (length x) field-width)
86 
+	       ;; Right-justify field
87 
+	       (append-string (format nil "~V@A" field-width x))
88 
+	       (incf k)))		; Skip next field, since we printed it already
89 
+	    (|=== T A B T O ===|
90 
+	     (setq x ($parameter k))	; Position to tab to
91 
+	     (incf k)
92 
+	     (when (< x (length wrstring))
93 
+	       ;; Flush line, start a new one
94 
+	       (format port "~A~%" wrstring)
95 
+	       (setq wrstring ""))
96 
+	     (append-string (format nil "~V,1@T" (- x (length wrstring) 1))))
97 
+	    (t
98 
+	     (append-string (format nil "~A " x))))))))
99 
+
100 
+
101 
+(defun ops-openfile (z)
102 
+  (prog (file mode id)
103 
+    ($reset)
104 
+    (eval-args z)
105 
+    (cond ((not (equal ($parametercount) 3.))
106 
+	   (%warn '|openfile: wrong number of arguments| z)
107 
+	   (return nil)))
108 
+    (setq id ($parameter 1))
109 
+    (setq file ($parameter 2))
110 
+    (setq mode ($parameter 3))
111 
+    (cond ((not (symbolp id))
112 
+	   (%warn '|openfile: file id must be a symbolic atom| id)
113 
+	   (return nil))
114 
+	  ((null id)
115 
+	   (%warn '|openfile: 'nil' is reserved for the terminal| nil)
116 
+	   (return nil))
117 
+	  ((or ($ifile id)($ofile id))
118 
+	   (%warn '|openfile: name already in use| id)
119 
+	   (return nil)))
120 
+;@@@	(cond ((eq mode 'in) (setf (gethash id *inputfile-table*) (infile file)))
121 
+;@@@	      ((eq mode 'out) (setf (gethash id *outputfile-table*) (outfile file)))
122 
+; dec 7 83 gdw added setq : is putprop needed ? )
123 
+    (cond ((eq mode 'in) (setf (gethash id *inputfile-table*)
124 
+			       (setq id (infile file))))
125 
+	  ((eq mode 'out) (setf (gethash id *outputfile-table*)
126 
+				(setq id (outfile file))))
127 
+	  (t (%warn '|openfile: illegal mode| mode)
128 
+	     (return nil)))
129 
+    (return nil)))
130 
+
131 
+
132 
+(defun infile (f_name)
133 
+  (open f_name :direction :input))
134 
+
135 
+(defun outfile (f_name)
136 
+  (open f_name :direction :output :if-exists :new-version))
137 
+
138 
+(defun ops-closefile (z)
139 
+  ($reset)
140 
+  (eval-args z)
141 
+  (mapc #'closefile2 (use-result-array)))
142 
+
143 
+(defun closefile2 (file)
144 
+  (let (port)
145 
+    (cond ((not (symbolp file))
146 
+	   (%warn '|closefile: illegal file identifier| file))
147 
+	  ((setq port ($ifile file))
148 
+	   (close port)
149 
+	   (remhash file *inputfile-table*))
150 
+	  ((setq port ($ofile file))
151 
+	   (close port)
152 
+	   (remhash file *outputfile-table*)))
153 
+    nil))
154 
+
155 
+(defun ops-default (z)
156 
+  (prog (file use)
157 
+    ($reset)
158 
+    (eval-args z)
159 
+    (cond ((not (equal ($parametercount) 2.))
160 
+	   (%warn '|default: wrong number of arguments| z)
161 
+	   (return nil)))
162 
+    (setq file ($parameter 1))
163 
+    (setq use ($parameter 2))
164 
+    (cond ((not (symbolp file))
165 
+	   (%warn '|default: illegal file identifier| file)
166 
+	   (return nil))
167 
+	  ((not (member use '(write accept trace) :test #'equal))
168 
+	   (%warn '|default: illegal use for a file| use)
169 
+	   (return nil))
170 
+	  ((and (member use '(write trace) :test #'equal)
171 
+		(not (null file))
172 
+		(not ($ofile file)))
173 
+	   (%warn '|default: file has not been opened for output| file)
174 
+	   (return nil))
175 
+	  ((and (equal use 'accept)
176 
+		(not (null file))
177 
+		(not ($ifile file)))
178 
+	   (%warn '|default: file has not been opened for input| file)
179 
+	   (return nil))
180 
+	  ((equal use 'write) (setq *write-file* file))
181 
+	  ((equal use 'accept) (setq *accept-file* file))
182 
+	  ((equal use 'trace) (setq *trace-file* file)))
183 
+    (return nil)))
184 
+
185 
+
186 
+(defun ops-accept (z)
187 
+  (prog (port arg)
188 
+    (cond ((> (length z) 1.)
189 
+	   (%warn '|accept: wrong number of arguments| z)
190 
+	   (return nil)))
191 
+    (setq port *standard-input*)
192 
+    (cond (*accept-file*
193 
+	   (setq port ($ifile *accept-file*))
194 
+	   (cond ((null port)
195 
+		  (%warn '|accept: file has been closed| *accept-file*)
196 
+		  (return nil)))))
197 
+    (cond ((= (length z) 1)
198 
+	   (setq arg ($varbind (car z)))
199 
+	   (cond ((not (symbolp arg))
200 
+		  (%warn '|accept: illegal file name| arg)
201 
+		  (return nil)))
202 
+	   (setq port ($ifile arg))
203 
+	   (cond ((null port)
204 
+		  (%warn '|accept: file not open for input| arg)
205 
+		  (return nil)))))
206 
+    (cond ((equal (peek-char t port nil "eof" ) "eof" )
207 
+	   ($value 'end-of-file)
208 
+	   (return nil)))
209 
+    (flat-value (read port))))
210 
+
211 
+
212 
+
213 
+;;; Dario Giuse - completely changed the algorithm. It now uses one read-line
214 
+;;; and the read-from-string.
215 
+;;;
216 
+(defun ops-acceptline (z)
217 
+  (let ((port *standard-input*)
218 
+	(def z))
219 
+    (cond (*accept-file*
220 
+	   (setq port ($ifile *accept-file*))
221 
+	   (cond ((null port)
222 
+		  (%warn '|acceptline: file has been closed|
223 
+			 *accept-file*)
224 
+		  (return-from ops-acceptline nil)))))
225 
+    (cond ((> (length def) 0)
226 
+	   (let ((arg ($varbind (car def))))
227 
+	     (cond ((and (symbolp arg) ($ifile arg))
228 
+		    (setq port ($ifile arg))
229 
+		    (setq def (cdr def)))))))
230 
+    (let ((line (read-line port nil 'eof)))
231 
+      (declare (simple-string line))
232 
+      ;; Strip meaningless characters from start and end of string.
233 
+      (setq line (string-trim '(#\( #\) #\, #\tab #\space) line))
234 
+      (when (equal line "")
235 
+	(mapc (function $change) def)
236 
+	(return-from ops-acceptline nil))
237 
+      (setq line (concatenate 'simple-string "(" line ")"))
238 
+      ;; Read all items from the line
239 
+      (flat-value (read-from-string line)))))
240 
+
241 
+(defun ops-rjust (z)
242 
+  (prog (val)
243 
+    (when (not (= (length z) 1.))
244 
+      (%warn '|rjust: wrong number of arguments| z)
245 
+      (return nil))
246 
+    (setq val ($varbind (car z)))
247 
+    (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
248 
+	   (%warn '|rjust: illegal value for field width| val)
249 
+	   (return nil)))
250 
+    ($value '|=== R J U S T ===|)
251 
+    ($value val)))
252 
+
253 
+
254 
+(defun ops-crlf (z)
255 
+  (cond  (z (%warn '|crlf: does not take arguments| z))
256 
+	 (t ($value '|=== C R L F ===|))))
257 
+
258 
+
259 
+(defun ops-tabto (z)
260 
+  (prog (val)
261 
+    (when (not (= (length z) 1.))
262 
+      (%warn '|tabto: wrong number of arguments| z)
263 
+      (return nil))
264 
+    (setq val ($varbind (car z)))
265 
+    (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
266 
+	   (%warn '|tabto: illegal column number| z)
267 
+	   (return nil)))
268 
+    ($value '|=== T A B T O ===|)
269 
+    ($value val)))
270 
+
271 
+(defun do-rjust (width value port)
272 
+  (prog (size)
273 
+    (cond ((eq value '|=== T A B T O ===|)
274 
+	   (%warn '|rjust cannot precede this function| 'tabto)
275 
+	   (return nil))
276 
+	  ((eq value '|=== C R L F ===|)
277 
+	   (%warn '|rjust cannot precede this function| 'crlf)
278 
+	   (return nil))
279 
+	  ((eq value '|=== R J U S T ===|)
280 
+	   (%warn '|rjust cannot precede this function| 'rjust)
281 
+	   (return nil)))
282 
+    ;original->        (setq size (flatc value (1+ width)))
283 
+    (setq size (min value (1+ width)))  ;### KLUGE
284 
+    (cond ((> size width)
285 
+	   (princ '| | port)
286 
+	   (princ value port)
287 
+	   (return nil)))
288 
+    ;###        (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
289 
+    ;^^^KLUGE @@@do
290 
+    (princ value port)))
291 
+
292 
+(defun do-tabto (col port)
293 
+  (prog (pos)
294 
+    ;### KLUGE: FLUSHES STREAM & SETS POS TO 0
295 
+    ;OIRGINAL->	(setq pos (1+ (nwritn port)))	;hmm-takes 1 arg @@@ port
296 
+    (finish-output port);kluge
297 
+    (setq pos 0);kluge
298 
+    (cond ((> pos col)
299 
+	   (terpri port)
300 
+	   (setq pos 1)))
301 
+    ;###(do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
302 
+    ;^^^KLUGE @@@do
303 
+    (return nil)))
304 
+
305 
+
306 
+(defun flat-value (x)
307 
+  (cond ((atom x) ($value x))
308 
+	(t (mapc #'flat-value x))))
309 
+
310 
+
311 
+
312 
+;;; Printing WM
313 
+
314 
+(defun ops-ppwm (avlist)
315 
+  (prog (next a)
316 
+    (setq *filters* nil)
317 
+    (setq next 1.)
318 
+    loop   (and (atom avlist) (go print))
319 
+    (setq a (car avlist))
320 
+    (setq avlist (cdr avlist))
321 
+    ;this must be expecting (ppwm class ^ attr ^ attr2 ...) not ^attr
322 
+    (cond ((eq a '^)
323 
+	   (setq next (car avlist))
324 
+	   (setq avlist (cdr avlist))
325 
+	   (setq next ($litbind next))
326 
+	   (and (floatp next) (setq next (floor next)))
327 
+	   (cond ((or (not (numberp next))
328 
+		      (> next *size-result-array*)
329 
+		      (> 1. next))
330 
+		  (%warn '|illegal index after ^| next)
331 
+		  (return nil))))
332 
+	  ((variablep a)
333 
+	   (%warn '|ppwm does not take variables| a)
334 
+	   (return nil))
335 
+	  (t (setq *filters* (cons next (cons a *filters*)))
336 
+	     (setq next (1+ next))))
337 
+    (go loop)
338 
+    print (mapwm #'ppwm2)
339 
+    (terpri)
340 
+    (return nil)))
341 
+
342 
+
343 
+(defun default-write-file ()
344 
+  (let ((port *standard-output*))
345 
+    (when *write-file*
346 
+      (setq port ($ofile *write-file*))
347 
+      (when (null port)
348 
+	(%warn '|write: file has been closed| *write-file*)
349 
+	(setq port *standard-output*)))
350 
+    port))
351 
+
352 
+(defun trace-file ()
353 
+  (let ((port *standard-output*))
354 
+    (when *trace-file*
355 
+      (setq port ($ofile *trace-file*))
356 
+      (when (null port)
357 
+	(%warn '|trace: file has been closed| *trace-file*)
358 
+	(setq port *standard-output*)))
359 
+    port))
360 
+
361 
+(defun ppwm2 (elm-tag)
362 
+  (cond ((filter (car elm-tag))
363 
+	 (terpri) (ppelm (car elm-tag) (default-write-file)))))
364 
+
365 
+(defun filter (elm)
366 
+  (prog (fl indx val)
367 
+    (setq fl *filters*)
368 
+    top  (and (atom fl) (return t))
369 
+    (setq indx (car fl))
370 
+    (setq val (cadr fl))
371 
+    (setq fl (cddr fl))
372 
+    (and (ident (nth (1- indx) elm) val) (go top))
373 
+    (return nil)))
374 
+
375 
+(defun ident (x y)
376 
+  (cond ((eq x y) t)
377 
+	((not (numberp x)) nil)
378 
+	((not (numberp y)) nil)
379 
+	((=alg x y) t)
380 
+	(t nil)))
381 
+
382 
+; the new ppelm is designed especially to handle literalize format
383 
+; however, it will do as well as the old ppelm on other formats
384 
+
385 
+(defun ppelm (elm port)
386 
+  (prog (ppdat sep val att mode lastpos)
387 
+    (princ (creation-time elm) port)
388 
+    (princ '|:  | port)
389 
+    (setq mode 'vector)
390 
+    (setq ppdat (gethash (car elm) *ppdat-table*))
391 
+    (and ppdat (setq mode 'a-v))
392 
+    (setq sep "(")				; ")"
393 
+    (setq lastpos 0)
394 
+    (do ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
395 
+	((atom vlist) nil)					; terminate
396 
+      (setq val (car vlist))				; tagbody begin
397 
+      (setq att (assoc curpos ppdat))	;should ret (curpos attr-name)
398 
+      (cond (att (setq att (cdr att)))	; att = (attr-name) ??
399 
+	    (t (setq att curpos)))
400 
+      (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
401 
+      (cond ((or (not (null val)) (eq mode 'vector))
402 
+	     (princ sep port)
403 
+	     (ppval val att lastpos port)
404 
+	     (setq sep '|    |)
405 
+	     (setq lastpos curpos))))
406 
+    (princ '|)| port)))
407 
+
408 
+(defun ppval (val att lastpos port)
409 
+  ;  (break "in ppval")
410 
+  (cond ((not (equal att (1+ lastpos)))		; ok, if we got an att
411 
+	 (princ '^ port)
412 
+	 (princ att port)
413 
+	 (princ '| | port)))
414 
+  (princ val port))
415 
+
416 
+
417 
+
418 
+;;; Printing production memory
419 
+
420 
+(defun ops-pm (z) (mapc #'pprule z) (terpri) nil)
421 
+
422 
+(defun pprule (name)
423 
+  (prog (matrix next lab)
424 
+    (and (not (symbolp name)) (return nil))
425 
+    (setq matrix (gethash name *production-table*))
426 
+    (and (null matrix) (return nil))
427 
+    (terpri)
428 
+    (princ '|(p |)      ;)
429 
+    (princ name)
430 
+    top	(and (atom matrix) (go fin))
431 
+    (setq next (car matrix))
432 
+    (setq matrix (cdr matrix))
433 
+    (setq lab nil)
434 
+    (terpri)
435 
+    (cond ((eq next '-)
436 
+	   (princ '|  - |)
437 
+	   (setq next (car matrix))
438 
+	   (setq matrix (cdr matrix)))
439 
+	  ((eq next '-->)
440 
+	   (princ '|  |))
441 
+	  ((and (eq next '{) (atom (car matrix)))
442 
+	   (princ '|   {|)
443 
+	   (setq lab (car matrix))
444 
+	   (setq next (cadr matrix))
445 
+	   (setq matrix (cdddr matrix)))
446 
+	  ((eq next '{)
447 
+	   (princ '|   {|)
448 
+	   (setq lab (cadr matrix))
449 
+	   (setq next (car matrix))
450 
+	   (setq matrix (cdddr matrix)))
451 
+	  (t (princ '|    |)))
452 
+    (ppline next)
453 
+    (cond (lab (princ '| |) (princ lab) (princ '})))
454 
+    (go top)
455 
+    fin	(princ '|)|)))
456 
+
457 
+(defun ppline (line)
458 
+  (cond ((atom line) (princ line))
459 
+	(t
460 
+	 (princ '|(|)			;)
461 
+	 (setq *ppline* line)
462 
+	 (ppline2)
463 
+					;(
464 
+	 (princ '|)|)))
465 
+  nil)
466 
+
467 
+(defun ppline2 ()
468 
+  (prog (needspace)
469 
+    (setq needspace nil)
470 
+    top  (and (atom *ppline*) (return nil))
471 
+    (and needspace (princ '| |))
472 
+    (cond ((eq (car *ppline*) '^) (ppattval))
473 
+	  (t (pponlyval)))
474 
+    (setq needspace t)
475 
+    (go top)))
476 
+
477 
+(defun ppattval ()
478 
+  (prog (att val)
479 
+    (setq att (cadr *ppline*))
480 
+    (setq *ppline* (cddr *ppline*))
481 
+    (setq val (getval))
482 
+    ;###	(cond ((> (+ (nwritn) (flatc att) (flatc val)) 76.)))
483 
+    ;@@@ nwritn no arg
484 
+    ;						;"plus" changed to "+" by gdw
485 
+    ;	       (terpri)
486 
+    ;	       (princ '|        |)
487 
+    (princ '^)
488 
+    (princ att)
489 
+    (mapc (function (lambda (z) (princ '| |) (princ z))) val)))
490 
+
491 
+(defun pponlyval ()
492 
+  (prog (val needspace)
493 
+    (setq val (getval))
494 
+    (setq needspace nil)
495 
+    ;###	(cond ((> (+ (nwritn) (flatc val)) 76.)))
496 
+    ;"plus" changed to "+" by gdw
497 
+    ;	       (setq needspace nil)		;^nwritn no arg @@@
498 
+    ;	       (terpri)
499 
+    ;	       (princ '|        |)
500 
+    top	(and (atom val) (return nil))
501 
+    (and needspace (princ '| |))
502 
+    (setq needspace t)
503 
+    (princ (car val))
504 
+    (setq val (cdr val))
505 
+    (go top)))
506 
+
507 
+(defun getval ()
508 
+  (let ((v1 (pop *ppline*))
509 
+	res)
510 
+    (cond ((member v1 '(= <> < <= => > <=>))
511 
+	   (setq res (cons v1 (getval))))
512 
+	  ((eq v1 '{)
513 
+	   (setq res (cons v1 (getupto '}))))
514 
+	  ((eq v1 '<<)
515 
+	   (setq res (cons v1 (getupto '>>))))
516 
+	  ((eq v1 '//)
517 
+	   (setq res (list v1 (car *ppline*)))
518 
+	   (setq *ppline* (cdr *ppline*)))
519 
+	  (t (setq res (list v1))))
520 
+    res))
521 
+
522 
+(defun getupto (end)
523 
+  (if (atom *ppline*) nil
524 
+      (let ((v (pop *ppline*)))
525 
+	(if (eq v end)
526 
+	    (list v)
527 
+	    (cons v (getupto end))))))
528 
+
529 
+;;; *EOF*
ops-main.lisp
History View file @ 5092d8a
0 530 
new file mode 100644
... ... 
@@ -0,0 +1,705 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+;;;; This file contains the top-level functions, function to literalize
18 
+;;;; and access attributes, and functions to manage the conflict set.
19 
+
20 
+
21 
+(in-package "OPS")
22 
+
23 
+;; (export '(literalize p vector-attribute strategy watch reset-ops))
24 
+
25 
+;;; Global variables used in this module only.
26 
+
27 
+(defvar *limit-token*)
28 
+(defvar *total-wm*)
29 
+(defvar *max-token*)
30 
+(defvar *total-token*)
31 
+(defvar *brkpts*)
32 
+(defvar *phase*)
33 
+(defvar *break-flag*)
34 
+(defvar *remaining-cycles*)
35 
+(defvar *conflict-set*)
36 
+(defvar *max-cs*)
37 
+(defvar *total-cs*)
38 
+(defvar *limit-cs*)
39 
+(defvar *strategy*)
40 
+(defvar *class-list*)
41 
+(defvar *buckets*)
42 
+
43 
+
44 
+
45 
+(defun main-init ()
46 
+  (setq *cycle-count* 0.)
47 
+  (setq *p-name* nil)
48 
+  (setq *ptrace* t)
49 
+  (setq *wtrace* nil)
50 
+  (setq *limit-token* 1000000.)
51 
+  (setq *limit-cs* 1000000.)
52 
+  (setq *total-wm* 0.)
53 
+  (setq *total-token* (setq *max-token* 0.))
54 
+  (setq *max-cs* (setq *total-cs* 0.))
55 
+  (setq *conflict-set* nil)
56 
+  (setq *strategy* 'lex)
57 
+  (setq *buckets* 127.)		; regular OPS5 allows 64 named slots
58 
+  (setq *class-list* nil)
59 
+  (setq *brkpts* nil)
60 
+  (setq *remaining-cycles* 1000000))
61 
+
62 
+
63 
+
64 
+;;;; Top level commands.
65 
+
66 
+
67 
+(defmacro run (&body z)
68 
+  `(ops-run ',z))
69 
+
70 
+(defmacro ppwm (&body avlist)
71 
+  `(ops-ppwm ',avlist))
72 
+
73 
+(defmacro wm (&body a)
74 
+  `(ops-wm ',a))
75 
+
76 
+(defmacro pm (&body z)
77 
+  `(ops-pm ',z))
78 
+
79 
+(defmacro cs (&body z)
80 
+  `(ops-cs ',z))
81 
+
82 
+(defmacro matches (&body rule-list)
83 
+  `(ops-matches ',rule-list))
84 
+
85 
+(defmacro strategy (&body z)
86 
+  `(ops-strategy ',z))
87 
+
88 
+(defmacro watch (&body z)
89 
+  `(ops-watch ',z))
90 
+
91 
+(defmacro pbreak (&body z)
92 
+  `(ops-pbreak ',z))
93 
+
94 
+(defmacro excise (&body z)
95 
+  `(ops-excise ',z))
96 
+
97 
+(defmacro p (&body z)
98 
+  `(ops-p ',z))
99 
+
100 
+(defmacro external (&body z)
101 
+  `(ops-external ',z))
102 
+
103 
+(defmacro literal (&body z)
104 
+  `(ops-literal ',z))
105 
+
106 
+(defmacro literalize (&body z)
107 
+  `(ops-literalize ',z))
108 
+
109 
+(defmacro vector-attribute (&body l)
110 
+  `(ops-vector-attribute ',l))
111 
+
112 
+(defun top-level-remove (z)
113 
+  (cond ((equal z '(*)) (process-changes nil (get-wm nil)))
114 
+	(t (process-changes nil (get-wm z)))))
115 
+
116 
+
117 
+
118 
+;;; Functions for run command
119 
+
120 
+(defun ops-run (z)
121 
+  (cond ((atom z) (setq *remaining-cycles* 1000000.) (do-continue nil))
122 
+	((and (atom (cdr z)) (numberp (car z)) (> (car z) 0.))
123 
+	 (setq *remaining-cycles* (car z))
124 
+	 (do-continue nil))
125 
+	(t 'what?)))
126 
+
127 
+
128 
+(defun do-continue (wmi)
129 
+  (cond (*critical*
130 
+	 (terpri)
131 
+	 (princ '|warning: network may be inconsistent|)))
132 
+  (process-changes wmi nil)
133 
+  (print-times (main)))
134 
+
135 
+
136 
+(defun process-changes (adds dels)
137 
+  (prog (x)
138 
+    process-deletes (and (atom dels) (go process-adds))
139 
+    (setq x (car dels))
140 
+    (setq dels (cdr dels))
141 
+    (remove-from-wm x)
142 
+    (go process-deletes)
143 
+    process-adds (and (atom adds) (return nil))
144 
+    (setq x (car adds))
145 
+    (setq adds (cdr adds))
146 
+    (add-to-wm x nil)
147 
+    (go process-adds)))
148 
+
149 
+
150 
+(defun main nil
151 
+  (prog (instance r)
152 
+    (setq *halt-flag* nil)
153 
+    (setq *break-flag* nil)
154 
+    (setq instance nil)
155 
+    dil  (setq *phase* 'conflict-resolution)
156 
+    (cond (*halt-flag*
157 
+	   (setq r '|end -- explicit halt|)
158 
+	   (go finis))
159 
+	  ((zerop *remaining-cycles*)
160 
+	   (setq r '***break***)
161 
+	   (setq *break-flag* t)
162 
+	   (go finis))
163 
+	  (*break-flag* (setq r '***break***) (go finis)))
164 
+    (setq *remaining-cycles* (1- *remaining-cycles*))
165 
+    (setq instance (conflict-resolution))
166 
+    (cond ((not instance)
167 
+	   (setq r '|end -- no production true|)
168 
+	   (go finis)))
169 
+    (setq *phase* (car instance))
170 
+    (accum-stats)
171 
+    (eval-rhs (car instance) (cdr instance))
172 
+    (check-limits)
173 
+    (and (broken (car instance)) (setq *break-flag* t))
174 
+    (go dil)
175 
+    finis (setq *p-name* nil)
176 
+    (return r)))
177 
+
178 
+
179 
+(defun broken (rule) (member rule *brkpts*))
180 
+
181 
+
182 
+(defun accum-stats nil
183 
+  (setq *cycle-count* (1+ *cycle-count*))
184 
+  (setq *total-token* (+ *total-token* *current-token*))
185 
+  ;"plus" changed to "+" by gdw
186 
+  (cond ((> *current-token* *max-token*)
187 
+	 (setq *max-token* *current-token*)))
188 
+  (setq *total-wm* (+ *total-wm* *current-wm*))	;"plus" changed to "+" by gdw
189 
+  (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))))
190 
+
191 
+
192 
+(defun check-limits nil
193 
+  (cond ((> (length *conflict-set*) *limit-cs*)
194 
+	 (format t "~%~%conflict set size exceeded the limit of ~D after ~D~%"
195 
+		 *limit-cs* *p-name*)
196 
+	 (setq *halt-flag* t)))
197 
+  (cond ((> *current-token* *limit-token*)
198 
+	 (format t "~%~%token memory size exceeded the limit of ~D after ~D~%"
199 
+		 *limit-token* *p-name*)
200 
+	 (setq *halt-flag* t))))
201 
+
202 
+
203 
+(defun print-times (mess)
204 
+  (prog (cc)
205 
+    (cond (*break-flag* (terpri) (return mess)))
206 
+    (setq cc (+ (float *cycle-count*) 1.0e-20))
207 
+    (terpri)
208 
+    (princ mess)
209 
+    (terpri)
210 
+    (format t "~3D productions (~D // ~D nodes)~%"
211 
+	    *pcount* *real-cnt* *virtual-cnt*)
212 
+    (format t "~3D firings (~D rhs actions)~%"
213 
+	    *cycle-count* *action-count*)
214 
+    (format t "~3D mean working memory size (~D maximum)~%"
215 
+	    (round (float *total-wm*) cc) *max-wm*)
216 
+    (format t "~3D mean conflict set size (~D maximum)~%"
217 
+	    (round (float *total-cs*) cc) *max-cs*)
218 
+    (format t "~3D mean token memory size (~D maximum)~%"
219 
+	    (round (float *total-token*) cc)
220 
+	    *max-token*)))
221 
+
222 
+
223 
+;;; Functions for strategy command
224 
+
225 
+(defun ops-strategy (z)
226 
+  (cond ((atom z) *strategy*)
227 
+	((equal z '(lex)) (setq *strategy* 'lex))
228 
+	((equal z '(mea)) (setq *strategy* 'mea))
229 
+	(t 'what?)))
230 
+
231 
+
232 
+;;; Functions for watch command
233 
+
234 
+(defun ops-watch (z)
235 
+  (cond ((equal z '(0.))
236 
+	 (setq *wtrace* nil)
237 
+	 (setq *ptrace* nil)
238 
+	 0.)
239 
+	((equal z '(1.)) (setq *wtrace* nil) (setq *ptrace* t) 1.)
240 
+	((equal z '(2.)) (setq *wtrace* t) (setq *ptrace* t) 2.)
241 
+	((equal z '(3.))
242 
+	 (setq *wtrace* t)
243 
+	 (setq *ptrace* t)
244 
+	 '(2. -- conflict set trace not supported))
245 
+	((and (atom z) (null *ptrace*)) 0.)
246 
+	((and (atom z) (null *wtrace*)) 1.)
247 
+	((atom z) 2.)
248 
+	(t 'what?)))
249 
+
250 
+
251 
+;;; Functions for excise command
252 
+
253 
+(defun ops-excise (z) (mapc (function excise-p) z))
254 
+
255 
+(defun excise-p (name)
256 
+  (cond ((and (symbolp name) (gethash name *topnode-table*))
257 
+	 (format t "~S is excised~%" name)
258 
+	 (setq *pcount* (1- *pcount*))
259 
+	 (remove-from-conflict-set name)
260 
+	 (kill-node (gethash name *topnode-table*))
261 
+	 (remhash name *production-table*)
262 
+	 (remhash name *backpointers-table*)
263 
+	 (remhash name *topnode-table*))))
264 
+
265 
+(defun kill-node (node)
266 
+  (prog nil
267 
+    top  (and (atom node) (return nil))
268 
+    (rplaca node '&old)
269 
+    (setq node (cdr node))
270 
+    (go top)))
271 
+
272 
+
273 
+;;; Functions for external command
274 
+
275 
+(defun ops-external (z) (catch '!error! (external2 z))) ;jgk inverted args
276 
+;& quoted tag
277 
+(defun external2 (z) (mapc (function external3) z))
278 
+
279 
+(defun external3 (x)
280 
+  (cond ((symbolp x) (setf (gethash x *external-routine-table*) t))
281 
+	(t (%error '|not a legal function name| x))))
282 
+
283 
+;;; Functions for pbreak command
284 
+
285 
+(defun ops-pbreak (z)
286 
+  (cond ((atom z) (terpri) *brkpts*)
287 
+	(t (mapc (function pbreak2) z) nil)))
288 
+
289 
+(defun pbreak2 (rule)
290 
+  (cond ((not (symbolp rule)) (%warn '|illegal name| rule))
291 
+	((not (gethash rule *topnode-table*)) (%warn '|not a production| rule))
292 
+	((member rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)))
293 
+	(t (setq *brkpts* (cons rule *brkpts*)))))
294 
+
295 
+(defun rematm (atm list)
296 
+  (cond ((atom list) list)
297 
+	((eq atm (car list)) (rematm atm (cdr list)))
298 
+	(t (cons (car list) (rematm atm (cdr list))))))
299 
+
300 
+
301 
+;;; Functions for matches command
302 
+
303 
+(defun ops-matches (rule-list)
304 
+  (mapc #'matches2 rule-list)
305 
+  (terpri))
306 
+
307 
+
308 
+(defun matches2 (p)
309 
+  (cond ((atom p)
310 
+	 (format t "~2&~A" p)
311 
+	 (matches3 (gethash p *backpointers-table*) 2. (list 1.)))))
312 
+
313 
+
314 
+(defun matches3 (nodes ce part)
315 
+  (cond ((not (null nodes))
316 
+	 (format t "~& ** matches for ~A ** "
317 
+		 part)
318 
+	 (mapc #'write-elms (find-left-mem (car nodes)))
319 
+	 (format t "~& ** matches for ~A ** "
320 
+		 (list ce))
321 
+	 (mapc #'write-elms (find-right-mem (car nodes)))
322 
+	 (matches3 (cdr nodes) (1+ ce) (cons ce part)))))
323 
+
324 
+(defun write-elms (wme-or-count)
325 
+  (cond ((consp  wme-or-count)	;dtpr\consp gdw
326 
+	 (terpri)
327 
+	 (mapc #'write-elms2 wme-or-count))))
328 
+
329 
+
330 
+(defun write-elms2 (x)
331 
+  (princ '|  |)
332 
+  (princ (creation-time x)))
333 
+
334 
+
335 
+(defun find-left-mem (node)
336 
+  (cond ((eq (car node) '&and) (memory-part (caddr node)))
337 
+	(t (car (caddr node)))))
338 
+
339 
+
340 
+(defun find-right-mem (node) (memory-part (cadddr node)))
341 
+
342 
+
343 
+;;; Function for cs command.
344 
+
345 
+(defun ops-cs (z)
346 
+  (cond ((atom z) (conflict-set))
347 
+	(t 'what?)))
348 
+
349 
+
350 
+
351 
+;;;; Functions for literalize and related operations.
352 
+
353 
+(defun ops-literal (z)
354 
+  (prog (atm val old)
355 
+    top  (and (atom z) (return 'bound))
356 
+    (or (eq (cadr z) '=) (return (%warn '|wrong format| z)))
357 
+    (setq atm (car z))
358 
+    (setq val (caddr z))
359 
+    (setq z (cdddr z))
360 
+    (cond ((not (numberp val))
361 
+	   (%warn '|can bind only to numbers| val))
362 
+	  ((or (not (symbolp atm)) (variablep atm))
363 
+	   (%warn '|can bind only constant atoms| atm))
364 
+	  ((and (setq old (literal-binding-of atm)) (not (equal old val)))
365 
+	   (%warn '|attempt to rebind attribute| atm))
366 
+	  (t (setf (gethash atm *ops-bind-table*) val)))
367 
+    (go top)))
368 
+
369 
+
370 
+(defun ops-literalize (l)
371 
+  (prog (class-name atts)
372 
+    (setq class-name (car l))
373 
+    (cond ((have-compiled-production)
374 
+	   (%warn '|literalize called after p| class-name)
375 
+	   (return nil))
376 
+	  ((gethash class-name *att-list-table*)
377 
+	   (%warn '|attempt to redefine class| class-name)
378 
+	   (return nil)))
379 
+    (setq *class-list* (cons class-name *class-list*))
380 
+    (setq atts (remove-duplicates (cdr l)))		; ??? should this
381 
+    ; warn of dup atts?
382 
+    (test-attribute-names atts)
383 
+    (mark-conflicts atts atts)
384 
+    (setf (gethash class-name *att-list-table*) atts)))
385 
+
386 
+(defun ops-vector-attribute (l)
387 
+  (cond ((have-compiled-production)
388 
+	 (%warn '|vector-attribute called after p| l))
389 
+	(t
390 
+	 (test-attribute-names l)
391 
+	 (mapc #'set-vector-attribute l))))
392 
+
393 
+(defun test-attribute-names (l)
394 
+  (mapc #'test-attribute-names2 l))
395 
+
396 
+(defun test-attribute-names2 (atm)
397 
+  (cond ((or (not (symbolp atm)) (variablep atm))
398 
+	 (%warn '|can bind only constant atoms| atm))))
399 
+
400 
+(defun finish-literalize nil
401 
+  (cond ((not (null *class-list*))
402 
+	 (mapc #'note-user-assigns *class-list*)
403 
+	 (mapc #'assign-scalars *class-list*)
404 
+	 (mapc #'assign-vectors *class-list*)
405 
+	 (mapc #'put-ppdat *class-list*)
406 
+	 (mapc #'erase-literal-info *class-list*)
407 
+	 (setq *class-list* nil)
408 
+	 (setq *buckets* nil))))
409 
+
410 
+(defun have-compiled-production nil (not (zerop *pcount*)))
411 
+
412 
+(defun put-ppdat (class)
413 
+  (prog (al att ppdat)
414 
+    (setq ppdat nil)
415 
+    (setq al (gethash class *att-list-table*))
416 
+    top  (cond ((not (atom al))
417 
+		(setq att (car al))
418 
+		(setq al (cdr al))
419 
+		(setq ppdat
420 
+		      (cons (cons (literal-binding-of att) att)
421 
+			    ppdat))
422 
+		(go top)))
423 
+    (setf (gethash class *ppdat-table*) ppdat)))
424 
+
425 
+; note-user-assigns and note-user-vector-assigns are needed only when
426 
+; literal and literalize are both used in a program.  They make sure that
427 
+; the assignments that are made explicitly with literal do not cause problems
428 
+; for the literalized classes.
429 
+
430 
+(defun note-user-assigns (class)
431 
+  (mapc #'note-user-assigns2 (gethash class *att-list-table*)))
432 
+
433 
+(defun note-user-assigns2 (att)
434 
+  (prog (num conf buck clash)
435 
+    (setq num (literal-binding-of att))
436 
+    (and (null num) (return nil))
437 
+    (setq conf (gethash att *conflicts-table*))
438 
+    (setq buck (store-binding att num))
439 
+    (setq clash (find-common-atom buck conf))
440 
+    (and clash
441 
+	 (%warn '|attributes in a class assigned the same number|
442 
+		(cons att clash)))
443 
+    (return nil)))
444 
+
445 
+(defun note-user-vector-assigns (att given needed)
446 
+  (and (> needed given)
447 
+       (%warn '|vector attribute assigned too small a value in literal| att)))
448 
+
449 
+(defun assign-scalars (class)
450 
+  (mapc #'assign-scalars2 (gethash class *att-list-table*)))
451 
+
452 
+(defun assign-scalars2 (att)
453 
+  (prog (tlist num bucket conf)
454 
+    (and (literal-binding-of att) (return nil))
455 
+    (and (is-vector-attribute att) (return nil))
456 
+    (setq tlist (buckets))
457 
+    (setq conf (gethash att *conflicts-table*))
458 
+    top  (cond ((atom tlist)
459 
+		(%warn '|could not generate a binding| att)
460 
+		(store-binding att -1.)
461 
+		(return nil)))
462 
+    (setq num (caar tlist))
463 
+    (setq bucket (cdar tlist))
464 
+    (setq tlist (cdr tlist))
465 
+    (cond ((disjoint bucket conf) (store-binding att num))
466 
+	  (t (go top)))))
467 
+
468 
+(defun assign-vectors (class)
469 
+  (mapc #'assign-vectors2 (gethash class *att-list-table*)))
470 
+
471 
+(defun assign-vectors2 (att)
472 
+  (prog (big conf new old need)
473 
+    (and (not (is-vector-attribute att)) (return nil))
474 
+    (setq big 1.)
475 
+    (setq conf (gethash att *conflicts-table*))
476 
+    top  (cond ((not (atom conf))
477 
+		(setq new (car conf))
478 
+		(setq conf (cdr conf))
479 
+		(cond ((is-vector-attribute new)
480 
+		       (%warn '|class has two vector attributes|
481 
+			      (list att new)))
482 
+		      (t (setq big (max (literal-binding-of new) big))))
483 
+		(go top)))
484 
+    (setq need (1+ big))			;"plus" changed to "+" by gdw
485 
+    (setq old (literal-binding-of att))
486 
+    (cond (old (note-user-vector-assigns att old need))
487 
+	  (t (store-binding att need)))
488 
+    (return nil)))
489 
+
490 
+(defun disjoint (la lb) (not (find-common-atom la lb)))
491 
+
492 
+(defun find-common-atom (la lb)
493 
+  (prog nil
494 
+    top  (cond ((null la) (return nil))
495 
+	       ((member (car la) lb) (return (car la)))
496 
+	       (t (setq la (cdr la)) (go top)))))
497 
+
498 
+(defun mark-conflicts (rem all)
499 
+  (cond ((not (null rem))
500 
+	 (mark-conflicts2 (car rem) all)
501 
+	 (mark-conflicts (cdr rem) all))))
502 
+
503 
+(defun mark-conflicts2 (atm lst)
504 
+  (prog (l)
505 
+    (setq l lst)
506 
+    top  (and (atom l) (return nil))
507 
+    (conflict atm (car l))
508 
+    (setq l (cdr l))
509 
+    (go top)))
510 
+
511 
+(defun conflict (a b)
512 
+  (prog (old)
513 
+    (setq old (gethash a *conflicts-table*))
514 
+    (and (not (eq a b))
515 
+	 (not (member b old))
516 
+	 (setf (gethash a *conflicts-table*) (cons b old)))))
517 
+
518 
+;@@@ use intrinsic
519 
+;(defun remove-duplicates  (lst)
520 
+   ;  (cond ((atom lst) nil)
521 
+	    ;        ((member (car lst) (cdr lst)) (remove-duplicates (cdr lst)))
522 
+	    ;        (t (cons (car lst) (remove-duplicates (cdr lst))))))
523 
+
524 
+(defun literal-binding-of (name) (gethash name *ops-bind-table*))
525 
+
526 
+(defun store-binding (name lit)
527 
+  (setf (gethash name *ops-bind-table*) lit)
528 
+  (add-bucket name lit))
529 
+
530 
+(defun add-bucket (name num)
531 
+  (prog (buc)
532 
+    (setq buc (assoc num (buckets)))
533 
+    (and (not (member name buc))
534 
+	 (rplacd buc (cons name (cdr buc))))
535 
+    (return buc)))
536 
+
537 
+(defun buckets nil
538 
+  (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
539 
+  *buckets*)
540 
+
541 
+(defun make-nums (k)
542 
+  (prog (nums)
543 
+    (setq nums nil)
544 
+    l    (and (< k 2.) (return nums))
545 
+    (setq nums (cons (list k) nums))
546 
+    (setq k (1- k))
547 
+    (go l)))
548 
+
549 
+(defun erase-literal-info (class)
550 
+  (mapc #'erase-literal-info2 (gethash class *att-list-table*))
551 
+  (remhash class *att-list-table*))
552 
+
553 
+(defun erase-literal-info2 (att)
554 
+  (remhash att *conflicts-table*))
555 
+
556 
+
557 
+
558 
+
559 
+;;;; Functions for conflict set management and resolution.
560 
+
561 
+
562 
+;;; Each conflict set element is a list of the following form:
563 
+;;; ((p-name . data-part) (sorted wm-recency) special-case-number)
564 
+
565 
+(defun conflict-resolution nil
566 
+  (let ((len (length *conflict-set*)))
567 
+    (when (> len *max-cs*)
568 
+      (setq *max-cs* len))
569 
+    (incf *total-cs* len)		;"plus" changed to "+" by gdw
570 
+    (when *conflict-set*
571 
+      (let ((best (best-of *conflict-set*)))
572 
+	(setq *conflict-set* (delete best *conflict-set* :test #'eq))
573 
+	(pname-instantiation best)))))
574 
+
575 
+(defun removecs (name data)
576 
+  (prog (cr-data inst cs)
577 
+    (setq cr-data (cons name data))
578 
+    (setq cs *conflict-set*)
579 
+    loop	(cond ((null cs)
580 
+		       (record-refract name data)
581 
+		       (return nil)))
582 
+    (setq inst (car cs))
583 
+    (setq cs (cdr cs))
584 
+    (and (not (top-levels-eq (car inst) cr-data)) (go loop))
585 
+    (setq *conflict-set* (delete inst *conflict-set* :test #'eq))))
586 
+
587 
+(defun insertcs (name data rating)
588 
+  (if (refracted name data)
589 
+      nil
590 
+      (let ((instan (list (cons name data) (order-tags data) rating)))
591 
+	(when (atom *conflict-set*)
592 
+	  (setq *conflict-set* nil))
593 
+	(push instan *conflict-set*))))
594 
+
595 
+(defun remove-from-conflict-set (name)
596 
+  (prog (cs entry)
597 
+    l1   (setq cs *conflict-set*)
598 
+    l2   (cond ((atom cs) (return nil)))
599 
+    (setq entry (car cs))
600 
+    (setq cs (cdr cs))
601 
+    (cond ((eq name (caar entry))
602 
+	   (setq *conflict-set* (delete entry *conflict-set* :test #'eq))
603 
+	   (go l1))
604 
+	  (t (go l2)))))
605 
+
606 
+(defun order-tags (dat)
607 
+  (prog (tags)
608 
+    (setq tags nil)
609 
+    l1p  (and (atom dat) (go l2p))
610 
+    (setq tags (cons (creation-time (car dat)) tags))
611 
+    (setq dat (cdr dat))
612 
+    (go l1p)
613 
+    l2p  (cond ((eq *strategy* 'mea)
614 
+		(return (cons (car tags) (dsort (cdr tags)))))
615 
+	       (t (return (dsort tags))))))
616 
+
617 
+(defun dsort (x)
618 
+  "Destructively sort x into descending order."
619 
+  (prog (sorted cur next cval nval)
620 
+    (and (atom (cdr x)) (return x))
621 
+    loop (setq sorted t)
622 
+    (setq cur x)
623 
+    (setq next (cdr x))
624 
+    chek (setq cval (car cur))
625 
+    (setq nval (car next))
626 
+    (cond ((> nval cval)
627 
+	   (setq sorted nil)
628 
+	   (rplaca cur nval)
629 
+	   (rplaca next cval)))
630 
+    (setq cur next)
631 
+    (setq next (cdr cur))
632 
+    (cond ((not (null next)) (go chek))
633 
+	  (sorted (return x))
634 
+	  (t (go loop)))))
635 
+
636 
+(defun best-of (set)
637 
+  (best-of* (car set) (cdr set)))
638 
+
639 
+(defun best-of* (best rem)
640 
+  (cond ((not rem) best)
641 
+	((conflict-set-compare best (car rem))
642 
+	 (best-of* best (cdr rem)))
643 
+	(t (best-of* (car rem) (cdr rem)))))
644 
+
645 
+(defun pname-instantiation (conflict-elem) (car conflict-elem))
646 
+
647 
+(defun order-part (conflict-elem) (cdr conflict-elem))
648 
+
649 
+(defun instantiation (conflict-elem)
650 
+  (cdr (pname-instantiation conflict-elem)))
651 
+
652 
+
653 
+(defun conflict-set-compare (x y)
654 
+  (prog (x-order y-order xl yl xv yv)
655 
+    (setq x-order (order-part x))
656 
+    (setq y-order (order-part y))
657 
+    (setq xl (car x-order))
658 
+    (setq yl (car y-order))
659 
+    data (cond ((and (null xl) (null yl)) (go ps))
660 
+	       ((null yl) (return t))
661 
+	       ((null xl) (return nil)))
662 
+    (setq xv (car xl))
663 
+    (setq yv (car yl))
664 
+    (cond ((> xv yv) (return t))
665 
+	  ((> yv xv) (return nil)))
666 
+    (setq xl (cdr xl))
667 
+    (setq yl (cdr yl))
668 
+    (go data)
669 
+    ps   (setq xl (cdr x-order))
670 
+    (setq yl (cdr y-order))
671 
+    psl  (cond ((null xl) (return t)))
672 
+    (setq xv (car xl))
673 
+    (setq yv (car yl))
674 
+    (cond ((> xv yv) (return t))
675 
+	  ((> yv xv) (return nil)))
676 
+    (setq xl (cdr xl))
677 
+    (setq yl (cdr yl))
678 
+    (go psl)))
679 
+
680 
+
681 
+(defun conflict-set nil
682 
+  (prog (cnts cs p z best)
683 
+    (setq cnts nil)
684 
+    (setq cs *conflict-set*)
685 
+    l1p  (and (atom cs) (go l2p))
686 
+    (setq p (caaar cs))
687 
+    (setq cs (cdr cs))
688 
+    (setq z (assoc p cnts))
689 
+    (cond ((null z) (setq cnts (cons (cons p 1.) cnts)))
690 
+	  (t (rplacd z (1+ (cdr z)))))
691 
+    (go l1p)
692 
+    l2p  (cond ((atom cnts)
693 
+		(setq best (best-of *conflict-set*))
694 
+		(terpri)
695 
+		(return (list (caar best) 'dominates))))
696 
+    (terpri)
697 
+    (princ (caar cnts))
698 
+    (cond ((> (cdar cnts) 1.)
699 
+	   (princ '|	(|)
700 
+		  (princ (cdar cnts))
701 
+		  (princ '| occurrences)|)))
702 
+    (setq cnts (cdr cnts))
703 
+    (go l2p)))
704 
+
705 
+;;; *EOF*
ops-match.lisp
History View file @ 5092d8a
0 706 
new file mode 100644
... ... 
@@ -0,0 +1,606 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+;;;; This file contains the functions that match working memory
18 
+;;;; elements against productions LHS.
19 
+
20 
+(in-package "OPS")
21 
+
22 
+
23 
+
24 
+;;; External global variables
25 
+
26 
+(defvar *current-token*)
27 
+
28 
+
29 
+;;; Internal global variables
30 
+
31 
+(defvar *alpha-data-part*)
32 
+(defvar *alpha-flag-part*)
33 
+(defvar *flag-part*)
34 
+(defvar *data-part*)
35 
+(defvar *sendtocall*)
36 
+(defvar *side*)
37 
+(proclaim '(special *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
38 
+	   *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
39 
+	   *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
40 
+	   *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
41 
+	   *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
42 
+	   *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
43 
+	   *c60* *c61* *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69*
44 
+	   *c70* *c71* *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79*
45 
+	   *c80* *c81* *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89*
46 
+	   *c90* *c91* *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99*
47 
+	   *c100* *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108* *c109*
48 
+	   *c110* *c111* *c112* *c113* *c114* *c115* *c116* *c117* *c118* *c119*
49 
+	   *c120* *c121* *c122* *c123* *c124* *c125* *c126* *c127*))
50 
+
51 
+
52 
+
53 
+;;; Network interpreter
54 
+
55 
+
56 
+(defun match-init ()
57 
+  (setq *current-token* 0.))
58 
+
59 
+
60 
+(defun match (flag wme)
61 
+  (sendto flag (list wme) 'left (list *first-node*)))
62 
+
63 
+; note that eval-nodelist is not set up to handle building
64 
+; productions.  would have to add something like ops4's build-flag
65 
+
66 
+(defun eval-nodelist (nl)
67 
+  (dolist (node nl)
68 
+    (setq *sendtocall* nil)
69 
+    (setq *last-node* node)
70 
+    (apply (car node) (cdr node))))
71 
+
72 
+(defun sendto (flag data side nl)
73 
+  (dolist (node nl)
74 
+    (setq *side* side)
75 
+    (setq *flag-part* flag)
76 
+    (setq *data-part* data)
77 
+    (setq *sendtocall* t)
78 
+    (setq *last-node* node)
79 
+    (apply (car node) (cdr node))))
80 
+
81 
+; &bus sets up the registers for the one-input nodes.  note that this
82 
+(defun &bus (outs)
83 
+  (prog (dp)
84 
+    (setq *alpha-flag-part* *flag-part*)
85 
+    (setq *alpha-data-part* *data-part*)
86 
+    (setq dp (car *data-part*))
87 
+    (setq *c1* (pop dp))
88 
+    (setq *c2* (pop dp))
89 
+    (setq *c3* (pop dp))
90 
+    (setq *c4* (pop dp))
91 
+    (setq *c5* (pop dp))
92 
+    (setq *c6* (pop dp))
93 
+    (setq *c7* (pop dp))
94 
+    (setq *c8* (pop dp))
95 
+    (setq *c9* (pop dp))
96 
+    (setq *c10* (pop dp))
97 
+    (setq *c11* (pop dp))
98 
+    (setq *c12* (pop dp))
99 
+    (setq *c13* (pop dp))
100 
+    (setq *c14* (pop dp))
101 
+    (setq *c15* (pop dp))
102 
+    (setq *c16* (pop dp))
103 
+    (setq *c17* (pop dp))
104 
+    (setq *c18* (pop dp))
105 
+    (setq *c19* (pop dp))
106 
+    (setq *c20* (pop dp))
107 
+    (setq *c21* (pop dp))
108 
+    (setq *c22* (pop dp))
109 
+    (setq *c23* (pop dp))
110 
+    (setq *c24* (pop dp))
111 
+    (setq *c25* (pop dp))
112 
+    (setq *c26* (pop dp))
113 
+    (setq *c27* (pop dp))
114 
+    (setq *c28* (pop dp))
115 
+    (setq *c29* (pop dp))
116 
+    (setq *c30* (pop dp))
117 
+    (setq *c31* (pop dp))
118 
+    (setq *c32* (pop dp))
119 
+    (setq *c33* (pop dp))
120 
+    (setq *c34* (pop dp))
121 
+    (setq *c35* (pop dp))
122 
+    (setq *c36* (pop dp))
123 
+    (setq *c37* (pop dp))
124 
+    (setq *c38* (pop dp))
125 
+    (setq *c39* (pop dp))
126 
+    (setq *c40* (pop dp))
127 
+    (setq *c41* (pop dp))
128 
+    (setq *c42* (pop dp))
129 
+    (setq *c43* (pop dp))
130 
+    (setq *c44* (pop dp))
131 
+    (setq *c45* (pop dp))
132 
+    (setq *c46* (pop dp))
133 
+    (setq *c47* (pop dp))
134 
+    (setq *c48* (pop dp))
135 
+    (setq *c49* (pop dp))
136 
+    (setq *c50* (pop dp))
137 
+    (setq *c51* (pop dp))
138 
+    (setq *c52* (pop dp))
139 
+    (setq *c53* (pop dp))
140 
+    (setq *c54* (pop dp))
141 
+    (setq *c55* (pop dp))
142 
+    (setq *c56* (pop dp))
143 
+    (setq *c57* (pop dp))
144 
+    (setq *c58* (pop dp))
145 
+    (setq *c59* (pop dp))
146 
+    (setq *c60* (pop dp))
147 
+    (setq *c61* (pop dp))
148 
+    (setq *c62* (pop dp))
149 
+    (setq *c63* (pop dp))
150 
+    (setq *c64* (pop dp))
151 
+    ;-------- added for 127 atr
152 
+    (setq *c65* (pop dp))
153 
+    (setq *c66* (pop dp))
154 
+    (setq *c67* (pop dp))
155 
+    (setq *c68* (pop dp))
156 
+    (setq *c69*(pop dp))
157 
+    (setq *c70* (pop dp))
158 
+    (setq *c71* (pop dp))
159 
+    (setq *c72* (pop dp))
160 
+    (setq *c73* (pop dp))
161 
+    (setq *c74* (pop dp))
162 
+    (setq *c75* (pop dp))
163 
+    (setq *c76* (pop dp))
164 
+    (setq *c77* (pop dp))
165 
+    (setq *c78* (pop dp))
166 
+    (setq *c79*(pop dp))
167 
+    (setq *c80* (pop dp))
168 
+    (setq *c81* (pop dp))
169 
+    (setq *c82* (pop dp))
170 
+    (setq *c83* (pop dp))
171 
+    (setq *c84* (pop dp))
172 
+    (setq *c85* (pop dp))
173 
+    (setq *c86* (pop dp))
174 
+    (setq *c87* (pop dp))
175 
+    (setq *c88* (pop dp))
176 
+    (setq *c89*(pop dp))
177 
+    (setq *c90* (pop dp))
178 
+    (setq *c91* (pop dp))
179 
+    (setq *c92* (pop dp))
180 
+    (setq *c93* (pop dp))
181 
+    (setq *c94* (pop dp))
182 
+    (setq *c95* (pop dp))
183 
+    (setq *c96* (pop dp))
184 
+    (setq *c97* (pop dp))
185 
+    (setq *c98* (pop dp))
186 
+    (setq *c99*(pop dp))
187 
+    (setq *c100* (pop dp))
188 
+    (setq *c101* (pop dp))
189 
+    (setq *c102* (pop dp))
190 
+    (setq *c103* (pop dp))
191 
+    (setq *c104* (pop dp))
192 
+    (setq *c105* (pop dp))
193 
+    (setq *c106* (pop dp))
194 
+    (setq *c107* (pop dp))
195 
+    (setq *c108* (pop dp))
196 
+    (setq *c109*(pop dp))
197 
+    (setq *c110* (pop dp))
198 
+    (setq *c111* (pop dp))
199 
+    (setq *c112* (pop dp))
200 
+    (setq *c113* (pop dp))
201 
+    (setq *c114* (pop dp))
202 
+    (setq *c115* (pop dp))
203 
+    (setq *c116* (pop dp))
204 
+    (setq *c117* (pop dp))
205 
+    (setq *c118* (pop dp))
206 
+    (setq *c119*(pop dp))
207 
+    (setq *c120* (pop dp))
208 
+    (setq *c121* (pop dp))
209 
+    (setq *c122* (pop dp))
210 
+    (setq *c123* (pop dp))
211 
+    (setq *c124* (pop dp))
212 
+    (setq *c125* (pop dp))
213 
+    (setq *c126* (pop dp))
214 
+    (setq *c127* (pop dp))
215 
+    ;(setq *c128* (car dp))
216 
+    ;--------
217 
+    (eval-nodelist outs)))
218 
+
219 
+(defun &any (outs register const-list)
220 
+  (prog (z c)
221 
+    (setq z (fast-symeval register))
222 
+    (cond ((numberp z) (go number)))
223 
+    symbol (cond ((null const-list) (return nil))
224 
+		 ((eq (car const-list) z) (go ok))
225 
+		 (t (setq const-list (cdr const-list)) (go symbol)))
226 
+    number (cond ((null const-list) (return nil))
227 
+		 ((and (numberp (setq c (car const-list)))
228 
+		       (=alg c z))
229 
+		  (go ok))
230 
+		 (t (setq const-list (cdr const-list)) (go number)))
231 
+    ok   (eval-nodelist outs)))
232 
+
233 
+(defun teqa (outs register constant)
234 
+  (and (eq (fast-symeval register) constant) (eval-nodelist outs)))
235 
+
236 
+(defun tnea (outs register constant)
237 
+  (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs)))
238 
+
239 
+(defun txxa (outs register constant)
240 
+  (declare (ignore constant))
241 
+  (and (symbolp (fast-symeval register)) (eval-nodelist outs)))
242 
+
243 
+(defun teqn (outs register constant)
244 
+  (let ((z (fast-symeval register)))
245 
+    (when (and (numberp z)
246 
+	       (=alg z constant))
247 
+      (eval-nodelist outs))))
248 
+
249 
+(defun tnen (outs register constant)
250 
+  (let ((z (fast-symeval register)))
251 
+    (when (or (not (numberp z))
252 
+	      (not (=alg z constant)))
253 
+      (eval-nodelist outs))))
254 
+
255 
+(defun txxn (outs register constant)
256 
+  (declare (ignore constant))
257 
+  (let ((z (fast-symeval register)))
258 
+    (when (numberp z)
259 
+      (eval-nodelist outs))))
260 
+
261 
+(defun tltn (outs register constant)
262 
+  (let ((z (fast-symeval register)))
263 
+    (when (and (numberp z)
264 
+	       (> constant z))
265 
+      (eval-nodelist outs))))
266 
+
267 
+(defun tgtn (outs register constant)
268 
+  (let ((z (fast-symeval register)))
269 
+    (when (and (numberp z)
270 
+	       (> z constant))
271 
+      (eval-nodelist outs))))
272 
+
273 
+(defun tgen (outs register constant)
274 
+  (let ((z (fast-symeval register)))
275 
+    (when (and (numberp z)
276 
+	       (not (> constant z)))
277 
+      (eval-nodelist outs))))
278 
+
279 
+(defun tlen (outs register constant)
280 
+  (let ((z (fast-symeval register)))
281 
+    (when (and (numberp z)
282 
+	       (not (> z constant)))
283 
+      (eval-nodelist outs))))
284 
+
285 
+(defun teqs (outs vara varb)
286 
+  (let* ((a (fast-symeval vara))
287 
+	 (b (fast-symeval varb)))
288 
+    (cond ((eq a b)
289 
+	   (eval-nodelist outs))
290 
+	  ((and (numberp a)
291 
+		(numberp b)
292 
+		(=alg a b))
293 
+	   (eval-nodelist outs)))))
294 
+
295 
+(defun tnes (outs vara varb)
296 
+  (let* ((a (fast-symeval vara))
297 
+	 (b (fast-symeval varb)))
298 
+    (cond ((eq a b)
299 
+	   nil)
300 
+	  ((and (numberp a)
301 
+		(numberp b)
302 
+		(=alg a b))
303 
+	   nil)
304 
+	  (t (eval-nodelist outs)))))
305 
+
306 
+(defun txxs (outs vara varb)
307 
+  (let* ((a (fast-symeval vara))
308 
+	 (b (fast-symeval varb)))
309 
+    (cond ((and (numberp a) (numberp b)) (eval-nodelist outs))
310 
+	  ((and (not (numberp a)) (not (numberp b)))
311 
+	   (eval-nodelist outs)))))
312 
+
313 
+(defun tlts (outs vara varb)
314 
+  (let* ((a (fast-symeval vara))
315 
+	 (b (fast-symeval varb)))
316 
+    (when (and (numberp a)
317 
+	       (numberp b)
318 
+	       (> b a))
319 
+      (eval-nodelist outs))))
320 
+
321 
+(defun tgts (outs vara varb)
322 
+  (let* ((a (fast-symeval vara))
323 
+	 (b (fast-symeval varb)))
324 
+    (when (and (numberp a)
325 
+	       (numberp b)
326 
+	       (> a b))
327 
+      (eval-nodelist outs))))
328 
+
329 
+(defun tges (outs vara varb)
330 
+  (let* ((a (fast-symeval vara))
331 
+	 (b (fast-symeval varb)))
332 
+    (when (and (numberp a)
333 
+	       (numberp b)
334 
+	       (not (> b a)))
335 
+      (eval-nodelist outs))))
336 
+
337 
+(defun tles (outs vara varb)
338 
+  (let* ((a (fast-symeval vara))
339 
+	 (b (fast-symeval varb)))
340 
+    (when (and (numberp a)
341 
+	       (numberp b)
342 
+	       (not (> a b)))
343 
+      (eval-nodelist outs))))
344 
+
345 
+(defun &two (left-outs right-outs)
346 
+  (prog (fp dp)
347 
+    (cond (*sendtocall*
348 
+	   (setq fp *flag-part*)
349 
+	   (setq dp *data-part*))
350 
+	  (t
351 
+	   (setq fp *alpha-flag-part*)
352 
+	   (setq dp *alpha-data-part*)))
353 
+    (sendto fp dp 'left left-outs)
354 
+    (sendto fp dp 'right right-outs)))
355 
+
356 
+(defun &mem (left-outs right-outs memory-list)
357 
+  (prog (fp dp)
358 
+    (cond (*sendtocall*
359 
+	   (setq fp *flag-part*)
360 
+	   (setq dp *data-part*))
361 
+	  (t
362 
+	   (setq fp *alpha-flag-part*)
363 
+	   (setq dp *alpha-data-part*)))
364 
+    (sendto fp dp 'left left-outs)
365 
+    (add-token memory-list fp dp nil)
366 
+    (sendto fp dp 'right right-outs)))
367 
+
368 
+(defun &and (outs lpred rpred tests)
369 
+  (let ((mem (if (eq *side* 'right)
370 
+		 (memory-part lpred)
371 
+		 (memory-part rpred))))
372 
+    (cond ((not mem) nil)
373 
+	  ((eq *side* 'right)
374 
+	   (and-right outs mem tests))
375 
+	  (t
376 
+	   (and-left outs mem tests)))))
377 
+
378 
+(defun and-left (outs mem tests)
379 
+  (prog (fp dp memdp tlist tst lind rind res)
380 
+    (setq fp *flag-part*)
381 
+    (setq dp *data-part*)
382 
+    fail (and (null mem) (return nil))
383 
+    (setq memdp (car mem))
384 
+    (setq mem (cdr mem))
385 
+    (setq tlist tests)
386 
+    tloop (and (null tlist) (go succ))
387 
+    (setq tst (car tlist))
388 
+    (setq tlist (cdr tlist))
389 
+    (setq lind (car tlist))
390 
+    (setq tlist (cdr tlist))
391 
+    (setq rind (car tlist))
392 
+    (setq tlist (cdr tlist))
393 
+    ;###        (comment the next line differs in and-left & -right)
394 
+    (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
395 
+    (cond (res (go tloop))
396 
+	  (t (go fail)))
397 
+    succ
398 
+    ;###	(comment the next line differs in and-left & -right)
399 
+    (sendto fp (cons (car memdp) dp) 'left outs)
400 
+    (go fail)))
401 
+
402 
+(defun and-right (outs mem tests)
403 
+  (prog (fp dp memdp tlist tst lind rind res)
404 
+    (setq fp *flag-part*)
405 
+    (setq dp *data-part*)
406 
+    fail (and (null mem) (return nil))
407 
+    (setq memdp (car mem))
408 
+    (setq mem (cdr mem))
409 
+    (setq tlist tests)
410 
+    tloop (and (null tlist) (go succ))
411 
+    (setq tst (car tlist))
412 
+    (setq tlist (cdr tlist))
413 
+    (setq lind (car tlist))
414 
+    (setq tlist (cdr tlist))
415 
+    (setq rind (car tlist))
416 
+    (setq tlist (cdr tlist))
417 
+    ;###        (comment the next line differs in and-left & -right)
418 
+    (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
419 
+    (cond (res (go tloop))
420 
+	  (t (go fail)))
421 
+    succ
422 
+    ;###        (comment the next line differs in and-left & -right)
423 
+    (sendto fp (cons (car dp) memdp) 'right outs)
424 
+    (go fail)))
425 
+
426 
+
427 
+(defun teqb (new eqvar)
428 
+  (cond ((eq new eqvar) t)
429 
+	((not (numberp new)) nil)
430 
+	((not (numberp eqvar)) nil)
431 
+	((=alg new eqvar) t)
432 
+	(t nil)))
433 
+
434 
+(defun tneb (new eqvar)
435 
+  (cond ((eq new eqvar) nil)
436 
+	((not (numberp new)) t)
437 
+	((not (numberp eqvar)) t)
438 
+	((=alg new eqvar) nil)
439 
+	(t t)))
440 
+
441 
+(defun tltb (new eqvar)
442 
+  (cond ((not (numberp new)) nil)
443 
+	((not (numberp eqvar)) nil)
444 
+	((> eqvar new) t)
445 
+	(t nil)))
446 
+
447 
+(defun tgtb (new eqvar)
448 
+  (cond ((not (numberp new)) nil)
449 
+	((not (numberp eqvar)) nil)
450 
+	((> new eqvar) t)
451 
+	(t nil)))
452 
+
453 
+(defun tgeb (new eqvar)
454 
+  (cond ((not (numberp new)) nil)
455 
+	((not (numberp eqvar)) nil)
456 
+	((not (> eqvar new)) t)
457 
+	(t nil)))
458 
+
459 
+(defun tleb (new eqvar)
460 
+  (cond ((not (numberp new)) nil)
461 
+	((not (numberp eqvar)) nil)
462 
+	((not (> new eqvar)) t)
463 
+	(t nil)))
464 
+
465 
+(defun txxb (new eqvar)
466 
+  (cond ((numberp new)
467 
+	 (cond ((numberp eqvar) t)
468 
+	       (t nil)))
469 
+	((numberp eqvar) nil)
470 
+	(t t)))
471 
+
472 
+(defun &p (rating name var-dope ce-var-dope rhs)
473 
+  (declare (ignore var-dope ce-var-dope rhs))
474 
+  (prog (fp dp)
475 
+    (cond (*sendtocall*
476 
+	   (setq fp *flag-part*)
477 
+	   (setq dp *data-part*))
478 
+	  (t
479 
+	   (setq fp *alpha-flag-part*)
480 
+	   (setq dp *alpha-data-part*)))
481 
+    (and (member fp '(nil old)) (removecs name dp))
482 
+    (and fp (insertcs name dp rating))))
483 
+
484 
+(defun &old (a b c d e)
485 
+  (declare (ignore a b c d e))
486 
+  nil)
487 
+
488 
+(defun &not (outs lmem rpred tests)
489 
+  (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil)
490 
+	((eq *side* 'right) (not-right outs (car lmem) tests))
491 
+	(t (not-left outs (memory-part rpred) tests lmem))))
492 
+
493 
+(defun not-left (outs mem tests own-mem)
494 
+  (prog (fp dp memdp tlist tst lind rind res c)
495 
+    (setq fp *flag-part*)
496 
+    (setq dp *data-part*)
497 
+    (setq c 0.)
498 
+    fail (and (null mem) (go fin))
499 
+    (setq memdp (car mem))
500 
+    (setq mem (cdr mem))
501 
+    (setq tlist tests)
502 
+    tloop (and (null tlist) (setq c (1+ c)) (go fail))
503 
+    (setq tst (car tlist))
504 
+    (setq tlist (cdr tlist))
505 
+    (setq lind (car tlist))
506 
+    (setq tlist (cdr tlist))
507 
+    (setq rind (car tlist))
508 
+    (setq tlist (cdr tlist))
509 
+    ;###        (comment the next line differs in not-left & -right)
510 
+    (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
511 
+    (cond (res (go tloop))
512 
+	  (t (go fail)))
513 
+    fin  (add-token own-mem fp dp c)
514 
+    (and (== c 0.) (sendto fp dp 'left outs))))
515 
+
516 
+(defun not-right (outs mem tests)
517 
+  (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
518 
+    (setq fp *flag-part*)
519 
+    (setq dp *data-part*)
520 
+    (cond ((not fp) (setq inc -1.) (setq newfp 'new))
521 
+	  ((eq fp 'new) (setq inc 1.) (setq newfp nil))
522 
+	  (t (return nil)))
523 
+    fail (and (null mem) (return nil))
524 
+    (setq memdp (car mem))
525 
+    (setq newc (cadr mem))
526 
+    (setq tlist tests)
527 
+    tloop (and (null tlist) (go succ))
528 
+    (setq tst (car tlist))
529 
+    (setq tlist (cdr tlist))
530 
+    (setq lind (car tlist))
531 
+    (setq tlist (cdr tlist))
532 
+    (setq rind (car tlist))
533 
+    (setq tlist (cdr tlist))
534 
+    ;###        (comment the next line differs in not-left & -right)
535 
+    (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
536 
+    (cond (res (go tloop))
537 
+	  (t (setq mem (cddr mem)) (go fail)))
538 
+    succ (setq newc (+ inc newc))		;"plus" changed to "+" by gdw
539 
+    (rplaca (cdr mem) newc)
540 
+    (cond ((or (and (== inc -1.) (== newc 0.))
541 
+	       (and (== inc 1.) (== newc 1.)))
542 
+	   (sendto newfp memdp 'right outs)))
543 
+    (setq mem (cddr mem))
544 
+    (go fail)))
545 
+
546 
+;;; Node memories
547 
+
548 
+
549 
+(defun add-token (memlis flag data-part num)
550 
+  (let (was-present)
551 
+    (cond ((eq flag 'new)
552 
+	   (setq was-present nil)
553 
+	   (real-add-token memlis data-part num))
554 
+	  ((not flag)
555 
+	   (setq was-present (remove-old memlis data-part num)))
556 
+	  ((eq flag 'old) (setq was-present t)))
557 
+    was-present))
558 
+
559 
+(defun real-add-token (lis data-part num)
560 
+  (incf *current-token*)
561 
+  (when num
562 
+    (push num (car lis)))
563 
+  (push data-part (car lis)))
564 
+
565 
+(defun remove-old (lis data num)
566 
+  (if num
567 
+      (remove-old-num lis data)
568 
+      (remove-old-no-num lis data)))
569 
+
570 
+(defun remove-old-num (lis data)
571 
+  (prog (m next last)
572 
+    (setq m (car lis))
573 
+    (cond ((atom m) (return nil))
574 
+	  ((top-levels-eq data (car m))
575 
+	   (setq *current-token* (1- *current-token*))
576 
+	   (rplaca lis (cddr m))
577 
+	   (return (car m))))
578 
+    (setq next m)
579 
+    loop (setq last next)
580 
+    (setq next (cddr next))
581 
+    (cond ((atom next) (return nil))
582 
+	  ((top-levels-eq data (car next))
583 
+	   (rplacd (cdr last) (cddr next))
584 
+	   (setq *current-token* (1- *current-token*))
585 
+	   (return (car next)))
586 
+	  (t (go loop)))))
587 
+
588 
+(defun remove-old-no-num (lis data)
589 
+  (prog (m next last)
590 
+    (setq m (car lis))
591 
+    (cond ((atom m) (return nil))
592 
+	  ((top-levels-eq data (car m))
593 
+	   (setq *current-token* (1- *current-token*))
594 
+	   (rplaca lis (cdr m))
595 
+	   (return (car m))))
596 
+    (setq next m)
597 
+    loop (setq last next)
598 
+    (setq next (cdr next))
599 
+    (cond ((atom next) (return nil))
600 
+	  ((top-levels-eq data (car next))
601 
+	   (rplacd last (cdr next))
602 
+	   (setq *current-token* (1- *current-token*))
603 
+	   (return (car next)))
604 
+	  (t (go loop)))))
605 
+
606 
+;;; *EOF*
ops-rhs.lisp
History View file @ 5092d8a
0 607 
new file mode 100644
... ... 
@@ -0,0 +1,646 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+;;;; This file contains all the functions necessary for RHS actions
18 
+;;;; including $actions.
19 
+
20 
+(in-package "OPS")
21 
+;; see ops.lisp
22 
+; (shadow '(remove write))
23 
+; (export '(remove write make modify crlf))
24 
+
25 
+;;; External global variables
26 
+
27 
+(defvar *size-result-array*)
28 
+(defvar *in-rhs*)
29 
+(defvar *current-wm*)
30 
+(defvar *max-wm*)
31 
+(defvar *action-count*)
32 
+(defvar *critical*)
33 
+
34 
+
35 
+;;; Internal global variables
36 
+
37 
+(defvar *wmpart-list*)
38 
+(defvar *wm-filter*)
39 
+(defvar *wm*)
40 
+(defvar *old-wm*)
41 
+(defvar *result-array*)
42 
+(defvar *variable-memory*)
43 
+(defvar *last*)
44 
+(defvar *max-index*)
45 
+(defvar *next-index*)
46 
+(defvar *data-matched*)
47 
+(defvar *ce-variable-memory*)
48 
+(defvar *rest*)
49 
+(defvar *build-trace*)
50 
+
51 
+
52 
+;;;; Functions for RHS evaluation
53 
+
54 
+(defun rhs-init ()
55 
+  ;; if the size of result-array changes, change the line in i-g-v which
56 
+  ;; sets the value of *size-result-array*
57 
+  (setq *size-result-array* 255.)	;255 /256 set by gdw
58 
+  (setq *result-array* (make-array 256 :initial-element nil)) ;jgk
59 
+  (setq *in-rhs* nil)
60 
+  (setq *build-trace* nil)
61 
+  (setq *max-wm* (setq *current-wm* 0.))
62 
+  (setq *action-count* 0.)
63 
+  (setq *critical* nil)
64 
+  (setq *wmpart-list* nil))
65 
+
66 
+
67 
+(defun eval-rhs (pname data)
68 
+  (when *ptrace*
69 
+    (let ((port (trace-file)))
70 
+      (format port "~&~A. ~A"
71 
+	      *cycle-count* pname)
72 
+      (time-tag-print data port)))
73 
+  (let ((node (gethash pname *topnode-table*)))
74 
+    (setq *data-matched* data
75 
+	  *p-name* pname
76 
+	  *last* nil)
77 
+    (init-var-mem (var-part node))
78 
+    (init-ce-var-mem (ce-var-part node))
79 
+    (begin-record pname data)
80 
+    (let ((*in-rhs* t))
81 
+      (eval (rhs-part node)))
82 
+    (end-record)))
83 
+
84 
+(defun eval-args (z)
85 
+  (prog (r)
86 
+    (rhs-tab 1.)
87 
+    la   (and (atom z) (return nil))
88 
+    (setq r (pop z))
89 
+    (when (eq r '^)
90 
+	   (rhs-tab (car z))
91 
+	   (setq r (cadr z))
92 
+	   (setq z (cddr z)))
93 
+    (cond ((eq r '//)
94 
+	   ($value (car z))
95 
+	   (setq z (cdr z)))
96 
+	  (t ($change r)))
97 
+    (go la)))
98 
+
99 
+;;;; RHS actions
100 
+;;;; Some of these can be called at the top level.
101 
+
102 
+(defmacro make (&body z)
103 
+  `(ops-make ',z))
104 
+
105 
+(defmacro remove (&body z)
106 
+  `(ops-remove ',z))
107 
+
108 
+(defmacro modify (&body z)
109 
+  `(ops-modify ',z))
110 
+
111 
+(defmacro openfile (&body z)
112 
+  `(ops-openfile ',z))
113 
+
114 
+(defmacro closefile (&body z)
115 
+  `(ops-closefile ',z))
116 
+
117 
+(defmacro default (&body z)
118 
+  `(ops-default ',z))
119 
+
120 
+(defmacro write (&body z)
121 
+  `(ops-write ',z))
122 
+
123 
+(defmacro crlf (&body z)
124 
+  `(ops-crlf ',z))
125 
+
126 
+(defmacro tabto (&body z)
127 
+  `(ops-tabto ',z))
128 
+
129 
+(defmacro rjust (&body z)
130 
+  `(ops-rjust ',z))
131 
+
132 
+(defmacro call (&body z)
133 
+  `(ops-call ',z))
134 
+
135 
+(defmacro bind (&body z)
136 
+  `(ops-bind ',z))
137 
+
138 
+(defmacro cbind (&body z)
139 
+  `(ops-cbind ',z))
140 
+
141 
+(defmacro build (&body z)
142 
+  `(ops-build ',z))
143 
+
144 
+(defmacro substr (&body l)
145 
+  `(ops-substr ',l))
146 
+
147 
+(defmacro compute (&body z)
148 
+  `(ops-compute ',z))
149 
+
150 
+(defmacro litval (&body z)
151 
+  `(ops-litval ',z))
152 
+
153 
+(defmacro accept (&body z)
154 
+  `(ops-accept ',z))
155 
+
156 
+(defmacro acceptline (&body z)
157 
+  `(ops-acceptline ',z))
158 
+
159 
+(defmacro arith (&body z)
160 
+  `(ops-arith ',z))
161 
+
162 
+
163 
+(defun ops-make (z)
164 
+  ($reset)
165 
+  (eval-args z)
166 
+  ($assert))
167 
+
168 
+(defun ops-remove (z)
169 
+  (prog (old)
170 
+    (when (not *in-rhs*)
171 
+      (return (top-level-remove z)))
172 
+    top  (and (atom z) (return nil))
173 
+    (setq old (get-ce-var-bind (car z)))
174 
+    (when (null old)
175 
+      (%warn '|remove: argument not an element variable| (car z))
176 
+      (return nil))
177 
+    (remove-from-wm old)
178 
+    (setq z (cdr z))
179 
+    (go top)))
180 
+
181 
+(defun ops-modify (z)
182 
+  (prog (old)
183 
+    (cond ((not *in-rhs*)
184 
+	   (%warn '|cannot be called at top level| 'modify)
185 
+	   (return nil)))
186 
+    (setq old (get-ce-var-bind (car z)))
187 
+    (cond ((null old)
188 
+	   (%warn '|modify: first argument must be an element variable|
189 
+		  (car z))
190 
+	   (return nil)))
191 
+    (remove-from-wm old)
192 
+    (setq z (cdr z))
193 
+    ($reset)
194 
+    copy (and (atom old) (go fin))
195 
+    ($change (car old))
196 
+    (setq old (cdr old))
197 
+    (go copy)
198 
+    fin  (eval-args z)
199 
+    ($assert)))
200 
+
201 
+(defun ops-bind (z)
202 
+  (prog (val)
203 
+    (cond ((not *in-rhs*)
204 
+	   (%warn '|cannot be called at top level| 'bind)
205 
+	   (return nil)))
206 
+    (cond ((< (length z) 1.)
207 
+	   (%warn '|bind: wrong number of arguments to| z)
208 
+	   (return nil))
209 
+	  ((not (symbolp (car z)))
210 
+	   (%warn '|bind: illegal argument| (car z))
211 
+	   (return nil))
212 
+	  ((= (length z) 1.) (setq val (gensym)))
213 
+	  (t ($reset)
214 
+	     (eval-args (cdr z))
215 
+	     (setq val ($parameter 1.))))
216 
+    (make-var-bind (car z) val)))
217 
+
218 
+(defun ops-cbind (z)
219 
+  (cond ((not *in-rhs*)
220 
+	 (%warn '|cannot be called at top level| 'cbind))
221 
+	((not (= (length z) 1.))
222 
+	 (%warn '|cbind: wrong number of arguments| z))
223 
+	((not (symbolp (car z)))
224 
+	 (%warn '|cbind: illegal argument| (car z)))
225 
+	((null *last*)
226 
+	 (%warn '|cbind: nothing added yet| (car z)))
227 
+	(t (make-ce-var-bind (car z) *last*))))
228 
+
229 
+
230 
+(defun ops-call (z)
231 
+  (let ((f (car z)))
232 
+    ($reset)
233 
+    (eval-args (cdr z))
234 
+    (funcall f)))
235 
+
236 
+
237 
+(defun halt ()
238 
+  (cond ((not *in-rhs*)
239 
+	 (%warn '|cannot be called at top level| 'halt))
240 
+	(t (setq *halt-flag* t))))
241 
+
242 
+(defun ops-build (z)
243 
+  (prog (r)
244 
+    (cond ((not *in-rhs*)
245 
+	   (%warn '|cannot be called at top level| 'build)
246 
+	   (return nil)))
247 
+    ($reset)
248 
+    (build-collect z)
249 
+    (setq r (unflat (use-result-array)))
250 
+    (and *build-trace* (funcall *build-trace* r))
251 
+    (compile-production (car r) (cdr r))))
252 
+
253 
+(defun ops-compute (z) ($value (ari z)))
254 
+
255 
+; arith is the obsolete form of compute
256 
+(defun ops-arith (z) ($value (ari z)))
257 
+
258 
+;;; Should change the division in this function to use / instead of floor
259 
+(defun ari (x)
260 
+  (cond ((atom x)
261 
+	 (%warn '|bad syntax in arithmetic expression | x)
262 
+	 0.)
263 
+	((atom (cdr x)) (ari-unit (car x)))
264 
+	((eq (cadr x) '+)
265 
+	 (+ (ari-unit (car x)) (ari (cddr x))))
266 
+	;"plus" changed to "+" by gdw
267 
+	((eq (cadr x) '-)
268 
+	 (- (ari-unit (car x)) (ari (cddr x))))
269 
+	((eq (cadr x) '*)
270 
+	 (* (ari-unit (car x)) (ari (cddr x))))
271 
+	((eq (cadr x) '//)
272 
+	 ;; was (floor (ari-unit (car x)) (ari (cddr x))) ;@@@ quotient? /
273 
+	 ;; but changed to / by mk 10-15-92
274 
+	 (/ (ari-unit (car x)) (ari (cddr x))))
275 
+   	((eq (cadr x) 'quotient)
276 
+	 ;; for backward compatability
277 
+	 (floor (ari-unit (car x)) (ari (cddr x))))
278 
+	;@@@ kluge only works for integers
279 
+	;@@@ changed to floor by jcp (from round)
280 
+	((eq (cadr x) '\\)
281 
+	 (mod (floor (ari-unit (car x))) (floor (ari (cddr x)))))
282 
+	(t (%warn '|bad syntax in arithmetic expression | x) 0.)))
283 
+
284 
+(defun ari-unit (a)
285 
+  (prog (r)
286 
+    (cond ((consp  a) (setq r (ari a)))	;dtpr\consp gdw
287 
+	  (t (setq r ($varbind a))))
288 
+    (cond ((not (numberp r))
289 
+	   (%warn '|bad value in arithmetic expression| a)
290 
+	   (return 0.))
291 
+	  (t (return r)))))
292 
+
293 
+(defun ops-substr (l)
294 
+  (prog (k elm start end)
295 
+    (cond ((not (= (length l) 3.))
296 
+	   (%warn '|substr: wrong number of arguments| l)
297 
+	   (return nil)))
298 
+    (setq elm (get-ce-var-bind (car l)))
299 
+    (cond ((null elm)
300 
+	   (%warn '|first argument to substr must be a ce var|
301 
+		  l)
302 
+	   (return nil)))
303 
+    (setq start ($varbind (cadr l)))
304 
+    (setq start ($litbind start))
305 
+    (cond ((not (numberp start))
306 
+	   (%warn '|second argument to substr must be a number|
307 
+		  l)
308 
+	   (return nil)))
309 
+;###	(comment |if a variable is bound to INF, the following|
310 
+;	 |will get the binding and treat it as INF is|
311 
+;	 |always treated.  that may not be good|)
312 
+    (setq end ($varbind (caddr l)))
313 
+    (cond ((eq end 'inf) (setq end (length elm))))
314 
+    (setq end ($litbind end))
315 
+    (cond ((not (numberp end))
316 
+	   (%warn '|third argument to substr must be a number|
317 
+		  l)
318 
+	   (return nil)))
319 
+;###	(comment |this loop does not check for the end of elm|
320 
+;         |instead it relies on cdr of nil being nil|
321 
+;         |this may not work in all versions of lisp|)
322 
+    (setq k 1.)
323 
+    la   (cond ((> k end) (return nil))
324 
+	       ((not (< k start)) ($value (car elm))))
325 
+    (setq elm (cdr elm))
326 
+    (setq k (1+ k))
327 
+    (go la)))
328 
+
329 
+(defun genatom nil ($value (gensym)))
330 
+
331 
+(defun ops-litval (z)
332 
+  (prog (r)
333 
+    (cond ((not (= (length z) 1.))
334 
+	   (%warn '|litval: wrong number of arguments| z)
335 
+	   ($value 0)
336 
+	   (return nil))
337 
+	  ((numberp (car z)) ($value (car z)) (return nil)))
338 
+    (setq r ($litbind ($varbind (car z))))
339 
+    (cond ((numberp r) ($value r) (return nil)))
340 
+    (%warn '|litval: argument has no literal binding| (car z))
341 
+    ($value 0)))
342 
+
343 
+
344 
+
345 
+; rhs-tab implements the tab ('^') function in the rhs.  it has
346 
+; four responsibilities:
347 
+;	- to move the array pointers
348 
+;	- to watch for tabbing off the left end of the array
349 
+;	  (ie, to watch for pointers less than 1)
350 
+;	- to watch for tabbing off the right end of the array
351 
+;	- to write nil in all the slots that are skipped
352 
+; the last is necessary if the result array is not to be cleared
353 
+; after each use; if rhs-tab did not do this, $reset
354 
+; would be much slower.
355 
+
356 
+(defun rhs-tab (z) ($tab ($varbind z)))
357 
+
358 
+
359 
+(defun time-tag-print (data port)
360 
+  (when (not (null data))
361 
+    (time-tag-print (cdr data) port)
362 
+    (princ '| | port)
363 
+    (princ (creation-time (car data)) port)))
364 
+
365 
+(defun init-var-mem (vlist)
366 
+  (prog (v ind r)
367 
+    (setq *variable-memory* nil)
368 
+    top  (and (atom vlist) (return nil))
369 
+    (setq v (car vlist))
370 
+    (setq ind (cadr vlist))
371 
+    (setq vlist (cddr vlist))
372 
+    (setq r (gelm *data-matched* ind))
373 
+    (setq *variable-memory* (cons (cons v r) *variable-memory*))
374 
+    (go top)))
375 
+
376 
+(defun init-ce-var-mem (vlist)
377 
+  (prog (v ind r)
378 
+    (setq *ce-variable-memory* nil)
379 
+    top  (and (atom vlist) (return nil))
380 
+    (setq v (car vlist))
381 
+    (setq ind (cadr vlist))
382 
+    (setq vlist (cddr vlist))
383 
+    (setq r (nth (1- ind) *data-matched*)) ; was ce-gelm
384 
+    (setq *ce-variable-memory*
385 
+	  (cons (cons v r) *ce-variable-memory*))
386 
+    (go top)))
387 
+
388 
+(defun make-ce-var-bind (var elem)
389 
+  (push (cons var elem)
390 
+	*ce-variable-memory*))
391 
+
392 
+(defun make-var-bind (var elem)
393 
+  (push (cons var elem)
394 
+	*variable-memory*))
395 
+
396 
+(defun get-ce-var-bind (x)
397 
+  (if (numberp x)
398 
+      (get-num-ce x)
399 
+      (let ((r (assoc x *ce-variable-memory*)))
400 
+	(when r
401 
+	  (cdr r)))))
402 
+
403 
+(defun get-num-ce (x)
404 
+  (prog (r l d)
405 
+    (setq r *data-matched*)
406 
+    (setq l (length r))
407 
+    (setq d (- l x))
408 
+    (and (> 0. d) (return nil))
409 
+    la   (cond ((null r) (return nil))
410 
+	       ((> 1. d) (return (car r))))
411 
+    (setq d (1- d))
412 
+    (setq r (cdr r))
413 
+    (go la)))
414 
+
415 
+(defun build-collect (z)
416 
+  (prog (r)
417 
+    la   (and (atom z) (return nil))
418 
+    (setq r (car z))
419 
+    (setq z (cdr z))
420 
+    (cond ((consp  r)	;dtpr\consp gdw
421 
+	   ($value '\()
422 
+		   (build-collect r)
423 
+		   ($value '\)))
424 
+	  ((eq r '\\) ($change (car z)) (setq z (cdr z)))
425 
+	  (t ($value r)))
426 
+    (go la)))
427 
+
428 
+(defun unflat (x)
429 
+  (setq *rest* x)
430 
+  (unflat*))
431 
+
432 
+(defun unflat* ()
433 
+  (if (atom *rest*)
434 
+      nil
435 
+      (let ((c (pop *rest*)))
436 
+	(cond ((eq c '\() (cons (unflat*) (unflat*)))
437 
+	      ((eq c '\)) nil)
438 
+	      (t (cons c (unflat*)))))))
439 
+
440 
+;;;; $Functions.
441 
+;;;; These functions provide an interface to the result array.
442 
+;;;; The result array is used to organize attribute values into their
443 
+;;;; correct slot.
444 
+
445 
+(defun $litbind (x)
446 
+  (if (symbolp x)
447 
+      (or (literal-binding-of x)
448 
+	  x)
449 
+      x))
450 
+
451 
+(defun $varbind (x)
452 
+  (if *in-rhs*
453 
+      ;; If we're in the RHS, lookup the binding.
454 
+      (let ((binding (assoc x *variable-memory*)))
455 
+	(if binding
456 
+	    (cdr binding)
457 
+	    x))
458 
+      ;; Otherwise just return it unevaluated.
459 
+      x))
460 
+
461 
+(defun $change (x)
462 
+  (if (consp  x)			;dtpr\consp gdw
463 
+      (eval-function x)
464 
+      ($value ($varbind x))))
465 
+
466 
+(defun $reset nil
467 
+  (setq *max-index* 0.)
468 
+  (setq *next-index* 1.))
469 
+
470 
+(defun $tab (z)
471 
+  (prog (edge next)
472 
+    (setq next ($litbind z))
473 
+    (when (floatp next)
474 
+      (setq next (floor next)))
475 
+    (when (or (not (numberp next))
476 
+	      (> next *size-result-array*)
477 
+	      (> 1. next))		; ( '| |)
478 
+      (%warn '|illegal index after ^| next)
479 
+      (return *next-index*))
480 
+    (setq edge (- next 1.))
481 
+    (cond ((> *max-index* edge) (go ok)))
482 
+    clear (when (== *max-index* edge) (go ok))
483 
+    (setf (aref *result-array* edge) nil)
484 
+    (decf edge)
485 
+    (go clear)
486 
+    ok   (setq *next-index* next)
487 
+    (return next)))
488 
+
489 
+(defun $value (v)
490 
+  (cond ((> *next-index* *size-result-array*)
491 
+	 (%warn '|index too large| *next-index*))
492 
+	(t
493 
+	 (and (> *next-index* *max-index*)
494 
+	      (setq *max-index* *next-index*))
495 
+	 (setf (aref *result-array* *next-index*) v)
496 
+	 (incf *next-index*))))
497 
+
498 
+(defun $assert nil
499 
+  (setq *last* (use-result-array))
500 
+  (add-to-wm *last* nil))
501 
+
502 
+(defun $parametercount ()
503 
+  *max-index*)
504 
+
505 
+(defun $parameter (k)
506 
+  (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
507 
+	 (%warn '|illegal parameter number | k)
508 
+	 nil)
509 
+	((> k *max-index*) nil)
510 
+	(t (aref *result-array* k))))
511 
+
512 
+(defun $ifile (x)
513 
+  (when (symbolp x)
514 
+    (gethash x *inputfile-table*)))
515 
+
516 
+(defun $ofile (x)
517 
+  (when (symbolp x)
518 
+    (gethash x *outputfile-table*)))
519 
+
520 
+;;;
521 
+
522 
+(defun use-result-array ()
523 
+  "Use-result-array returns the contents of the result array as a list."
524 
+  ;; is *max-index* acting like a fill-pointer? Then we can't just use
525 
+  ;; coerce, unless we change *result-array* to use a fill pointer.
526 
+  ;; Also, note that index 0 of the array is ignored.
527 
+  (prog (k r)
528 
+    (setq k *max-index*)
529 
+    (setq r nil)
530 
+    top  (and (== k 0.) (return r))
531 
+    (setq r (cons (aref *result-array* k) r))
532 
+    (decf k)
533 
+    (go top)))
534 
+
535 
+(defun eval-function (form)
536 
+  (if (not *in-rhs*)
537 
+      (%warn '|functions cannot be used at top level| (car form))
538 
+      (eval form)))
539 
+
540 
+;;;; WM maintaining functions
541 
+
542 
+;;; The order of operations in the following two functions is critical.
543 
+;;; add-to-wm order: (1) change wm (2) record change (3) match
544 
+;;; remove-from-wm order: (1) record change (2) match (3) change wm
545 
+;;; (back will not restore state properly unless wm changes are recorded
546 
+;;; before the cs changes that they cause)  (match will give errors if
547 
+;;; the thing matched is not in wm at the time)
548 
+
549 
+(defun add-to-wm (wme override)
550 
+  (prog (fa z part timetag port)
551 
+    (setq *critical* t)
552 
+    (setq *current-wm* (1+ *current-wm*))
553 
+    (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
554 
+    (setq *action-count* (1+ *action-count*))
555 
+    (setq fa (wm-hash wme))
556 
+    (or (member fa *wmpart-list*)
557 
+	(setq *wmpart-list* (cons fa *wmpart-list*)))
558 
+    (setq part (gethash fa *wmpart*-table*))
559 
+    (cond (override (setq timetag override))
560 
+	  (t (setq timetag *action-count*)))
561 
+    (setq z (cons wme timetag))
562 
+    (setf (gethash fa *wmpart*-table*) (cons z part))
563 
+    (record-change '=>wm *action-count* wme)
564 
+    (match 'new wme)
565 
+    (setq *critical* nil)
566 
+    (cond ((and *in-rhs* *wtrace*)
567 
+	   (setq port (trace-file))
568 
+	   (terpri port)
569 
+	   (princ '|=>wm: | port)
570 
+	   (ppelm wme port)))))
571 
+
572 
+;;; remove-from-wm uses eq, not equal to determine if wme is present
573 
+
574 
+(defun remove-from-wm (wme)
575 
+  (prog (fa z part timetag port)
576 
+    (setq fa (wm-hash wme))
577 
+    (setq part (gethash fa *wmpart*-table*))
578 
+    (setq z (assoc wme part))
579 
+    (or z (return nil))
580 
+    (setq timetag (cdr z))
581 
+    (cond ((and *wtrace* *in-rhs*)
582 
+	   (setq port (trace-file))
583 
+	   (terpri port)
584 
+	   (princ '|<=wm: | port)
585 
+	   (ppelm wme port)))
586 
+    (setq *action-count* (1+ *action-count*))
587 
+    (setq *critical* t)
588 
+    (setq *current-wm* (1- *current-wm*))
589 
+    (record-change '<=wm timetag wme)
590 
+    (match nil wme)
591 
+    (setf (gethash fa *wmpart*-table*) (delete z part :test #'eq))
592 
+    (setq *critical* nil)))
593 
+
594 
+;;; mapwm maps down the elements of wm, applying fn to each element
595 
+;;; each element is of form (datum . creation-time)
596 
+
597 
+(defun mapwm (fn)
598 
+  (dolist (wmpl *wmpart-list*)
599 
+    (mapc fn (gethash wmpl *wmpart*-table*)))
600 
+  #|(prog (wmpl part)
601 
+    (setq wmpl *wmpart-list*)
602 
+    lab1 (cond ((atom wmpl) (return nil)))
603 
+    (setq part (gethash (car wmpl) *wmpart*-table*))
604 
+    (setq wmpl (cdr wmpl))
605 
+    (mapc fn part)
606 
+    (go lab1))|#
607 
+  )
608 
+
609 
+(defun ops-wm (a)
610 
+  (mapc #'(lambda (z) (terpri) (ppelm z *standard-output*))
611 
+	(get-wm a))
612 
+  nil)
613 
+
614 
+(defun creation-time (wme)
615 
+  (cdr (assoc wme (gethash (wm-hash wme) *wmpart*-table*))))
616 
+
617 
+(defun get-wm (z)
618 
+  (setq *wm-filter* z)
619 
+  (setq *wm* nil)
620 
+  (mapwm #'(lambda (elem)
621 
+	     (when (or (null *wm-filter*)
622 
+		       (member (cdr elem) *wm-filter*)) ;test #'equal
623 
+	       (push (car elem) *wm*))))
624 
+  (prog2 nil *wm* (setq *wm* nil)))
625 
+
626 
+(defun wm-hash (x)
627 
+  (cond ((not x) '<default>)
628 
+	((not (car x)) (wm-hash (cdr x)))
629 
+	((symbolp (car x)) (car x))
630 
+	(t (wm-hash (cdr x)))))
631 
+
632 
+(defun refresh ()
633 
+  (setq *old-wm* nil)
634 
+  (mapwm #'refresh-collect)
635 
+  (mapc #'refresh-del *old-wm*)
636 
+  (mapc #'refresh-add *old-wm*)
637 
+  (setq *old-wm* nil))
638 
+
639 
+(defun refresh-collect (x)
640 
+  (push x *old-wm*))
641 
+
642 
+(defun refresh-del (x) (remove-from-wm (car x)))
643 
+
644 
+(defun refresh-add (x) (add-to-wm (car x) (cdr x)))
645 
+
646 
+;;; *EOF*
ops-util.lisp
History View file @ 5092d8a
0 647 
new file mode 100644
... ... 
@@ -0,0 +1,160 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+;;;; This file contains utility definitions that are needed by other ops
18 
+;;;; modules.  This must be loaded first so commonlisp systems that
19 
+;;;; expand macros early have them available.
20 
+
21 
+;;; Change Log:
22 
+;;; 13-OCT-92 mk    Replaced all uses of ASSQ with ASSOC, as appropriate.
23 
+;;; 13-OCT-92 mk    Replaced all uses of DELQ with DELETE #'EQ.
24 
+;;; 13-OCT-92 mk    Renamed SP-DELETE as TREE-REMOVE and modified the
25 
+;;;                 definition slightly.
26 
+;;; 13-OCT-92 mk    Got rid of PUTVECTOR and GETVECTOR.
27 
+;;; 13-OCT-92 mk    Eliminated usage of PUTPROP, GET, and REMPROP.
28 
+;;; 13-OCT-92 mk    Replaced CE-GELM with a call to NTH.
29 
+;;; 13-OCT-92 mk    Replaced INTERQ with INTERSECTION.
30 
+;;; 13-OCT-92 mk    Replaced FIX with FLOOR.
31 
+;;; 13-OCT-92 mk    Replaced NCONS with LIST.
32 
+;;; 13-OCT-92 mk    Replaced DTPR with CONSP.
33 
+
34 
+
35 
+(in-package "OPS")
36 
+
37 
+
38 
+(defun tree-remove (element tree &key (test #'equal))
39 
+  "TREE-REMOVE is a function which deletes every occurence
40 
+   of ELEMENT from TREE. This function was defined because Common Lisp's
41 
+   REMOVE function only removes top level elements from a list."
42 
+  (when tree
43 
+    (if (funcall test element (car tree))
44 
+	(tree-remove element (cdr tree) :test test)
45 
+	(cons (car tree)
46 
+	      (tree-remove element (cdr tree) :test test)))))
47 
+
48 
+;;; Functions that were revised so that they would compile efficiently
49 
+(eval-when (compile eval load)
50 
+
51 
+(defmacro == (x y)
52 
+  ;; Skef Wholey - The = function in Common Lisp will compile into good code
53 
+  ;; (in all implementations that I know of) when given the right declarations.
54 
+  ;; In this case, we know both numbers are fixnums, so we use that
55 
+  ;; information.
56 
+  `(= (the fixnum ,x) (the fixnum ,y)))
57 
+
58 
+(defmacro =alg (a b)
59 
+  ;; =ALG returns T if A and B are algebraically equal.
60 
+  ;; This corresponds to equalp - Dario Giuse
61 
+  ;; But equalp uses eql for comparison if the things are numbers - Skef Wholey
62 
+  `(eql ,a ,b))
63 
+
64 
+(defmacro fast-symeval (&body z)
65 
+  `(symbol-value ,(car z)))
66 
+
67 
+) ;eval-when
68 
+
69 
+
70 
+; The loops in gelm were unwound so that fewer calls on DIFFERENCE
71 
+; would be needed
72 
+
73 
+(defun gelm (x k)
74 
+  ; (locally) 				;@@@ locally isn't implemented yet
75 
+  (declare (optimize speed))
76 
+  (prog (ce sub)
77 
+    (setq ce (truncate  k 10000.))		;use multiple-value-setq???
78 
+    (setq sub (- k (* ce 10000.)))		;@@@ ^
79 
+
80 
+    celoop (and (eq ce 0.) (go ph2))
81 
+    (setq x (cdr x))
82 
+    (and (eq ce 1.) (go ph2))
83 
+    (setq x (cdr x))
84 
+    (and (eq ce 2.) (go ph2))
85 
+    (setq x (cdr x))
86 
+    (and (eq ce 3.) (go ph2))
87 
+    (setq x (cdr x))
88 
+    (and (eq ce 4.) (go ph2))
89 
+    (setq ce (- ce 4.))
90 
+    (go celoop)
91 
+    ph2  (setq x (car x))
92 
+    subloop (and (eq sub 0.) (go finis))
93 
+    (setq x (cdr x))
94 
+    (and (eq sub 1.) (go finis))
95 
+    (setq x (cdr x))
96 
+    (and (eq sub 2.) (go finis))
97 
+    (setq x (cdr x))
98 
+    (and (eq sub 3.) (go finis))
99 
+    (setq x (cdr x))
100 
+    (and (eq sub 4.) (go finis))
101 
+    (setq x (cdr x))
102 
+    (and (eq sub 5.) (go finis))
103 
+    (setq x (cdr x))
104 
+    (and (eq sub 6.) (go finis))
105 
+    (setq x (cdr x))
106 
+    (and (eq sub 7.) (go finis))
107 
+    (setq x (cdr x))
108 
+    (and (eq sub 8.) (go finis))
109 
+    (setq sub (- sub 8.))
110 
+    (go subloop)
111 
+    finis (return (car x))) ) ;  )  	;end prog,< locally >, defun
112 
+
113 
+(defun %warn (what where)
114 
+  (format t "~&?~@[~A~]..~A..~A"
115 
+	   *p-name* where what)
116 
+  where)
117 
+
118 
+(defun %error (what where)
119 
+  (%warn what where)
120 
+  (throw '!error! '!error!)) 	;jgk quoted arguments
121 
+
122 
+(defun top-levels-eq (la lb)
123 
+  (do ((sublist-a la (cdr sublist-a))
124 
+       (sublist-b lb (cdr sublist-b)))
125 
+      ((eq sublist-a sublist-b)
126 
+       t)
127 
+    (when (or (null sublist-a)
128 
+	      (null sublist-b)
129 
+	      (not (eq (car sublist-a) (car sublist-b))))
130 
+      (return nil)))
131 
+  #|(prog nil
132 
+    lx   (cond ((eq la lb) (return t))
133 
+	       ((null la) (return nil))
134 
+	       ((null lb) (return nil))
135 
+	       ((not (eq (car la) (car lb))) (return nil)))
136 
+    (setq la (cdr la))
137 
+    (setq lb (cdr lb))
138 
+    (go lx))|#
139 
+  )
140 
+
141 
+;@@@ revision suggested by sf/inc. by gdw
142 
+(defun variablep (x)
143 
+  (and (symbolp x)
144 
+       (char= (char (symbol-name x) 0) #\< )))
145 
+
146 
+
147 
+#|
148 
+Commented out - Dario Giuse.
149 
+This is unnecessary in Spice Lisp
150 
+
151 
+; break mechanism:
152 
+(proclaim '(special erm *break-character*))
153 
+
154 
+(defun setbreak nil (setq *break-flag* t))
155 
+(setq *break-character* #\control-D)
156 
+(bind-keyboard-function *break-character* #'setbreak)
157 
+(princ "*** use control-d for ops break, or setq *break-character asciival***")
158 
+
159 
+|#
160 
+;;; *EOF*
ops.lisp
History View file @ 5092d8a
0 161 
new file mode 100644
... ... 
@@ -0,0 +1,112 @@
1 
+;;; ****************************************************************
2 
+;;; OPS5 Interpreter ***********************************************
3 
+;;; ****************************************************************
4 
+;;; This Common Lisp version of OPS5 is in the public domain.  It is based
5 
+;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
6 
+;;; at Carnegie-Mellon University, which was placed in the public domain by
7 
+;;; the author in accordance with CMU policies.  Ported to Common Lisp by
8 
+;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
9 
+;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
10 
+;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
11 
+;;; Mark Kantrowitz on 14-OCT-92.
12 
+;;;
13 
+;;; This code is made available is, and without warranty of any kind by the
14 
+;;; authors or by Carnegie-Mellon University.
15 
+;;;
16 
+
17 
+;;; Change Log:
18 
+;;; 13-OCT-92 mk    Modified pathname usage to not be CMU Common Lisp specific.
19 
+;;; 15-OCT-92 mk    Changed definition of // in ARI so that division uses /
20 
+;;;                 instead of FLOOR. Added QUOTIENT infix operator for
21 
+;;;                 backward compatability.
22 
+;;; 15-OCT-92 mk    Moved all exports and shadows to this file, and modified
23 
+;;;                 them somewhat, to allow OPS5 to run on the Macintosh.
24 
+
25 
+;;;; This file handles the loading of all files composing the OPS interpreter.
26 
+;;;; It also performs the necessary initialization.
27 
+
28 
+(in-package :cl-user)
29 
+
30 
+(eval-when (compile load eval)
31 
+  #+(or (and :excl (or :allegro-v4.0 :allegro-v4.1)) :mcl)
32 
+  (pushnew :cltl2 *features*))
33 
+
34 
+(defpackage "OPS" (:use "COMMON-LISP")
35 
+  (:shadow "REMOVE" "WRITE")
36 
+  (:export "REMOVE" "WRITE" "MAKE" "MODIFY" "CRLF"
37 
+	   "-->"
38 
+	   "LITERALIZE" "P" "VECTOR-ATTRIBUTE" "STRATEGY" "WATCH" "RESET-OPS"))
39 
+
40 
+(in-package "OPS")
41 
+
42 
+;;; ********************************
43 
+;;; Source Directory ***************
44 
+;;; ********************************
45 
+
46 
+(defparameter *ops-code-directory* ""
47 
+  "Directory where OPS5 source code is stored.")
48 
+
49 
+(defun ops-pathname (filename)
50 
+  (concatenate 'string *ops-code-directory* filename))
51 
+
52 
+(defun load-ops-file (filename)
53 
+  (load (ops-pathname filename)))
54 
+
55 
+(defun compile-load (filename)
56 
+  (let ((pname (ops-pathname filename)))
57 
+    (compile-file (concatenate 'string pname ".lisp"))
58 
+    (load pname)))
59 
+
60 
+;;; ********************************
61 
+;;; OPS Loading, Compilation, Init *
62 
+;;; ********************************
63 
+
64 
+(defun load-ops ()
65 
+  (load-ops-file "ops-globals")
66 
+  (load-ops-file "ops-util")
67 
+  (load-ops-file "ops-backup")
68 
+  (load-ops-file "ops-compile")
69 
+  (load-ops-file "ops-main")
70 
+  (load-ops-file "ops-match")
71 
+  (load-ops-file "ops-io")
72 
+  (load-ops-file "ops-rhs")
73 
+  (load-ops-file "ops-init")
74 
+  (ops-init))
75 
+
76 
+(defun compile-ops ()
77 
+  (load-ops-file "ops")			; so that shadowing takes place...
78 
+  (compile-load "ops-globals")
79 
+  (compile-load "ops-util")		; macros
80 
+  (compile-load "ops-compile")
81 
+  (compile-load "ops-rhs")		; defines macros used in ops-init
82 
+  (compile-load "ops-main")		; macros
83 
+  (compile-load "ops-match")
84 
+  (compile-load "ops-backup")
85 
+  (compile-load "ops-io")
86 
+  (compile-load "ops-init"))
87 
+
88 
+;;; ********************************
89 
+;;; REP Loop ***********************
90 
+;;; ********************************
91 
+
92 
+(defun ops ()
93 
+  "OPS Read-Eval-Print Loop."
94 
+  (let ((counter 0))
95 
+    (loop
96 
+      (incf counter)
97 
+      (format t "~&~D. " counter)
98 
+      (let* ((input (string-trim '(#\space #\tab) (read-line)))
99 
+	     (space-pos (position #\space input))
100 
+	     (tag (subseq input 0 space-pos)))
101 
+	(cond ((or (string-equal tag "exit")
102 
+		   (string-equal tag "quit"))
103 
+	       (return))
104 
+	      ((string-equal tag "load")
105 
+	       (load (subseq input (1+ space-pos))))
106 
+	      (t
107 
+	       (let ((form (read-from-string (concatenate 'string
108 
+							  "(" input ")"))))
109 
+		 (print (eval form)))))))))
110 
+
111 
+;;; *EOF*
112 
+