###############################################################################
###
### File              : blocks.soar
### Original author(s): John E. Laird <laird@eecs.umich.edu>
### Organization      : University of Michigan AI Lab
### Created on        : 15 Mar 1995, 13:53:46
### Last Modified By  : Clare Bates Congdon <congdon@eecs.umich.edu>
### Last Modified On  : 17 Jul 1996, 16:35:14
### Soar Version      : 7
###
### Description : A new, simpler implementation of the blocks world
###               with just three blocks being moved at random.
###
### Notes: 
###   CBC, 6/27: Converted to Tcl syntax
###   CBC, 6/27: Added extensive comments
###############################################################################

 
###############################################################################
# Create the initial state with blocks A, B, and C on the table.
#
# This is the first production that will fire; Soar creates the initial state
#   as an architectural function (in the 'zeroth' decision cycle), which will
#   match against this production.
# This production does a lot of work because it is creating (preferences for)
# all the structure for the initial state:
# 1. The state has a problem-space named 'blocks'. The problem-space limits
#    the operators that will be selected for a task. In this simple problem,
#    it isn't really necessary (there is only one operator), but it's a
#    programming convention that you should get used to.
# 2. The state has four 'things' -- three blocks and the table.
# 3. The state has three 'ontop' relations
# 4. Each of the things has substructure: their type and their names. Note that
#    the fourth thing is actually a 'table'.
# 5. Each of the ontop relations has substructure: the top thing and the
#    bottom thing.
# Finally, the production writes a message for the user.
#
# Note that this production will fire exactly once and will never retract.

sp {blocks-world*elaborate*initial-state
   (state <s> ^superstate nil)
-->
   (<s> ^problem-space blocks
        ^thing <block-A> <block-B> <block-C> <table>
        ^ontop <ontop-A> <ontop-B> <ontop-C>)
   (<block-A> ^type block ^name A)
   (<block-B> ^type block ^name B)
   (<block-C> ^type block ^name C)
   (<table> ^type table ^name TABLE)
   (<ontop-A> ^top-block <block-A> ^bottom-block <table>)
   (<ontop-B> ^top-block <block-B> ^bottom-block <table>)
   (<ontop-C> ^top-block <block-C> ^bottom-block <table>)
   (write (crlf) |Initial state has A, B, and C on the table.|)}


###############################################################################
# State elaborations - keep track of which objects are clear
# There are two productions - one for blocks and one for the table.
###############################################################################

###############################################################################
# Assert table always clear
#
# The conditions establish that:
#  1. The state has a problem-space named 'blocks'.
#  2. The state has a thing of type table.
# The action:
#  1. creates an acceptable preference for an attribute-value pair asserting
#     the table is clear.
#
# This production will also fire once and never retract.

sp {elaborate*table*clear
   (state <s> ^problem-space blocks
              ^thing <table>)
   (<table> ^type table)
-->
   (<table> ^clear yes)}

###############################################################################
# Calculate whether a block is clear
#
# The conditions establish that:
#  1. The state has a problem-space named 'blocks'.
#  2. The state has a thing of type block.
#  3. There is no 'ontop' relation having the block as its 'bottom-block'.
# The action:
#  1. create an acceptable preference for an attribute-value pair asserting
#     the block is clear.
#
# This production will retract whenever an 'ontop' relation for the given block
#  is created. Since the (<block> ^clear yes) wme only has i-support, it will
#  be removed from working memory automatically when the production retracts.

sp {elaborate*block*clear
   (state <s> ^problem-space blocks
              ^thing <block>)
   (<block> ^type block)
   -(<ontop> ^bottom-block <block>)
-->
   (<block> ^clear yes)}


###############################################################################
# Suggest MOVE-BLOCK operators
#
# This production proposes operators that move one block ontop of another block.  
# The conditions establish that:
#  1. The state has a problem-space named 'blocks'
#  2. The block moved and the block moved TO must be both be clear.
#  3. The block moved is different from the block moved to.
#  4. The block moved must be type block.
#  5. The block moved must not already be ontop the block being moved to.
# The actions:
#  1. create an acceptable preference for an operator.
#  2. create acceptable preferences for the substructure of the operator (its
#     name, its 'moving-block' and the 'destination).

