###############################################################################
###
### 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> ) }