├── LICENSE ├── README.md ├── attic └── clean-or-attempt.tgz ├── bin └── sbcl-config.sh ├── contrib ├── cdmojoli.lisp └── heater.lisp ├── docs └── ExampleRulebases.md ├── examples ├── auto-notify.lisp ├── cf.lisp ├── contexts.lisp ├── core.lisp ├── logical.lisp ├── mab-clos.lisp ├── mab-kw.lisp ├── mab.clp ├── mab.lisp ├── metaclass.lisp ├── mycin.lisp ├── rpc-client.lisp ├── rpc-server.lisp ├── rpc.lisp ├── sbcl-notify.lisp ├── semi-mab.lisp └── test-ce.lisp ├── images ├── hierarchy-background.gif └── powmia.png ├── lisa.asd ├── perf └── stack-perf.lisp ├── ql.lisp ├── sbcl ├── compiler.txt └── sbcl-core.lisp ├── src ├── belief-systems │ ├── belief.lisp │ ├── certainty-factors.lisp │ └── null-belief-system.lisp ├── config │ ├── config.lisp │ └── epilogue.lisp ├── core │ ├── activation.lisp │ ├── belief-interface.lisp │ ├── binding.lisp │ ├── conditions.lisp │ ├── conflict-resolution-strategies.lisp │ ├── context.lisp │ ├── deffacts.lisp │ ├── environment.lisp │ ├── epilogue.lisp │ ├── fact-parser.lisp │ ├── fact.lisp │ ├── heap.lisp │ ├── language.lisp │ ├── meta.lisp │ ├── pattern.lisp │ ├── preamble.lisp │ ├── rete.lisp │ ├── retrieve.lisp │ ├── rule-parser.lisp │ ├── rule.lisp │ ├── strategies.lisp │ ├── tms-support.lisp │ ├── token.lisp │ └── watches.lisp ├── debugger │ └── lisa-debugger.lisp ├── grouping-stack │ ├── LICENSE │ ├── balancer.lisp │ ├── grouping-stack.asd │ ├── item.lisp │ ├── package.lisp │ └── stack.lisp ├── implementations │ ├── aclrpc-support.lisp │ ├── allegro-auto-notify.lisp │ ├── cmucl-auto-notify.lisp │ ├── lispworks-auto-notify.lisp │ ├── sbcl-auto-notify.lisp │ └── workarounds.lisp ├── logger │ └── logger.lisp ├── packages │ └── pkgdecl.lisp ├── reflect │ └── reflect.lisp ├── rete │ └── reference │ │ ├── join-node.lisp │ │ ├── network-crawler.lisp │ │ ├── network-ops.lisp │ │ ├── node-pair.lisp │ │ ├── node-tests.lisp │ │ ├── node1.lisp │ │ ├── node2-exists.lisp │ │ ├── node2-not.lisp │ │ ├── node2-test.lisp │ │ ├── node2.lisp │ │ ├── or-node2.lisp │ │ ├── rete-compiler.lisp │ │ ├── shared-node.lisp │ │ ├── successor.lisp │ │ ├── terminal-node.lisp │ │ └── tms.lisp └── utils │ ├── compose.lisp │ └── utils.lisp └── version.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2000 David Young 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /attic/clean-or-attempt.tgz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/youngde811/Lisa/b0a62f06d19ee3cf476a784c8ebbfad1e287aee2/attic/clean-or-attempt.tgz -------------------------------------------------------------------------------- /bin/sbcl-config.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # MIT License 4 | 5 | # Copyright (c) 2000 David Young 6 | 7 | # Permission is hereby granted, free of charge, to any person obtaining a copy 8 | # of this software and associated documentation files (the "Software"), to deal 9 | # in the Software without restriction, including without limitation the rights 10 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | # copies of the Software, and to permit persons to whom the Software is 12 | # furnished to do so, subject to the following conditions: 13 | 14 | # The above copyright notice and this permission notice shall be included in all 15 | # copies or substantial portions of the Software. 16 | 17 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | # SOFTWARE. 24 | 25 | # This script can be used to install and configure Quicklisp for your SBCL environment. 26 | # All Quicklisp installation defaults are taken, so if you want a different installation 27 | # experience, please do all of this manually. 28 | 29 | # Quicklisp: https://www.quicklisp.org/beta/ 30 | 31 | progname="$(basename $0)" 32 | 33 | set -e -o pipefail 34 | 35 | workdir= 36 | 37 | usage() { 38 | cat < 19 | (modify ?counter (count 1))) 20 | 21 | (format t "my-counter is at ~S~%" (counter-count *my-counter*)) 22 | (run) 23 | (format t "my-counter is at ~S~%" (counter-count *my-counter*)) 24 | -------------------------------------------------------------------------------- /contrib/heater.lisp: -------------------------------------------------------------------------------- 1 | 2 | ;;; This sample code was contributed by Gaston Pepe to isolate a bug he found with Lisa's 3 | ;;; TEST conditional element. The TEST CE must have been broken at least ten years ago via 4 | ;;; an unapproved commit, while Lisa was still hosted on SourceForge. 5 | 6 | (eval-when (:compile-toplevel :load-toplevel :execute) 7 | (when (not (find-package "LISA-HEATER")) 8 | (defpackage "LISA-HEATER" 9 | (:use "LISA-LISP") 10 | (:export "HEATER-SIMULATION")))) 11 | 12 | (in-package "LISA-HEATER") 13 | 14 | (make-inference-engine) 15 | 16 | (deftemplate ambient-temperature () 17 | (slot current-temperature) 18 | (slot desired-temperature) 19 | (slot location)) 20 | 21 | (deftemplate heater-state () 22 | (slot state)) 23 | 24 | ;; Rules 25 | 26 | (defrule turn-on-heater () 27 | (ambient-temperature (current-temperature ?ct) 28 | (desired-temperature ?dt) 29 | (location ?loc)) 30 | (test (equal ?loc "room")) 31 | => 32 | (assert (heater-state (state on))) 33 | (print "Turning on the heater")) 34 | 35 | (defrule turn-off-heater () 36 | (ambient-temperature (current-temperature ?ct) 37 | (desired-temperature ?dt) 38 | (location ?loc)) 39 | (test (equal ?loc "room")) 40 | => 41 | (assert (heater-state (state off))) 42 | (print "Turning off the heater")) 43 | 44 | ;; Simulation 45 | 46 | (defun heater-simulation () 47 | ;; Initialize the system state 48 | (reset) 49 | (assert (ambient-temperature (current-temperature 20) 50 | (desired-temperature 22) 51 | (location "room"))) 52 | (loop 53 | do 54 | ;; Execute the inference engine 55 | (run) 56 | 57 | ;; Add a new ambient-temperature fact 58 | (assert (ambient-temperature (current-temperature (+ 10 (random 20))) 59 | (desired-temperature 22) 60 | (location "room"))) 61 | 62 | ;; Pause for 10 seconds 63 | (sleep 10))) 64 | -------------------------------------------------------------------------------- /docs/ExampleRulebases.md: -------------------------------------------------------------------------------- 1 | ## The Monkey and Banana (MAB) Problem ## 2 | 3 | The Monkey and Banana[^1] problem is a classic artificial intelligence planning/logic problem that has been solved using 4 | various expert system shells and logic programming languages. Lisa's implementation is a direct translation of the 5 | source implementation written for CLIPS[^2]; it may be found in [_examples/mab.lisp_](../examples/mab.lisp) and 6 | [_examples/mab-clos.lisp_](../examples/mab-clos.lisp). 7 | 8 | ### Sample MAB Code ### 9 | 10 | ```lisp 11 | (defrule hold-chest-to-put-on-floor () 12 | (goal-is-to (action unlock) (argument-1 ?chest)) 13 | (thing (name ?chest) (on-top-of (not floor)) (weight light)) 14 | (monkey (holding (not ?chest))) 15 | (not (goal-is-to (action hold) (argument-1 ?chest))) 16 | => 17 | (assert (goal-is-to (action hold) (argument-1 ?chest) 18 | (argument-2 empty)))) 19 | 20 | (defrule put-chest-on-floor () 21 | (goal-is-to (action unlock) (argument-1 ?chest)) 22 | (?monkey (monkey (location ?place) (on-top-of ?on) (holding ?chest))) 23 | (?thing (thing (name ?chest))) 24 | => 25 | (format t "Monkey throws the ~A off the ~A onto the floor.~%" ?chest ?on) 26 | (modify ?monkey (holding blank)) 27 | (modify ?thing (location ?place) (on-top-of floor))) 28 | 29 | (defrule get-key-to-unlock () 30 | (goal-is-to (action unlock) (argument-1 ?obj)) 31 | (thing (name ?obj) (on-top-of floor)) 32 | (chest (name ?obj) (unlocked-by ?key)) 33 | (monkey (holding (not ?key))) 34 | (not (goal-is-to (action hold) (argument-1 ?key))) 35 | => 36 | (assert (goal-is-to (action hold) (argument-1 ?key) 37 | (argument-2 empty)))) 38 | 39 | ... 40 | 41 | (defrule climb-directly () 42 | (?goal (goal-is-to (action on) (argument-1 ?obj))) 43 | (thing (name ?obj) (location ?place) (on-top-of ?on)) 44 | (?monkey (monkey (location ?place) (on-top-of ?on) (holding blank))) 45 | => 46 | (format t "Monkey climbs onto the ~A.~%" ?obj) 47 | (modify ?monkey (on-top-of ?obj)) 48 | (retract ?goal)) 49 | 50 | (defrule already-on-object () 51 | (?goal (goal-is-to (action on) (argument-1 ?obj))) 52 | (monkey (on-top-of ?obj)) 53 | => 54 | (retract ?goal)) 55 | 56 | ;;; Eat-object rules... 57 | 58 | (defrule hold-to-eat () 59 | (goal-is-to (action eat) (argument-1 ?obj)) 60 | (monkey (holding (not ?obj))) 61 | (not (goal-is-to (action hold) (argument-1 ?obj))) 62 | => 63 | (assert (goal-is-to (action hold) (argument-1 ?obj) 64 | (argument-2 empty)))) 65 | 66 | (defrule satisfy-hunger () 67 | (?goal (goal-is-to (action eat) (argument-1 ?name))) 68 | (?monkey (monkey (holding ?name))) 69 | (?thing (thing (name ?name))) 70 | => 71 | (format t "Monkey eats the ~A.~%" ?name) 72 | (modify ?monkey (holding blank)) 73 | (retract ?goal) 74 | (retract ?thing)) 75 | ``` 76 | 77 | ### Sample MAB Run ### 78 | 79 | ```lisp 80 | CL-USER> (load "examples/mab.lisp") 81 | T 82 | CL-USER> (in-package :lisa-mab) 83 | LISA-MAB> # 84 | LISA-MAB> (run-mab) 85 | [15:00:26] lisa-mab mab.lisp (run-mab repeat-mab) - Starting run... 86 | Monkey jumps off the GREEN-COUCH onto the floor. 87 | Monkey walks to T2-2. 88 | Monkey climbs onto the RED-COUCH. 89 | Monkey climbs onto the BIG-PILLOW. 90 | Monkey grabs the RED-CHEST. 91 | Monkey throws the RED-CHEST off the BIG-PILLOW onto the floor. 92 | Monkey jumps off the BIG-PILLOW onto the floor. 93 | Monkey walks to T1-3. 94 | Monkey grabs the RED-KEY. 95 | 96 | ... 97 | 98 | Monkey walks to T7-7 holding the BLUE-KEY. 99 | Monkey opens the BLUE-CHEST with the BLUE-KEY revealing the BANANAS. 100 | Monkey drops the BLUE-KEY. 101 | Monkey climbs onto the BLUE-CHEST. 102 | Monkey grabs the BANANAS. 103 | Monkey eats the BANANAS. 104 | Evaluation took: 105 | 0.028 seconds of real time 106 | 0.028730 seconds of total run time (0.027518 user, 0.001212 system) 107 | 103.57% CPU 108 | 241 lambdas converted 109 | 13,727,952 bytes consed 110 | 111 | NIL 112 | ``` 113 | 114 | ## MYCIN ## 115 | 116 | Another interesting problem is MYCIN, an early backward chaining expert system that used artificial intelligence to 117 | identify bacteria causing severe infections, such as bacteremia and meningitis, and to recommend antibiotics, with the 118 | dosage adjusted for patient's body weight. Lisa uses a forward-chaining version borrowed from Peter Norvig's excellent 119 | book on artificial intelligence[^3]. The run output is brief, but the rulebase in 120 | [_examples/mycin.lisp_](../examples/mycin.lisp) is an interesting study, as it illustrates Lisa's implementation of 121 | Certainty Factors. 122 | 123 | ### Sample MYCIN Code ### 124 | 125 | ```lisp 126 | (defrule rule-52 (:belief 0.4) 127 | (culture-site (value blood)) 128 | (gram (value neg) (entity ?organism)) 129 | (morphology (value rod)) 130 | (burn (value serious)) 131 | => 132 | (assert (organism-identity (value pseudomonas) (entity ?organism)))) 133 | 134 | (defrule rule-71 (:belief 0.7) 135 | (gram (value pos) (entity ?organism)) 136 | (morphology (value coccus)) 137 | (growth-conformation (value clumps)) 138 | => 139 | (assert (organism-identity (value staphylococcus) (entity ?organism)))) 140 | 141 | (defrule rule-73 (:belief 0.9) 142 | (culture-site (value blood)) 143 | (gram (value neg) (entity ?organism)) 144 | (morphology (value rod)) 145 | (aerobicity (value anaerobic)) 146 | => 147 | (assert (organism-identity (value bacteroides) (entity ?organism)))) 148 | 149 | ... 150 | ``` 151 | 152 | ### Sample MYCIN Run ### 153 | 154 | ```lisp 155 | CL-USER> (load "examples/mycin") 156 | T 157 | CL-USER> (in-package :lisa-user) 158 | # 159 | LISA-USER> (culture-1) 160 | Identity: PSEUDOMONAS (0.760) 161 | Identity: ENTEROBACTERIACEAE (0.800) 162 | 5 163 | LISA-USER> (culture-2) 164 | Identity: PSEUDOMONAS (0.646) 165 | Identity: BACTEROIDES (0.720) 166 | 5 167 | LISA-USER> 168 | ``` 169 | 170 | [^1]: The [Monkey and Banana](https://en.wikipedia.org/wiki/Monkey_and_banana_problem) AI problem. 171 | [^2]: [CLIPS](https://www.clipsrules.net/): A tool for building expert systems. 172 | [^3]: "Paradigms of Artificial Intelligence Programming: Case Studies in Common Lisp", Peter Norvig, 1991. 173 | -------------------------------------------------------------------------------- /examples/auto-notify.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Small test code for LISA's auto-notify feature. 26 | 27 | (in-package :lisa-user) 28 | 29 | (defclass frodo () 30 | ((name :initarg :name 31 | :initform 'frodo 32 | :reader frodo-name) 33 | (has-ring :initform nil 34 | :accessor has-ring)) 35 | (:metaclass standard-kb-class)) 36 | 37 | (defrule frodo () 38 | (frodo (has-ring t)) 39 | => 40 | (format t "Frodo has the Ring!~%")) 41 | 42 | (defparameter *frodo* (make-instance 'frodo)) 43 | 44 | (reset) 45 | 46 | (assert (#?*frodo*)) 47 | -------------------------------------------------------------------------------- /examples/cf.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Test code for Lisa's certainty factor support. 26 | 27 | (in-package :lisa-user) 28 | 29 | (defclass hobbit () 30 | ((name :initarg :name 31 | :reader name))) 32 | 33 | (defclass has-ring () ()) 34 | 35 | (defclass two-clowns () ()) 36 | 37 | (defrule frodo () 38 | (hobbit (name frodo)) 39 | => 40 | (assert (has-ring) :belief 0.9)) 41 | 42 | (defrule bilbo (:belief 0.3) 43 | (hobbit (name bilbo)) 44 | => 45 | (assert (has-ring))) 46 | 47 | (defrule combine (:belief 0.6) 48 | (?a (hobbit (name merry))) 49 | (?b (hobbit (name pippin))) 50 | => 51 | (assert (two-clowns))) 52 | 53 | (defrule combine-2 (:belief 0.9) 54 | (?a (hobbit (name sam))) 55 | (?b (hobbit (name bilbo))) 56 | => 57 | (assert (two-clowns))) 58 | 59 | (defun combine () 60 | (assert (hobbit (name merry)) :belief 0.8) 61 | (assert (hobbit (name pippin)) :belief 0.2) 62 | (run)) 63 | -------------------------------------------------------------------------------- /examples/contexts.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa-user) 26 | 27 | (defcontext :hobbits) 28 | (defcontext :wizards) 29 | (defcontext :elves) 30 | (defcontext :dwarves) 31 | 32 | (deftemplate frodo () 33 | (slot name)) 34 | 35 | (deftemplate gandalf () 36 | (slot name)) 37 | 38 | (deftemplate legolas () 39 | (slot name)) 40 | 41 | (deftemplate gimli () 42 | (slot name)) 43 | 44 | (defrule frodo (:context :hobbits) 45 | (frodo) 46 | => 47 | (format t "frodo fired; focusing on :wizards.~%") 48 | (assert (gandalf (name gandalf))) 49 | (focus :wizards)) 50 | 51 | (defrule gandalf (:context :wizards) 52 | (gandalf (name gandalf)) 53 | => 54 | (format t "gandalf fired; gimli should fire now.~%") 55 | (assert (legolas)) 56 | (assert (gimli))) 57 | 58 | (defrule legolas (:context :elves) 59 | (legolas) 60 | => 61 | (format t "legolas firing; hopefully this was a manual focus.~%")) 62 | 63 | (defrule gimli (:context :dwarves :auto-focus t :salience 100) 64 | (gimli) 65 | => 66 | (format t "gimli (an auto-focus rule) fired.~%") 67 | (refocus)) 68 | 69 | (defrule should-not-fire (:context :dwarves) 70 | (gimli) 71 | => 72 | (error "This rule should not have fired!")) 73 | 74 | (defrule start (:salience 100) 75 | => 76 | (format t "starting...~%") 77 | (focus :hobbits)) 78 | 79 | (defrule finish () 80 | (?gimli (gimli)) 81 | => 82 | (retract ?gimli) 83 | (format t "finished.~%")) 84 | 85 | (reset) 86 | (assert (frodo)) 87 | (run) 88 | -------------------------------------------------------------------------------- /examples/core.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa-user) 26 | 27 | (clear) 28 | 29 | (deftemplate frodo () 30 | (slot name) 31 | (slot has-ring) 32 | (slot age)) 33 | 34 | (deftemplate bilbo () 35 | (slot name) 36 | (slot relative) 37 | (slot age)) 38 | 39 | (deftemplate gandalf () 40 | (slot name) 41 | (slot age)) 42 | 43 | (deftemplate saruman () 44 | (slot name)) 45 | 46 | (deftemplate samwise () 47 | (slot name) 48 | (slot friend) 49 | (slot age)) 50 | 51 | (deftemplate hobbit () 52 | (slot name)) 53 | 54 | (deftemplate pippin () 55 | (slot name)) 56 | 57 | #+ignore 58 | (defrule frodo () 59 | (frodo (name ?name frodo)) 60 | => 61 | (format t "frodo fired: ~S~%" ?name)) 62 | 63 | #+ignore 64 | (defrule not-frodo () 65 | (frodo (name ?name (not frodo))) 66 | => 67 | (format t "not-frodo fired: ~S~%" ?name)) 68 | 69 | #+ignore 70 | (defrule simple-rule () 71 | (frodo) 72 | => 73 | (format t "simple-rule fired.~%")) 74 | 75 | #+ignore 76 | (defrule special-pattern () 77 | ;;;(bilbo (name ?name) (relative ?name)) 78 | (frodo (name ?fname) (has-ring ?ring (eq ?ring ?fname))) 79 | => 80 | ) 81 | 82 | #+ignore 83 | (defrule negated-slot-rule () 84 | (frodo (name (not frodo))) 85 | => 86 | ) 87 | 88 | #+ignore 89 | (defrule shared-rule-a () 90 | (frodo (name frodo)) 91 | (gandalf (name gandalf) (age 100)) 92 | => 93 | ) 94 | 95 | #+ignore 96 | (defrule shared-rule-b () 97 | (frodo (name frodo)) 98 | (gandalf (name gandalf) (age 200)) 99 | => 100 | ) 101 | 102 | #+ignore 103 | (defrule constraints () 104 | (frodo (name ?name)) 105 | (samwise (name sam) (friend ?friend (not frodo))) 106 | => 107 | (format t "constraints: ~S ~S~%" ?name ?friend)) 108 | 109 | #+ignore 110 | (defrule variable-rule () 111 | (frodo (name ?name)) 112 | (?sam (samwise (name ?name) (friend ?name))) 113 | => 114 | (format t "variable-rule fired: ~S~%" ?sam) 115 | (modify ?sam (name samwise))) 116 | 117 | (defrule logical-1 () 118 | (logical 119 | (frodo)) 120 | => 121 | (assert (bilbo))) 122 | 123 | (defrule logical-2 () 124 | (logical 125 | (bilbo)) 126 | => 127 | (assert (samwise))) 128 | 129 | (defrule exists () 130 | (frodo (name ?name)) 131 | (exists (bilbo (name ?name))) 132 | => 133 | (format t "exists fired.~%")) 134 | 135 | #+ignore 136 | (defrule respond-to-logical-rule () 137 | (bilbo) 138 | => 139 | (format t "Uh oh...~%")) 140 | 141 | #+ignore 142 | (defrule or-rule () 143 | (frodo) 144 | (or (gandalf) 145 | (samwise)) 146 | => 147 | (format t "or-rule~%")) 148 | 149 | #+ignore 150 | (defrule or-rule () 151 | (or (samwise (name sam)) 152 | (gandalf (name gandalf))) 153 | (frodo (name ?name)) 154 | (or (hobbit) 155 | (pippin)) 156 | (saruman) 157 | => 158 | (format t "or-rule fired.~%")) 159 | 160 | #+ignore 161 | (defrule samwise () 162 | (samwise (name samwise)) 163 | => 164 | (format t "Rule samwise fired.~%")) 165 | 166 | #+ignore 167 | (defrule test-rule () 168 | (frodo (name ?name)) 169 | (samwise (friend ?name) (age ?age)) 170 | (test (eq ?age 100)) 171 | => 172 | ) 173 | 174 | #+ignore 175 | (defrule negated-variable () 176 | (frodo (name ?name)) 177 | (samwise (friend (not ?name))) 178 | => 179 | ) 180 | 181 | #+ignore 182 | (defrule simple () 183 | (?f (gandalf (age 100))) 184 | => 185 | (let ((?age 1000)) 186 | (modify ?f (age ?age) (name (intern (make-symbol "gandalf")))))) 187 | 188 | #+ignore 189 | (defrule embedded-rule () 190 | (gandalf (name gandalf) (age ?age)) 191 | => 192 | (defrule new-gandalf () 193 | (gandalf (name new-gandalf) (age ?age)) 194 | => 195 | (format t "new-gandalf fired.~%"))) 196 | 197 | #| 198 | (defparameter *frodo* (assert (frodo (name frodo)))) 199 | (defparameter *bilbo* (assert (bilbo (name bilbo)))) 200 | (defparameter *samwise* (assert (samwise (friend frodo) (age 100)))) 201 | (defparameter *gandalf* (assert (gandalf (name gandalf) (age 200)))) 202 | |# 203 | 204 | (reset) 205 | -------------------------------------------------------------------------------- /examples/logical.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa-user) 26 | 27 | (clear) 28 | 29 | (deftemplate frodo () 30 | (slot name) 31 | (slot has-ring) 32 | (slot age)) 33 | 34 | (deftemplate bilbo () 35 | (slot name) 36 | (slot relative) 37 | (slot age)) 38 | 39 | (deftemplate gandalf () 40 | (slot name) 41 | (slot age)) 42 | 43 | (deftemplate saruman () 44 | (slot name)) 45 | 46 | (deftemplate samwise () 47 | (slot name) 48 | (slot friend) 49 | (slot age)) 50 | 51 | (deftemplate hobbit () 52 | (slot name)) 53 | 54 | (deftemplate pippin () 55 | (slot name)) 56 | 57 | ;;; Rules testing the LOGICAL conditional element 58 | 59 | (defrule logical-1 () 60 | (logical 61 | (frodo)) 62 | => 63 | (format t "Firing rule logical-1: asserting BILBO~%") 64 | (assert (bilbo (name "bilbo")))) 65 | 66 | (defrule logical-2 () 67 | (?frodo (frodo)) 68 | => 69 | (format t "Firing rule logical-2: retracting FRODO should retract BILBO~%") 70 | (retract ?frodo)) 71 | 72 | (defun run-logical () 73 | (reset) 74 | (assert (frodo (name "frodo") (has-ring t) (age 55))) 75 | (run)) 76 | 77 | -------------------------------------------------------------------------------- /examples/metaclass.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package "CL-USER") 26 | 27 | (defclass standard-kb-class (standard-class) ()) 28 | 29 | (defmethod initialize-instance :after ((self standard-kb-class) &rest initargs) 30 | (dolist (slot (slot-value self 'clos::direct-slots)) 31 | (dolist (writer (clos:slot-definition-writers slot)) 32 | (let* ((gf (ensure-generic-function writer)) 33 | (method-class 34 | (generic-function-method-class gf))) 35 | (multiple-value-bind (body initargs) 36 | (clos:make-method-lambda 37 | gf 38 | (class-prototype method-class) 39 | '(new-value object) 40 | nil 41 | `(format t "setting slot ~S to ~S~%" ',(clos:slot-definition-name slot) new-value)) 42 | (clos:add-method 43 | gf 44 | (apply #'make-instance method-class 45 | :function (compile nil body) 46 | :specializers 47 | `(,(find-class t) ,self) 48 | :qualifiers '(:after) 49 | :lambda-list '(value object) 50 | initargs))))))) 51 | 52 | (defmethod validate-superclass ((class standard-kb-class) 53 | (superclass standard-class)) 54 | t) 55 | 56 | (defclass frodo () 57 | ((name :initarg :name 58 | :initform nil 59 | :accessor frodo-name) 60 | (age :initarg :age 61 | :initform 100 62 | :accessor frodo-age)) 63 | (:metaclass standard-kb-class)) 64 | 65 | (defparameter *frodo* (make-instance 'frodo :name 'frodo)) 66 | -------------------------------------------------------------------------------- /examples/mycin.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: An implementation of MYCIN as illustrated in PAIP, pg. 553. The example 26 | ;; is used to illustrate (and test) Lisa's new support for certainty factors. I didn't do 27 | ;; a faithful port of the PAIP version; in particular, there's no interaction with the 28 | ;; operator right now. However, all rules are present and the two scenarios on pgs. 555 and 29 | ;; 556 are represented (by the functions CULTURE-1 and CULTURE-2). 30 | 31 | (in-package :lisa-user) 32 | 33 | (clear) 34 | 35 | (setf lisa::*allow-duplicate-facts* nil) 36 | 37 | (defclass param-mixin () 38 | ((value :initarg :value 39 | :initform nil 40 | :reader value) 41 | (entity :initarg :entity 42 | :initform nil 43 | :reader entity))) 44 | 45 | (defclass culture () ()) 46 | 47 | (defclass culture-site (param-mixin) ()) 48 | 49 | (defclass culture-age (param-mixin) ()) 50 | 51 | (defclass patient () 52 | ((name :initarg :name 53 | :initform nil 54 | :reader name) 55 | (sex :initarg :sex 56 | :initform nil 57 | :reader sex) 58 | (age :initarg :age 59 | :initform nil 60 | :reader age))) 61 | 62 | (defclass burn (param-mixin) ()) 63 | 64 | (defclass compromised-host (param-mixin) ()) 65 | 66 | (defclass organism () ()) 67 | 68 | (defclass gram (param-mixin) ()) 69 | 70 | (defclass morphology (param-mixin) ()) 71 | 72 | (defclass aerobicity (param-mixin) ()) 73 | 74 | (defclass growth-conformation (param-mixin) ()) 75 | 76 | (defclass organism-identity (param-mixin) ()) 77 | 78 | (defrule rule-52 (:belief 0.4) 79 | (culture-site (value blood)) 80 | (gram (value neg) (entity ?organism)) 81 | (morphology (value rod)) 82 | (burn (value serious)) 83 | => 84 | (assert (organism-identity (value pseudomonas) (entity ?organism)))) 85 | 86 | (defrule rule-71 (:belief 0.7) 87 | (gram (value pos) (entity ?organism)) 88 | (morphology (value coccus)) 89 | (growth-conformation (value clumps)) 90 | => 91 | (assert (organism-identity (value staphylococcus) (entity ?organism)))) 92 | 93 | (defrule rule-73 (:belief 0.9) 94 | (culture-site (value blood)) 95 | (gram (value neg) (entity ?organism)) 96 | (morphology (value rod)) 97 | (aerobicity (value anaerobic)) 98 | => 99 | (assert (organism-identity (value bacteroides) (entity ?organism)))) 100 | 101 | (defrule rule-75 (:belief 0.6) 102 | (gram (value neg) (entity ?organism)) 103 | (morphology (value rod)) 104 | (compromised-host (value t)) 105 | => 106 | (assert (organism-identity (value pseudomonas) (entity ?organism)))) 107 | 108 | (defrule rule-107 (:belief 0.8) 109 | (gram (value neg) (organism ?organism)) 110 | (morphology (value rod)) 111 | (aerobicity (value aerobic)) 112 | => 113 | (assert (organism-identity (value enterobacteriaceae) (entity ?organism)))) 114 | 115 | (defrule rule-165 (:belief 0.7) 116 | (gram (value pos) (entity ?organism)) 117 | (morphology (value coccus)) 118 | (growth-conformation (value chains)) 119 | => 120 | (assert (organism-identity (value streptococcus) (entity ?organism)))) 121 | 122 | (defrule conclusion (:salience -10) 123 | (?identity (organism-identity (value ?value))) 124 | => 125 | (format t "Identity: ~A (~,3F)~%" ?value (belief:belief-factor ?identity))) 126 | 127 | (defun culture-1 (&key (runp t)) 128 | (reset) 129 | (let ((?organism (make-instance 'organism)) 130 | (?patient (make-instance 'patient 131 | :name "Sylvia Fischer" 132 | :sex 'female 133 | :age 27))) 134 | (assert (compromised-host (value t) (entity ?patient))) 135 | (assert (burn (value serious) (entity ?patient))) 136 | (assert (culture-site (value blood))) 137 | (assert (culture-age (value 3))) 138 | (assert (gram (value neg) (entity ?organism))) 139 | (assert (morphology (value rod) (entity ?organism))) 140 | (assert (aerobicity (value aerobic) (entity ?organism))) 141 | (when runp 142 | (run)))) 143 | 144 | (defun culture-2 (&key (runp t)) 145 | (reset) 146 | (let ((?organism (make-instance 'organism)) 147 | (?patient (make-instance 'patient 148 | :name "Sylvia Fischer" 149 | :sex 'female 150 | :age 27))) 151 | (assert (compromised-host (value t) (entity ?patient))) 152 | (assert (burn (value serious) (entity ?patient))) 153 | (assert (culture-site (value blood))) 154 | (assert (culture-age (value 3))) 155 | (assert (gram (value neg) (entity ?organism)) :belief 0.8) 156 | (assert (gram (value pos) (entity ?organism)) :belief 0.2) 157 | (assert (morphology (value rod) (entity ?organism))) 158 | (assert (aerobicity (value anaerobic) (entity ?organism))) 159 | (when runp 160 | (run)))) 161 | -------------------------------------------------------------------------------- /examples/rpc-client.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: A sample implementation of an RPC client that requests 26 | ;; inferencing services from a Lisa server. 27 | 28 | (in-package "RPC") 29 | 30 | (defclass frodo () 31 | ((name :initarg :name 32 | :initform nil 33 | :accessor frodo-name) 34 | (has-ring :initform :no 35 | :accessor frodo-has-ring) 36 | (companions :initform nil 37 | :accessor frodo-companions))) 38 | 39 | (defun set-slot-value (new-value instance slot-name) 40 | (setf (slot-value instance slot-name) new-value)) 41 | 42 | (defmethod print-object ((self frodo) strm) 43 | (print-unreadable-object (strm strm :type t :identity t) 44 | (format strm "~S, ~S, ~S" 45 | (frodo-name self) 46 | (frodo-has-ring self) 47 | (frodo-companions self)))) 48 | 49 | (defun make-client () 50 | (make-rpc-client 51 | 'rpc-socket-port 52 | :remote-host *lisa-server-host* 53 | :remote-port *lisa-server-port*)) 54 | 55 | (defun run-client () 56 | (let ((frodo (make-instance 'frodo :name 'frodo))) 57 | (format t "Frodo instance before inferencing: ~S~%" frodo) 58 | (multiple-value-bind (port stuff) 59 | (make-client) 60 | (with-remote-port (port :close t) 61 | (rcall 'reset) 62 | (rcall 'assert-object frodo) 63 | (rcall 'run) 64 | (format t "Frodo instance after inferencing: ~S~%" frodo) 65 | frodo)))) 66 | 67 | (defun run-all () 68 | (start-server) 69 | (run-client)) 70 | -------------------------------------------------------------------------------- /examples/rpc-server.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;;; Description: A sample implementation of an RPC server capable of reasoning 26 | ;;; over remote objects. 27 | 28 | (in-package "RPC") 29 | 30 | (defvar *lisa-server-host* "localhost") 31 | (defvar *lisa-server-port* 10000) 32 | (defvar *server-proc* nil) 33 | 34 | (defun assert-object (object) 35 | (let ((*package* (find-package "RPC"))) 36 | (format t "package is ~S~%" *package*) 37 | (format t "object is ~S~%" object) 38 | (format t "class of object is ~S~%" (class-of object)) 39 | (format t "class name of object is ~S~%" (class-name (class-of object))) 40 | (assert-instance object) 41 | object)) 42 | 43 | (defun initialize-client-environment (port) 44 | (format t "Initialising client environment~%") 45 | (import-remote-class port 'remote-instance "frodo")) 46 | 47 | (defun make-server () 48 | (make-rpc-server 49 | 'rpc-socket-server 50 | :name "Lisa RPC Server" 51 | :local-port *lisa-server-port* 52 | :open :listener 53 | :connect-action :call 54 | :connect-function 55 | #'(lambda (port &rest args) 56 | (initialize-client-environment port) 57 | (values)))) 58 | 59 | (defun start-server () 60 | (when (null *server-proc*) 61 | (setf *server-proc* (make-server))) 62 | *server-proc*) 63 | 64 | (defun stop-server () 65 | (unless (null *server-proc*) 66 | (rpc-close :stop :final) 67 | (setf *server-proc* nil))) 68 | 69 | (defrule remote-frodo () 70 | (?frodo (frodo (has-ring :no))) 71 | => 72 | (modify ?frodo (has-ring t) (companions '(samwise gandalf)))) 73 | -------------------------------------------------------------------------------- /examples/rpc.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package "CL-USER") 26 | 27 | (eval-when (:compile-toplevel :load-toplevel :execute) 28 | (require 'aclrpc) 29 | (unless (find-package "RPC") 30 | (defpackage "RPC" 31 | (:use "COMMON-LISP" "NET.RPC")))) 32 | 33 | (in-package "RPC") 34 | 35 | (defvar *server-host* "localhost") 36 | (defvar *server-port* 10000) 37 | (defvar *server-proc* nil) 38 | 39 | (defclass frodo () 40 | ((name :initarg :name 41 | :initform nil 42 | :accessor frodo-name) 43 | (age :initform 0 44 | :accessor frodo-age))) 45 | 46 | (defmethod print-object ((self frodo) strm) 47 | (print-unreadable-object (strm strm :type t :identity t) 48 | (format strm "~S, ~S" (frodo-name self) (frodo-age self)))) 49 | 50 | (defclass remote-frodo (rpc-remote-ref) ()) 51 | 52 | (defmethod frodo-name ((self remote-frodo)) 53 | (rcall 'frodo-name self)) 54 | 55 | (defmethod (setf slot-value-of-instance) 56 | (new-value (instance rpc-remote-ref) slot-name) 57 | (rcall 'set-instance-slot instance slot-name new-value)) 58 | 59 | (defun assert-instance (object) 60 | (format t "instance is ~S~%" object) 61 | (format t "class-of instance is ~S~%" (class-of object)) 62 | (setf (slot-value-of-instance object 'age) 100) 63 | object) 64 | 65 | (defun initialize-client-environment (port) 66 | (format t "Initialising client environment~%") 67 | (import-remote-class port 'remote-frodo "frodo")) 68 | 69 | (defun set-instance-slot (object slot value) 70 | (setf (slot-value object slot) value)) 71 | 72 | (defun make-server () 73 | (make-rpc-server 74 | 'rpc-socket-server 75 | :name "RPC Server" 76 | :local-port *server-port* 77 | :open :listener 78 | :connect-action :call 79 | :connect-function 80 | #'(lambda (port &rest args) 81 | (initialize-client-environment port) 82 | (values)))) 83 | 84 | (defun start-server () 85 | (when (null *server-proc*) 86 | (setf *server-proc* (make-server))) 87 | *server-proc*) 88 | 89 | (defun stop-server () 90 | (unless (null *server-proc*) 91 | (rpc-close :stop :final) 92 | (setf *server-proc* nil))) 93 | 94 | (defun make-client () 95 | (make-rpc-client 96 | 'rpc-socket-port 97 | :remote-host *server-host* 98 | :remote-port *server-port*)) 99 | 100 | (defun run-client () 101 | (multiple-value-bind (port stuff) 102 | (make-client) 103 | (with-remote-port (port :close t) 104 | (let ((frodo (make-instance 'frodo :name 'frodo))) 105 | (rcall 'assert-instance frodo) 106 | (format t "frodo instance after remote call: ~S~%" frodo) 107 | frodo)))) 108 | 109 | (defun run-sample () 110 | (start-server) 111 | (run-client)) 112 | -------------------------------------------------------------------------------- /examples/sbcl-notify.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :LISA-USER) 26 | 27 | (defclass counter () 28 | ((count :initform 0 29 | :reader counter-count)) 30 | (:metaclass lisa:standard-kb-class)) 31 | 32 | (defrule increment-when-zero () 33 | (?counter (counter (count 0))) 34 | => 35 | (modify ?counter (count 1))) 36 | 37 | (defrule fire-when-one () 38 | (counter (count 1)) 39 | => 40 | (format t "FIRE-WHEN-ONE fired!~%")) 41 | 42 | (reset) 43 | 44 | (defrule startup () 45 | => 46 | (assert ((make-instance 'counter)))) 47 | 48 | (reset) 49 | (run) 50 | -------------------------------------------------------------------------------- /examples/semi-mab.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (use-default-engine) 28 | 29 | (deftemplate monkey () 30 | (slot location) 31 | (slot on-top-of) 32 | (slot holding)) 33 | 34 | (deftemplate thing () 35 | (slot name) 36 | (slot location) 37 | (slot on-top-of) 38 | (slot weight)) 39 | 40 | (deftemplate chest () 41 | (slot name) 42 | (slot contents) 43 | (slot unlocked-by)) 44 | 45 | (deftemplate goal-is-to () 46 | (slot action) 47 | (slot argument-1) 48 | (slot argument-2)) 49 | 50 | (defrule hold-chest-to-put-on-floor () 51 | (goal-is-to (action unlock) (argument-1 ?chest)) 52 | (thing (name ?chest) (on-top-of (not floor)) (weight light)) 53 | (monkey (holding (not ?chest))) 54 | (not (goal-is-to (action hold) (argument-1 ?chest))) 55 | => 56 | (assert (goal-is-to (action hold) (argument-1 ?chest) 57 | (argument-2 empty)))) 58 | 59 | (defrule unlock-chest-to-hold-object () 60 | (goal-is-to (action hold) (argument-1 ?obj)) 61 | (chest (name ?chest) (contents ?obj)) 62 | (not (goal-is-to (action unlock) (argument-1 ?chest))) 63 | => 64 | (assert (goal-is-to (action unlock) (argument-1 ?chest) 65 | (argument-2 empty)))) 66 | 67 | (defrule use-ladder-to-hold () 68 | (goal-is-to (action hold) (argument-1 ?obj)) 69 | (thing (name ?obj) (location ?place) (on-top-of ceiling) (weight light)) 70 | (not (thing (name ladder) (location ?place))) 71 | (not (goal-is-to (action move) (argument-1 ladder) (argument-2 ?place))) 72 | => 73 | (assert (goal-is-to (action move) (argument-1 ladder) (argument-2 ?place)))) 74 | 75 | (defrule hold-to-eat () 76 | (goal-is-to (action eat) (argument-1 ?obj)) 77 | (monkey (holding (not ?obj))) 78 | (not (goal-is-to (action hold) (argument-1 ?obj))) 79 | => 80 | (format t "firing hold-to-eat~%") 81 | (assert (goal-is-to (action hold) (argument-1 ?obj) 82 | (argument-2 empty)))) 83 | 84 | (deffacts mab-startup () 85 | (monkey (location t5-7) (on-top-of green-couch) 86 | (location green-couch) (holding blank)) 87 | (thing (name green-couch) (location t5-7) (weight heavy) 88 | (on-top-of floor)) 89 | (thing (name red-couch) (location t2-2) 90 | (on-top-of floor) (weight heavy)) 91 | (thing (name big-pillow) (location t2-2) 92 | (weight light) (on-top-of red-couch)) 93 | (thing (name red-chest) (location t2-2) 94 | (weight light) (on-top-of big-pillow)) 95 | (chest (name red-chest) (contents ladder) (unlocked-by red-key)) 96 | (thing (name blue-chest) (location t7-7) 97 | (weight light) (on-top-of ceiling)) 98 | (thing (name grapes) (location t7-8) 99 | (weight light) (on-top-of ceiling)) 100 | (chest (name blue-chest) (contents bananas) (unlocked-by blue-key)) 101 | (thing (name blue-couch) (location t8-8) 102 | (on-top-of floor) (weight heavy)) 103 | (thing (name green-chest) (location t8-8) 104 | (weight light) (on-top-of ceiling)) 105 | (chest (name green-chest) (contents blue-key) (unlocked-by red-key)) 106 | (thing (name red-key) 107 | (on-top-of floor) (weight light) (location t1-3)) 108 | (goal-is-to (action eat) (argument-1 bananas) (argument-2 empty))) 109 | -------------------------------------------------------------------------------- /examples/test-ce.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;;; Description: This tiny rulebase was written to verify a fix to Lisa's TEST 26 | ;;; conditional element, reported by Gaston Pepe. 27 | 28 | (in-package :lisa-user) 29 | 30 | (deftemplate hobbit () 31 | (slot name)) 32 | 33 | (defrule check-frodo () 34 | (hobbit (name ?name)) 35 | (test (equal ?name "frodo")) 36 | => 37 | (format t "Frodo found!~%") 38 | (assert (hobbit (name "bilbo")))) 39 | 40 | (defrule check-bilbo () 41 | (hobbit (name ?name)) 42 | (test (or (equal ?name "bilbo") 43 | (equal ?name "pippin"))) 44 | => 45 | (format t "Frodo's bud ~A found!~%" ?name)) 46 | 47 | (defun hobbits () 48 | (reset) 49 | (assert (hobbit (name "frodo"))) 50 | (run) 51 | (facts) 52 | (reset) 53 | (facts) 54 | t) 55 | -------------------------------------------------------------------------------- /images/hierarchy-background.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/youngde811/Lisa/b0a62f06d19ee3cf476a784c8ebbfad1e287aee2/images/hierarchy-background.gif -------------------------------------------------------------------------------- /images/powmia.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/youngde811/Lisa/b0a62f06d19ee3cf476a784c8ebbfad1e287aee2/images/powmia.png -------------------------------------------------------------------------------- /perf/stack-perf.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :cl-user) 26 | 27 | (eval-when (:compile-toplevel :load-toplevel :execute) 28 | (unless (find-package "STACK-PERF") 29 | (defpackage "STACK-PERF" 30 | (:use "COMMON-LISP") 31 | (:export "TEST-DEFAULT-IMPL" 32 | "TEST-GP-IMPL")))) 33 | 34 | (in-package #:stack-perf) 35 | 36 | (defclass token () 37 | ((facts :initform nil 38 | :initarg :stack 39 | :accessor token-facts) 40 | (hash-code :initform nil 41 | :accessor token-hash-code) 42 | (fact-count :initform 0 43 | :type (unsigned-byte 64) 44 | :accessor token-fact-count))) 45 | 46 | (defclass fact () 47 | ((name :initform nil 48 | :initarg :name 49 | :reader fact-name))) 50 | 51 | (defun token-top-fact-default (token) 52 | (with-slots ((fact-vector facts) 53 | (fact-count fact-count)) token 54 | (declare (type fixnum fact-count)) 55 | (aref fact-vector (1- fact-count)))) 56 | 57 | (defun token-push-fact-default (token fact) 58 | (declare (optimize (speed 3) (safety 1) (debug 0))) 59 | (with-slots ((fact-vector facts) 60 | (fact-count fact-count) 61 | (hash-code hash-code)) token 62 | (declare (type fixnum fact-count)) 63 | (vector-push-extend fact fact-vector) 64 | (push fact hash-code) 65 | (incf fact-count)) 66 | token) 67 | 68 | (defun token-pop-fact-default (token) 69 | (declare (type token token)) 70 | (declare (optimize (speed 3) (safety 1) (debug 0))) 71 | (with-slots ((fact-vector facts) 72 | (fact-count fact-count) 73 | (hash-code hash-code)) token 74 | (declare (type fixnum fact-count)) 75 | (unless (zerop (fill-pointer fact-vector)) 76 | (pop hash-code) 77 | (aref fact-vector (decf (fill-pointer fact-vector)))))) 78 | 79 | (defun token-push-fact-gs (token fact) 80 | (declare (optimize (speed 3) (safety 1) (debug 0))) 81 | (with-slots ((fact-stack facts) 82 | (hash-code hash-code)) token 83 | (grouping-stack:stack-push fact fact-stack) 84 | (push fact hash-code)) 85 | token) 86 | 87 | (defun token-pop-fact-gs (token) 88 | (declare (type token token)) 89 | (with-slots ((fact-stack facts) 90 | (hash-code hash-code)) token 91 | (unless (zerop (grouping-stack:stack-size fact-stack)) 92 | (pop hash-code) 93 | (grouping-stack:stack-pop fact-stack)))) 94 | 95 | (defun test-default-impl (&key (ntimes 100)) 96 | (let ((token (make-instance 'token :stack (make-array 64 :initial-element nil :adjustable t :fill-pointer 0)))) 97 | (dotimes (i ntimes) 98 | (token-push-fact-default token (make-instance 'fact :name (format nil "frodo-~D" i)))) 99 | (dotimes (i ntimes) 100 | (token-pop-fact-default token)))) 101 | 102 | (defun test-gs-impl (&key (ntimes 100)) 103 | (let ((token (make-instance 'token 104 | :stack (grouping-stack:make-grouping-stack 105 | (make-instance 'grouping-stack:inactive-balancer))))) 106 | (dotimes (i ntimes) 107 | (token-push-fact-gs token (make-instance 'fact :name (format nil "frodo-~D" i)))) 108 | (dotimes (i ntimes) 109 | (token-pop-fact-gs token)))) 110 | -------------------------------------------------------------------------------- /ql.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: This is a convenience file for folks who are using Quicklisp. 26 | 27 | (in-package :cl-user) 28 | 29 | (load "lisa.asd") 30 | (asdf:operate 'asdf:load-op :lisa :force t) 31 | -------------------------------------------------------------------------------- /sbcl/sbcl-core.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: This sample Lisp file may be used to create a custom sbcl core file, containing whatever packages 26 | ;; one wishes to have added to base sbcl. 27 | 28 | (in-package :cl-user) 29 | 30 | (mapc #'require '(:sb-bsd-sockets :sb-posix :sb-introspect :sb-cltl2 :asdf :uiop)) 31 | 32 | #-quicklisp 33 | (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" 34 | (user-homedir-pathname)))) 35 | (when (probe-file quicklisp-init) 36 | (load quicklisp-init))) 37 | 38 | ;;; Be sure to change the core target to something suitable for your environment. 39 | 40 | (save-lisp-and-die (concatenate 'string (sb-posix:getcwd) "/sbcl/sbcl-lisa.core")) 41 | -------------------------------------------------------------------------------- /src/belief-systems/belief.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Common interfaces to Lisa's belief-system. 26 | 27 | (in-package :belief) 28 | 29 | ;;; The principal interface by which outside code hooks objects that support some kind of belief-factor 30 | ;;; interface into this library. 31 | 32 | (defgeneric belief-factor (obj)) 33 | (defgeneric adjust-belief (objects rule-belief &optional old-belief)) 34 | (defgeneric belief->english (belief-factor)) 35 | -------------------------------------------------------------------------------- /src/belief-systems/certainty-factors.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: An implementation of Certainty Factors as found in Peter Norvig's PAIP. 26 | 27 | (in-package :belief) 28 | 29 | (defconstant +true+ 1.0) 30 | (defconstant +false+ -1.0) 31 | (defconstant +unknown+ 0.0) 32 | 33 | (defun certainty-factor-p (number) 34 | (<= +false+ number +true+)) 35 | 36 | (deftype certainty-factor () 37 | `(and (real) 38 | (satisfies certainty-factor-p))) 39 | 40 | (defun true-p (cf) 41 | (check-type cf certainty-factor) 42 | (> cf +unknown+)) 43 | 44 | (defun false-p (cf) 45 | (check-type cf certainty-factor) 46 | (< cf +unknown+)) 47 | 48 | (defun unknown-p (cf) 49 | (check-type cf certainty-factor) 50 | (= cf +unknown+)) 51 | 52 | (defun cf-combine (a b) 53 | (check-type a certainty-factor) 54 | (check-type b certainty-factor) 55 | (cond ((and (plusp a) 56 | (plusp b)) 57 | (+ a b (* -1 a b))) 58 | ((and (minusp a) 59 | (minusp b)) 60 | (+ a b (* a b))) 61 | (t (/ (+ a b) 62 | (- 1 (min (abs a) (abs b))))))) 63 | 64 | (defun conjunct-cf (objects) 65 | "Combines the certainty factors of objects matched within a single rule." 66 | (let ((conjuncts 67 | (loop for obj in objects 68 | for cf = (belief-factor obj) 69 | if cf collect cf))) 70 | (if conjuncts 71 | (apply #'min conjuncts) 72 | nil))) 73 | 74 | (defgeneric recalculate-cf (objects rule-cf old-cf) 75 | (:method (objects (rule-cf number) (old-cf number)) 76 | (let* ((combined-cf (conjunct-cf objects)) 77 | (new-cf (if combined-cf (* rule-cf combined-cf) rule-cf))) 78 | (cf-combine old-cf new-cf))) 79 | (:method (objects (rule-cf number) (old-cf t)) 80 | (let* ((combined-cf (conjunct-cf objects)) 81 | (new-cf (if combined-cf combined-cf rule-cf)) 82 | (factor (if combined-cf rule-cf 1.0))) 83 | (* new-cf factor))) 84 | (:method (objects (rule-cf t) (old-cf t)) 85 | (let* ((combined-cf (conjunct-cf objects))) 86 | (if combined-cf 87 | (* combined-cf 1.0) 88 | nil)))) 89 | 90 | (defun cf->english (cf) 91 | (cond ((= cf 1.0) "certain evidence") 92 | ((> cf 0.8) "strongly suggestive evidence") 93 | ((> cf 0.5) "suggestive evidence") 94 | ((> cf 0.0) "weakly suggestive evidence") 95 | ((= cf 0.0) "no evidence either way") 96 | ((< cf 0.0) (concatenate 'string (cf->english (- cf)) " against the conclusion")))) 97 | 98 | ;;; interface into the generic belief system. 99 | 100 | (defmethod adjust-belief (objects (rule-belief number) &optional (old-belief nil)) 101 | (recalculate-cf objects rule-belief old-belief)) 102 | 103 | (defmethod adjust-belief (objects (rule-belief t) &optional old-belief) 104 | (declare (ignore objects old-belief)) 105 | nil) 106 | 107 | (defmethod belief->english ((cf number)) 108 | (cf->english cf)) 109 | 110 | -------------------------------------------------------------------------------- /src/belief-systems/null-belief-system.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :belief) 26 | 27 | ;;; interface into the generic belief system. 28 | 29 | (defmethod belief-factor ((obj t)) 30 | nil) 31 | 32 | (defmethod adjust-belief ((objects t) (rule-belief t) &optional (old-belief nil)) 33 | nil) 34 | 35 | (defmethod belief->english ((belief t)) 36 | nil) 37 | -------------------------------------------------------------------------------- /src/config/config.lisp: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: User-customisable configuration settings for Lisa. It is expected 26 | ;; that developers will edit this file as they see fit. 27 | 28 | (in-package :lisa) 29 | 30 | ;;; The reference guide has complete details, but: 31 | ;;; 32 | ;;; * Setting USE-FANCY-ASSERT enables the #? dispatch macro character. 33 | ;;; * Setting ALLOW-DUPLICATE-FACTS disables duplicate fact checking during 34 | ;;; assertions. 35 | ;;; * Setting CONSIDER-TAXONOMY instructs Lisa to consider a CLOS instance's 36 | ;;; ancestors during pattern matching. 37 | 38 | (eval-when (:load-toplevel) 39 | (setf (use-fancy-assert) t) 40 | (setf (allow-duplicate-facts) t) 41 | (setf (consider-taxonomy) t)) 42 | -------------------------------------------------------------------------------- /src/config/epilogue.lisp: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (deftemplate initial-fact ()) 28 | 29 | (deftemplate query-fact ()) 30 | 31 | ;;; This macro is courtesy of Paul Werkowski. A very nice idea. 32 | 33 | (defmacro define-lisa-lisp () 34 | (flet ((externals-of (pkg) 35 | (loop for s being each external-symbol in pkg collect s))) 36 | (let* ((lisa-externs (externals-of "LISA")) 37 | (lisa-shadows (intersection (package-shadowing-symbols "LISA") 38 | lisa-externs)) 39 | (cl-externs (externals-of "COMMON-LISP"))) 40 | `(defpackage "LISA-LISP" 41 | (:use "COMMON-LISP") 42 | (:shadowing-import-from "LISA" ,@lisa-shadows) 43 | (:import-from "LISA" ,@(set-difference lisa-externs lisa-shadows)) 44 | (:export ,@cl-externs) 45 | (:export ,@lisa-externs))))) 46 | 47 | (eval-when (:load-toplevel :execute) 48 | (make-default-inference-engine) 49 | (setf *active-context* (initial-context (inference-engine))) 50 | (define-lisa-lisp) 51 | (when (use-fancy-assert) 52 | (set-dispatch-macro-character 53 | #\# #\? #'(lambda (strm subchar arg) 54 | (declare (ignore subchar arg)) 55 | (list 'identity (read strm t nil t))))) 56 | (pushnew :lisa *features*)) 57 | 58 | 59 | -------------------------------------------------------------------------------- /src/core/activation.lisp: -------------------------------------------------------------------------------- 1 | ;;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: This class represents an activation of a rule. 26 | 27 | (in-package :lisa) 28 | 29 | (defvar *activation-timestamp* 0) 30 | 31 | (defclass activation () 32 | ((rule :initarg :rule 33 | :initform nil 34 | :reader activation-rule) 35 | (tokens :initarg :tokens 36 | :initform nil 37 | :reader activation-tokens) 38 | (timestamp :initform (incf *activation-timestamp*) 39 | :reader activation-timestamp) 40 | (eligible :initform t 41 | :accessor activation-eligible)) 42 | (:documentation 43 | "Represents a rule activation.")) 44 | 45 | (defmethod activation-priority ((self activation)) 46 | (rule-salience (activation-rule self))) 47 | 48 | (defmethod fire-activation ((self activation)) 49 | (trace-firing self) 50 | (fire-rule (activation-rule self) (activation-tokens self))) 51 | 52 | (defun eligible-p (activation) 53 | (activation-eligible activation)) 54 | 55 | (defun inactive-p (activation) 56 | (not (eligible-p activation))) 57 | 58 | (defun activation-fact-list (activation &key (detailp nil)) 59 | (token-make-fact-list (activation-tokens activation) :detailp detailp)) 60 | 61 | (defmethod print-object ((self activation) strm) 62 | (let ((tokens (activation-tokens self)) 63 | (rule (activation-rule self))) 64 | (print-unreadable-object (self strm :identity t :type t) 65 | (format strm "(~A ~A ; salience = ~D)" 66 | (rule-name rule) 67 | (mapcar #'fact-symbolic-id 68 | (token-make-fact-list tokens)) 69 | (rule-salience rule))))) 70 | 71 | (defmethod hash-key ((self activation)) 72 | (hash-key (activation-tokens self))) 73 | 74 | (defun make-activation (rule tokens) 75 | (make-instance 'activation :rule rule :tokens tokens)) 76 | 77 | -------------------------------------------------------------------------------- /src/core/belief-interface.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defmethod belief:belief-factor ((self fact)) 28 | (belief-factor self)) 29 | 30 | (defmethod belief:belief-factor ((self rule)) 31 | (belief-factor self)) 32 | -------------------------------------------------------------------------------- /src/core/binding.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defstruct (binding 28 | (:type list) 29 | (:constructor %make-binding)) 30 | variable address slot-name) 31 | 32 | (defun make-binding (var address slot-name) 33 | (%make-binding :variable var :address address :slot-name slot-name)) 34 | 35 | (defun pattern-binding-p (binding) 36 | (eq (binding-slot-name binding) :pattern)) 37 | -------------------------------------------------------------------------------- /src/core/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (define-condition duplicate-fact (error) 28 | ((existing-fact :reader duplicate-fact-existing-fact 29 | :initarg :existing-fact)) 30 | (:report (lambda (condition strm) 31 | (declare (ignore strm)) 32 | (log:warn "Lisa detected an attempt to assert a duplicate for: ~S" 33 | (duplicate-fact-existing-fact condition))))) 34 | 35 | (define-condition parsing-error (error) 36 | ((text :initarg :text 37 | :initform nil 38 | :reader text) 39 | (location :initarg :location 40 | :initform nil 41 | :reader location)) 42 | (:report (lambda (condition strm) 43 | (declare (ignore strm)) 44 | (log:error "Parsing error: ~A" (text condition)) 45 | (error t)))) 46 | 47 | (define-condition slot-parsing-error (parsing-error) 48 | ((slot-name :initarg :slot-name 49 | :initform nil 50 | :reader slot-name)) 51 | (:report (lambda (condition strm) 52 | (declare (ignore strm)) 53 | (log:error "Slot parsing error: slot ~A, pattern location ~A, text ~A" 54 | (slot-name condition) (location condition) (text condition)) 55 | (error t)))) 56 | 57 | (define-condition class-parsing-error (parsing-error) 58 | ((class-name :initarg :class-name 59 | :initform nil 60 | :reader class-name)) 61 | (:report (lambda (condition strm) 62 | (declare (ignore strm)) 63 | (log:error "Class parsing error: ~A, ~A" (class-name condition) (text condition))))) 64 | 65 | (define-condition rule-parsing-error (parsing-error) 66 | ((rule-name :initarg :rule-name 67 | :initform nil 68 | :reader rule-name)) 69 | (:report (lambda (condition strm) 70 | (declare (ignore strm)) 71 | (log:error "Rule parsing error: rule name ~A, pattern location ~A, text ~A" 72 | (rule-name condition) (location condition) (text condition))))) 73 | -------------------------------------------------------------------------------- /src/core/context.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defclass context () 28 | ((name :initarg :name 29 | :reader context-name) 30 | (rules :initform (make-hash-table :test #'equal) 31 | :reader context-rules) 32 | (strategy :initarg :strategy 33 | :reader context-strategy))) 34 | 35 | (defmethod print-object ((self context) strm) 36 | (print-unreadable-object (self strm :type t) 37 | (if (initial-context-p self) 38 | (format strm "~S" "The Initial Context") 39 | (format strm "~A" (context-name self))))) 40 | 41 | (defmethod find-rule-in-context ((self context) (rule-name string)) 42 | (values (gethash rule-name (context-rules self)))) 43 | 44 | (defmethod find-rule-in-context ((self context) (rule-name symbol)) 45 | (values (gethash (symbol-name rule-name) (context-rules self)))) 46 | 47 | (defun add-rule-to-context (context rule) 48 | (setf (gethash (symbol-name (rule-name rule)) (context-rules context)) 49 | rule)) 50 | 51 | (defmethod conflict-set ((self context)) 52 | (context-strategy self)) 53 | 54 | (defmethod remove-rule-from-context ((self context) (rule-name symbol)) 55 | (remhash (symbol-name rule-name) (context-rules self))) 56 | 57 | (defmethod remove-rule-from-context ((self context) (rule t)) 58 | (remove-rule-from-context self (rule-name rule))) 59 | 60 | (defun clear-activations (context) 61 | (remove-activations (context-strategy context))) 62 | 63 | (defun context-activation-list (context) 64 | (list-activations (context-strategy context))) 65 | 66 | (defun context-rule-list (context) 67 | (loop for rule being the hash-values of (context-rules context) 68 | collect rule)) 69 | 70 | (defun clear-context (context) 71 | (clear-activations context) 72 | (clrhash (context-rules context))) 73 | 74 | (defun initial-context-p (context) 75 | (string= (context-name context) "INITIAL-CONTEXT")) 76 | 77 | (defun make-context-name (defined-name) 78 | (typecase defined-name 79 | (symbol (symbol-name defined-name)) 80 | (string defined-name) 81 | (otherwise 82 | (let ((msg "The context name must be a string designator.")) 83 | (log:error msg) 84 | (error msg))))) 85 | 86 | (defmacro with-context (context &body body) 87 | `(let ((*active-context* ,context)) 88 | ,@body)) 89 | 90 | (defmacro with-rule-name-parts ((context short-name long-name) 91 | symbolic-name &body body) 92 | (let ((qualifier (gensym)) 93 | (rule-name (gensym))) 94 | `(let* ((,rule-name (symbol-name ,symbolic-name)) 95 | (,qualifier (position #\. ,rule-name)) 96 | (,context (if ,qualifier 97 | (subseq ,rule-name 0 ,qualifier) 98 | (symbol-name :initial-context))) 99 | (,short-name (if ,qualifier 100 | (subseq ,rule-name (1+ ,qualifier)) 101 | ,rule-name)) 102 | (,long-name (if ,qualifier 103 | ,rule-name 104 | (concatenate 'string ,context "." ,short-name)))) 105 | ,@body))) 106 | 107 | (defun make-context (name &key (strategy nil)) 108 | (make-instance 'context 109 | :name (make-context-name name) 110 | :strategy (if (null strategy) 111 | (make-breadth-first-strategy) 112 | strategy))) 113 | -------------------------------------------------------------------------------- /src/core/deffacts.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: This class represents "autoloaded" facts that are asserted automatically 26 | ;; as part of an engine reset. 27 | 28 | (in-package :lisa) 29 | 30 | (defclass deffacts () 31 | ((name :initarg :name 32 | :reader deffacts-name) 33 | (fact-list :initarg :fact-list 34 | :initform nil 35 | :reader deffacts-fact-list)) 36 | (:documentation 37 | "This class represents 'autoloaded' facts that are asserted automatically 38 | as part of an inference engine reset.")) 39 | 40 | (defmethod print-object ((self deffacts) strm) 41 | (print-unreadable-object (self strm :type t :identity t) 42 | (format strm "~S ; ~S" (deffacts-name self) (deffacts-fact-list self)))) 43 | 44 | (defun make-deffacts (name facts) 45 | (make-instance 'deffacts :name name :fact-list (copy-list facts))) 46 | 47 | -------------------------------------------------------------------------------- /src/core/environment.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Defines the standard Lisa environment. 26 | 27 | (in-package :lisa) 28 | 29 | (defvar *default-engine* nil 30 | "The currently active inference engine.") 31 | 32 | (defun use-default-engine () 33 | "Create and make available a default instance of the inference engine. Use 34 | this function when you want a basic, single-threaded Lisa environment." 35 | (when (null *default-engine*) 36 | (setf *default-engine* (make-inference-engine))) 37 | (values *default-engine*)) 38 | 39 | (defun use-engine (engine) 40 | "Make ENGINE the default inference engine. Use this function with great care 41 | in an MP environment." 42 | (setf *default-engine* engine)) 43 | 44 | (defun current-engine (&optional (errorp t)) 45 | "Returns the currently-active inference engine. Usually only invoked by code 46 | running within the context of WITH-INFERENCE-ENGINE." 47 | (when errorp 48 | (cl:assert (not (null *default-engine*)) (*default-engine*) 49 | "The current inference engine has not been established.")) 50 | (values *default-engine*)) 51 | 52 | (defmacro with-inference-engine ((engine) &body body) 53 | "Evaluates BODY within the context of the inference engine ENGINE. This 54 | macro is MP-safe." 55 | `(let ((*default-engine* ,engine)) 56 | (progn ,@body))) 57 | 58 | (defun clear-environment (engine) 59 | "Completely resets the inference engine ENGINE." 60 | (clear-engine engine) 61 | (values)) 62 | -------------------------------------------------------------------------------- /src/core/epilogue.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (deftemplate initial-fact ()) 28 | 29 | (deftemplate query-fact ()) 30 | 31 | ;;; This macro is courtesy of Paul Werkowski. A very nice idea. 32 | 33 | (defmacro define-lisa-lisp () 34 | (flet ((externals-of (pkg) 35 | (loop for s being each external-symbol in pkg collect s))) 36 | (let* ((lisa-externs (externals-of "LISA")) 37 | (lisa-shadows (intersection (package-shadowing-symbols "LISA") 38 | lisa-externs)) 39 | (cl-externs (externals-of "COMMON-LISP"))) 40 | `(defpackage "LISA-LISP" 41 | (:use "COMMON-LISP") 42 | (:shadowing-import-from "LISA" ,@lisa-shadows) 43 | (:import-from "LISA" ,@(set-difference lisa-externs lisa-shadows)) 44 | (:export ,@cl-externs) 45 | (:export ,@lisa-externs))))) 46 | 47 | (eval-when (:load-toplevel :execute) 48 | (make-default-inference-engine) 49 | (setf *active-context* (initial-context (inference-engine))) 50 | (define-lisa-lisp) 51 | (when (use-fancy-assert) 52 | (set-dispatch-macro-character 53 | #\# #\? #'(lambda (strm subchar arg) 54 | (declare (ignore subchar arg)) 55 | (list 'identity (read strm t nil t))))) 56 | (pushnew :lisa *features*)) 57 | 58 | 59 | -------------------------------------------------------------------------------- /src/core/fact-parser.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defun create-template-class-slots (class-name slot-list) 28 | (labels ((determine-default (default-form) 29 | (unless (and (consp default-form) 30 | (eq (first default-form) 'default) 31 | (= (length default-form) 2)) 32 | (error 'class-parsing-error :class-name class-name 33 | :text "malformed DEFAULT keyword")) 34 | (second default-form)) 35 | (build-one-slot (template) 36 | (destructuring-bind (keyword slot-name &optional default) 37 | template 38 | (unless (eq keyword 'slot) 39 | (error 'class-parsing-error :class-name class-name 40 | :text "unrecognized keyword: ~A" keyword)) 41 | `(,slot-name 42 | :initarg ,(intern (symbol-name slot-name) 'keyword) 43 | :initform 44 | ,(if (null default) nil (determine-default default)) 45 | :reader 46 | ,(intern (format nil "~S-~S" class-name slot-name)))))) 47 | (mapcar #'build-one-slot slot-list))) 48 | 49 | (defun redefine-deftemplate (class-name body) 50 | (let ((class (gensym))) 51 | `(let ((,class 52 | (defclass ,class-name (inference-engine-object) 53 | ,@(list (create-template-class-slots class-name body))))) 54 | ,class))) 55 | 56 | (defun bind-logical-dependencies (fact) 57 | (add-logical-dependency 58 | (inference-engine) fact 59 | (make-dependency-set (active-tokens) (rule-logical-marker (active-rule)))) 60 | fact) 61 | 62 | (defun parse-and-insert-instance (instance &key (belief nil)) 63 | (ensure-meta-data-exists (class-name (class-of instance))) 64 | (let ((fact 65 | (make-fact-from-instance (class-name (class-of instance)) instance))) 66 | (when (and (in-rule-firing-p) 67 | (logical-rule-p (active-rule))) 68 | (bind-logical-dependencies fact)) 69 | (assert-fact (inference-engine) fact :belief belief))) 70 | 71 | (defun parse-and-retract-instance (instance engine) 72 | (retract-fact engine instance)) 73 | 74 | (defun show-deffacts (deffact) 75 | (format t "~S~%" deffact) 76 | (values deffact)) 77 | 78 | (defun parse-and-insert-deffacts (name body) 79 | (let ((deffacts (gensym))) 80 | `(let ((,deffacts (list))) 81 | (dolist (fact ',body) 82 | (let ((head (first fact))) 83 | (ensure-meta-data-exists head) 84 | (push 85 | (apply #'make-fact head (rest fact)) 86 | ,deffacts))) 87 | (add-autofact (inference-engine) (make-deffacts ',name (nreverse ,deffacts)))))) 88 | 89 | -------------------------------------------------------------------------------- /src/core/heap.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Lisp -*- 2 | ;;; 3 | ;;; Copyright (c) 2002, 2003 Gene Michael Stover. 4 | ;;; 5 | ;;; This library is free software; you can redistribute it 6 | ;;; and/or modify it under the terms of version 2.1 of the GNU 7 | ;;; Lesser General Public License as published by the Free 8 | ;;; Software Foundation. 9 | ;;; 10 | ;;; This library is distributed in the hope that it will be 11 | ;;; useful, but WITHOUT ANY WARRANTY; without even the implied 12 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 13 | ;;; PURPOSE. See the GNU General Public License for more 14 | ;;; details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public 17 | ;;; License along with this library; if not, write to the 18 | ;;; Free Software Foundation, Inc., 59 Temple Place, Suite 330, 19 | ;;; Boston, MA 02111-1307 USA 20 | ;;; 21 | 22 | ;;; Adapted for Lisa: 4/3/2006. 23 | 24 | (in-package :lisa.heap) 25 | 26 | (defstruct heap 27 | less-fn 28 | order 29 | a 30 | max-count) 31 | 32 | (defun default-search-predicate (heap obj) 33 | (declare (ignore heap) (ignore obj)) 34 | t) 35 | 36 | (defun percolate-down (heap hole x) 37 | "Private. Move the HOLE down until it's in a location suitable for X. 38 | Return the new index of the hole." 39 | (do ((a (heap-a heap)) 40 | (less (heap-less-fn heap)) 41 | (child (lesser-child heap hole) (lesser-child heap hole))) 42 | ((or (>= child (fill-pointer a)) (funcall less x (aref a child))) 43 | hole) 44 | (setf (aref a hole) (aref a child) 45 | hole child))) 46 | 47 | (defun percolate-up (heap hole x) 48 | "Private. Moves the HOLE until it's in a location suitable for holding 49 | X. Does not actually bind X to the HOLE. Returns the new 50 | index of the HOLE. The hole itself percolates down; it's the X 51 | that percolates up." 52 | (let ((d (heap-order heap)) 53 | (a (heap-a heap)) 54 | (less (heap-less-fn heap))) 55 | (setf (aref a 0) x) 56 | (do ((i hole parent) 57 | (parent (floor (/ hole d)) (floor (/ parent d)))) 58 | ((not (funcall less x (aref a parent))) i) 59 | (setf (aref a i) (aref a parent))))) 60 | 61 | (defvar *heap* nil) 62 | 63 | (defun heap-init (heap less-fn &key (order 2) (initial-contents nil)) 64 | "Initialize the indicated heap. If INITIAL-CONTENTS is a non-empty 65 | list, the heap's contents are intiailized to the values in that 66 | list; they are ordered according to LESS-FN. INITIAL-CONTENTS must 67 | be a list or NIL." 68 | (setf *heap* heap) 69 | (setf (heap-less-fn heap) less-fn 70 | (heap-order heap) order 71 | (heap-a heap) (make-array 2 :initial-element nil 72 | :adjustable t :fill-pointer 1) 73 | (heap-max-count heap) 0) 74 | (when initial-contents 75 | (dolist (i initial-contents) (vector-push-extend i (heap-a heap))) 76 | (loop for i from (floor (/ (length (heap-a heap)) order)) downto 1 77 | do (let* ((tmp (aref (heap-a heap) i)) 78 | (hole (percolate-down heap i tmp))) 79 | (setf (aref (heap-a heap) hole) tmp))) 80 | (setf (heap-max-count heap) (length (heap-a heap)))) 81 | heap) 82 | 83 | (defun create-heap (less-fn &key (order 2) (initial-contents nil)) 84 | (heap-init (make-heap) less-fn :order order 85 | :initial-contents initial-contents)) 86 | 87 | (defun heap-clear (heap) 88 | "Remove all elements from the heap, leaving it empty. Faster 89 | (& more convenient) than calling HEAP-REMOVE until the heap is 90 | empty." 91 | (setf (fill-pointer (heap-a heap)) 1) 92 | nil) 93 | 94 | (defun heap-count (heap) 95 | (1- (fill-pointer (heap-a heap)))) 96 | 97 | (defun heap-empty-p (heap) 98 | "Returns non-NIL if & only if the heap contains no items." 99 | (= (fill-pointer (heap-a heap)) 1)) 100 | 101 | (defun heap-insert (heap x) 102 | "Insert a new element into the heap. Return the element (which probably 103 | isn't very useful)." 104 | (let ((a (heap-a heap))) 105 | ;; Append a hole for the new element. 106 | (vector-push-extend nil a) 107 | 108 | ;; Move the hole from the end towards the front of the 109 | ;; queue until it is in the right position for the new 110 | ;; element. 111 | (setf (aref a (percolate-up heap (1- (fill-pointer a)) x)) x))) 112 | 113 | (defun heap-find-idx (heap fnp) 114 | "Return the index of the element which satisfies the predicate FNP. 115 | If there is no such element, return the fill pointer of HEAP's array A." 116 | (do* ((a (heap-a heap)) 117 | (fp (fill-pointer a)) 118 | (i 1 (1+ i))) 119 | ((or (>= i fp) (funcall fnp heap (aref a i))) 120 | i))) 121 | 122 | (defun heap-remove (heap &optional (fn #'default-search-predicate)) 123 | "Remove the minimum (first) element in the heap & return it. It's 124 | an error if the heap is already empty. (Should that be an error?)" 125 | (let ((a (heap-a heap)) 126 | (i (heap-find-idx heap fn))) 127 | (cond ((< i (fill-pointer a));; We found an element to remove. 128 | (let ((x (aref a i)) 129 | (last-object (vector-pop a))) 130 | (setf (aref a (percolate-down heap i last-object)) last-object) 131 | x)) 132 | (t nil))));; Nothing to remove 133 | 134 | (defun heap-find (heap &optional (fn #'default-search-predicate)) 135 | (let ((a (heap-a heap)) 136 | (i (heap-find-idx heap fn))) 137 | (cond ((< i (fill-pointer a)) ; We found an element to remove. 138 | (aref a i)) 139 | (t nil)))) 140 | 141 | (defun heap-collect (heap &optional (fn #'default-search-predicate)) 142 | (if (heap-empty-p heap) 143 | nil 144 | (loop for obj across (heap-a heap) 145 | when (funcall fn heap obj) 146 | collect obj))) 147 | 148 | (defun heap-peek (heap) 149 | "Return the first element in the heap, but don't remove it. It'll 150 | be an error if the heap is empty. (Should that be an error?)" 151 | (aref (heap-a heap) 1)) 152 | 153 | (defun lesser-child (heap parent) 154 | "Return the index of the lesser child. If there's one child, 155 | return its index. If there are no children, return 156 | (FILL-POINTER (HEAP-A HEAP))." 157 | (let* ((a (heap-a heap)) 158 | (left (* parent (heap-order heap))) 159 | (right (1+ left)) 160 | (fp (fill-pointer a))) 161 | (cond ((>= left fp) fp) 162 | ((= right fp) left) 163 | ((funcall (heap-less-fn heap) (aref a left) (aref a right)) left) 164 | (t right)))) 165 | 166 | (provide "heap") 167 | 168 | ;;; --- end of file --- 169 | 170 | -------------------------------------------------------------------------------- /src/core/meta.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Meta operations that Lisa uses to support the manipulation of 26 | ;; facts and instances. 27 | 28 | ;; NB: A note on terminology. We make the distinction here between symbolic 29 | ;; slot names and effective slot names. The former refers to an internal 30 | ;; symbol, created by Lisa, used to identify fact slots within rules; the 31 | ;; latter refers to the actual, package-qualified slot name. 32 | 33 | (in-package :lisa) 34 | 35 | (defun get-class-name (meta-object) 36 | (fact-meta-object-class-name meta-object)) 37 | 38 | (defun get-slot-list (meta-object) 39 | (fact-meta-object-slot-list meta-object)) 40 | 41 | (defun get-superclasses (meta-object) 42 | (fact-meta-object-superclasses meta-object)) 43 | 44 | (defun find-meta-fact (symbolic-name &optional (errorp t)) 45 | "Locates the META-FACT instance associated with SYMBOLIC-NAME. If ERRORP is 46 | non-nil, signals an error if no binding is found." 47 | (let ((meta-fact (find-meta-object (inference-engine) symbolic-name))) 48 | (when (and errorp (null meta-fact)) 49 | (log:error "This fact does not have a registered meta class: ~S" symbolic-name) 50 | (error t)) 51 | meta-fact)) 52 | 53 | ;;; Corrected version courtesy of Aneil Mallavarapu... 54 | 55 | (defun acquire-meta-data (actual-name) 56 | (labels ((build-meta-object (class all-superclasses) ; NEW LINE (AM 9/19/03) 57 | (let* ((class-name (class-name class)) 58 | (meta-data 59 | (make-fact-meta-object 60 | :class-name class-name 61 | :slot-list (reflect:class-slot-list class) 62 | :superclasses all-superclasses))) ; new line (AM 9/19/03) 63 | (register-meta-object (inference-engine) class-name meta-data) 64 | meta-data)) 65 | (examine-class (class-object) 66 | (let ((superclasses 67 | (if *consider-taxonomy-when-reasoning* 68 | (reflect:class-all-superclasses class-object) ; NEW LINE (AM 9/19/03) 69 | nil))) 70 | (build-meta-object class-object superclasses) 71 | (dolist (super superclasses) 72 | (examine-class super))))) 73 | (examine-class (find-class actual-name)))) 74 | 75 | ;;; Corrected version courtesy of Aneil Mallavarapu... 76 | 77 | (defun import-class-specification (class-name) 78 | (labels ((import-class-object (class-object) ; defined this internal function 79 | (let ((class-symbols (list class-name))) 80 | (dolist (slot-name (reflect:class-slot-list class-object)) 81 | (push slot-name class-symbols)) 82 | (import class-symbols) 83 | (when *consider-taxonomy-when-reasoning* 84 | (dolist (ancestor (reflect:find-direct-superclasses class-object)) 85 | (import-class-object ancestor))) ; changed to import-class-object 86 | class-object))) 87 | (import-class-object (find-class class-name)))) 88 | 89 | (defun ensure-meta-data-exists (class-name) 90 | (flet ((ensure-class-definition () 91 | (loop 92 | (when (find-class class-name nil) 93 | (acquire-meta-data class-name) 94 | (return)) 95 | (log:error "Lisa doesn't know about the template named by (~S)." class-name) 96 | (error t)))) 97 | (let ((meta-data (find-meta-object (inference-engine) class-name))) 98 | (when (null meta-data) 99 | (ensure-class-definition) 100 | (setf meta-data 101 | (find-meta-object (inference-engine) class-name))) 102 | meta-data))) 103 | -------------------------------------------------------------------------------- /src/core/pattern.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Structures here collectively represent patterns after they've 26 | ;; been analysed by the language parser. This is the canonical representation 27 | ;; of parsed patterns that Rete compilers are intended to see. 28 | 29 | (in-package :lisa) 30 | 31 | ;;; Represents the canonical form of a slot within a pattern analysed by the 32 | ;;; DEFRULE parser. NAME is the slot identifier; VALUE is the slot's value, 33 | ;;; and its type can be one of (symbol number string list) or a LISA variable; 34 | ;;; SLOT-BINDING is the binding object, present if VALUE is a LISA variable; 35 | ;;; NEGATED is non-NIL if the slot occurs within a NOT form; 36 | ;;; INTRA-PATTERN-BINDINGS is a list of binding objects, present if all of the 37 | ;;; variables used by the slot reference bindings within the slot's pattern; 38 | ;;; CONSTRAINT, if not NIL, represents a constraint placed on the slot's 39 | ;;; value. CONSTRAINT should only be non-NIL if VALUE is a variable, and can 40 | ;;; be one of the types listed for VALUE or a CONS representing arbitrary 41 | ;;; Lisp code; CONSTRAINT-BINDINGS is a list of binding objects that are 42 | ;;; present if the slot has a constraint. 43 | 44 | (defstruct pattern-slot 45 | "Represents the canonical form of a slot within a pattern analysed by the 46 | DEFRULE parser." 47 | (name nil :type symbol) 48 | (value nil) 49 | (slot-binding nil :type list) 50 | (negated nil :type symbol) 51 | (intra-pattern-bindings nil :type symbol) 52 | (constraint nil) 53 | (constraint-bindings nil :type list)) 54 | 55 | ;;; PARSED-PATTERN represents the canonical form of a pattern analysed by the 56 | ;;; language parser. CLASS is the name, or head, of the pattern, as a symbol; 57 | ;;; SLOTS is a list of PATTERN-SLOT objects representing the analysed slots of 58 | ;;; the pattern; ADDRESS is a small integer representing the pattern's 59 | ;;; position within the rule form, starting at 0; PATTERN-BINDING, if not NIL, 60 | ;;; is the variable to which a fact matching the pattern will be bound during 61 | ;;; the match process; TEST-BINDINGS is a list of BINDING objects present if 62 | ;;; the pattern is a TEST CE; BINDING-SET is the set of variable bindings used 63 | ;;; by the pattern; TYPE is one of (:GENERIC :NEGATED :TEST :OR) and indicates 64 | ;;; the kind of pattern represented; SUB-PATTERNS, if non-NIL, is set for an 65 | ;;; OR CE and is a list of PARSED-PATTERN objects that represent the branches 66 | ;;; within the OR; LOGICAL, if non-NIL, indicates this pattern participates in 67 | ;;; truth maintenance. 68 | 69 | (defstruct parsed-pattern 70 | "Represents the canonical form of a pattern analysed by the DEFRULE parser." 71 | (class nil :type symbol) 72 | (slots nil) 73 | (address 0 :type integer) 74 | (pattern-binding nil) 75 | (test-bindings nil :type list) 76 | (binding-set nil :type list) 77 | (logical nil :type symbol) 78 | (sub-patterns nil :type list) 79 | (type :generic :type symbol)) 80 | 81 | (defstruct rule-actions 82 | (bindings nil :type list) 83 | (actions nil :type list)) 84 | 85 | (defun generic-pattern-p (pattern) 86 | (eq (parsed-pattern-type pattern) :generic)) 87 | 88 | (defun existential-pattern-p (pattern) 89 | (eq (parsed-pattern-type pattern) :existential)) 90 | 91 | (defun test-pattern-p (pattern) 92 | (eq (parsed-pattern-type pattern) :test)) 93 | 94 | (defun test-pattern-predicate (pattern) 95 | (parsed-pattern-slots pattern)) 96 | 97 | (defun negated-pattern-p (pattern) 98 | (eq (parsed-pattern-type pattern) :negated)) 99 | 100 | (defun parsed-pattern-test-forms (pattern) 101 | (cl:assert (test-pattern-p pattern) nil 102 | "This pattern is not a test pattern: ~S" pattern) 103 | (parsed-pattern-slots pattern)) 104 | 105 | (defun simple-slot-p (pattern-slot) 106 | (not (variablep (pattern-slot-value pattern-slot)))) 107 | 108 | (defun intra-pattern-slot-p (pattern-slot) 109 | (or (simple-slot-p pattern-slot) 110 | (pattern-slot-intra-pattern-bindings pattern-slot))) 111 | 112 | (defun constrained-slot-p (pattern-slot) 113 | (not (null (pattern-slot-constraint pattern-slot)))) 114 | 115 | (defun simple-bound-slot-p (pattern-slot) 116 | (and (variablep (pattern-slot-value pattern-slot)) 117 | (not (constrained-slot-p pattern-slot)))) 118 | 119 | (defun negated-slot-p (pattern-slot) 120 | (pattern-slot-negated pattern-slot)) 121 | 122 | (defun bound-pattern-p (parsed-pattern) 123 | (not (null (parsed-pattern-pattern-binding parsed-pattern)))) 124 | 125 | (defun compound-pattern-p (parsed-pattern) 126 | (not (null (parsed-pattern-sub-patterns parsed-pattern)))) 127 | 128 | (defun logical-pattern-p (parsed-pattern) 129 | (parsed-pattern-logical parsed-pattern)) 130 | -------------------------------------------------------------------------------- /src/core/preamble.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defvar *active-rule* nil) 28 | (defvar *active-engine* nil) 29 | (defvar *active-tokens* nil) 30 | (defvar *active-context* nil) 31 | (defvar *ignore-this-instance*) 32 | 33 | (defmacro with-auto-notify ((var instance) &body body) 34 | `(let* ((,var ,instance) 35 | (*ignore-this-instance* ,var)) 36 | ,@body)) 37 | 38 | (defgeneric make-rete-network (&rest args &key &allow-other-keys)) 39 | 40 | (defun active-context () 41 | *active-context*) 42 | 43 | (defun active-tokens () 44 | *active-tokens*) 45 | 46 | (defun active-rule () 47 | *active-rule*) 48 | 49 | (defun active-engine () 50 | *active-engine*) 51 | 52 | (defun in-rule-firing-p () 53 | (not (null (active-rule)))) 54 | 55 | (defgeneric equals (a b)) 56 | (defgeneric slot-value-of-instance (object slot-name)) 57 | (defgeneric (setf slot-value-of-instance) (new-value object slot-name)) 58 | 59 | (defvar *consider-taxonomy-when-reasoning* nil) 60 | (defvar *allow-duplicate-facts* t) 61 | (defvar *use-fancy-assert* t) 62 | (defvar *clear-handlers* nil) 63 | 64 | (defun consider-taxonomy () 65 | *consider-taxonomy-when-reasoning*) 66 | 67 | (defsetf consider-taxonomy () (new-value) 68 | `(setf *consider-taxonomy-when-reasoning* ,new-value)) 69 | 70 | (defun allow-duplicate-facts () 71 | *allow-duplicate-facts*) 72 | 73 | (defsetf allow-duplicate-facts () (new-value) 74 | `(setf *allow-duplicate-facts* ,new-value)) 75 | 76 | (defun use-fancy-assert () 77 | *use-fancy-assert*) 78 | 79 | (defsetf use-fancy-assert () (new-value) 80 | `(setf *use-fancy-assert* ,new-value)) 81 | 82 | (defclass inference-engine-object () ()) 83 | 84 | (defmacro register-clear-handler (tag func) 85 | `(eval-when (:load-toplevel) 86 | (unless (assoc ,tag *clear-handlers* :test #'string=) 87 | (setf *clear-handlers* 88 | (acons ,tag ,func *clear-handlers*))))) 89 | 90 | (defun clear-system-environment () 91 | (mapc #'(lambda (assoc) 92 | (funcall (cdr assoc))) 93 | *clear-handlers*) 94 | t) 95 | 96 | (defun clear-environment-handlers () 97 | (setf *clear-handlers* nil)) 98 | 99 | (defun variable-p (obj) 100 | (and (symbolp obj) 101 | (char= (schar (symbol-name obj) 0) #\?))) 102 | 103 | (defmacro starts-with-? (sym) 104 | `(eq (aref (symbol-name ,sym) 0) #\?)) 105 | 106 | (defmacro variablep (sym) 107 | `(variable-p ,sym)) 108 | 109 | (defmacro quotablep (obj) 110 | `(and (symbolp ,obj) 111 | (not (starts-with-? ,obj)))) 112 | 113 | (defmacro literalp (sym) 114 | `(or (and (symbolp ,sym) 115 | (not (variablep ,sym)) 116 | (not (null ,sym))) 117 | (numberp ,sym) 118 | (stringp ,sym))) 119 | 120 | (defmacro multifieldp (val) 121 | `(and (listp ,val) 122 | (eq (first ,val) 'quote))) 123 | 124 | (defmacro slot-valuep (val) 125 | `(or (literalp ,val) 126 | (consp ,val) 127 | (variablep ,val))) 128 | 129 | (defmacro constraintp (constraint) 130 | `(or (null ,constraint) 131 | (literalp ,constraint) 132 | (consp ,constraint))) 133 | 134 | (defun make-default-inference-engine () 135 | (when (null *active-engine*) 136 | (setf *active-engine* (make-inference-engine))) 137 | *active-engine*) 138 | 139 | (defun use-default-engine () 140 | (warn "USE-DEFAULT-ENGINE is deprecated. Lisa now automatically creates a 141 | default instance of the inference engine at load time.") 142 | (when (null *active-engine*) 143 | (setf *active-engine* (make-inference-engine))) 144 | *active-engine*) 145 | 146 | (defun current-engine (&optional (errorp t)) 147 | "Returns the currently-active inference engine. Usually only invoked by code 148 | running within the context of WITH-INFERENCE-ENGINE." 149 | (when errorp 150 | (cl:assert (not (null *active-engine*)) (*active-engine*) 151 | "The current inference engine has not been established.")) 152 | *active-engine*) 153 | 154 | (defun inference-engine (&rest args) 155 | (apply #'current-engine args)) 156 | 157 | (defmacro with-inference-engine ((engine) &body body) 158 | "Evaluates BODY within the context of the inference engine ENGINE. This 159 | macro is MP-safe." 160 | `(let ((*active-engine* ,engine)) 161 | (progn ,@body))) 162 | 163 | (register-clear-handler 164 | "environment" 165 | #'(lambda () 166 | (setf *active-engine* (make-inference-engine)) 167 | (setf *active-context* (find-context (inference-engine) :initial-context)))) 168 | -------------------------------------------------------------------------------- /src/core/retrieve.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defvar *query-result* nil 28 | "Holds the results of query firings.") 29 | 30 | (defun run-query (query-rule) 31 | "Runs a query (RULE instance), and returns both the value of *QUERY-RESULT* 32 | and the query name itself." 33 | (declare (ignorable query-rule)) 34 | (let ((*query-result* (list))) 35 | (assert (query-fact)) 36 | (run) 37 | *query-result*)) 38 | 39 | (defmacro defquery (name &body body) 40 | "Defines a new query identified by the symbol NAME." 41 | `(define-rule ,name ',body)) 42 | 43 | ;;; Queries fired by RETRIEVE collect their results in the special variable 44 | ;;; *QUERY-RESULT*. As an example, one firing of this query, 45 | ;;; 46 | ;;; (retrieve (?x ?y) 47 | ;;; (?x (rocky (name ?name))) 48 | ;;; (?y (hobbit (name ?name)))) 49 | ;;; 50 | ;;; will produce a result similar to, 51 | ;;; 52 | ;;; (((?X . #) (?Y . #))) 53 | 54 | #+nil 55 | (defmacro retrieve ((&rest varlist) &body body) 56 | (flet ((make-query-binding (var) 57 | `(cons ',var ,var))) 58 | (let ((query-name (gensym)) 59 | (query (gensym))) 60 | `(with-inference-engine 61 | ((make-query-engine (inference-engine))) 62 | (let* ((,query-name (gensym)) 63 | (,query 64 | (defquery ',query-name 65 | (query-fact) 66 | ,@body 67 | => 68 | (push (list ,@(mapcar #'make-query-binding varlist)) 69 | *query-result*)))) 70 | (run-query ,query)))))) 71 | 72 | (defmacro retrieve ((&rest varlist) &body body) 73 | (let ((query-name (gensym)) 74 | (query (gensym))) 75 | `(with-inference-engine 76 | ((make-query-engine (inference-engine))) 77 | (let* ((,query-name (gensym)) 78 | (,query 79 | (defquery ',query-name 80 | (query-fact) 81 | ,@body 82 | => 83 | (push (list ,@(mapcar #'(lambda (var) 84 | var) 85 | varlist)) 86 | *query-result*)))) 87 | (run-query ,query))))) 88 | 89 | (defmacro with-simple-query ((var value) query &body body) 90 | "For each variable/instance pair in a query result, invoke BODY with VAR 91 | bound to the query variable and VALUE bound to the instance." 92 | (let ((result (gensym))) 93 | `(let ((,result ,query)) 94 | (dolist (match ,result) 95 | (dolist (binding match) 96 | (let ((,var (car binding)) 97 | (,value (cdr binding))) 98 | ,@body)))))) 99 | -------------------------------------------------------------------------------- /src/core/tms-support.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Support functions for Lisa's Truth Maintenance System (TMS). 26 | 27 | (in-package :lisa) 28 | 29 | (defvar *scheduled-dependencies*) 30 | 31 | (define-symbol-macro scheduled-dependencies *scheduled-dependencies*) 32 | 33 | (defun add-logical-dependency (rete fact dependency-set) 34 | (setf (gethash dependency-set (rete-dependency-table rete)) 35 | (push fact (gethash dependency-set (rete-dependency-table rete))))) 36 | 37 | (defun find-logical-dependencies (rete dependency-set) 38 | (gethash dependency-set (rete-dependency-table rete))) 39 | 40 | (defun make-dependency-set (tokens marker) 41 | (let ((dependencies (list))) 42 | (loop for i from 1 to marker 43 | do (push (token-find-fact tokens i) dependencies)) 44 | (nreverse dependencies))) 45 | 46 | (defun schedule-dependency-removal (dependency-set) 47 | (push dependency-set scheduled-dependencies)) 48 | 49 | (defmacro with-truth-maintenance ((rete) &body body) 50 | (let ((rval (gensym))) 51 | `(let* ((*scheduled-dependencies* (list)) 52 | (,rval 53 | (progn ,@body))) 54 | (dolist (dependency scheduled-dependencies) 55 | (with-accessors ((table rete-dependency-table)) ,rete 56 | (dolist (dependent-fact 57 | (gethash dependency table) 58 | (remhash dependency table)) 59 | (retract-fact ,rete dependent-fact)))) 60 | ,rval))) 61 | -------------------------------------------------------------------------------- /src/core/token.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defconstant +fact-vec-init-len+ 64) 28 | 29 | (defclass token () 30 | ((facts :initform 31 | (make-array +fact-vec-init-len+ :initial-element nil :adjustable t :fill-pointer 0) 32 | :type vector 33 | :accessor token-facts) 34 | (not-counter :initform 0 35 | :accessor token-not-counter) 36 | (exists-counter :initform 0 37 | :accessor token-exists-counter) 38 | (hash-code :initform (list) 39 | :accessor token-hash-code) 40 | (fact-count :initform 0 41 | :type (unsigned-byte 64) 42 | :accessor token-fact-count))) ; big performance optimization 43 | 44 | (defclass add-token (token) ()) 45 | (defclass remove-token (token) ()) 46 | (defclass reset-token (token) ()) 47 | 48 | (defun token-increment-exists-counter (token) 49 | (incf (token-exists-counter token))) 50 | 51 | (defun token-decrement-exists-counter (token) 52 | (cl:assert (plusp (token-exists-counter token)) nil 53 | "The EXISTS join node logic is busted.") 54 | (decf (token-exists-counter token))) 55 | 56 | (defun token-increment-not-counter (token) 57 | (values token (incf (token-not-counter token)))) 58 | 59 | (defun token-decrement-not-counter (token) 60 | (cl:assert (plusp (token-not-counter token)) nil 61 | "The negated join node logic is busted.") 62 | (values token (decf (token-not-counter token)))) 63 | 64 | (defun token-negated-p (token) 65 | (plusp (token-not-counter token))) 66 | 67 | (defun token-make-fact-list (token &key (detailp t) (debugp nil)) 68 | (let* ((facts (list)) 69 | (vector (token-facts token)) 70 | (length (token-fact-count token))) 71 | (dotimes (i length) 72 | (let ((fact (aref vector i))) 73 | (if debugp 74 | (push fact facts) 75 | (when (typep fact 'fact) 76 | (push (if detailp fact (fact-symbolic-id fact)) 77 | facts))))) 78 | (nreverse facts))) 79 | 80 | (defun token-find-fact (token address) 81 | (aref (slot-value token 'facts) address)) 82 | 83 | (defun token-top-fact (token) 84 | (with-slots ((fact-vector facts) 85 | (fact-count fact-count)) token 86 | (declare (type fixnum fact-count) (type (vector t) fact-vector)) 87 | (aref fact-vector (1- fact-count)))) 88 | 89 | ;;; Using WITH-SLOTS yields a 2x improvement in CPU usage during profiling. 90 | 91 | (defun token-push-fact (token fact) 92 | (declare (optimize (speed 3) (safety 1) (debug 0))) 93 | (with-slots ((fact-vector facts) 94 | (fact-count fact-count) 95 | (hash-code hash-code)) token 96 | (declare (type fixnum fact-count) (type (vector t) fact-vector)) 97 | (vector-push-extend fact fact-vector) 98 | (push fact hash-code) 99 | (incf fact-count)) 100 | token) 101 | 102 | (defun token-pop-fact (token) 103 | (declare (type token token)) 104 | (declare (optimize (speed 3) (safety 1) (debug 0))) 105 | (with-slots ((fact-vector facts) 106 | (hash-code hash-code) 107 | (fact-count fact-count)) token 108 | (declare (type fixnum fact-count) (type (vector t) fact-vector)) 109 | (unless (zerop (fill-pointer fact-vector)) 110 | (pop hash-code) 111 | (decf fact-count) 112 | (aref fact-vector (decf (fill-pointer fact-vector)))))) 113 | 114 | (defun fast-array-copy (target-array token count) 115 | (declare (type fixnum count) (type (vector t) target-array) (type token token)) 116 | (declare (optimize (speed 3) (debug 0) (safety 1))) 117 | (dotimes (i count) 118 | (token-push-fact token (aref target-array i))) 119 | target-array) 120 | 121 | (defun replicate-token (token &key (token-class nil)) 122 | (declare (optimize (speed 3) (safety 1) (debug 0))) 123 | (let ((new-token 124 | (make-instance (if token-class 125 | (find-class token-class) 126 | (class-of token))))) 127 | (with-slots ((existing-fact-vector facts)) token 128 | (let ((length (token-fact-count token))) 129 | (declare (type fixnum length)) 130 | (fast-array-copy existing-fact-vector new-token length))) 131 | new-token)) 132 | 133 | (defmethod hash-key ((self token)) 134 | (token-hash-code self)) 135 | 136 | (defmethod make-add-token ((fact fact)) 137 | (token-push-fact (make-instance 'add-token) fact)) 138 | 139 | (defmethod make-remove-token ((fact fact)) 140 | (token-push-fact (make-instance 'remove-token) fact)) 141 | 142 | (defmethod make-remove-token ((token token)) 143 | (replicate-token token :token-class 'remove-token)) 144 | 145 | (defmethod make-reset-token ((fact t)) 146 | (token-push-fact (make-instance 'reset-token) t)) 147 | -------------------------------------------------------------------------------- /src/core/watches.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defvar *assert-fact* nil) 28 | (defvar *retract-fact* nil) 29 | (defvar *enable-activation* nil) 30 | (defvar *disable-activation* nil) 31 | (defvar *fire-rule* nil) 32 | (defvar *watches* nil) 33 | 34 | (defun watch-activation-detail (activation direction) 35 | (format *trace-output* "~A Activation: ~A : ~A~%" 36 | direction 37 | (rule-default-name (activation-rule activation)) 38 | (activation-fact-list activation)) 39 | (values)) 40 | 41 | (defun watch-enable-activation (activation) 42 | (watch-activation-detail activation "==>")) 43 | 44 | (defun watch-disable-activation (activation) 45 | (watch-activation-detail activation "<==")) 46 | 47 | (defun watch-rule-firing (activation) 48 | (let ((rule (activation-rule activation))) 49 | (format *trace-output* "FIRE ~D: ~A ~A~%" 50 | (rete-firing-count (rule-engine rule)) 51 | (rule-default-name rule) 52 | (activation-fact-list activation)) 53 | (values))) 54 | 55 | (defun watch-fact-detail (fact direction) 56 | (format *trace-output* "~A ~A ~S~%" 57 | direction (fact-symbolic-id fact) 58 | (reconstruct-fact fact)) 59 | (values)) 60 | 61 | (defun watch-assert (fact) 62 | (watch-fact-detail fact "==>")) 63 | 64 | (defun watch-retract (fact) 65 | (watch-fact-detail fact "<==")) 66 | 67 | (defun watch-event (event) 68 | (ecase event 69 | (:facts (setf *assert-fact* #'watch-assert) 70 | (setf *retract-fact* #'watch-retract)) 71 | (:activations (setf *enable-activation* #'watch-enable-activation) 72 | (setf *disable-activation* #'watch-disable-activation)) 73 | (:rules (setf *fire-rule* #'watch-rule-firing)) 74 | (:all (watch-event :facts) 75 | (watch-event :activations) 76 | (watch-event :rules))) 77 | (unless (eq event :all) 78 | (pushnew event *watches*)) 79 | event) 80 | 81 | (defun unwatch-event (event) 82 | (ecase event 83 | (:facts (setf *assert-fact* nil) 84 | (setf *retract-fact* nil)) 85 | (:activations (setf *enable-activation* nil) 86 | (setf *disable-activation* nil)) 87 | (:rules (setf *fire-rule* nil)) 88 | (:all (unwatch-event :facts) 89 | (unwatch-event :activations) 90 | (unwatch-event :rules))) 91 | (unless (eq event :all) 92 | (setf *watches* 93 | (delete event *watches*))) 94 | event) 95 | 96 | (defun watches () 97 | *watches*) 98 | 99 | (defmacro trace-assert (fact) 100 | `(unless (null *assert-fact*) 101 | (funcall *assert-fact* ,fact))) 102 | 103 | (defmacro trace-retract (fact) 104 | `(unless (null *retract-fact*) 105 | (funcall *retract-fact* ,fact))) 106 | 107 | (defmacro trace-enable-activation (activation) 108 | `(unless (null *enable-activation*) 109 | (funcall *enable-activation* ,activation))) 110 | 111 | (defmacro trace-disable-activation (activation) 112 | `(unless (null *disable-activation*) 113 | (funcall *disable-activation* ,activation))) 114 | 115 | (defmacro trace-firing (activation) 116 | `(unless (null *fire-rule*) 117 | (funcall *fire-rule* ,activation))) 118 | -------------------------------------------------------------------------------- /src/debugger/lisa-debugger.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: The LISA debugger. 26 | 27 | (in-package :lisa) 28 | 29 | (defvar *breakpoints* (make-hash-table)) 30 | (defvar *stepping* nil) 31 | (defvar *read-eval-print*) 32 | (defvar *suspended-rule*) 33 | (defvar *tokens*) 34 | 35 | (defmacro in-debugger-p () 36 | `(cl:assert (boundp '*suspended-rule*) nil 37 | "The debugger must be running to use this function.")) 38 | 39 | #+LispWorks 40 | (defmacro with-debugger-streams (&body body) 41 | `(let ((*standard-input* *standard-input*) 42 | (*standard-output* *standard-output*) 43 | (*terminal-io* *terminal-io*)) 44 | (progn ,@body))) 45 | 46 | #-LispWorks 47 | (defmacro with-debugger-streams (&body body) 48 | `(let ((*terminal-io* *terminal-io*) 49 | (*standard-input* *terminal-io*) 50 | (*standard-output* *terminal-io*)) 51 | (progn ,@body))) 52 | 53 | (defun leave-debugger () 54 | (setf *stepping* nil)) 55 | 56 | (defun has-breakpoint-p (rule) 57 | (gethash (rule-name rule) *breakpoints*)) 58 | 59 | (defun breakpoints () 60 | (format t "Current breakpoints:~%") 61 | (loop for rule-name being the hash-value of *breakpoints* 62 | do (format t " ~A~%" rule-name)) 63 | (values)) 64 | 65 | (defun breakpoint-operation (rule-name op) 66 | (let ((rule (find-rule (inference-engine) rule-name))) 67 | (cond ((null rule) 68 | (format t "There's no rule by this name (~A)~%" rule-name)) 69 | (t 70 | (funcall op (rule-name rule)))) 71 | rule-name)) 72 | 73 | (defun set-break (rule-name) 74 | (breakpoint-operation 75 | rule-name #'(lambda (rule-name) 76 | (setf (gethash rule-name *breakpoints*) 77 | rule-name))) 78 | rule-name) 79 | 80 | (defun clear-break (rule-name) 81 | (breakpoint-operation 82 | rule-name #'(lambda (rule-name) 83 | (remhash rule-name *breakpoints*))) 84 | rule-name) 85 | 86 | (defun clear-breaks () 87 | (clrhash *breakpoints*) 88 | nil) 89 | 90 | (defun next () 91 | (in-debugger-p) 92 | (setf *stepping* t) 93 | (setf *read-eval-print* nil) 94 | (values)) 95 | 96 | (defun resume () 97 | (in-debugger-p) 98 | (setf *read-eval-print* nil) 99 | (setf *stepping* nil) 100 | (values)) 101 | 102 | (defun instance (fact) 103 | (find-instance-of-fact fact)) 104 | 105 | (defun token (index) 106 | (in-debugger-p) 107 | (cl:assert (and (not (minusp index)) 108 | (< index (token-fact-count *tokens*))) 109 | nil "The token index isn't valid.") 110 | (let ((fact (token-find-fact *tokens* index))) 111 | (cond ((typep fact 'fact) 112 | fact) 113 | (t 114 | (format t "The index ~D references a non-fact object." index) 115 | nil)))) 116 | 117 | (defun tokens (&key (verbose nil)) 118 | (in-debugger-p) 119 | (format t "Token stack for ~A:~%" (rule-name (rule))) 120 | (do* ((facts (token-make-fact-list *tokens* :debugp t) (rest facts)) 121 | (fact (first facts) (first facts)) 122 | (index 0 (incf index))) 123 | ((endp facts)) 124 | (when (typep fact 'fact) 125 | (if verbose 126 | (format t " [~D] ~S~%" index fact) 127 | (format t " [~D] ~A, ~A~%" 128 | index 129 | (fact-symbolic-id fact) 130 | (fact-name fact))))) 131 | (values)) 132 | 133 | (defun bindings () 134 | (in-debugger-p) 135 | (format t "Effective bindings for ~A:~%" (rule-name (rule))) 136 | (dolist (binding (rule-binding-set (rule))) 137 | (format t " ~A: ~S~%" 138 | (binding-variable binding) 139 | (if (pattern-binding-p binding) 140 | (token-find-fact *tokens* (binding-address binding)) 141 | (get-slot-value 142 | (token-find-fact *tokens* (binding-address binding)) 143 | (binding-slot-name binding))))) 144 | (values)) 145 | 146 | (defun debugger-repl () 147 | (with-debugger-streams 148 | (do ((*read-eval-print* t) 149 | (count 0 (incf count))) 150 | ((not *read-eval-print*) count) 151 | (handler-case 152 | (progn 153 | (format t "LISA-DEBUG[~D]: " count) 154 | (force-output) 155 | (print (eval (read-from-string (read-line)))) 156 | (terpri)) 157 | (error (e) 158 | (cerror "Remain in the LISA debugger." e) 159 | (unless (yes-or-no-p "Remain in the debugger? ") 160 | (leave-debugger) 161 | (setf *read-eval-print* nil))))))) 162 | 163 | (defmethod fire-rule :around ((self rule) tokens) 164 | (when (or *stepping* 165 | (has-breakpoint-p self)) 166 | (let ((*active-rule* self) 167 | (*suspended-rule* self) 168 | (*tokens* tokens)) 169 | (format t "Stopping in rule ~S~%" (rule-name self)) 170 | (debugger-repl))) 171 | (call-next-method)) 172 | 173 | (defmethod run-engine :after ((self rete) &optional step) 174 | (leave-debugger)) 175 | 176 | (defmethod forget-rule :before ((self rete) (rule-name symbol)) 177 | (clear-break rule-name)) 178 | 179 | (provide 'lisa-debugger) 180 | -------------------------------------------------------------------------------- /src/grouping-stack/balancer.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.grouping-stack) 2 | 3 | (defclass balancer () 4 | ()) 5 | 6 | (defclass inactive-balancer (balancer) 7 | ()) 8 | 9 | (defmethod balance ((stack grouping-stack) (balancer inactive-balancer)) 10 | (declare (ignore balancer)) 11 | stack) 12 | 13 | (defclass sink-balancer (balancer) 14 | ((buffer-size :initarg :buffer-size :initform 2 :accessor buffer-size))) 15 | 16 | (defmethod balance ((stack grouping-stack) (balancer sink-balancer)) 17 | (let ((items (nthcdr (buffer-size balancer) (stack-items stack)))) 18 | (unless (null (cdr items)) 19 | (setf (car items) (make-instance 'item :content (apply #'combine (mapcar #'content items))) 20 | (cdr items) NIL)))) 21 | 22 | (defclass grouping-balancer (balancer) 23 | ((grouping-threshold :initarg :grouping-threshold :initform 2 :accessor grouping-threshold) 24 | (group-size :initarg :group-size :initform 2 :accessor group-size) 25 | (max-items :initarg :max-items :initform NIL :accessor max-items))) 26 | 27 | (defmethod balance ((stack grouping-stack) (balancer grouping-balancer)) 28 | ) 29 | -------------------------------------------------------------------------------- /src/grouping-stack/grouping-stack.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem grouping-stack 2 | :name "grouping-stack" 3 | :version "0.0.1" 4 | :license "Artistic" 5 | :author "Yukari Hafner " 6 | :maintainer "Yukari Hafner " 7 | :description "A stack implementation that allows automatic grouping and balancing of items for fast traversal." 8 | :homepage "https://github.com/Shinmera/SKEL" 9 | :serial T 10 | :components ((:file "package") 11 | (:file "item") 12 | (:file "stack") 13 | (:file "balancer")) 14 | :depends-on ()) 15 | -------------------------------------------------------------------------------- /src/grouping-stack/item.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.grouping-stack) 2 | 3 | (defgeneric combinable-p (a b) 4 | (:method (a b) 5 | (declare (ignore a b)) 6 | T)) 7 | 8 | (defgeneric combine (content &rest other-content)) 9 | 10 | (defclass item () 11 | ((content :initarg :content :initform (error "CONTENT required.") :accessor content))) 12 | 13 | (defmethod print-object ((item item) stream) 14 | (print-unreadable-object (item stream :type T) 15 | (write (content item) :stream stream)) 16 | item) 17 | 18 | (defun make-item (content) 19 | (make-instance 'item :content content)) 20 | 21 | (defclass group (item) 22 | ((items :initarg :items :initform () :accessor items))) 23 | 24 | (defmethod print-object ((group group) stream) 25 | (print-unreadable-object (group stream :type T) 26 | (write (content group) :stream stream) 27 | (write (items group))) 28 | group) 29 | -------------------------------------------------------------------------------- /src/grouping-stack/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:grouping-stack 3 | (:nicknames #:org.shirakumo.grouping-stack) 4 | (:use #:cl) 5 | ;; balancer.lisp 6 | (:export 7 | #:balancer 8 | #:inactive-balancer 9 | #:sink-balancer 10 | #:buffer-size) 11 | ;; item.lisp 12 | (:export 13 | #:combinable-p 14 | #:combine 15 | #:item 16 | #:content 17 | #:make-item 18 | #:group 19 | #:items) 20 | ;; stack.lisp 21 | (:export 22 | #:grouping-stack 23 | #:stack-items 24 | #:stack-count 25 | #:stack-balancer 26 | #:balance 27 | #:make-grouping-stack 28 | #:stack-push 29 | #:stack-push-many 30 | #:stack-pop 31 | #:stack-size 32 | #:stack-clear 33 | #:map-stack)) 34 | -------------------------------------------------------------------------------- /src/grouping-stack/stack.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.grouping-stack) 2 | 3 | (defclass grouping-stack () 4 | ((items :initform () :accessor stack-items) 5 | (count :initform 0 :accessor stack-count) 6 | (balancer :initarg :balancer :initform (error "BALANCER required.") :accessor stack-balancer))) 7 | 8 | (defmethod initialize-instance :after ((stack grouping-stack) &key) 9 | (etypecase (stack-items stack) (list)) 10 | (when (symbolp (stack-balancer stack)) 11 | (setf (stack-balancer stack) (make-instance (stack-balancer stack)))) 12 | (etypecase (stack-balancer stack) (balancer))) 13 | 14 | (defmethod print-object ((stack grouping-stack) stream) 15 | (print-unreadable-object (stack stream :type T :identity T) 16 | (format stream "(~d:~d) ~a" 17 | (stack-size stack) (stack-count stack) 18 | (class-name (class-of (stack-balancer stack))))) 19 | stack) 20 | 21 | (defgeneric balance (stack balancer) 22 | (:method ((stack grouping-stack) (balancer (eql T))) 23 | (balance stack (stack-balancer stack)))) 24 | 25 | (defun make-grouping-stack (balancer &key initial-contents) 26 | (let ((stack (make-instance 'grouping-stack :balancer balancer))) 27 | (setf (stack-items stack) (mapcar #'make-item initial-contents)) 28 | (setf (stack-count stack) (length (stack-items stack))) 29 | (balance stack T) 30 | stack)) 31 | 32 | (defgeneric stack-push (content stack) 33 | (:method (content (stack grouping-stack)) 34 | (push (make-instance 'item :content content) 35 | (stack-items stack)) 36 | (incf (stack-count stack)) 37 | (balance stack T) 38 | stack)) 39 | 40 | (defgeneric stack-push-many (contents stack) 41 | (:method ((contents list) (stack grouping-stack)) 42 | (dolist (content contents) 43 | (push (make-instance 'item :content content) 44 | (stack-items stack)) 45 | (incf (stack-count stack))) 46 | (balance stack T) 47 | stack)) 48 | 49 | (defgeneric stack-pop (stack) 50 | (:method ((stack grouping-stack)) 51 | (prog1 (content (pop (stack-items stack))) 52 | (decf (stack-count stack)) 53 | (balance stack T)))) 54 | 55 | (defgeneric stack-size (stack) 56 | (:method ((stack grouping-stack)) 57 | (length (stack-items stack)))) 58 | 59 | (defgeneric stack-clear (stack) 60 | (:method ((stack grouping-stack)) 61 | (setf (stack-items stack) ()) 62 | (setf (stack-count stack) 0) 63 | stack)) 64 | 65 | (defgeneric map-stack (function stack) 66 | (:method ((function function) (stack grouping-stack)) 67 | (loop for item in (stack-items stack) 68 | do (funcall function (content item))) 69 | stack)) 70 | -------------------------------------------------------------------------------- /src/implementations/aclrpc-support.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Experimental support for remote object reasoning, using Allegro's RPC implementation. 26 | 27 | (in-package "CL-USER") 28 | 29 | (eval-when (:compile-toplevel :load-toplevel :execute) 30 | (require 'aclrpc) 31 | (unless (find-package "LISA.RPC") 32 | (defpackage "LISA.RPC" 33 | (:use "LISA-LISP" "NET.RPC") 34 | (:nicknames "RPC")))) 35 | 36 | (in-package "LISA.RPC") 37 | 38 | (defclass remote-kb-class (standard-class) 39 | ((proxy-class-name :reader proxy-class-name))) 40 | 41 | (defclass remote-instance (rpc-remote-ref) 42 | () 43 | (:metaclass remote-kb-class)) 44 | 45 | (defmethod initialize-instance :after ((self remote-instance) &rest args) 46 | (declare (ignore args)) 47 | (setf (slot-value (class-of self) 'proxy-class-name) 48 | (intern (rr-type self) 'rpc))) 49 | 50 | (defmethod class-name ((class remote-kb-class)) 51 | (proxy-class-name class)) 52 | 53 | (defmethod lisa:slot-value-of-instance ((object remote-instance) slot-name) 54 | (rcall 'slot-value object slot-name)) 55 | 56 | (defmethod (setf lisa:slot-value-of-instance) 57 | (new-value (object remote-instance) slot-name) 58 | (rcall 'set-slot-value new-value object slot-name)) 59 | -------------------------------------------------------------------------------- /src/implementations/allegro-auto-notify.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Allegro-specific implementation of Lisa's auto-notification 26 | ;; mechanism, whereby changes to the slot values of CLOS instances, outside 27 | ;; of Lisa's control, are picked up via the MOP protocol and synchronized 28 | ;; with KB facts. 29 | 30 | (in-package :lisa) 31 | 32 | (defclass standard-kb-class (standard-class) ()) 33 | 34 | (defmethod make-instance :around ((self standard-kb-class) &rest initargs) 35 | (declare (ignore initargs)) 36 | (let ((*ignore-this-instance* self)) 37 | (call-next-method))) 38 | 39 | (defmethod (setf mop:slot-value-using-class) :after (new-value (class standard-kb-class) instance slot) 40 | (declare (ignore new-value)) 41 | (flet ((ignore-instance (object) 42 | (and (boundp '*ignore-this-instance*) 43 | (eq object *ignore-this-instance*)))) 44 | (unless (ignore-instance class) 45 | (mark-instance-as-changed 46 | instance :slot-id (clos:slot-definition-name slot))))) 47 | 48 | (defmethod validate-superclass ((class standard-kb-class) (superclass standard-class)) 49 | t) 50 | 51 | (eval-when (:load-toplevel) 52 | (pushnew :lisa-autonotify *features*)) 53 | -------------------------------------------------------------------------------- /src/implementations/cmucl-auto-notify.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: CMU-Lisp-specific implementation of Lisa's auto-notification 26 | ;; mechanism, whereby changes to the slot values of CLOS instances, outside 27 | ;; of Lisa's control, are picked up via the MOP protocol and synchronized 28 | ;; with KB facts. 29 | 30 | ;; This file courtesy of Fred Gilham. 31 | 32 | (in-package :lisa) 33 | 34 | (defclass standard-kb-class (standard-class) ()) 35 | 36 | (defmethod make-instance :around ((self standard-kb-class) &rest initargs) 37 | (declare (ignore initargs)) 38 | (let ((*ignore-this-instance* self)) 39 | (call-next-method))) 40 | 41 | (defmethod (setf mop:slot-value-using-class) :after (new-value (class standard-kb-class) instance slot) 42 | (declare (ignore new-value)) 43 | (flet ((ignore-instance (object) 44 | (and (boundp '*ignore-this-instance*) 45 | (eq object *ignore-this-instance*)))) 46 | (unless (ignore-instance class) 47 | (mark-instance-as-changed 48 | instance :slot-id (mop:slot-definition-name slot))))) 49 | 50 | (defmethod mop:validate-superclass ((class standard-kb-class) (superclass standard-class)) 51 | t) 52 | 53 | (eval-when (:load-toplevel) 54 | (pushnew :lisa-autonotify *features*)) 55 | -------------------------------------------------------------------------------- /src/implementations/lispworks-auto-notify.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Lispworks-specific code for Lisa's auto notification 26 | ;; mechanism, whereby changes to the slot values of CLOS instances, outside 27 | ;; of Lisa's control, are picked up via the MOP protocol and synchronized 28 | ;; with KB facts. 29 | 30 | (in-package :lisa) 31 | 32 | (defclass standard-kb-class (standard-class) ()) 33 | 34 | (defun lispworks-respond-to-slot-change (instance slot-name) 35 | (flet ((ignore-instance (object) 36 | (and (boundp '*ignore-this-instance*) 37 | (eq object *ignore-this-instance*)))) 38 | (unless (ignore-instance instance) 39 | (mark-instance-as-changed instance :slot-id slot-name)))) 40 | 41 | (defmethod initialize-instance :after ((self standard-kb-class) &rest initargs) 42 | (dolist (slot (clos:class-direct-slots self)) 43 | (dolist (writer (clos:slot-definition-writers slot)) 44 | (let* ((gf (ensure-generic-function writer)) 45 | (method-class (clos:generic-function-method-class gf))) 46 | (multiple-value-bind (body initargs) 47 | (clos:make-method-lambda gf (clos:class-prototype method-class) '(new-value object) 48 | nil 49 | `(lispworks-respond-to-slot-change 50 | object ',(clos:slot-definition-name slot))) 51 | (clos:add-method gf 52 | (apply #'make-instance method-class 53 | :function (compile nil body) 54 | :specializers `(,(find-class t) ,self) 55 | :qualifiers '(:after) 56 | :lambda-list '(value object) 57 | initargs))))))) 58 | 59 | (defmethod validate-superclass ((class standard-kb-class) (superclass standard-class)) 60 | t) 61 | 62 | (eval-when (:load-toplevel) 63 | (pushnew :lisa-autonotify *features*)) 64 | -------------------------------------------------------------------------------- /src/implementations/sbcl-auto-notify.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: CMU-Lisp-specific implementation of Lisa's auto-notification 26 | ;; mechanism, whereby changes to the slot values of CLOS instances, outside 27 | ;; of Lisa's control, are picked up via the MOP protocol and synchronized 28 | ;; with KB facts. 29 | 30 | ;; This file adapted to SBCL using Fred Gilham's submission for CMUCL. 31 | 32 | (in-package :lisa) 33 | 34 | (defclass standard-kb-class (standard-class) ()) 35 | 36 | (defmethod make-instance :around ((self standard-kb-class) &rest initargs) 37 | (declare (ignore initargs)) 38 | (let ((*ignore-this-instance* self)) 39 | (call-next-method))) 40 | 41 | (defmethod (setf sb-mop:slot-value-using-class) :after (new-value (class standard-kb-class) instance slot) 42 | (declare (ignore new-value)) 43 | (flet ((ignore-instance (object) 44 | (and (boundp '*ignore-this-instance*) 45 | (eq object *ignore-this-instance*)))) 46 | (unless (ignore-instance class) 47 | (mark-instance-as-changed 48 | instance :slot-id (sb-mop:slot-definition-name slot))))) 49 | 50 | (defmethod sb-mop:validate-superclass ((class standard-kb-class) (superclass standard-class)) 51 | t) 52 | 53 | (eval-when (:compile-toplevel :load-toplevel :execute) 54 | (pushnew :lisa-auto-notify *features*)) 55 | 56 | (provide 'lisa-auto-notify) 57 | -------------------------------------------------------------------------------- /src/implementations/workarounds.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Code in this file implements workarounds for bugs in the 26 | ;; various implementations. 27 | 28 | (in-package :lisa) 29 | 30 | #+cmu18 ;; workaround PCL bug, as per Paul Werkowski 31 | (defun pcl::inform-type-system-about-std-class (name) nil) 32 | -------------------------------------------------------------------------------- /src/logger/logger.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: This file configures some basic attributes of LOG4CL that make it 26 | ;; suitable for Lisa. 27 | 28 | (in-package :lisa) 29 | 30 | (defun logger-add-file-appender (path &key (backup nil)) 31 | (log:config :daily path :backup backup)) 32 | -------------------------------------------------------------------------------- /src/packages/pkgdecl.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Package declarations for Lisa. 26 | 27 | (in-package :cl-user) 28 | 29 | ;;; accommodate implementations whose CLOS is really PCL, like CMUCL... 30 | 31 | (eval-when (:compile-toplevel :load-toplevel :execute) 32 | (when (and (not (find-package 'clos)) 33 | (find-package 'pcl)) 34 | (rename-package (find-package 'pcl) 'pcl 35 | `(clos ,@(package-nicknames 'pcl))))) 36 | 37 | (eval-when (:compile-toplevel :load-toplevel :execute) 38 | (defpackage "LISA" 39 | (:use "COMMON-LISP") 40 | (:export 41 | "ASSERT" 42 | "DEFAULT" 43 | . 44 | #1=( 45 | "*SHOW-LISA-WARNINGS*" 46 | "=>" 47 | "ACTIVATION" 48 | "ACTIVE-NETWORK" 49 | "ACTIVE-RULE" 50 | "AGENDA" 51 | "ALLOW-DUPLICATE-FACTS" 52 | "ASSERT-INSTANCE" 53 | "AUTO-FOCUS-P" 54 | "BINDINGS" 55 | "BREAKPOINTS" 56 | "CLEAR" 57 | "CLEAR-BREAK" 58 | "CLEAR-BREAKS" 59 | "CONSIDER-TAXONOMY" 60 | "CONTEXT" 61 | "CONTEXT-NAME" 62 | "CONTEXTS" 63 | "CURRENT-ENGINE" 64 | "DEFCONTEXT" 65 | "DEFFACTS" 66 | "DEFIMPORT" 67 | "DEFRULE" 68 | "DEFTEMPLATE" 69 | "DEPENDENCIES" 70 | "DUPLICATE-FACT" 71 | "ENGINE" 72 | "EXISTS" 73 | "FACT" 74 | "FACT-ID" 75 | "FACT-NAME" 76 | "FACTS" 77 | "FIND-CONTEXT" 78 | "FIND-FACT-BY-ID" 79 | "FIND-FACT-BY-NAME" 80 | "FIND-RULE" 81 | "FOCUS" 82 | "FOCUS-STACK" 83 | "HALT" 84 | "IN-RULE-FIRING-P" 85 | "INFERENCE-ENGINE" 86 | "INITIAL-FACT" 87 | "INSTANCE" 88 | "LOGICAL" 89 | "LOGGER-ADD-FILE-APPENDER" 90 | "MAKE-INFERENCE-ENGINE" 91 | "MARK-INSTANCE-AS-CHANGED" 92 | "MODIFY" 93 | "NEXT" 94 | "REFOCUS" 95 | "RESET" 96 | "RESUME" 97 | "RETE" 98 | "RETE-NETWORK" 99 | "RETRACT" 100 | "RETRACT-INSTANCE" 101 | "RETRIEVE" 102 | "RULE" 103 | "RULE-COMMENT" 104 | "RULE-CONTEXT" 105 | "RULE-DEFAULT-NAME" 106 | "RULE-NAME" 107 | "RULE-SALIENCE" 108 | "RULE-SHORT-NAME" 109 | "RULES" 110 | "RUN" 111 | "SET-BREAK" 112 | "SHOW-NETWORK" 113 | "SLOT" 114 | "SLOT-VALUE-OF-INSTANCE" 115 | "STANDARD-KB-CLASS" 116 | "TEST" 117 | "TOKEN" 118 | "TOKENS" 119 | "UNDEFCONTEXT" 120 | "UNDEFRULE" 121 | "UNWATCH" 122 | "USE-DEFAULT-ENGINE" 123 | "USE-FANCY-ASSERT" 124 | "USE-LISA" 125 | "WALK" 126 | "WATCH" 127 | "WATCHING" 128 | "WITH-INFERENCE-ENGINE" 129 | "WITH-SIMPLE-QUERY")) 130 | (:shadow "ASSERT")) 131 | 132 | (defpackage "LISA-USER" 133 | (:use "COMMON-LISP") 134 | (:shadowing-import-from "LISA" "ASSERT" "DEFAULT") 135 | (:import-from "LISA" . #1#))) 136 | 137 | (defpackage "LISA.REFLECT" 138 | (:use "COMMON-LISP") 139 | (:nicknames "REFLECT") 140 | #+(or Allegro LispWorks) 141 | (:import-from "CLOS" 142 | "ENSURE-CLASS" 143 | "CLASS-DIRECT-SUPERCLASSES" 144 | "CLASS-FINALIZED-P" 145 | "FINALIZE-INHERITANCE") 146 | 147 | #+CMU 148 | (:import-from "CLOS" 149 | "CLASS-FINALIZED-P" 150 | "FINALIZE-INHERITANCE") 151 | #+:sbcl 152 | (:import-from "SB-MOP" 153 | "CLASS-FINALIZED-P" 154 | "FINALIZE-INHERITANCE") 155 | (:export 156 | "CLASS-ALL-SUPERCLASSES" 157 | "CLASS-FINALIZED-P" 158 | "CLASS-SLOT-LIST" 159 | "ENSURE-CLASS" 160 | "FINALIZE-INHERITANCE" 161 | "FIND-DIRECT-SUPERCLASSES")) 162 | 163 | (defpackage "LISA.BELIEF" 164 | (:use "COMMON-LISP") 165 | (:nicknames "BELIEF") 166 | (:export 167 | "ADJUST-BELIEF" 168 | "BELIEF->ENGLISH" 169 | "BELIEF-FACTOR" 170 | "FALSE-P" 171 | "TRUE-P" 172 | "UKNOWN-P")) 173 | 174 | (defpackage "LISA.HEAP" 175 | (:use "COMMON-LISP") 176 | (:nicknames "HEAP") 177 | (:export 178 | "CREATE-HEAP" 179 | "HEAP-CLEAR" 180 | "HEAP-COUNT" 181 | "HEAP-COLLECT" 182 | "HEAP-EMPTY-P" 183 | "HEAP-FIND" 184 | "HEAP-INSERT" 185 | "HEAP-PEEK" 186 | "HEAP-REMOVE")) 187 | 188 | (defpackage "LISA.UTILS" 189 | (:use "COMMON-LISP") 190 | (:nicknames "UTILS") 191 | (:export 192 | "COLLECT" 193 | "COMPOSE" 194 | "COMPOSE-ALL" 195 | "COMPOSE-F" 196 | "FIND-AFTER" 197 | "FIND-BEFORE" 198 | "FIND-IF-AFTER" 199 | "FLATTEN" 200 | "LSTHASH" 201 | "MAP-IN" 202 | "STRING-TOKENS")) 203 | -------------------------------------------------------------------------------- /src/rete/reference/join-node.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defclass join-node () 28 | ((successor :initform nil 29 | :accessor join-node-successor) 30 | (logical-block :initform nil 31 | :reader join-node-logical-block) 32 | (tests :initform (list) 33 | :accessor join-node-tests) 34 | (left-memory :initform (make-hash-table :test #'equal) 35 | :reader join-node-left-memory) 36 | (right-memory :initform (make-hash-table :test #'equal) 37 | :reader join-node-right-memory))) 38 | 39 | (defun mark-as-logical-block (join-node marker) 40 | (setf (slot-value join-node 'logical-block) marker)) 41 | 42 | (defun logical-block-p (join-node) 43 | (numberp (join-node-logical-block join-node))) 44 | 45 | (defun remember-token (memory token) 46 | (setf (gethash (hash-key token) memory) token)) 47 | 48 | (defun forget-token (memory token) 49 | (remhash (hash-key token) memory)) 50 | 51 | (defun add-tokens-to-left-memory (join-node tokens) 52 | (remember-token (join-node-left-memory join-node) tokens)) 53 | 54 | (defun add-token-to-right-memory (join-node token) 55 | (remember-token (join-node-right-memory join-node) token)) 56 | 57 | (defun remove-tokens-from-left-memory (join-node tokens) 58 | (forget-token (join-node-left-memory join-node) tokens)) 59 | 60 | (defun remove-token-from-right-memory (join-node token) 61 | (forget-token (join-node-right-memory join-node) token)) 62 | 63 | (defun left-memory-count (join-node) 64 | (hash-table-count (join-node-left-memory join-node))) 65 | 66 | (defun right-memory-count (join-node) 67 | (hash-table-count (join-node-right-memory join-node))) 68 | 69 | (defun test-tokens (join-node left-tokens right-token) 70 | (declare (optimize (speed 3) (safety 1) (debug 0))) 71 | (token-push-fact left-tokens (token-top-fact right-token)) 72 | (with-slots ((node-tests tests)) join-node 73 | (prog1 74 | (every #'(lambda (test) 75 | (declare (type function test)) 76 | (funcall test left-tokens)) 77 | node-tests) 78 | (token-pop-fact left-tokens)))) 79 | 80 | (defmethod pass-tokens-to-successor ((self join-node) left-tokens) 81 | (call-successor (join-node-successor self) left-tokens)) 82 | 83 | (defmethod combine-tokens ((left-tokens token) (right-token token)) 84 | (token-push-fact (replicate-token left-tokens) (token-top-fact right-token))) 85 | 86 | (defmethod combine-tokens ((left-tokens token) (right-token t)) 87 | (token-push-fact (replicate-token left-tokens) right-token)) 88 | 89 | (defmethod add-successor ((self join-node) successor-node connector) 90 | (setf (join-node-successor self) 91 | (make-successor successor-node connector))) 92 | 93 | (defmethod join-node-add-test ((self join-node) test) 94 | (push test (join-node-tests self))) 95 | 96 | (defmethod clear-memories ((self join-node)) 97 | (clrhash (join-node-left-memory self)) 98 | (clrhash (join-node-right-memory self))) 99 | 100 | (defmethod accept-tokens-from-left ((self join-node) (left-tokens reset-token)) 101 | (clear-memories self) 102 | (pass-tokens-to-successor self left-tokens)) 103 | 104 | (defmethod accept-token-from-right ((self join-node) (right-token reset-token)) 105 | nil) 106 | 107 | (defmethod print-object ((self join-node) strm) 108 | (print-unreadable-object (self strm :type t :identity t) 109 | (format strm "left ~S ; right ~S ; tests ~S" 110 | (left-memory-count self) 111 | (right-memory-count self) 112 | (length (join-node-tests self))))) 113 | -------------------------------------------------------------------------------- /src/rete/reference/network-crawler.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defun show-network (&optional (rete-network (active-network)) (strm *terminal-io*)) 28 | (labels ((get-roots () 29 | (loop for node being the hash-values of (rete-roots rete-network) 30 | collect node)) 31 | (get-successors (shared-node) 32 | (loop for s being the hash-values of (shared-node-successors shared-node) 33 | collect (successor-node s))) 34 | (get-successor (join-node) 35 | (list (successor-node (join-node-successor join-node)))) 36 | (trace-nodes (nodes &optional (level 0)) 37 | (unless (null nodes) 38 | (let* ((node (first nodes)) 39 | (string (format nil "~S" node))) 40 | (format strm "~V<~A~>~%" (+ level (length string)) string) 41 | (typecase node 42 | (shared-node 43 | (trace-nodes (get-successors node) (+ level 3))) 44 | (join-node 45 | (trace-nodes (get-successor node) (+ level 3))) 46 | (terminal-node 47 | nil)) 48 | (trace-nodes (rest nodes) level))))) 49 | (trace-nodes (get-roots)))) 50 | -------------------------------------------------------------------------------- /src/rete/reference/network-ops.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defun add-token-to-network (rete-network token-ctor) 28 | (loop for root-node being the hash-values of (rete-roots rete-network) 29 | do (accept-token root-node (funcall token-ctor)))) 30 | 31 | (defun add-fact-to-network (rete-network fact) 32 | (add-token-to-network 33 | rete-network #'(lambda () (make-add-token fact)))) 34 | 35 | (defun remove-fact-from-network (rete-network fact) 36 | (add-token-to-network 37 | rete-network #'(lambda () (make-remove-token fact)))) 38 | 39 | (defun reset-network (rete-network) 40 | (add-token-to-network 41 | rete-network #'(lambda () (make-reset-token t)))) 42 | 43 | (defmethod decrement-use-count ((node join-node)) 0) 44 | (defmethod decrement-use-count ((node terminal-node)) 0) 45 | 46 | (defun remove-rule-from-network (rete-network rule) 47 | (labels ((remove-nodes (nodes) 48 | (if (endp nodes) rule 49 | (let ((node (node-pair-child (first nodes))) 50 | (parent (node-pair-parent (first nodes)))) 51 | (when (zerop (decrement-use-count node)) 52 | (remove-node-from-parent rete-network parent node)) 53 | (remove-nodes (rest nodes)))))) 54 | (remove-nodes (rule-node-list rule)))) 55 | 56 | (defmethod find-existing-successor ((parent shared-node) (node node1)) 57 | (gethash (node1-test node) (shared-node-successors parent))) 58 | 59 | (defmethod find-existing-successor (parent node) 60 | (declare (ignore parent node)) 61 | nil) 62 | 63 | (defvar *node-set* nil) 64 | 65 | (defmethod add-node-set ((parent shared-node) node &optional (count-p nil)) 66 | (when count-p 67 | (increment-use-count parent)) 68 | (push (make-node-pair node parent) *node-set*)) 69 | 70 | (defmethod add-node-set ((parent join-node) node &optional count-p) 71 | (declare (ignore node count-p)) 72 | nil) 73 | 74 | (defmethod add-node-set (parent node &optional count-p) 75 | (declare (ignore count-p)) 76 | (push (make-node-pair node parent) *node-set*)) 77 | 78 | (defun merge-networks (from-rete to-rete) 79 | (labels ((find-root-node (network node) 80 | (gethash (node1-test node) (rete-roots network))) 81 | (collect-node-sets (parent children) 82 | (if (endp children) parent 83 | (let ((child (first children))) 84 | (add-node-set parent child) 85 | (when (typep child 'shared-node) 86 | (collect-node-sets child 87 | (shared-node-successor-nodes child))) 88 | (collect-node-sets parent (rest children))))) 89 | (add-new-root (network root) 90 | (setf (gethash (node1-test root) (rete-roots network)) root) 91 | (add-node-set t root) 92 | (collect-node-sets root (shared-node-successor-nodes root))) 93 | (merge-successors (parent successors) 94 | (if (endp successors) parent 95 | (let* ((new-successor (first successors)) 96 | (existing-successor 97 | (find-existing-successor 98 | parent (successor-node new-successor)))) 99 | (cond ((null existing-successor) 100 | (add-successor parent (successor-node new-successor) 101 | (successor-connector new-successor)) 102 | (add-node-set parent (successor-node new-successor))) 103 | (t 104 | (add-node-set 105 | parent (successor-node existing-successor) t) 106 | (merge-successors 107 | (successor-node existing-successor) 108 | (shared-node-all-successors 109 | (successor-node new-successor))))) 110 | (merge-successors parent (rest successors))))) 111 | (merge-root-node (new-root) 112 | (let ((existing-root 113 | (find-root-node to-rete new-root))) 114 | (cond ((null existing-root) 115 | (add-new-root to-rete new-root)) 116 | (t 117 | (add-node-set t existing-root) 118 | (merge-successors 119 | existing-root 120 | (shared-node-all-successors new-root))))))) 121 | (let ((*node-set* (list))) 122 | (loop for new-root being the hash-values of (rete-roots from-rete) 123 | do (merge-root-node new-root)) 124 | (nreverse *node-set*)))) 125 | -------------------------------------------------------------------------------- /src/rete/reference/node-pair.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defun make-node-pair (child parent) 28 | (cons child parent)) 29 | 30 | (defun node-pair-child (node-pair) 31 | (car node-pair)) 32 | 33 | (defun node-pair-parent (node-pair) 34 | (cdr node-pair)) 35 | -------------------------------------------------------------------------------- /src/rete/reference/node1.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defclass node1 (shared-node) 28 | ((test :initarg :test 29 | :reader node1-test))) 30 | 31 | (defmethod add-successor ((self node1) (new-node node1) connector) 32 | (with-slots ((successor-table successors)) self 33 | (let ((successor (gethash (node1-test new-node) successor-table))) 34 | (when (null successor) 35 | (setf successor 36 | (setf (gethash (node1-test new-node) successor-table) 37 | (make-successor new-node connector)))) 38 | (successor-node successor)))) 39 | 40 | (defmethod add-successor ((self node1) (new-node t) connector) 41 | (setf (gethash `(,new-node ,connector) (shared-node-successors self)) 42 | (make-successor new-node connector)) 43 | new-node) 44 | 45 | (defmethod remove-successor ((self node1) successor-node) 46 | (let ((successors (shared-node-successors self))) 47 | (maphash #'(lambda (key successor) 48 | (when (eq successor-node (successor-node successor)) 49 | (remhash key successors))) 50 | successors) 51 | successor-node)) 52 | 53 | (defmethod accept-token ((self node1) token) 54 | (if (funcall (node1-test self) token) 55 | (pass-token-to-successors self token) 56 | nil)) 57 | 58 | (defmethod accept-token ((self node1) (token reset-token)) 59 | (pass-token-to-successors self (token-push-fact token t))) 60 | 61 | (defmethod print-object ((self node1) strm) 62 | (print-unreadable-object (self strm :type t :identity t) 63 | (format strm "~S ; ~D" (node1-test self) (node-use-count self)))) 64 | 65 | (defun make-node1 (test) 66 | (make-instance 'node1 :test test)) 67 | 68 | -------------------------------------------------------------------------------- /src/rete/reference/node2-exists.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defclass node2-exists (join-node) ()) 28 | 29 | (defmethod test-against-right-memory ((self node2-exists) (left-tokens add-token)) 30 | (loop for right-token being the hash-values of (join-node-right-memory self) 31 | do (when (test-tokens self left-tokens right-token) 32 | (token-increment-exists-counter left-tokens) 33 | (pass-tokens-to-successor 34 | self (combine-tokens left-tokens right-token))))) 35 | 36 | (defmethod test-against-right-memory ((self node2-exists) (left-tokens remove-token)) 37 | (loop for right-token being the hash-values of (join-node-right-memory self) 38 | do (when (test-tokens self left-tokens right-token) 39 | (pass-tokens-to-successor 40 | self (combine-tokens left-tokens right-token))))) 41 | 42 | (defmethod test-against-left-memory ((self node2-exists) (right-token add-token)) 43 | (loop for left-tokens being the hash-values of (join-node-left-memory self) 44 | do (when (and (test-tokens self left-tokens right-token) 45 | (= (token-increment-exists-counter left-tokens) 1)) 46 | (pass-tokens-to-successor 47 | self (combine-tokens left-tokens right-token))))) 48 | 49 | (defmethod test-against-left-memory ((self node2-exists) (right-token remove-token)) 50 | (loop for left-tokens being the hash-values of (join-node-left-memory self) 51 | do (when (test-tokens self left-tokens right-token) 52 | (token-decrement-exists-counter left-tokens) 53 | (pass-tokens-to-successor 54 | self (combine-tokens 55 | (make-remove-token left-tokens) right-token))))) 56 | 57 | (defmethod accept-tokens-from-left ((self node2-exists) (left-tokens add-token)) 58 | (add-tokens-to-left-memory self left-tokens) 59 | (test-against-right-memory self left-tokens)) 60 | 61 | (defmethod accept-token-from-right ((self node2-exists) (right-token add-token)) 62 | (add-token-to-right-memory self right-token) 63 | (test-against-left-memory self right-token)) 64 | 65 | (defmethod accept-tokens-from-left ((self node2-exists) (left-tokens remove-token)) 66 | (when (remove-tokens-from-left-memory self left-tokens) 67 | (test-against-right-memory self left-tokens))) 68 | 69 | (defmethod accept-token-from-right ((self node2-exists) (right-token remove-token)) 70 | (when (remove-token-from-right-memory self right-token) 71 | (test-against-left-memory self right-token))) 72 | 73 | (defun make-node2-exists () 74 | (make-instance 'node2-exists)) 75 | 76 | -------------------------------------------------------------------------------- /src/rete/reference/node2-not.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defclass node2-not (join-node) ()) 28 | 29 | (defmethod test-against-right-memory ((self node2-not) left-tokens) 30 | (loop for right-token being the hash-values of (join-node-right-memory self) 31 | do (when (test-tokens self left-tokens right-token) 32 | (token-increment-not-counter left-tokens))) 33 | (unless (token-negated-p left-tokens) 34 | (pass-tokens-to-successor 35 | self (combine-tokens left-tokens self)))) 36 | 37 | (defmethod test-against-left-memory ((self node2-not) 38 | (right-token add-token)) 39 | (loop for left-tokens being the hash-values of (join-node-left-memory self) 40 | do (when (test-tokens self left-tokens right-token) 41 | (token-increment-not-counter left-tokens) 42 | (pass-tokens-to-successor 43 | self (combine-tokens (make-remove-token left-tokens) self))))) 44 | 45 | (defmethod test-against-left-memory ((self node2-not) 46 | (right-token remove-token)) 47 | (loop for left-tokens being the hash-values of (join-node-left-memory self) 48 | do (when (and (test-tokens self left-tokens right-token) 49 | (not (token-negated-p 50 | (token-decrement-not-counter left-tokens)))) 51 | (pass-tokens-to-successor 52 | self (combine-tokens left-tokens self))))) 53 | 54 | (defmethod accept-tokens-from-left ((self node2-not) (left-tokens add-token)) 55 | (add-tokens-to-left-memory self left-tokens) 56 | (test-against-right-memory self left-tokens)) 57 | 58 | (defmethod accept-tokens-from-left ((self node2-not) (left-tokens remove-token)) 59 | (when (remove-tokens-from-left-memory self left-tokens) 60 | (pass-tokens-to-successor self (combine-tokens left-tokens self)))) 61 | 62 | (defmethod accept-token-from-right ((self node2-not) (right-token add-token)) 63 | (add-token-to-right-memory self right-token) 64 | (test-against-left-memory self right-token)) 65 | 66 | (defmethod accept-token-from-right ((self node2-not) (right-token remove-token)) 67 | (when (remove-token-from-right-memory self right-token) 68 | (test-against-left-memory self right-token))) 69 | 70 | (defun make-node2-not () 71 | (make-instance 'node2-not)) 72 | -------------------------------------------------------------------------------- /src/rete/reference/node2-test.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defclass node2-test (join-node) ()) 28 | 29 | (defmethod accept-tokens-from-left ((self node2-test) (left-tokens add-token)) 30 | (add-tokens-to-left-memory self left-tokens) 31 | (when (every #'(lambda (test) 32 | (funcall test left-tokens)) 33 | (join-node-tests self)) 34 | (pass-tokens-to-successor self (combine-tokens left-tokens self)))) 35 | 36 | (defmethod accept-tokens-from-left ((self node2-test) (left-tokens remove-token)) 37 | (when (remove-tokens-from-left-memory self left-tokens) 38 | (pass-tokens-to-successor self (combine-tokens left-tokens self)))) 39 | 40 | (defun make-node2-test () 41 | (make-instance 'node2-test)) 42 | -------------------------------------------------------------------------------- /src/rete/reference/node2.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defclass node2 (join-node) ()) 28 | 29 | (defmethod test-against-right-memory ((self node2) left-tokens) 30 | (loop for right-token being the hash-values of (join-node-right-memory self) 31 | do (when (test-tokens self left-tokens right-token) 32 | (pass-tokens-to-successor 33 | self (combine-tokens left-tokens right-token))))) 34 | 35 | (defmethod test-against-left-memory ((self node2) (right-token add-token)) 36 | (loop for left-tokens being the hash-values of (join-node-left-memory self) 37 | do (when (test-tokens self left-tokens right-token) 38 | (pass-tokens-to-successor 39 | self (combine-tokens left-tokens right-token))))) 40 | 41 | (defmethod test-against-left-memory ((self node2) (right-token remove-token)) 42 | (loop for left-tokens being the hash-values of (join-node-left-memory self) 43 | do (when (test-tokens self left-tokens right-token) 44 | (pass-tokens-to-successor 45 | self (combine-tokens 46 | (make-remove-token left-tokens) right-token))))) 47 | 48 | (defmethod accept-tokens-from-left ((self node2) (left-tokens add-token)) 49 | (add-tokens-to-left-memory self left-tokens) 50 | (test-against-right-memory self left-tokens)) 51 | 52 | (defmethod accept-token-from-right ((self node2) (right-token add-token)) 53 | (add-token-to-right-memory self right-token) 54 | (test-against-left-memory self right-token)) 55 | 56 | (defmethod accept-tokens-from-left ((self node2) (left-tokens remove-token)) 57 | (when (remove-tokens-from-left-memory self left-tokens) 58 | (test-against-right-memory self left-tokens))) 59 | 60 | (defmethod accept-token-from-right ((self node2) (right-token remove-token)) 61 | (when (remove-token-from-right-memory self right-token) 62 | (test-against-left-memory self right-token))) 63 | 64 | (defun make-node2 () 65 | (make-instance 'node2)) 66 | 67 | -------------------------------------------------------------------------------- /src/rete/reference/or-node2.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defclass or-node2 (node2) 28 | ((branch-successes :initform (make-hash-table :test #'equal) 29 | :accessor branch-successes) 30 | (branch-tokens :initform (make-hash-table :test #'equal) 31 | :accessor branch-tokens))) 32 | 33 | (defmethod test-tokens ((self or-node) left-tokens right-token) 34 | (declare (optimize (speed 3) (safety 0) (debug 0))) 35 | (token-push-fact left-tokens (token-top-fact right-token)) 36 | (prog1 37 | (some #'(lambda (test) 38 | (declare (type function test)) 39 | (funcall test left-tokens)) 40 | (join-node-tests self)) 41 | (token-pop-fact left-tokens))) 42 | 43 | ;; Helper to create a unique key for a token in a specific branch 44 | 45 | (defun make-branch-key (token branch-index) 46 | (cons (token-facts token) branch-index)) 47 | 48 | (defmethod test-against-left-memory ((self or-node) (right-token add-token)) 49 | (loop for left-tokens being the hash-values of (join-node-left-memory self) 50 | for branch-index from 0 51 | when (test-tokens self left-tokens right-token) 52 | do (let ((branch-key (make-branch-key left-tokens branch-index))) 53 | (setf (gethash branch-key (or-node-branch-successes self)) t) 54 | (setf (gethash branch-key (or-node-branch-tokens self)) (combine-tokens left-tokens right-token)) 55 | (pass-tokens-to-successor self (gethash branch-key (or-node-branch-tokens self)))))) 56 | 57 | (defmethod test-against-right-memory ((self or-node) left-tokens) 58 | (loop for right-token being the hash-values of (join-node-right-memory self) 59 | for branch-index from 0 60 | when (test-tokens self left-tokens right-token) 61 | do (let ((branch-key (make-branch-key left-tokens branch-index))) 62 | (setf (gethash branch-key (or-node-branch-successes self)) t) 63 | (setf (gethash branch-key (or-node-branch-tokens self)) (combine-tokens left-tokens right-token)) 64 | (pass-tokens-to-successor self (gethash branch-key (or-node-branch-tokens self)))))) 65 | 66 | (defmethod accept-tokens-from-left ((self or-node) (left-tokens remove-token)) 67 | (loop for branch-index from 0 68 | for branch-key = (make-branch-key left-tokens branch-index) 69 | when (gethash branch-key (or-node-branch-successes self)) 70 | do (progn 71 | (remhash branch-key (or-node-branch-successes self)) 72 | (let ((stored-token (gethash branch-key (or-node-branch-tokens self)))) 73 | (remhash branch-key (or-node-branch-tokens self)) 74 | 75 | (defmethod accept-token-from-right ((self or-node) (right-token remove-token)) 76 | (loop for branch-index from 0 77 | for branch-key = (make-branch-key right-token branch-index) 78 | when (gethash branch-key (or-node-branch-successes self)) 79 | do (progn 80 | (remhash branch-key (or-node-branch-successes self)) 81 | (let ((stored-token (gethash branch-key (or-node-branch-tokens self)))) 82 | (remhash branch-key (or-node-branch-tokens self)) 83 | ;; Only propagate removal if no other branches are successful 84 | (when (zerop (hash-table-count (or-node-branch-successes self))) 85 | (when (remove-token-from-right-memory self right-token) 86 | (pass-tokens-to-successor self (make-remove-token stored-token)))))))) 87 | -------------------------------------------------------------------------------- /src/rete/reference/shared-node.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defclass shared-node () 28 | ((successors :initform (make-hash-table :test #'equal) 29 | :reader shared-node-successors) 30 | (refcnt :initform 0 31 | :accessor shared-node-refcnt))) 32 | 33 | (defmethod increment-use-count ((self shared-node)) 34 | (incf (shared-node-refcnt self))) 35 | 36 | (defmethod decrement-use-count ((self shared-node)) 37 | (decf (shared-node-refcnt self))) 38 | 39 | (defmethod node-use-count ((self shared-node)) 40 | (shared-node-refcnt self)) 41 | 42 | (defmethod node-referenced-p ((self shared-node)) 43 | (plusp (node-use-count self))) 44 | 45 | (defmethod pass-token-to-successors ((self shared-node) token) 46 | (loop for successor being the hash-values of (shared-node-successors self) 47 | do (funcall (successor-connector successor) 48 | (successor-node successor) 49 | token))) 50 | 51 | (defun shared-node-successor-nodes (shared-node) 52 | (loop for successor being the hash-values of (shared-node-successors shared-node) 53 | collect (successor-node successor))) 54 | 55 | (defun shared-node-all-successors (shared-node) 56 | (loop for successor being the hash-values of (shared-node-successors shared-node) 57 | collect successor)) 58 | -------------------------------------------------------------------------------- /src/rete/reference/successor.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defun make-successor (node connector) 28 | (cons node connector)) 29 | 30 | (defun successor-node (successor) 31 | (car successor)) 32 | 33 | (defun successor-connector (successor) 34 | (cdr successor)) 35 | 36 | (defun call-successor (successor &rest args) 37 | (apply #'funcall 38 | (successor-connector successor) 39 | (successor-node successor) 40 | args)) 41 | -------------------------------------------------------------------------------- /src/rete/reference/terminal-node.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | (in-package :lisa) 26 | 27 | (defclass terminal-node () 28 | ((rule :initarg :rule 29 | :initform nil 30 | :reader terminal-node-rule))) 31 | 32 | (defmethod accept-token ((self terminal-node) (tokens add-token)) 33 | (let* ((rule (terminal-node-rule self)) 34 | (activation (make-activation rule tokens))) 35 | (add-activation (rule-engine rule) activation) 36 | (bind-rule-activation rule activation tokens) 37 | t)) 38 | 39 | (defmethod accept-token ((self terminal-node) (tokens remove-token)) 40 | (let* ((rule (terminal-node-rule self)) 41 | (activation (find-activation-binding rule tokens))) 42 | (unless (null activation) 43 | (disable-activation (rule-engine rule) activation) 44 | (unbind-rule-activation rule tokens)) 45 | t)) 46 | 47 | (defmethod accept-token ((self terminal-node) (token reset-token)) 48 | (clear-activation-bindings (terminal-node-rule self)) 49 | t) 50 | 51 | (defmethod print-object ((self terminal-node) strm) 52 | (print-unreadable-object (self strm :type t) 53 | (format strm "~A" (rule-name (terminal-node-rule self))))) 54 | 55 | (defun make-terminal-node (rule) 56 | (make-instance 'terminal-node :rule rule)) 57 | -------------------------------------------------------------------------------- /src/rete/reference/tms.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Network-specific support for truth maintenance. 26 | 27 | (in-package :lisa) 28 | 29 | (defmethod pass-tokens-to-successor :before ((self join-node) (left-tokens remove-token)) 30 | (when (logical-block-p self) 31 | (schedule-dependency-removal 32 | (make-dependency-set left-tokens (join-node-logical-block self))))) 33 | -------------------------------------------------------------------------------- /src/utils/compose.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Description: Utilities used to compose anonymous functions. 26 | 27 | (in-package :lisa) 28 | 29 | (defun build-lambda-expression (forms) 30 | (labels ((compose-body (forms &optional (body nil)) 31 | (if (null forms) 32 | body 33 | (compose-body (rest forms) 34 | (nconc body 35 | `(,(first forms))))))) 36 | `(lambda () 37 | (progn ,@(compose-body forms))))) 38 | 39 | (defmacro compile-function (forms) 40 | "Build and compile an anonymous function, using the body provided in 41 | FORMS." 42 | `(compile nil (build-lambda-expression ,forms))) 43 | -------------------------------------------------------------------------------- /version.lisp: -------------------------------------------------------------------------------- 1 | ;; This file is part of Lisa, the Lisp-based Intelligent Software Agents platform. 2 | 3 | ;; MIT License 4 | 5 | ;; Copyright (c) 2000 David Young 6 | 7 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;; of this software and associated documentation files (the "Software"), to deal 9 | ;; in the Software without restriction, including without limitation the rights 10 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;; copies of the Software, and to permit persons to whom the Software is 12 | ;; furnished to do so, subject to the following conditions: 13 | 14 | ;; The above copyright notice and this permission notice shall be included in all 15 | ;; copies or substantial portions of the Software. 16 | 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;; SOFTWARE. 24 | 25 | ;; Update the version symbol in this file whenever you do a new release. 26 | 27 | (eval-when (:load-toplevel :execute) 28 | (pushnew :lisa3.9.2 *features*)) 29 | --------------------------------------------------------------------------------