├── README.md ├── README.orig ├── TODO ├── demo ├── auto.ops ├── auto.run ├── ops-demo-mab.lisp ├── ops-demo-ttt.lisp ├── reactor.ops └── reactor.run ├── doc ├── lang.doc ├── lang.mss └── lang.ps ├── ops-backup.lisp ├── ops-compile.lisp ├── ops-globals.lisp ├── ops-init.lisp ├── ops-io.lisp ├── ops-main.lisp ├── ops-match.lisp ├── ops-rhs.lisp ├── ops-util.lisp ├── ops.lisp ├── ops5.asd └── package.lisp /README.md: -------------------------------------------------------------------------------- 1 | # OPS5 2 | 3 | This repository contains a Common Lisp implementation of 4 | [OPS5](https://en.wikipedia.org/wiki/OPS5). It was obtained from the 5 | [CMU AI 6 | Archive](https://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/areas/expert/systems/ops5/0.html) 7 | on January 16, 2020, and modified by Zachary Beane to build and run on 8 | modern (as of 2020) Common Lisp implementations. 9 | 10 | The original software and all updates by Zachary Beane are in the 11 | public domain. 12 | 13 | The original, unchanged README file is available unchanged as 14 | [README.orig](README.orig). 15 | -------------------------------------------------------------------------------- /README.orig: -------------------------------------------------------------------------------- 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 | # 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* 133 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | 2 | Rewrite code to eliminate the use of PROG, etc. General code cleanup. 3 | 4 | -------------------------------------------------------------------------------- /demo/auto.ops: -------------------------------------------------------------------------------- 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 ^value nil) 39 | --> 40 | (write (crlf) "Is this true:" "[no] ") 41 | (bind (acceptline no)) 42 | (modify 2 ^value )) 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 |you must turn the key to start the car|) 82 | (make fact ^name ^value yes) 83 | (write (crlf) "Concluding" (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 |problem is in fuel or ignition system|) 92 | (make fact ^name ^value yes) 93 | (write (crlf) "Concluding" (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 |problem is in starting system|) 101 | (make fact ^name ^value yes) 102 | (write (crlf) "Concluding" (crlf))) 103 | 104 | (p out-of-gas 105 | (task ^goal diagnose) 106 | (fact ^name |fuel gauge shows empty| ^value yes) 107 | --> 108 | (bind |out of gas|) 109 | (make fact ^name ^value yes) 110 | (write (crlf) "Concluding" (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 |engine is flooded: wait 15 minutes|) 120 | (make fact ^name ^value yes) 121 | (write (crlf) "Concluding" (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 |you have a bad ignition system|) 131 | (make fact ^name ^value yes) 132 | (write (crlf) "Concluding" (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 |you have a dead battery|) 140 | (make fact ^name ^value yes) 141 | (write (crlf) "Concluding" (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 |you have a bad starter|) 150 | (make fact ^name ^value yes) 151 | (write (crlf) "Concluding" (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 |problem in fuel system: bad fuel pump or filter|) 161 | (make fact ^name ^value yes) 162 | (write (crlf) "Concluding" (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))) 177 | -------------------------------------------------------------------------------- /demo/auto.run: -------------------------------------------------------------------------------- 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 60 | -------------------------------------------------------------------------------- /demo/ops-demo-mab.lisp: -------------------------------------------------------------------------------- 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 ) 38 | (object ^name ^at