sp {blocks-world*propose*move-block
   (state <s> ^problem-space blocks
              ^thing <thing1> {<> <thing1> <thing2>}
              ^ontop <ontop>)
   (<thing1> ^type block ^clear yes)
   (<thing2> ^clear yes)
   (<ontop> ^top-block <thing1>
            ^bottom-block <> <thing2>)
-->
   (<s> ^operator <o> +)
   (<o> ^name move-block
        ^moving-block <thing1>
        ^destination <thing2>)}

###############################################################################
# Make all acceptable move-block operators also indifferent
#
# The conditions establish that:
#  1. the state has an acceptable preference for an operator
#  2. the operator is named move-block
# The actions:
#  1. create an indifferent prefererence for the operator

sp {blocks-world*compare*move-block*indifferent
   (state <s> ^operator <o> +)
   (<o> ^name move-block)
-->
   (<s> ^operator <o> =)}



###############################################################################
# Apply a MOVE-BLOCK operator
# 
# There are two productions that are part of applying the operator.
# Both will fire in parallel.
###############################################################################

###############################################################################
# Apply a MOVE-BLOCK operator
#   (the block is no longer ontop of the thing it used to be ontop of)
#
# This production is part of the application of a move-block operator.
# The conditions establish that:
#  1. An operator has been selected for the current state
#     a. the operator is named move-block
#     b. the operator has a 'moving-block' and a 'destination'
#  2. The state has an ontop relation
#     a. the ontop relation has a 'top-block' that is the same as the
#        'moving-block' of the operator
#     b. the ontop relation has a 'bottom-block' that is different from the 
#        'destination' of the operator
# The actions:
#  1. create a reject preference for the ontop relation

sp {blocks-world*apply*move-block*remove-old-ontop
   (state <s> ^operator <o>
              ^ontop <ontop>)
   (<o> ^name move-block 
        ^moving-block <block1> 
        ^destination <block2>)
   (<ontop> ^top-block <block1> 
            ^bottom-block { <> <block2> <block3> })
-->
   (<s> ^ontop <ontop> -)}
 

###############################################################################
# Apply a MOVE-BLOCK operator
#   (the block is now ontop of the destination)
#
# This production is part of the application of a move-block operator.
# The conditions establish that:
#  1. An operator has been selected for the current state
#     a. the operator is named move-block
#     b. the operator has a 'moving-block' and a 'destination'
# The actions:
#  1. create an acceptable preference for a new ontop relation
#  2. create (acceptable preferences for) the substructure of the ontop
#     relation: the top block and the bottom block

sp {blocks-world*apply*move-block*add-new-ontop
   (state <s> ^operator <o>)
   (<o> ^name move-block
        ^moving-block <block1>
        ^destination <block2>)
-->
   (<s> ^ontop <ontop>)
   (<ontop> ^top-block <block1>
            ^bottom-block <block2>)}


###############################################################################
###############################################################################
# Detect that the goal has been achieved 
#
# The conditions establish that:
#  1. The state has a problem-space named 'blocks'
#  2. The state has three ontop relations
#     a. a block named A is ontop a block named B
#     b. a block named B is ontop a block named C
#     c. a block named C is ontop a block named TABLE
# The actions:
#  1. print a message for the user that the A,B,C tower has been built
#  2. halt Soar

sp {blocks-world*detect*goal
   (state <s> ^problem-space blocks
              ^ontop <AB> 
               { <> <AB> <BC>}
               { <> <AB> <> <BC> <CT> } )
   (<AB> ^top-block <A> ^bottom-block <B>)
   (<BC> ^top-block <B> ^bottom-block <C>)
   (<CT> ^top-block <C> ^bottom-block <T>)
   (<A> ^type block ^name A)
   (<B> ^type block ^name B)
   (<C> ^type block ^name C)
   (<T> ^type table ^name TABLE)
-->
   (write (crlf) |Achieved A, B, C|)
   (halt)}


###############################################################################
###############################################################################
# Monitor the state: Print a message every time a block is moved
#
# The conditions establish that:
#  1. An operator has been selected for the current state
#     a. the operator is named move-block
#     b. the operator has a 'moving-block' and a 'destination'
#  2. each block has a name
# The actions:
#  1. print a message for the user that the block has been moved to the
#     destination. 

sp {blocks-world*monitor*move-block
   (state <s> ^operator <o>)
   (<o> ^name move-block
        ^moving-block <block1>
        ^destination <block2>)
   (<block1> ^name <block1-name>)
   (<block2> ^name <block2-name>)   
-->
   (write (crlf) |Moving Block: | <block1-name>
                 | to: | <block2-name> ) }