; ************************************************************
; * This program implements the first solution to the text's *
; * Blocks World problem. It includes deftemplates for       *
; * describing the problem's initial state and goal, and     *
; * rules for moving a specified block on top of another.    * 
; ************************************************************

; Ordered facts (no deftemplate) will identify the blocks.

(deftemplate on-top-of "Describes one block on top of another"
   (slot upper)
   (slot lower))

(deftemplate goal "Describes a goal"
   (slot move)
   (slot on-top-of))

; Rules:

(defrule move-directly "Moves a clear block onto another clear block."
   ?goal <- (goal (move ?block1) (on-top-of ?block2))
   (block ?block1)
   (block ?block2)
   (on-top-of (upper nothing) (lower ?block1))
   ?stack1 <- (on-top-of (upper ?block1) (lower ?block3))
   ?stack2 <- (on-top-of (upper nothing) (lower ?block2))
   =>
   (retract ?goal ?stack1 ?stack2)
   (assert (on-top-of (upper ?block1) (lower ?block2))
           (on-top-of (upper nothing) (lower ?block3)))
   (printout t "Move " ?block1 " on top of " ?block2 "." crlf))

(defrule move-to-floor "Moves a clear block to the floor."
   ?goal <- (goal (move ?block1) (on-top-of floor))
   (block ?block1)
   (on-top-of (upper nothing) (lower ?block1))
   ?stack <- (on-top-of (upper ?block1) (lower ?block2))
   ; Note that we're not insisting that ?block2 be a block.
   =>
   (retract ?goal ?stack)
   (assert (on-top-of (upper ?block1) (lower floor))
           (on-top-of (upper nothing) (lower ?block2)))
   (printout t "Move " ?block1 " to floor." crlf))

(defrule clear-upper-block "Establishes a goal to clear an upper block."
   (goal (move ?block1) (on-top-of ?))  ; Note wild card.
   (block ?block1)
   (on-top-of (upper ?block2) (lower ?block1))
   (block ?block2)
   =>
   (assert (goal (move ?block2) (on-top-of floor))))

(defrule clear-lower-block "Establishes a goal to clear a lower block."
   (goal (move ?) (on-top-of ?block1))  ; Wild card again.
   (block ?block1)
   (on-top-of (upper ?block2) (lower ?block1))
   (block ?block2)
   =>
   (assert (goal (move ?block2) (on-top-of floor))))

; ***********************************************************************
; * The following deffacts describe this initial situation for the      *
; * problem: ---  ---, and we want to put block C on block F.           *
; *          |A|  |D|                                                   *
; *          ---  ---                                                   *
; *          |B|  |E|                                                   *
; *          ---  ---                                                   *
; *          |C|  |F|                                                   *
; *          ---  ---                                                   *
; ***********************************************************************

(deffacts initial-situation "A/B/C, D/E/F, and we want to put C on F."
   (block A)
   (block B)
   (block C)
   (block D)
   (block E)
   (block F)
   (on-top-of (upper nothing) (lower A))
   (on-top-of (upper A) (lower B))
   (on-top-of (upper B) (lower C))
   (on-top-of (upper C) (lower floor))
   (on-top-of (upper nothing) (lower D))
   (on-top-of (upper D) (lower E))
   (on-top-of (upper E) (lower F))
   (on-top-of (upper F) (lower floor))
   (goal (move C) (on-top-of F)))