_PROLOG/V: PROLOG IN THE SMALLTALK ENVIRONMENT_
by
Gregory L. Lazarev



[LISTING ONE]

/*  blocks transfer program */


       /* generic */
go( Start, Goal) :- path( Start, Goal, [Start]), !.


path( Goal, Goal, Hist) :-   printpath( Hist).
path( State, Goal, Hist) :-  move( State, Interm),
                             not( member( Interm, Hist) ),
                             path( Interm, Goal, [Interm|Hist]).


member( X, [X|_]).
member( X, [_|T]) :- member( X, T).


printpath( []).
printpath( [H|T] ) :- printpath( T), write( H), nl.



        /* problem specific */
blocks1 :- go( [on(a,b), on(b,t), on(c,t)], [on(a,b), on(b,c), on(c,t)] ).
blocks2 :- go( [on(a,t), on(b,t), on(c,a)], [on(a,b), on(b,c), on(c,t)] ).
blocks3 :- go( [on(a,b), on(b,t), on(c,t),on(d,a)], [on(a,d), on(b,c), on(c,t),
                on(d,b)] ).


move( State1, State2) :- member( on( X,Y), State1),
                         clear( X, State1),
                         not( table( Y)),
                         subst( on( X, Y), State1, on( X, t), State2).
move( State1, State2) :- member( on( X,Y), State1),
                         clear( X, State1),
                         member( on( Z, _), State1),  X \= Z,
                         clear( Z, State1),
                         subst( on( X, Y), State1, on( X, Z), State2).


clear( X, State) :- not( member( on( _, X), State)).


subst( _, [], _, []).
subst( X, [X|L], A, [A|M]) :- !, subst( X, L, A, M).
subst( X, [Y|L], A, [Y|M]) :- subst( X, L, A, M).


table( t).


[LISTING TWO]

Prolog variableSubclass: #Blocks
  instanceVariableNames:
    'position animator number between replyStream selectedChoice '
  classVariableNames: ''
  poolDictionaries: ''


Blocks class methods




Blocks methods

add: block1 onBl:block2
        "add one block to the top of the other"
    | ordColl index col size|
 index := 1.
 col := 0.
 [index <= number
    and: [col = 0] ]
       whileTrue: [
            ( (position at: index) includes: block2 )
                ifTrue: [ col := index].
            index := index + 1].
 ordColl := position at: col.
 ordColl add: block1.
 size := ordColl size.
 position at: col
          put: ordColl.
 animator tell: block1
            place: ( (between * col) - (between * (2/3) ) )  @
         ( (RectPict extent y - 5) - ( 60 * size * Aspect) truncated )


add: block onTbl: col
        "(re)initialize column: add the first block to it"
    | ordColl |
 ordColl := position at: col.
 ordColl add: block.
 position at: col
          put: ordColl.
 animator tell: block
          place: ( (between * col) - (between * (2/3) ) )  @
       ( (RectPict extent y - 5) - ( 60 *  Aspect) truncated)


assign: size
        "assign a variable number"
  number := size

choice: aSymbol
        "Private - Change to the selected choice type."
    selectedChoice := aSymbol.      " #blocks1, #blocks2 or #blocks3"
    self
        changed: #input;
        changed: #reply;
        changed: #graph:


choices
        "Private - Answer an Array of choices"
    ^#( blocks1 blocks2 blocks3 )


doBlocks
     "Actual call to Prolog"
    CursorManager execute change.
    selectedChoice == #blocks1
       ifTrue: [self :? blocks1() ].
    selectedChoice == #blocks2
       ifTrue: [self :? blocks2() ].
    selectedChoice == #blocks3
       ifTrue:  [self :? blocks3() ].
    CursorManager normal change


doBlocksMenu
        "Menu do\help"
   ^Menu
       labels: 'do\help' withCrs
       lines: #()
       selectors: #(doBlocks help)


finish
    Menu message: 'The solution is found'


graph: aRect
   " initialize graph pane, assign global variables"
    |  aForm |
  aForm := Form
     width: aRect width
     height: aRect height.
  aForm displayAt: aRect origin.        "background"
  RectPict := aRect.                    "global vars"
  White := ( Form
       width: 60 height: ( 60 * Aspect) truncated ).
  ^aForm

help
     "Provide help message"
    selectedChoice == #blocks1
       ifTrue: [replyStream nextPutAll:
 'EXPLANATION: This is an animation of the 3 blocks problem'; cr ].
    selectedChoice == #blocks2
       ifTrue: [replyStream nextPutAll:
 'EXPLANATION: This is an animation of the 3 blocks problem'; cr ].
    selectedChoice == #blocks3
     ifTrue: [replyStream nextPutAll:
 'EXPLANATION: This is an animation of the 4 blocks problem'; cr ]


