|
Here is a solution to the classic Monkey and Bananas problem implemented in Lisa:
(lisa:consider-taxonomy)
(defclass mab-fundamental () ())
(defclass monkey (mab-fundamental)
((location :initarg :location
:initform 'green-couch)
(on-top-of :initarg :on-top-of
:initform 'floor)
(satisfied :initarg :satisfied
:initform nil)
(holding :initarg :holding
:initform 'nothing)))
(defclass thing (mab-fundamental)
((name :initarg :name)
(location :initarg :location)
(on-top-of :initarg :on-top-of
:initform 'floor)
(weight :initarg :weight
:initform 'light)))
(defclass chest (mab-fundamental)
((name :initarg :name)
(contents :initarg :contents)
(unlocked-by :initarg :unlocked-by)))
(defclass goal-is-to (mab-fundamental)
((action :initarg :action)
(argument-1 :initarg :argument-1)
(argument-2 :initarg :argument-2
:initform nil)))
;;;(watch :activations)
;;;(watch :facts)
;;;(watch :rules)
;;; Chest-unlocking rules...
(defrule hold-chest-to-put-on-floor ()
(goal-is-to (action unlock) (argument-1 ?chest))
(thing (name ?chest) (on-top-of (not floor)) (weight light))
(monkey (holding (not ?chest)))
(not (goal-is-to (action hold) (argument-1 ?chest)))
=>
(assert ((make-instance 'goal-is-to :action 'hold :argument-1 ?chest))))
(defrule put-chest-on-floor ()
(goal-is-to (action unlock) (argument-1 ?chest))
(?monkey (monkey (location ?place) (on-top-of ?on) (holding ?chest)))
(?thing (thing (name ?chest)))
=>
(format t "Monkey throws the ~A off the ~A onto the floor.~%" ?chest ?on)
(modify ?monkey (holding blank))
(modify ?thing (location ?place) (on-top-of floor)))
(defrule get-key-to-unlock ()
(goal-is-to (action unlock) (argument-1 ?obj))
(thing (name ?obj) (on-top-of floor))
(chest (name ?obj) (unlocked-by ?key))
(monkey (holding (not ?key)))
(not (goal-is-to (action hold) (argument-1 ?key)))
=>
(assert ((make-instance 'goal-is-to :action 'hold :argument-1 ?key))))
(defrule move-to-chest-with-key ()
(goal-is-to (action unlock) (argument-1 ?chest))
(thing (name ?chest) (location ?cplace) (on-top-of floor))
(monkey (location (not ?cplace)) (holding ?key))
(chest (name ?chest) (unlocked-by ?key))
(not (goal-is-to (action walk-to) (argument-1 ?cplace)))
=>
(assert ((make-instance 'goal-is-to :action 'walk-to :argument-1 ?cplace))))
(defrule unlock-chest-with-key ()
(?goal (goal-is-to (action unlock) (argument-1 ?name)))
(?chest (chest (name ?name) (contents ?contents) (unlocked-by ?key)))
(thing (name ?name) (location ?place) (on-top-of ?on))
(monkey (location ?place) (on-top-of ?on) (holding ?key))
=>
(format t "Monkey opens the ~A with the ~A revealing the ~A.~%"
?name ?key ?contents)
(modify ?chest (contents nothing))
(assert ((make-instance 'thing :name ?contents :location ?place
:weight 'light :on-top-of ?name)))
(retract ?goal))
;;; Hold-object rules...
(defrule unlock-chest-to-hold-object ()
(goal-is-to (action hold) (argument-1 ?obj))
(chest (name ?chest) (contents ?obj))
(not (goal-is-to (action unlock) (argument-1 ?chest)))
=>
(assert ((make-instance 'goal-is-to :action 'unlock :argument-1 ?chest))))
(defrule use-ladder-to-hold ()
(goal-is-to (action hold) (argument-1 ?obj))
(thing (name ?obj) (location ?place) (on-top-of ceiling) (weight light))
(not (thing (name ladder) (location ?place)))
(not (goal-is-to (action move) (argument-1 ladder) (argument-2 ?place)))
=>
(assert ((make-instance 'goal-is-to :action 'move
:argument-1 'ladder
:argument-2 ?place))))
(defrule climb-ladder-to-hold ()
(goal-is-to (action hold) (argument-1 ?obj))
(thing (name ?obj) (location ?place) (on-top-of ceiling) (weight light))
(thing (name ladder) (location ?place) (on-top-of floor))
(monkey (on-top-of (not ladder)))
(not (goal-is-to (action on) (argument-1 ladder)))
=>
(assert ((make-instance 'goal-is-to :action 'on :argument-1 'ladder))))
(defrule grab-object-from-ladder ()
(?goal (goal-is-to (action hold) (argument-1 ?name)))
(?thing (thing (name ?name) (location ?place)
(on-top-of ceiling) (weight light)))
(thing (name ladder) (location ?place))
(?monkey (monkey (location ?place) (on-top-of ladder) (holding blank)))
=>
(format t "Monkey grabs the ~A.~%" ?name)
(modify ?thing (location held) (on-top-of held))
(modify ?monkey (holding ?name))
(retract ?goal))
(defrule climb-to-hold ()
(goal-is-to (action hold) (argument-1 ?obj))
(thing (name ?obj) (location ?place (not ceiling))
(on-top-of ?on) (weight light))
(monkey (location ?place) (on-top-of (not ?on)))
(not (goal-is-to (action on) (argument-1 ?on)))
=>
(assert ((make-instance 'goal-is-to :action 'on :argument-1 ?on))))
(defrule walk-to-hold ()
(goal-is-to (action hold) (argument-1 ?obj))
(thing (name ?obj) (location ?place) (on-top-of (not ceiling))
(weight light))
(monkey (location (not ?place)))
(not (goal-is-to (action walk-to) (argument-1 ?place)))
=>
(assert ((make-instance 'goal-is-to :action 'walk-to :argument-1 ?place))))
(defrule drop-to-hold ()
(goal-is-to (action hold) (argument-1 ?obj))
(thing (name ?obj) (location ?place) (on-top-of ?on) (weight light))
(monkey (location ?place) (on-top-of ?on) (holding (not blank)))
(not (goal-is-to (action hold) (argument-1 blank)))
=>
(assert ((make-instance 'goal-is-to :action 'hold :argument-1 'blank))))
(defrule grab-object ()
(?goal (goal-is-to (action hold) (argument-1 ?name)))
(?thing (thing (name ?name) (location ?place)
(on-top-of ?on) (weight light)))
(?monkey (monkey (location ?place) (on-top-of ?on) (holding blank)))
=>
(format t "Monkey grabs the ~A.~%" ?name)
(modify ?thing (location held) (on-top-of held))
(modify ?monkey (holding ?name))
(retract ?goal))
(defrule drop-object ()
(?goal (goal-is-to (action hold) (argument-1 blank)))
(?monkey (monkey (location ?place) (on-top-of ?on)
(holding ?name (not blank))))
(?thing (thing (name ?name)))
=>
(format t "Monkey drops the ~A.~%" ?name)
(modify ?monkey (holding blank))
(modify ?thing (location ?place) (on-top-of ?on))
(retract ?goal))
;;; Move-object rules...
(defrule unlock-chest-to-move-object ()
(goal-is-to (action move) (argument-1 ?obj))
(chest (name ?chest) (contents ?obj))
(not (goal-is-to (action unlock) (argument-1 ?chest)))
=>
(assert ((make-instance 'goal-is-to :action 'unlock :argument-1 ?chest))))
(defrule hold-object-to-move ()
(goal-is-to (action move) (argument-1 ?obj) (argument-2 ?place))
(thing (name ?obj) (location (not ?place)) (weight light))
(monkey (holding (not ?obj)))
(not (goal-is-to (action hold) (argument-1 ?obj)))
=>
(assert ((make-instance 'goal-is-to :action 'hold :argument-1 ?obj))))
(defrule move-object-to-place ()
(goal-is-to (action move) (argument-1 ?obj) (argument-2 ?place))
(monkey (location (not ?place)) (holding ?obj))
(not (goal-is-to (action walk-to) (argument-1 ?place)))
=>
(assert ((make-instance 'goal-is-to :action 'walk-to :argument-1 ?place))))
(defrule drop-object-once-moved ()
(?goal (goal-is-to (action move) (argument-1 ?name) (argument-2 ?place)))
(?monkey (monkey (location ?place) (holding ?obj)))
(?thing (thing (name ?name) (weight light)))
=>
(format t "Monkey drops the ~A.~%" ?name)
(modify ?monkey (holding blank))
(modify ?thing (location ?place) (on-top-of floor))
(retract ?goal))
(defrule already-moved-object ()
(?goal (goal-is-to (action move) (argument-1 ?obj) (argument-2 ?place)))
(thing (name ?obj) (location ?place))
=>
(retract ?goal))
;;; Walk-to-place rules...
(defrule already-at-place ()
(?goal (goal-is-to (action walk-to) (argument-1 ?place)))
(monkey (location ?place))
=>
(retract ?goal))
(defrule get-on-floor-to-walk ()
(goal-is-to (action walk-to) (argument-1 ?place))
(monkey (location (not ?place)) (on-top-of (not floor)))
(not (goal-is-to (action on) (argument-1 floor)))
=>
(assert ((make-instance 'goal-is-to :action 'on :argument-1 'floor))))
(defrule walk-holding-nothing ()
(?goal (goal-is-to (action walk-to) (argument-1 ?place)))
(?monkey (monkey (location (not ?place)) (on-top-of floor) (holding blank)))
=>
(format t "Monkey walks to ~A.~%" ?place)
(modify ?monkey (location ?place))
(retract ?goal))
(defrule walk-holding-object ()
(?goal (goal-is-to (action walk-to) (argument-1 ?place)))
(?monkey (monkey (location (not ?place)) (on-top-of floor) (holding ?obj)))
(thing (name ?obj))
=>
(format t "Monkey walks to ~A holding the ~A.~%" ?place ?obj)
(modify ?monkey (location ?place))
(retract ?goal))
;;; Get-on-object rules...
(defrule jump-onto-floor ()
(?goal (goal-is-to (action on) (argument-1 floor)))
(?monkey (monkey (on-top-of ?on (not floor))))
=>
(format t "Monkey jumps off the ~A onto the floor.~%" ?on)
(modify ?monkey (on-top-of floor))
(retract ?goal))
(defrule walk-to-place-to-climb ()
(goal-is-to (action on) (argument-1 ?obj))
(thing (name ?obj) (location ?place))
(monkey (location (not ?place)))
(not (goal-is-to (action walk-to) (argument-1 ?place)))
=>
(assert ((make-instance 'goal-is-to :action 'walk-to :argument-1 ?place))))
(defrule drop-to-climb ()
(goal-is-to (action on) (argument-1 ?obj))
(thing (name ?obj) (location ?place))
(monkey (location ?place) (holding (not blank)))
(not (goal-is-to (action hold) (argument-1 blank)))
=>
(assert ((make-instance 'goal-is-to :action 'hold :argument-1 'blank))))
(defrule climb-indirectly ()
(goal-is-to (action on) (argument-1 ?obj))
(thing (name ?obj) (location ?place) (on-top-of ?on))
(monkey (location ?place) (on-top-of ?top
(and (not (eq ?top ?on))
(not (eq ?top ?obj))))
(holding blank))
(not (goal-is-to (action on) (argument-1 ?on)))
=>
(assert ((make-instance 'goal-is-to :action 'on :argument-1 ?on))))
(defrule climb-directly ()
(?goal (goal-is-to (action on) (argument-1 ?obj)))
(thing (name ?obj) (location ?place) (on-top-of ?on))
(?monkey (monkey (location ?place) (on-top-of ?on) (holding blank)))
=>
(format t "Monkey climbs onto the ~A.~%" ?obj)
(modify ?monkey (on-top-of ?obj))
(retract ?goal))
(defrule already-on-object ()
(?goal (goal-is-to (action on) (argument-1 ?obj)))
(monkey (on-top-of ?obj))
=>
(retract ?goal))
;;; Eat-object rules...
(defrule hold-to-eat ()
(goal-is-to (action eat) (argument-1 ?obj))
(monkey (holding (not ?obj)))
(not (goal-is-to (action hold) (argument-1 ?obj)))
=>
(assert ((make-instance 'goal-is-to :action 'hold :argument-1 ?obj))))
(defrule satisfy-hunger ()
(?goal (goal-is-to (action eat) (argument-1 ?name)))
(?monkey (monkey (holding ?name)))
(?thing (thing (name ?name)))
=>
(format t "Monkey eats the ~A.~%" ?name)
(modify ?monkey (holding blank) (satisfied t))
(retract ?goal)
(retract ?thing))
(defrule monkey-is-satisfied ()
(monkey (satisfied t) (:object ?monkey))
=>
(format t "Monkey is satisfied: ~S~%" ?monkey))
;;; Retract every object whose ancestor is an instance of MAB-FUNDAMENTAL...
(defrule cleanup (:salience -100)
(?fact (mab-fundamental))
=>
(retract ?fact))
;;; startup rule...
(defrule startup ()
=>
(assert
((make-instance 'monkey :location 't5-7
:on-top-of 'green-couch
:location 'green-couch
:holding 'blank)))
(assert
((make-instance 'thing :name 'green-couch
:location 't5-7
:weight 'heavy
:on-top-of 'floor)))
(assert
((make-instance 'thing :name 'red-couch
:location 't2-2
:weight 'heavy
:on-top-of 'floor)))
(assert
((make-instance 'thing :name 'big-pillow
:location 't2-2
:weight 'light
:on-top-of 'red-couch)))
(assert
((make-instance 'thing :name 'red-chest
:location 't2-2
:weight 'light
:on-top-of 'big-pillow)))
(assert
((make-instance 'chest :name 'red-chest
:contents 'ladder
:unlocked-by 'red-key)))
(assert
((make-instance 'thing :name 'blue-chest
:location 't7-7
:weight 'light
:on-top-of 'ceiling)))
(assert
((make-instance 'thing :name 'grapes
:location 't7-8
:weight 'light
:on-top-of 'ceiling)))
(assert
((make-instance 'chest :name 'blue-chest
:contents 'bananas
:unlocked-by 'blue-key)))
(assert
((make-instance 'thing :name 'blue-couch
:location 't8-8
:weight 'heavy
:on-top-of 'floor)))
(assert
((make-instance 'thing :name 'green-chest
:location 't8-8
:weight 'light
:on-top-of 'ceiling)))
(assert
((make-instance 'chest :name 'green-chest
:contents 'blue-key
:unlocked-by 'red-key)))
(assert
((make-instance 'thing :name 'red-key
:location 't1-3
:weight 'light
:on-top-of 'floor)))
(assert
((make-instance 'goal-is-to :action 'eat
:argument-1 'bananas))))
|