^on ceiling) 39 | --> 40 | (make goal ^status active ^type move ^object ladder ^to

)) 41 | 42 | 43 | (p mb2 44 | (goal ^status active ^type holds ^object ) 45 | (object ^name ^at

^on ceiling) 46 | (object ^name ladder ^at

) 47 | --> 48 | (make goal ^status active ^type on ^object ladder)) 49 | 50 | 51 | (p mb3 52 | (goal ^status active ^type holds ^object ) 53 | (object ^name ^at

^on ceiling) 54 | (object ^name ladder ^at

) 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 ) 62 | (object ^name ^at

^on ceiling) 63 | (object ^name ladder ^at

) 64 | (monkey ^on ladder ^holds nil) 65 | --> 66 | (write (crlf) "grab" ) 67 | (modify 4 ^holds ) 68 | (modify 1 ^status satified)) 69 | 70 | 71 | 72 | (p mb5 73 | (goal ^status active ^type holds ^object ) 74 | (object ^name ^at

^on floor) 75 | --> 76 | (make goal ^status active ^type walk-to ^object

)) 77 | 78 | 79 | (p mb6 80 | (goal ^status active ^type holds ^object ) 81 | (object ^name ^at

^on floor) 82 | (monkey ^at

) 83 | --> 84 | (make goal ^status active ^type holds ^object nil)) 85 | 86 | 87 | (p mb7 88 | (goal ^status active ^type holds ^object ) 89 | (object ^name ^at

^on floor) 90 | (monkey ^at

^holds nil) 91 | --> 92 | (write (crlf) "grab" ) 93 | (modify 3 ^holds ) 94 | (modify 1 ^status satisfied)) 95 | 96 | (p mb8 97 | (goal ^status active ^type move ^object ^to

) 98 | (object ^name ^weight light ^at <>

) 99 | --> 100 | (make goal ^status active ^type holds ^object )) 101 | 102 | 103 | (p mb9 104 | (goal ^status active ^type move ^object ^to

) 105 | (object ^name ^weight light ^at <>

) 106 | (monkey ^holds ) 107 | --> 108 | (make goal ^status active ^type walk-to ^object

)) 109 | 110 | 111 | (p mb10 112 | (goal ^status active ^type move ^object ^to

) 113 | (object ^name ^weight light ^at

) 114 | --> 115 | (modify 1 ^status satisfied)) 116 | 117 | 118 | (p mb11 119 | (goal ^status active ^type walk-to ^object

) 120 | --> 121 | (make goal ^status active ^type on ^object floor)) 122 | 123 | (p mb12 124 | (goal ^status active ^type walk-to ^object

) 125 | (monkey ^on floor ^at { <>

} ^holds nil) 126 | --> 127 | (write (crlf) "walk to"

) 128 | (modify 2 ^at

) 129 | (modify 1 ^status satisfied)) 130 | 131 | 132 | (p mb13 133 | (goal ^status active ^type walk-to ^object

) 134 | (monkey ^on floor ^at { <>

} ^holds <> nil) 135 | (object ^name ) 136 | --> 137 | (write (crlf) "walk to"

) 138 | (modify 2 ^at

) 139 | (modify 3 ^at

) 140 | (modify 1 ^status satisfied)) 141 | 142 | (p mb14 143 | (goal ^status active ^type on ^object floor) 144 | (monkey ^on { <> 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 ) 152 | (object ^name ^at

) 153 | --> 154 | (make goal ^status active ^type walk-to ^object

)) 155 | 156 | 157 | 158 | (p mb16 159 | (goal ^status active ^type on ^object ) 160 | (object ^name ^at

) 161 | (monkey ^at

) 162 | --> 163 | (make goal ^status active ^type holds ^object nil)) 164 | 165 | 166 | (p mb17 167 | (goal ^status active ^type on ^object ) 168 | (object ^name ^at

) 169 | (monkey ^at

^holds nil) 170 | --> 171 | (write (crlf) "climb onto" ) 172 | (modify 3 ^on ) 173 | (modify 1 ^status satisfied)) 174 | 175 | (p mb18 176 | (goal ^status active ^type holds ^object nil) 177 | (monkey ^holds { <> nil}) 178 | --> 179 | (write (crlf) "drop" ) 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 | 197 | -------------------------------------------------------------------------------- /demo/ops-demo-ttt.lisp: -------------------------------------------------------------------------------- 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 ) 71 | (opposite ^of ^is ) 72 | (position ^row 1 ^column 1 ^value ) 73 | (position ^row 1 ^column 2 ^value ) 74 | (position ^row 1 ^column 3 ^value ) 75 | (position ^row 2 ^column 1 ^value ) 76 | (position ^row 2 ^column 2 ^value ) 77 | (position ^row 2 ^column 3 ^value ) 78 | (position ^row 3 ^column 1 ^value ) 79 | (position ^row 3 ^column 2 ^value ) 80 | (position ^row 3 ^column 3 ^value ) 81 | --> 82 | (modify 2 ^status unmade ^whose-turn ) 83 | (write (crlf) (crlf) (crlf) 84 | (tabto 12) (tabto 15) "|" (tabto 18) 85 | (tabto 21) "|" (tabto 24) 86 | (tabto 10) ----------------- 87 | (tabto 12) (tabto 15) "|" (tabto 18) 88 | (tabto 21) "|" (tabto 24) 89 | (tabto 10) ----------------- 90 | (tabto 12) (tabto 15) "|" (tabto 18) 91 | (tabto 21) "|" (tabto 24) ) ) 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 ^is human) 98 | (opposite ^of ^is ) 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 ^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 ^is human) 112 | - (opposite ^of ) 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 ) 122 | (player ^with-mark ^is ) 123 | --> 124 | (make task ^actor ) ) 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 ) 130 | (opposite ^of ^is ) 131 | (player ^with-mark ) 132 | (position ^column ^value ) 133 | - (position ^column ^value <> ) 134 | --> 135 | (remove 2) 136 | (make player ^with-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 ) 142 | (opposite ^of ^is ) 143 | (player ^with-mark ) 144 | (position ^row ^value ) 145 | - (position ^row ^value <> ) 146 | --> 147 | (remove 2) 148 | (make player ^with-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 ) 154 | (opposite ^of ^is ) 155 | (player ^with-mark ) 156 | (position ^row 2 ^column 2 ^value ) 157 | (position ^row { <> 2} ^column { <> 2} 158 | ^identity ^value ) 159 | (position ^row ^column 160 | ^identity <> ^value ) 161 | --> 162 | (remove 2) 163 | (make player ^with-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 ^is winner) 169 | (player ^with-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 ^is winner) 177 | (player ^with-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 ) 185 | (player ^with-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 215 | ^input { >= 0 <= 3} { >= 0 <= 3} nil) 216 | (position ^row ^column ^value | |) 217 | --> 218 | (remove 2) 219 | (make move (substr 2 2 input) ^status made ^input nil) 220 | (modify 3 ^value ) ) 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 nil ^input << 1 2 3 >> << 1 2 3 >>) 230 | (position ^row ^column ^value { <> | |}) 231 | --> 232 | (write (crlf) (crlf) "There is already an " " in " ) 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 ) 253 | - (position ^row 2 ^column 2 ^value | |) 254 | (position ^row ^column ^value | |) 255 | --> 256 | (modify 2 ^status made) 257 | (modify 3 ^value ) ) 258 | 259 | (p computer--select-center 260 | ; select the center if it's available 261 | (task ^actor computer) 262 | (move ^status unmade ^whose-turn ) 263 | (position ^row 2 ^column 2 ^value | |) 264 | --> 265 | (modify 2 ^status made) 266 | (modify 3 ^value ) ) 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 ) 272 | (position ^row ^column 273 | ^value { <> <> | |}) 274 | (position ^column ^value | |) 275 | (position ^row <> ^column ^value ) 276 | --> 277 | (modify 2 ^status made) 278 | (modify 4 ^value ) ) 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 ) 284 | (position ^row ^column 285 | ^value { <> <> | |}) 286 | (position ^row ^value | |) 287 | (position ^row ^column <> ^value ) 288 | --> 289 | (modify 2 ^status made) 290 | (modify 4 ^value ) ) 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 ) 296 | (position ^row 2 ^column 2 297 | ^value { <> <> | |}) 298 | (position ^row { <> 2} ^column { <> 2} ^value | |) 299 | (position ^row ^column ^value ) 300 | --> 301 | (modify 2 ^status made) 302 | (modify 4 ^value ) ) 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 ) 309 | (position ^row ^column ^value ) 310 | - (position ^row <> ^column ^value <> | |) 311 | (position ^row <> ^column ^value | |) 312 | --> 313 | (modify 2 ^status made) 314 | (modify 4 ^value ) ) 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 ) 321 | (position ^row ^column ^value ) 322 | - (position ^row ^column <> ^value <> | |) 323 | (position ^row ^column <> ^value | |) 324 | --> 325 | (modify 2 ^status made) 326 | (modify 4 ^value ) ) 327 | -------------------------------------------------------------------------------- /demo/reactor.ops: -------------------------------------------------------------------------------- 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 (accept)) 33 | (make task ^goal input) 34 | (make accident ^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 ^name ^value unknown ^raw-value nil) 51 | --> 52 | (write "Enter value for" "[1..100]: ") 53 | (bind (accept)) 54 | (modify 2 ^raw-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 ^name ^trend unknown ^change nil) 63 | --> 64 | (write "Enter old value for" "[1..100]: ") 65 | (bind (accept)) 66 | (write "Enter new value for" "[1..100]: ") 67 | (bind (accept)) 68 | (modify 2 ^change (compute - ))) 69 | 70 | ;;; get the status for systems 71 | 72 | (p get-status 73 | (task ^goal input) 74 | (fact ^system ^name nil ^status unknown) 75 | --> 76 | (write "Enter value for" "[on, off]: ") 77 | (bind (accept)) 78 | (modify 2 ^status )) 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 ^name ^raw-value < 33 ^value unknown) 98 | --> 99 | (modify 2 ^value low) 100 | (write "Rule classify-low concludes that" 101 | "is low" (crlf))) 102 | 103 | (p classify-high 104 | (task ^goal classify) 105 | (fact ^system ^name ^raw-value > 66 ^value unknown) 106 | --> 107 | (modify 2 ^value high) 108 | (write "Rule classify-high concludes that" 109 | "is high" (crlf))) 110 | 111 | (p classify-nominal 112 | (task ^goal classify) 113 | (fact ^system ^name ^value unknown) 114 | --> 115 | (modify 2 ^value nominal) 116 | (write "Rule classify-nominal concludes that" 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 ^name ^trend unknown ^change { < -3}) 125 | --> 126 | (modify 2 ^trend decreasing) 127 | (write "Rule classify-decreasing concludes that" 128 | "is decreasing" (crlf))) 129 | 130 | (p classify-increasing 131 | (task ^goal classify) 132 | (fact ^system ^name ^trend unknown ^change { > 3}) 133 | --> 134 | (modify 2 ^trend increasing) 135 | (write "Rule classify-increasing concludes that" 136 | "is increasing" (crlf))) 137 | 138 | (p classify-steady 139 | (task ^goal classify) 140 | (fact ^system ^name ^trend unknown) 141 | --> 142 | (modify 2 ^trend steady) 143 | (write "Rule classify-steady concludes that" 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 ) 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 ) 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 ) 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 ) 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 ) 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 { <> nil}) 293 | (fact ^system ^name ^raw-value ^value = ) 294 | --> 295 | (write " " ":" (crlf))) 296 | 297 | ;;; Print trends 298 | 299 | (p explain-trends 300 | (task ^goal explain ^subgoal reply ^query { <> nil}) 301 | (fact ^system ^name ^change ^trend = ) 302 | --> 303 | (write " " ":" changed (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 | 319 | -------------------------------------------------------------------------------- /demo/reactor.run: -------------------------------------------------------------------------------- 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 66 | -------------------------------------------------------------------------------- /doc/lang.doc: -------------------------------------------------------------------------------- 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 |problem is in starting system|) 33 | (make fact ^name ^value yes) 34 | (write (crlf) Concluding (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 , ``'' 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 ) -- is pattern (in LHS condition form), prints all wme's 127 | that match . No variables, predicates or special characters are allowed 128 | in in . 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 ) -- 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 ) -- 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 { > 100 } ) 153 | (number ^value { <> } ) 154 | (number ^value { < 50 } ) 155 | --> 156 | (write (crlf) ) ) 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 ) -- 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 ) 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 ) deletes working memory elements with time tags in 210 | 211 | 212 | The EXCISE Command 213 | 214 | (excise ) -- prevents rules from firing (still in network), reload to 215 | recall, but won't be current on wm. 216 | -------------------------------------------------------------------------------- /doc/lang.mss: -------------------------------------------------------------------------------- 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 |problem is in starting system|) 46 | (make fact ^name ^value yes) 47 | (write (crlf) Concluding (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 }, ``'' 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 )} -- is pattern (in LHS condition form), 155 | prints all wme's that match . 156 | No variables, predicates or special characters are allowed in in . 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 )} -- 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 )} -- 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 { > 100 } ) 183 | (number ^value { <> } ) 184 | (number ^value { < 50 } ) 185 | --> 186 | (write (crlf) ) ) 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 )} -- 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 )} 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 )} deletes working memory elements with time tags in 251 | @End[Itemize] 252 | 253 | @Center[@b[The EXCISE Command]] 254 | 255 | @t{(excise )} -- prevents rules from firing (still in network), 256 | reload to recall, but won't be current on wm. 257 | 258 | 259 | 260 | -------------------------------------------------------------------------------- /doc/lang.ps: -------------------------------------------------------------------------------- 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 |problem is in starting system|\051)SH 163 | 9600 46880 MT 164 | (\050make fact ^name ^value yes\051)SH 165 | 9600 48011 MT 166 | (\050write \050crlf\051 Concluding \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 )70 W 206 | /Helvetica SF 207 | (, ``'' 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 \051)149 W 438 | /Helvetica SF 439 | 16088 XM 440 | (-- is pattern \050in LHS condition form\051, prints all wme's that) 441 | 149 W( match . 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( . 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 \051)SH 475 | /Helvetica SF 476 | 15190 XM 477 | (-- 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 \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 { > 100 } \051)SH 512 | 13800 35736 MT 513 | (\050number ^value { <> } \051)SH 514 | 13800 36867 MT 515 | (\050number ^value { < 50 } \051)SH 516 | 13800 37998 MT 517 | (-->)SH 518 | 13800 39129 MT 519 | (\050write \050crlf\051 \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 \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 \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 \051)SH 657 | /Helvetica SF 658 | 19258 XM 659 | (deletes working memory elements with time tags in )SH 660 | /Helvetica-Bold SF 661 | 25154 31355 MT 662 | (The EXCISE Command)SH 663 | /Courier SF 664 | 8312 33922 MT 665 | (\050excise \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 676 | -------------------------------------------------------------------------------- /ops-backup.lisp: -------------------------------------------------------------------------------- 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* nil) 25 | (defvar *record* nil) 26 | (defvar *record-array* nil) 27 | (defvar *recording* nil) 28 | (defvar *max-record-index* nil) 29 | (defvar *record-index* nil) 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 | (let ((r (aref *record-array* *record-index*))) ; ((')) 43 | (when (null r) (return '|nothing more stored|)) 44 | (setf (aref *record-array* *record-index*) nil) 45 | (record-index-plus -1.) 46 | (undo-record r)))) 47 | 48 | 49 | ; *max-record-index* holds the maximum legal index for record-array 50 | ; so it and the following must be changed at the same time 51 | 52 | (defun begin-record (p data) 53 | (setq *recording* t) 54 | (setq *record* (list '=>refract p data))) 55 | 56 | (defun end-record () 57 | (when *recording* 58 | (setq *record* 59 | (cons *cycle-count* (cons *p-name* *record*))) 60 | (record-index-plus 1.) 61 | (setf (aref *record-array* *record-index*) *record*) 62 | (setq *record* nil) 63 | (setq *recording* nil))) 64 | 65 | (defun record-change (direct time elm) 66 | (when *recording* 67 | (setq *record* 68 | (cons direct (cons time (cons elm *record*)))))) 69 | 70 | ; to maintain refraction information, need keep only one piece of information: 71 | ; need to record all unsuccessful attempts to delete things from the conflict 72 | ; set. unsuccessful deletes are caused by attempting to delete refracted 73 | ; instantiations. when backing up, have to avoid putting things back into the 74 | ; conflict set if they were not deleted when running forward 75 | 76 | (defun record-refract (rule data) 77 | (when *recording* 78 | (setq *record* (cons '<=refract (cons rule (cons data *record*)))))) 79 | 80 | (defun refracted (rule data) 81 | (when *refracts* 82 | (let ((z (cons rule data))) 83 | (member z *refracts* :test #'equal))) 84 | #|(prog (z) 85 | (and (null *refracts*) (return nil)) 86 | (setq z (cons rule data)) 87 | (return (member z *refracts* :test #'equal)))|# 88 | ) 89 | 90 | 91 | (defun record-index-plus (k) 92 | (incf *record-index* k) 93 | (cond ((< *record-index* 0.) 94 | (setq *record-index* *max-record-index*)) 95 | ((> *record-index* *max-record-index*) 96 | (setq *record-index* 0.)))) 97 | 98 | ; the following routine initializes the record. putting nil in the 99 | ; first slot indicates that that the record does not go back further 100 | ; than that. (when the system backs up, it writes nil over the used 101 | ; records so that it will recognize which records it has used. thus 102 | ; the system is set up anyway never to back over a nil.) 103 | 104 | (defun initialize-record nil 105 | (setq *record-index* 0.) 106 | (setq *recording* nil) 107 | (setq *max-record-index* 31.) 108 | (setf (aref *record-array* 0.) nil)) 109 | 110 | 111 | ;; replaced per jcp 112 | ;;; Commented out 113 | #| 114 | (defun undo-record (r) 115 | (prog (save act a b rate) 116 | ;### (comment *recording* must be off during back up) 117 | (setq save *recording*) 118 | (setq *refracts* nil) 119 | (setq *recording* nil) 120 | (and *ptrace* (back-print (list '|undo:| (car r) (cadr r)))) 121 | (setq r (cddr r)) 122 | top (and (atom r) (go fin)) 123 | (setq act (car r)) 124 | (setq a (cadr r)) 125 | (setq b (caddr r)) 126 | (setq r (cdddr r)) 127 | (and *wtrace* (back-print (list '|undo:| act a))) 128 | (cond ((eq act '<=wm) (add-to-wm b a)) 129 | ((eq act '=>wm) (remove-from-wm b)) 130 | ((eq act '<=refract) 131 | (setq *refracts* (cons (cons a b) *refracts*))) 132 | ((and (eq act '=>refract) (still-present b)) 133 | (setq *refracts* (delete (cons a b) *refracts*)) 134 | (setq rate (rating-part (gethash a *topnode-table*))) 135 | (removecs a b) 136 | (insertcs a b rate)) 137 | (t (%warn '|back: cannot undo action| (list act a)))) 138 | (go top) 139 | fin (setq *recording* save) 140 | (setq *refracts* nil) 141 | (return nil))) 142 | ;;; End commented out 143 | |# 144 | 145 | 146 | (defun undo-record (r) 147 | (prog (save act a b rate) 148 | ;### (comment *recording* must be off during back up) 149 | (setq save *recording*) 150 | (setq *refracts* nil) 151 | (setq *recording* nil) 152 | (and *ptrace* (back-print (list '|undo:| (car r) (cadr r)))) 153 | (setq r (cddr r)) 154 | top (and (atom r) (go fin)) 155 | (setq act (car r)) 156 | (setq a (cadr r)) 157 | (setq b (caddr r)) 158 | (setq r (cdddr r)) 159 | (and *wtrace* (back-print (list '|undo:| act a))) 160 | (cond ((eq act '<=wm) (add-to-wm b a)) 161 | ((eq act '=>wm) (remove-from-wm b)) 162 | ((eq act '<=refract) 163 | (setq *refracts* (cons (cons a b) *refracts*))) 164 | ((and (eq act '=>refract) (still-present b)) 165 | (setq *refracts* (tree-remove (cons a b) *refracts*)) 166 | (setq rate (rating-part (gethash a *topnode-table*))) 167 | (removecs a b) 168 | (insertcs a b rate)) 169 | (t (%warn '|back: cannot undo action| (list act a)))) 170 | (go top) 171 | fin (setq *recording* save) 172 | (setq *refracts* nil) 173 | (return nil))) 174 | 175 | 176 | 177 | ; still-present makes sure that the user has not deleted something 178 | ; from wm which occurs in the instantiation about to be restored; it 179 | ; makes the check by determining whether each wme still has a time tag. 180 | 181 | (defun still-present (data) 182 | (prog nil 183 | loop 184 | (cond ((atom data) (return t)) 185 | ((creation-time (car data)) 186 | (setq data (cdr data)) 187 | (go loop)) 188 | (t (return nil))))) 189 | 190 | (defun back-print (x) 191 | (let ((stream (trace-file))) 192 | (format stream "~&~S" x))) 193 | 194 | ;;; *EOF* 195 | -------------------------------------------------------------------------------- /ops-compile.lisp: -------------------------------------------------------------------------------- 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: ( ( eq 3) 309 | ; ( ne 1) 310 | ; . . . ) 311 | ; 312 | ; *vars* is a list of triples: (name ce-number subelement-number) 313 | ; eg: ( ( 3 3) 314 | ; ( 1 1) 315 | ; . . . ) 316 | ; 317 | ; *ce-vars* is a list of pairs: (name ce-number) 318 | ; eg: ( (ce1 1) 319 | ; ( 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 '¬)) 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 '¬)) (promote-var vdope))) 389 | (go la) 390 | lb (and kind (build-beta kind tlist)) 391 | (or (eq kind '¬) (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 ¬) :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* 825 | -------------------------------------------------------------------------------- /ops-globals.lisp: -------------------------------------------------------------------------------- 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 | 62 | -------------------------------------------------------------------------------- /ops-init.lisp: -------------------------------------------------------------------------------- 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 | 58 | -------------------------------------------------------------------------------- /ops-io.lisp: -------------------------------------------------------------------------------- 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* 530 | -------------------------------------------------------------------------------- /ops-main.lisp: -------------------------------------------------------------------------------- 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* nil) 28 | (defvar *total-wm* nil) 29 | (defvar *max-token* nil) 30 | (defvar *total-token* nil) 31 | (defvar *brkpts* nil) 32 | (defvar *phase* nil) 33 | (defvar *break-flag* nil) 34 | (defvar *remaining-cycles* nil) 35 | (defvar *conflict-set* nil) 36 | (defvar *max-cs* nil) 37 | (defvar *total-cs* nil) 38 | (defvar *limit-cs* nil) 39 | (defvar *strategy* nil) 40 | (defvar *class-list* nil) 41 | (defvar *buckets* nil) 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* 706 | -------------------------------------------------------------------------------- /ops-match.lisp: -------------------------------------------------------------------------------- 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* nil) 27 | 28 | 29 | ;;; Internal global variables 30 | 31 | (defvar *alpha-data-part* nil) 32 | (defvar *alpha-flag-part* nil) 33 | (defvar *flag-part* nil) 34 | (defvar *data-part* nil) 35 | (defvar *sendtocall* nil) 36 | (defvar *side* nil) 37 | 38 | ;; Define register variables *c1* through *c127* 39 | (macrolet ((define-registers () 40 | `(progn 41 | ,@(loop for i from 1 to 127 42 | for name = (read-from-string (format nil "*c~A*" i)) 43 | collect `(defvar ,name))))) 44 | (define-registers)) 45 | 46 | 47 | 48 | ;;; Network interpreter 49 | 50 | 51 | (defun match-init () 52 | (setq *current-token* 0.)) 53 | 54 | 55 | (defun match (flag wme) 56 | (sendto flag (list wme) 'left (list *first-node*))) 57 | 58 | ; note that eval-nodelist is not set up to handle building 59 | ; productions. would have to add something like ops4's build-flag 60 | 61 | (defun eval-nodelist (nl) 62 | (dolist (node nl) 63 | (setq *sendtocall* nil) 64 | (setq *last-node* node) 65 | (apply (car node) (cdr node)))) 66 | 67 | (defun sendto (flag data side nl) 68 | (dolist (node nl) 69 | (setq *side* side) 70 | (setq *flag-part* flag) 71 | (setq *data-part* data) 72 | (setq *sendtocall* t) 73 | (setq *last-node* node) 74 | (apply (car node) (cdr node)))) 75 | 76 | ; &bus sets up the registers for the one-input nodes. note that this 77 | (defun &bus (outs) 78 | (prog (dp) 79 | (setq *alpha-flag-part* *flag-part*) 80 | (setq *alpha-data-part* *data-part*) 81 | (setq dp (car *data-part*)) 82 | (setq *c1* (pop dp)) 83 | (setq *c2* (pop dp)) 84 | (setq *c3* (pop dp)) 85 | (setq *c4* (pop dp)) 86 | (setq *c5* (pop dp)) 87 | (setq *c6* (pop dp)) 88 | (setq *c7* (pop dp)) 89 | (setq *c8* (pop dp)) 90 | (setq *c9* (pop dp)) 91 | (setq *c10* (pop dp)) 92 | (setq *c11* (pop dp)) 93 | (setq *c12* (pop dp)) 94 | (setq *c13* (pop dp)) 95 | (setq *c14* (pop dp)) 96 | (setq *c15* (pop dp)) 97 | (setq *c16* (pop dp)) 98 | (setq *c17* (pop dp)) 99 | (setq *c18* (pop dp)) 100 | (setq *c19* (pop dp)) 101 | (setq *c20* (pop dp)) 102 | (setq *c21* (pop dp)) 103 | (setq *c22* (pop dp)) 104 | (setq *c23* (pop dp)) 105 | (setq *c24* (pop dp)) 106 | (setq *c25* (pop dp)) 107 | (setq *c26* (pop dp)) 108 | (setq *c27* (pop dp)) 109 | (setq *c28* (pop dp)) 110 | (setq *c29* (pop dp)) 111 | (setq *c30* (pop dp)) 112 | (setq *c31* (pop dp)) 113 | (setq *c32* (pop dp)) 114 | (setq *c33* (pop dp)) 115 | (setq *c34* (pop dp)) 116 | (setq *c35* (pop dp)) 117 | (setq *c36* (pop dp)) 118 | (setq *c37* (pop dp)) 119 | (setq *c38* (pop dp)) 120 | (setq *c39* (pop dp)) 121 | (setq *c40* (pop dp)) 122 | (setq *c41* (pop dp)) 123 | (setq *c42* (pop dp)) 124 | (setq *c43* (pop dp)) 125 | (setq *c44* (pop dp)) 126 | (setq *c45* (pop dp)) 127 | (setq *c46* (pop dp)) 128 | (setq *c47* (pop dp)) 129 | (setq *c48* (pop dp)) 130 | (setq *c49* (pop dp)) 131 | (setq *c50* (pop dp)) 132 | (setq *c51* (pop dp)) 133 | (setq *c52* (pop dp)) 134 | (setq *c53* (pop dp)) 135 | (setq *c54* (pop dp)) 136 | (setq *c55* (pop dp)) 137 | (setq *c56* (pop dp)) 138 | (setq *c57* (pop dp)) 139 | (setq *c58* (pop dp)) 140 | (setq *c59* (pop dp)) 141 | (setq *c60* (pop dp)) 142 | (setq *c61* (pop dp)) 143 | (setq *c62* (pop dp)) 144 | (setq *c63* (pop dp)) 145 | (setq *c64* (pop dp)) 146 | ;-------- added for 127 atr 147 | (setq *c65* (pop dp)) 148 | (setq *c66* (pop dp)) 149 | (setq *c67* (pop dp)) 150 | (setq *c68* (pop dp)) 151 | (setq *c69*(pop dp)) 152 | (setq *c70* (pop dp)) 153 | (setq *c71* (pop dp)) 154 | (setq *c72* (pop dp)) 155 | (setq *c73* (pop dp)) 156 | (setq *c74* (pop dp)) 157 | (setq *c75* (pop dp)) 158 | (setq *c76* (pop dp)) 159 | (setq *c77* (pop dp)) 160 | (setq *c78* (pop dp)) 161 | (setq *c79*(pop dp)) 162 | (setq *c80* (pop dp)) 163 | (setq *c81* (pop dp)) 164 | (setq *c82* (pop dp)) 165 | (setq *c83* (pop dp)) 166 | (setq *c84* (pop dp)) 167 | (setq *c85* (pop dp)) 168 | (setq *c86* (pop dp)) 169 | (setq *c87* (pop dp)) 170 | (setq *c88* (pop dp)) 171 | (setq *c89*(pop dp)) 172 | (setq *c90* (pop dp)) 173 | (setq *c91* (pop dp)) 174 | (setq *c92* (pop dp)) 175 | (setq *c93* (pop dp)) 176 | (setq *c94* (pop dp)) 177 | (setq *c95* (pop dp)) 178 | (setq *c96* (pop dp)) 179 | (setq *c97* (pop dp)) 180 | (setq *c98* (pop dp)) 181 | (setq *c99*(pop dp)) 182 | (setq *c100* (pop dp)) 183 | (setq *c101* (pop dp)) 184 | (setq *c102* (pop dp)) 185 | (setq *c103* (pop dp)) 186 | (setq *c104* (pop dp)) 187 | (setq *c105* (pop dp)) 188 | (setq *c106* (pop dp)) 189 | (setq *c107* (pop dp)) 190 | (setq *c108* (pop dp)) 191 | (setq *c109*(pop dp)) 192 | (setq *c110* (pop dp)) 193 | (setq *c111* (pop dp)) 194 | (setq *c112* (pop dp)) 195 | (setq *c113* (pop dp)) 196 | (setq *c114* (pop dp)) 197 | (setq *c115* (pop dp)) 198 | (setq *c116* (pop dp)) 199 | (setq *c117* (pop dp)) 200 | (setq *c118* (pop dp)) 201 | (setq *c119*(pop dp)) 202 | (setq *c120* (pop dp)) 203 | (setq *c121* (pop dp)) 204 | (setq *c122* (pop dp)) 205 | (setq *c123* (pop dp)) 206 | (setq *c124* (pop dp)) 207 | (setq *c125* (pop dp)) 208 | (setq *c126* (pop dp)) 209 | (setq *c127* (pop dp)) 210 | ;(setq *c128* (car dp)) 211 | ;-------- 212 | (eval-nodelist outs))) 213 | 214 | (defun &any (outs register const-list) 215 | (prog (z c) 216 | (setq z (fast-symeval register)) 217 | (cond ((numberp z) (go number))) 218 | symbol (cond ((null const-list) (return nil)) 219 | ((eq (car const-list) z) (go ok)) 220 | (t (setq const-list (cdr const-list)) (go symbol))) 221 | number (cond ((null const-list) (return nil)) 222 | ((and (numberp (setq c (car const-list))) 223 | (=alg c z)) 224 | (go ok)) 225 | (t (setq const-list (cdr const-list)) (go number))) 226 | ok (eval-nodelist outs))) 227 | 228 | (defun teqa (outs register constant) 229 | (and (eq (fast-symeval register) constant) (eval-nodelist outs))) 230 | 231 | (defun tnea (outs register constant) 232 | (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs))) 233 | 234 | (defun txxa (outs register constant) 235 | (declare (ignore constant)) 236 | (and (symbolp (fast-symeval register)) (eval-nodelist outs))) 237 | 238 | (defun teqn (outs register constant) 239 | (let ((z (fast-symeval register))) 240 | (when (and (numberp z) 241 | (=alg z constant)) 242 | (eval-nodelist outs)))) 243 | 244 | (defun tnen (outs register constant) 245 | (let ((z (fast-symeval register))) 246 | (when (or (not (numberp z)) 247 | (not (=alg z constant))) 248 | (eval-nodelist outs)))) 249 | 250 | (defun txxn (outs register constant) 251 | (declare (ignore constant)) 252 | (let ((z (fast-symeval register))) 253 | (when (numberp z) 254 | (eval-nodelist outs)))) 255 | 256 | (defun tltn (outs register constant) 257 | (let ((z (fast-symeval register))) 258 | (when (and (numberp z) 259 | (> constant z)) 260 | (eval-nodelist outs)))) 261 | 262 | (defun tgtn (outs register constant) 263 | (let ((z (fast-symeval register))) 264 | (when (and (numberp z) 265 | (> z constant)) 266 | (eval-nodelist outs)))) 267 | 268 | (defun tgen (outs register constant) 269 | (let ((z (fast-symeval register))) 270 | (when (and (numberp z) 271 | (not (> constant z))) 272 | (eval-nodelist outs)))) 273 | 274 | (defun tlen (outs register constant) 275 | (let ((z (fast-symeval register))) 276 | (when (and (numberp z) 277 | (not (> z constant))) 278 | (eval-nodelist outs)))) 279 | 280 | (defun teqs (outs vara varb) 281 | (let* ((a (fast-symeval vara)) 282 | (b (fast-symeval varb))) 283 | (cond ((eq a b) 284 | (eval-nodelist outs)) 285 | ((and (numberp a) 286 | (numberp b) 287 | (=alg a b)) 288 | (eval-nodelist outs))))) 289 | 290 | (defun tnes (outs vara varb) 291 | (let* ((a (fast-symeval vara)) 292 | (b (fast-symeval varb))) 293 | (cond ((eq a b) 294 | nil) 295 | ((and (numberp a) 296 | (numberp b) 297 | (=alg a b)) 298 | nil) 299 | (t (eval-nodelist outs))))) 300 | 301 | (defun txxs (outs vara varb) 302 | (let* ((a (fast-symeval vara)) 303 | (b (fast-symeval varb))) 304 | (cond ((and (numberp a) (numberp b)) (eval-nodelist outs)) 305 | ((and (not (numberp a)) (not (numberp b))) 306 | (eval-nodelist outs))))) 307 | 308 | (defun tlts (outs vara varb) 309 | (let* ((a (fast-symeval vara)) 310 | (b (fast-symeval varb))) 311 | (when (and (numberp a) 312 | (numberp b) 313 | (> b a)) 314 | (eval-nodelist outs)))) 315 | 316 | (defun tgts (outs vara varb) 317 | (let* ((a (fast-symeval vara)) 318 | (b (fast-symeval varb))) 319 | (when (and (numberp a) 320 | (numberp b) 321 | (> a b)) 322 | (eval-nodelist outs)))) 323 | 324 | (defun tges (outs vara varb) 325 | (let* ((a (fast-symeval vara)) 326 | (b (fast-symeval varb))) 327 | (when (and (numberp a) 328 | (numberp b) 329 | (not (> b a))) 330 | (eval-nodelist outs)))) 331 | 332 | (defun tles (outs vara varb) 333 | (let* ((a (fast-symeval vara)) 334 | (b (fast-symeval varb))) 335 | (when (and (numberp a) 336 | (numberp b) 337 | (not (> a b))) 338 | (eval-nodelist outs)))) 339 | 340 | (defun &two (left-outs right-outs) 341 | (prog (fp dp) 342 | (cond (*sendtocall* 343 | (setq fp *flag-part*) 344 | (setq dp *data-part*)) 345 | (t 346 | (setq fp *alpha-flag-part*) 347 | (setq dp *alpha-data-part*))) 348 | (sendto fp dp 'left left-outs) 349 | (sendto fp dp 'right right-outs))) 350 | 351 | (defun &mem (left-outs right-outs memory-list) 352 | (prog (fp dp) 353 | (cond (*sendtocall* 354 | (setq fp *flag-part*) 355 | (setq dp *data-part*)) 356 | (t 357 | (setq fp *alpha-flag-part*) 358 | (setq dp *alpha-data-part*))) 359 | (sendto fp dp 'left left-outs) 360 | (add-token memory-list fp dp nil) 361 | (sendto fp dp 'right right-outs))) 362 | 363 | (defun &and (outs lpred rpred tests) 364 | (let ((mem (if (eq *side* 'right) 365 | (memory-part lpred) 366 | (memory-part rpred)))) 367 | (cond ((not mem) nil) 368 | ((eq *side* 'right) 369 | (and-right outs mem tests)) 370 | (t 371 | (and-left outs mem tests))))) 372 | 373 | (defun and-left (outs mem tests) 374 | (prog (fp dp memdp tlist tst lind rind res) 375 | (setq fp *flag-part*) 376 | (setq dp *data-part*) 377 | fail (and (null mem) (return nil)) 378 | (setq memdp (car mem)) 379 | (setq mem (cdr mem)) 380 | (setq tlist tests) 381 | tloop (and (null tlist) (go succ)) 382 | (setq tst (car tlist)) 383 | (setq tlist (cdr tlist)) 384 | (setq lind (car tlist)) 385 | (setq tlist (cdr tlist)) 386 | (setq rind (car tlist)) 387 | (setq tlist (cdr tlist)) 388 | ;### (comment the next line differs in and-left & -right) 389 | (setq res (funcall tst (gelm memdp rind) (gelm dp lind))) 390 | (cond (res (go tloop)) 391 | (t (go fail))) 392 | succ 393 | ;### (comment the next line differs in and-left & -right) 394 | (sendto fp (cons (car memdp) dp) 'left outs) 395 | (go fail))) 396 | 397 | (defun and-right (outs mem tests) 398 | (prog (fp dp memdp tlist tst lind rind res) 399 | (setq fp *flag-part*) 400 | (setq dp *data-part*) 401 | fail (and (null mem) (return nil)) 402 | (setq memdp (car mem)) 403 | (setq mem (cdr mem)) 404 | (setq tlist tests) 405 | tloop (and (null tlist) (go succ)) 406 | (setq tst (car tlist)) 407 | (setq tlist (cdr tlist)) 408 | (setq lind (car tlist)) 409 | (setq tlist (cdr tlist)) 410 | (setq rind (car tlist)) 411 | (setq tlist (cdr tlist)) 412 | ;### (comment the next line differs in and-left & -right) 413 | (setq res (funcall tst (gelm dp rind) (gelm memdp lind))) 414 | (cond (res (go tloop)) 415 | (t (go fail))) 416 | succ 417 | ;### (comment the next line differs in and-left & -right) 418 | (sendto fp (cons (car dp) memdp) 'right outs) 419 | (go fail))) 420 | 421 | 422 | (defun teqb (new eqvar) 423 | (cond ((eq new eqvar) t) 424 | ((not (numberp new)) nil) 425 | ((not (numberp eqvar)) nil) 426 | ((=alg new eqvar) t) 427 | (t nil))) 428 | 429 | (defun tneb (new eqvar) 430 | (cond ((eq new eqvar) nil) 431 | ((not (numberp new)) t) 432 | ((not (numberp eqvar)) t) 433 | ((=alg new eqvar) nil) 434 | (t t))) 435 | 436 | (defun tltb (new eqvar) 437 | (cond ((not (numberp new)) nil) 438 | ((not (numberp eqvar)) nil) 439 | ((> eqvar new) t) 440 | (t nil))) 441 | 442 | (defun tgtb (new eqvar) 443 | (cond ((not (numberp new)) nil) 444 | ((not (numberp eqvar)) nil) 445 | ((> new eqvar) t) 446 | (t nil))) 447 | 448 | (defun tgeb (new eqvar) 449 | (cond ((not (numberp new)) nil) 450 | ((not (numberp eqvar)) nil) 451 | ((not (> eqvar new)) t) 452 | (t nil))) 453 | 454 | (defun tleb (new eqvar) 455 | (cond ((not (numberp new)) nil) 456 | ((not (numberp eqvar)) nil) 457 | ((not (> new eqvar)) t) 458 | (t nil))) 459 | 460 | (defun txxb (new eqvar) 461 | (cond ((numberp new) 462 | (cond ((numberp eqvar) t) 463 | (t nil))) 464 | ((numberp eqvar) nil) 465 | (t t))) 466 | 467 | (defun &p (rating name var-dope ce-var-dope rhs) 468 | (declare (ignore var-dope ce-var-dope rhs)) 469 | (prog (fp dp) 470 | (cond (*sendtocall* 471 | (setq fp *flag-part*) 472 | (setq dp *data-part*)) 473 | (t 474 | (setq fp *alpha-flag-part*) 475 | (setq dp *alpha-data-part*))) 476 | (and (member fp '(nil old)) (removecs name dp)) 477 | (and fp (insertcs name dp rating)))) 478 | 479 | (defun &old (a b c d e) 480 | (declare (ignore a b c d e)) 481 | nil) 482 | 483 | (defun ¬ (outs lmem rpred tests) 484 | (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil) 485 | ((eq *side* 'right) (not-right outs (car lmem) tests)) 486 | (t (not-left outs (memory-part rpred) tests lmem)))) 487 | 488 | (defun not-left (outs mem tests own-mem) 489 | (prog (fp dp memdp tlist tst lind rind res c) 490 | (setq fp *flag-part*) 491 | (setq dp *data-part*) 492 | (setq c 0.) 493 | fail (and (null mem) (go fin)) 494 | (setq memdp (car mem)) 495 | (setq mem (cdr mem)) 496 | (setq tlist tests) 497 | tloop (and (null tlist) (setq c (1+ c)) (go fail)) 498 | (setq tst (car tlist)) 499 | (setq tlist (cdr tlist)) 500 | (setq lind (car tlist)) 501 | (setq tlist (cdr tlist)) 502 | (setq rind (car tlist)) 503 | (setq tlist (cdr tlist)) 504 | ;### (comment the next line differs in not-left & -right) 505 | (setq res (funcall tst (gelm memdp rind) (gelm dp lind))) 506 | (cond (res (go tloop)) 507 | (t (go fail))) 508 | fin (add-token own-mem fp dp c) 509 | (and (== c 0.) (sendto fp dp 'left outs)))) 510 | 511 | (defun not-right (outs mem tests) 512 | (prog (fp dp memdp tlist tst lind rind res newfp inc newc) 513 | (setq fp *flag-part*) 514 | (setq dp *data-part*) 515 | (cond ((not fp) (setq inc -1.) (setq newfp 'new)) 516 | ((eq fp 'new) (setq inc 1.) (setq newfp nil)) 517 | (t (return nil))) 518 | fail (and (null mem) (return nil)) 519 | (setq memdp (car mem)) 520 | (setq newc (cadr mem)) 521 | (setq tlist tests) 522 | tloop (and (null tlist) (go succ)) 523 | (setq tst (car tlist)) 524 | (setq tlist (cdr tlist)) 525 | (setq lind (car tlist)) 526 | (setq tlist (cdr tlist)) 527 | (setq rind (car tlist)) 528 | (setq tlist (cdr tlist)) 529 | ;### (comment the next line differs in not-left & -right) 530 | (setq res (funcall tst (gelm dp rind) (gelm memdp lind))) 531 | (cond (res (go tloop)) 532 | (t (setq mem (cddr mem)) (go fail))) 533 | succ (setq newc (+ inc newc)) ;"plus" changed to "+" by gdw 534 | (rplaca (cdr mem) newc) 535 | (cond ((or (and (== inc -1.) (== newc 0.)) 536 | (and (== inc 1.) (== newc 1.))) 537 | (sendto newfp memdp 'right outs))) 538 | (setq mem (cddr mem)) 539 | (go fail))) 540 | 541 | ;;; Node memories 542 | 543 | 544 | (defun add-token (memlis flag data-part num) 545 | (let (was-present) 546 | (cond ((eq flag 'new) 547 | (setq was-present nil) 548 | (real-add-token memlis data-part num)) 549 | ((not flag) 550 | (setq was-present (remove-old memlis data-part num))) 551 | ((eq flag 'old) (setq was-present t))) 552 | was-present)) 553 | 554 | (defun real-add-token (lis data-part num) 555 | (incf *current-token*) 556 | (when num 557 | (push num (car lis))) 558 | (push data-part (car lis))) 559 | 560 | (defun remove-old (lis data num) 561 | (if num 562 | (remove-old-num lis data) 563 | (remove-old-no-num lis data))) 564 | 565 | (defun remove-old-num (lis data) 566 | (prog (m next last) 567 | (setq m (car lis)) 568 | (cond ((atom m) (return nil)) 569 | ((top-levels-eq data (car m)) 570 | (setq *current-token* (1- *current-token*)) 571 | (rplaca lis (cddr m)) 572 | (return (car m)))) 573 | (setq next m) 574 | loop (setq last next) 575 | (setq next (cddr next)) 576 | (cond ((atom next) (return nil)) 577 | ((top-levels-eq data (car next)) 578 | (rplacd (cdr last) (cddr next)) 579 | (setq *current-token* (1- *current-token*)) 580 | (return (car next))) 581 | (t (go loop))))) 582 | 583 | (defun remove-old-no-num (lis data) 584 | (prog (m next last) 585 | (setq m (car lis)) 586 | (cond ((atom m) (return nil)) 587 | ((top-levels-eq data (car m)) 588 | (setq *current-token* (1- *current-token*)) 589 | (rplaca lis (cdr m)) 590 | (return (car m)))) 591 | (setq next m) 592 | loop (setq last next) 593 | (setq next (cdr next)) 594 | (cond ((atom next) (return nil)) 595 | ((top-levels-eq data (car next)) 596 | (rplacd last (cdr next)) 597 | (setq *current-token* (1- *current-token*)) 598 | (return (car next))) 599 | (t (go loop))))) 600 | 601 | ;;; *EOF* 602 | -------------------------------------------------------------------------------- /ops-rhs.lisp: -------------------------------------------------------------------------------- 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* nil) 28 | (defvar *in-rhs* nil) 29 | (defvar *current-wm* nil) 30 | (defvar *max-wm* nil) 31 | (defvar *action-count* nil) 32 | (defvar *critical* nil) 33 | 34 | 35 | ;;; Internal global variables 36 | 37 | (defvar *wmpart-list* nil) 38 | (defvar *wm-filter* nil) 39 | (defvar *wm* nil) 40 | (defvar *old-wm* nil) 41 | (defvar *result-array* nil) 42 | (defvar *variable-memory* nil) 43 | (defvar *last* nil) 44 | (defvar *max-index* nil) 45 | (defvar *next-index* nil) 46 | (defvar *data-matched* nil) 47 | (defvar *ce-variable-memory* nil) 48 | (defvar *rest* nil) 49 | (defvar *build-trace* nil) 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) ') 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* 647 | -------------------------------------------------------------------------------- /ops-util.lisp: -------------------------------------------------------------------------------- 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* 161 | -------------------------------------------------------------------------------- /ops.lisp: -------------------------------------------------------------------------------- 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 | (in-package "OPS") 26 | 27 | ;;; ******************************** 28 | ;;; REP Loop *********************** 29 | ;;; ******************************** 30 | 31 | (defun ops () 32 | "OPS Read-Eval-Print Loop." 33 | (let ((counter 0)) 34 | (loop 35 | (incf counter) 36 | (format t "~&~D. " counter) 37 | (let* ((input (string-trim '(#\space #\tab) (read-line))) 38 | (space-pos (position #\space input)) 39 | (tag (subseq input 0 space-pos))) 40 | (cond ((or (string-equal tag "exit") 41 | (string-equal tag "quit")) 42 | (return)) 43 | ((string-equal tag "load") 44 | (load (subseq input (1+ space-pos)))) 45 | (t 46 | (let ((form (read-from-string (concatenate 'string 47 | "(" input ")")))) 48 | (print (eval form))))))))) 49 | 50 | ;;; *EOF* 51 | 52 | -------------------------------------------------------------------------------- /ops5.asd: -------------------------------------------------------------------------------- 1 | ;;;; ops.asd 2 | 3 | (asdf:defsystem #:ops5 4 | :license "Public Domain" 5 | :description "The Ops5 programming language for production systems" 6 | :author "Zach Beane " 7 | :serial t 8 | :components ((:file "package") 9 | (:file "ops-globals") 10 | (:file "ops-util") 11 | (:file "ops-compile") 12 | (:file "ops-rhs") 13 | (:file "ops-match") 14 | (:file "ops-main") 15 | (:file "ops-backup") 16 | (:file "ops-init") 17 | (:file "ops-io") 18 | (:file "ops"))) 19 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage #:ops 4 | (:use #:cl) 5 | (:shadow #:remove 6 | #:write) 7 | (:export #:remove 8 | #:write 9 | #:make 10 | #:modify 11 | #:crlf 12 | #:--> 13 | #:literalize 14 | #:p 15 | #:vector-attribute 16 | #:strategy 17 | #:match 18 | #:reset-ops 19 | #:ops)) 20 | 21 | --------------------------------------------------------------------------------