initAnimation
   " initialize Animation"
    | blockImages |
  blockImages :=
        Array with: White.
  animator := Animation new
        initialize: RectPict.
  animator add: blockImages
        name: 'Black'
        color: #black.
  animator add: blockImages
        name: 'LightGray'
        color: #lightGray.
   animator add: blockImages
        name: 'Gray'
        color:#gray.
   selectedChoice ==  #blocks3
     ifTrue: [ animator add: blockImages
                   name: 'DarkGray'
                   color: #darkGray].
      " set speed, shift, background"
   animator
     setBackground;
     speed: 8;
     shiftRate: 10


initialize1
            "initialize Blocks"
    | pen|
     " draw bottom"
 pen := Pen new.
 pen defaultNib: 3 @ 2.
 pen
     place: (RectPict origin x + 5) @ (RectPict corner y - 5);
     goto: (RectPict corner x - 5) @ (RectPict corner y - 5).
     " assign between variable"
 between := RectPict width // number.
     "initialize animation and position"
 self
        initAnimation;
        initPosition

initPosition
        "Set the receiver's initial position"
 position := Array new: number.
 1 to: number do: [:index|
                     position at: index
                              put: OrderedCollection new]


input
        "Private - Answer an input text for
         the selected choice (blocks1, blocks2 or blocks3)."
   | text1 text2 text3 text|
  text1 := 'FROM:  A on B, B on Table, C on Table
TO  :  A on B, B on C, C on Table
       ( COLORS: A- Black, B- LightGray, C- Gray)'.
  text2 := 'FROM:  A on Table, B on Table, C on A
TO  :  A on B, B on C, C on Table
       ( COLORS: A- Black, B- LightGray, C- Gray)'.
  text3 := 'FROM:  A on B, B on Table, C on Table, D on A
TO  :  A on D, B on C, C on Table, D on B
 ( COLORS: A- Black, B- LightGray, C- Gray, D- DarkGray)'.
  selectedChoice == #blocks1
     ifTrue: [text := text1].
  selectedChoice == #blocks2
     ifTrue: [text := text2].
  selectedChoice == #blocks3
     ifTrue: [text := text3].
  ^text
openOn
        "Create a window on Blocks.
         Define the type, behavior and relative
         size of each pane and schedule the window."
    | topPane replyPane|
    topPane := TopPane new label: 'B L O C K S'.
    topPane addSubpane:
        (ListPane new
            model: self;
            name: #choices;
            change: #choice:;
            selection: 1;
            framingRatio: ( 0 @ 0 extent: 1/4 @ (1/6) ) ).
    selectedChoice := #blocks1.
    topPane addSubpane:
        (TextPane new
            model: self;
            name: #input;
            menu: #doBlocksMenu;
            framingRatio: ( 1/4 @ 0 extent:  3/4 @ (1/6) ) ).
    topPane addSubpane:
        (replyPane := TextPane new
            model: self;
            name: #reply;
            framingRatio: ( 0 @ (1/6) extent: 1 @ (1/6) ) ).
    topPane addSubpane:
        (GraphPane new
            model: self;
            name: #graph:;
            framingRatio: ( 0 @ (1/3) extent: 1 @ (2/3) ) ).
    topPane reframe:
        (Display boundingBox insetBy: 10@10).
    replyStream := replyPane dispatcher.
    topPane dispatcher openWindow scheduleWindow


remove: block
        "remove block (from the data structure only)"
    | ordColl index col|
 index := 1.
 col := 0.
 [index <= number
    and: [col = 0] ]
       whileTrue: [
            ( (position at: index) includes: block )
                ifTrue: [ col := index].
            index := index + 1].
 ordColl := position at: col.
 ordColl removeLast.
 position at: col
          put: ordColl


reply
    " Initiate reply pane with an empty String."
  ^ String new



[LISTING THREE]

Blocks variableSubclass: #BlocksPro
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''


BlocksPro class methods


BlocksPro methods

"add on the Table"
addDraw( x) :-
    name( x, name1), col( x, col1),
    is( _, self add: name1 value onTbl: col1 value).


"add on the Block"
addDraw( x, z) :-
    name(x, name1), name( z, name2),
    is( _, self add: name1 value onBl: name2 value).


"arrange0 - the first part of arrange"
arrange0( len, _, _, accum, accum) :-
            length( accum, accumLen),
            eq( len, accumLen).
arrange0( len, master, prev, accum, ordered) :-
            nextStep( master, prev, [], nextPrev),
            append( nextPrev, accum, nextAccum),
            arrange0( len, master, nextPrev, nextAccum, ordered).


"arrange1 - the second step of arrange"
arrange1( master, [#t], arrMaster, arrMaster).
arrange1( master, [h|t], interm, arrMaster) :-
            member( on(h,x), master),
            arrange1( master, t, [on(h,x)| interm], arrMaster).


"arrange ,i.e. [on(a,b),on(b,t),on(c,t),on(d,a)] -->
    --> [d,a,b,c,t] --> [on(c,t), on(b,t), on(a,b), on(d,a)] "
arrange( master, arrMaster) :-
              length( master, len0),
              is( len, len0 value + 1),
              arrange0( len, master, [#t], [#t], ordered),
              arrange1( master, ordered, [], arrMaster),
              !.


"blocks1"
blocks1():- go( [on(#a,#b), on(#b,#t), on(#c,#t)],  [on(#a,#b),
                on(#b,#c), on(#c,#t)] ).


"blocks2"
blocks2():- go( [on(#a,#t), on(#b,#t), on(#c,#a)],  [on(#a,#b),
                on(#b,#c), on(#c,#t)] ).


"blocks3"
blocks3():- go( [on(#a,#b), on(#b,#t), on(#c,#t), on(#d,#a)],
                [on(#a,#d), on(#b,#c), on(#c,#t), on(#d,#b)] ).


"clear"
clear( x, state) :- not( member( on( _, x), state) ).


"column"
col( #a, 1).
col( #b, 2).
col( #c, 3).
col( #d, 4).


"go"
go( start, goal) :- init( start),
                    path( start, goal, [start]),
                    is( _, self finish),
                    !.


"initialize"
init( start) :- length( start, startSize),
                is( _, self assign: startSize value),
                is( _, self initialize1 ),
                arrange( start, arrStart),
                initDraw( arrStart),
                is( _, Menu message: 'Press button to start'),
                !.


"initial drawing"
initDraw( []).
initDraw( [on(x,#t)|tail]) :- addDraw( x),
                              initDraw( tail).
initDraw( [on(x,z)|tail]) :-  addDraw( x,z),
                              initDraw( tail).

"move"
move(state1,state2,x,y,#t) :- member( on( x, y), state1),
                       clear( x, state1),
                       not( table( y) ),
                       subst( on( x, y), state1, on( x, #t), state2).
move(state1,state2,x,y,z) :- member( on( x, y), state1),
                       clear( x, state1),
                       member( on( z, _), state1),  ne( x, z),
                       clear( z, state1),
                       subst( on( x, y), state1, on( x, z), state2).


      "draw Block --> Table"
moveDraw( x, _, #t) :-
    name( x, name1), col( x, col1),
    is( _, self remove: name1 value),
    is( _, self add: name1 value onTbl: col1 value).

      "draw Table --> Block; Block --> Block"
moveDraw( x, _, z) :-
    ne( z, #t),
    name(x, name1), name( z, name2),
    is( _, self remove: name1 value),
    is( _, self add: name1 value onBl: name2 value).


"draw In and Out"
moveDrawInOut( block, placeFrom, placeTo) :-
                        moveDraw( block, placeFrom, placeTo).
moveDrawInOut( block, placeFrom, placeTo) :-
                        moveDraw( block, placeTo, placeFrom),
                        fail().                   " reverse back"


"name"
name( #a, 'Black').
name( #b, 'LightGray').
name( #c, 'Gray').
name( #d, 'DarkGray').


"nextStep - called from arrange0"
nextStep( _, [], nextPrev, nextPrev).
nextStep( master, [h|t], current, nextPrev) :-
      findall( x, member( on( x,h), master), interm),
      append( interm, current, current1),
      nextStep( master, t, current1, nextPrev).


"path"
path( goal, goal, hist) :- is( _, self changed: #reply),
                           printpath( hist).
path( state, goal, hist) :- move(state, interm, block, placeFrom, placeTo),
                            not( member( interm, hist) ),
                            moveDrawInOut( block, placeFrom, placeTo),
                            path( interm, goal, [interm| hist] ).

"printpath1"
printpath1( [h]) :- is( _, replyStream nextPutAll:
                                 (h value printString) ).
printpath1( [h| t] ) :- is( _, replyStream nextPutAll:
                               (  (h value printString), ', ' ) ),
                        printpath1( t).


"printpath - print list in the reverse order"
printpath( []).
printpath( [h| t] ) :- printpath( t),
                       is( _, replyStream nextPutAll: '['),
                       printpath1( h),
                       is( _, replyStream nextPutAll: ']'),
                       is( _, replyStream cr).


"substitute"
subst( _, [], _, []).
subst( x, [x| l], a, [a| m]) :- !,
                                subst( x, l, a, m).
subst( x, [y| l], a, [y| m]) :- subst( x, l, a, m).


"table"
 table( #t).