home *** CD-ROM | disk | FTP | other *** search
/ Hall of Fame / HallofFameCDROM.cdr / proglc / ddj1188.lzh / GREGLAZ.ASC < prev    next >
Text File  |  1988-10-21  |  14KB  |  495 lines
  1. _PROLOG/V: PROLOG IN THE SMALLTALK ENVIRONMENT_
  2. by
  3. Gregory L. Lazarev
  4.  
  5.  
  6.  
  7. [LISTING ONE]
  8.  
  9. /*  blocks transfer program */
  10.  
  11.  
  12.        /* generic */
  13. go( Start, Goal) :- path( Start, Goal, [Start]), !.
  14.  
  15.  
  16. path( Goal, Goal, Hist) :-   printpath( Hist).
  17. path( State, Goal, Hist) :-  move( State, Interm),
  18.                              not( member( Interm, Hist) ),
  19.                              path( Interm, Goal, [Interm|Hist]).
  20.  
  21.  
  22. member( X, [X|_]).
  23. member( X, [_|T]) :- member( X, T).
  24.  
  25.  
  26. printpath( []).
  27. printpath( [H|T] ) :- printpath( T), write( H), nl.
  28.  
  29.  
  30.  
  31.         /* problem specific */
  32. blocks1 :- go( [on(a,b), on(b,t), on(c,t)], [on(a,b), on(b,c), on(c,t)] ).
  33. blocks2 :- go( [on(a,t), on(b,t), on(c,a)], [on(a,b), on(b,c), on(c,t)] ).
  34. blocks3 :- go( [on(a,b), on(b,t), on(c,t),on(d,a)], [on(a,d), on(b,c), on(c,t),
  35.                 on(d,b)] ).
  36.  
  37.  
  38. move( State1, State2) :- member( on( X,Y), State1),
  39.                          clear( X, State1),
  40.                          not( table( Y)),
  41.                          subst( on( X, Y), State1, on( X, t), State2).
  42. move( State1, State2) :- member( on( X,Y), State1),
  43.                          clear( X, State1),
  44.                          member( on( Z, _), State1),  X \= Z,
  45.                          clear( Z, State1),
  46.                          subst( on( X, Y), State1, on( X, Z), State2).
  47.  
  48.  
  49. clear( X, State) :- not( member( on( _, X), State)).
  50.  
  51.  
  52. subst( _, [], _, []).
  53. subst( X, [X|L], A, [A|M]) :- !, subst( X, L, A, M).
  54. subst( X, [Y|L], A, [Y|M]) :- subst( X, L, A, M).
  55.  
  56.  
  57. table( t).
  58.  
  59.  
  60. [LISTING TWO]
  61.  
  62. Prolog variableSubclass: #Blocks
  63.   instanceVariableNames:
  64.     'position animator number between replyStream selectedChoice '
  65.   classVariableNames: ''
  66.   poolDictionaries: ''
  67.  
  68.  
  69. Blocks class methods
  70.  
  71.  
  72.  
  73.  
  74. Blocks methods
  75.  
  76. add: block1 onBl:block2
  77.         "add one block to the top of the other"
  78.     | ordColl index col size|
  79.  index := 1.
  80.  col := 0.
  81.  [index <= number
  82.     and: [col = 0] ]
  83.        whileTrue: [
  84.             ( (position at: index) includes: block2 )
  85.                 ifTrue: [ col := index].
  86.             index := index + 1].
  87.  ordColl := position at: col.
  88.  ordColl add: block1.
  89.  size := ordColl size.
  90.  position at: col
  91.           put: ordColl.
  92.  animator tell: block1
  93.             place: ( (between * col) - (between * (2/3) ) )  @
  94.          ( (RectPict extent y - 5) - ( 60 * size * Aspect) truncated )
  95.  
  96.  
  97. add: block onTbl: col
  98.         "(re)initialize column: add the first block to it"
  99.     | ordColl |
  100.  ordColl := position at: col.
  101.  ordColl add: block.
  102.  position at: col
  103.           put: ordColl.
  104.  animator tell: block
  105.           place: ( (between * col) - (between * (2/3) ) )  @
  106.        ( (RectPict extent y - 5) - ( 60 *  Aspect) truncated)
  107.  
  108.  
  109. assign: size
  110.         "assign a variable number"
  111.   number := size
  112.  
  113. choice: aSymbol
  114.         "Private - Change to the selected choice type."
  115.     selectedChoice := aSymbol.      " #blocks1, #blocks2 or #blocks3"
  116.     self
  117.         changed: #input;
  118.         changed: #reply;
  119.         changed: #graph:
  120.  
  121.  
  122. choices
  123.         "Private - Answer an Array of choices"
  124.     ^#( blocks1 blocks2 blocks3 )
  125.  
  126.  
  127. doBlocks
  128.      "Actual call to Prolog"
  129.     CursorManager execute change.
  130.     selectedChoice == #blocks1
  131.        ifTrue: [self :? blocks1() ].
  132.     selectedChoice == #blocks2
  133.        ifTrue: [self :? blocks2() ].
  134.     selectedChoice == #blocks3
  135.        ifTrue:  [self :? blocks3() ].
  136.     CursorManager normal change
  137.  
  138.  
  139. doBlocksMenu
  140.         "Menu do\help"
  141.    ^Menu
  142.        labels: 'do\help' withCrs
  143.        lines: #()
  144.        selectors: #(doBlocks help)
  145.  
  146.  
  147. finish
  148.     Menu message: 'The solution is found'
  149.  
  150.  
  151. graph: aRect
  152.    " initialize graph pane, assign global variables"
  153.     |  aForm |
  154.   aForm := Form
  155.      width: aRect width
  156.      height: aRect height.
  157.   aForm displayAt: aRect origin.        "background"
  158.   RectPict := aRect.                    "global vars"
  159.   White := ( Form
  160.        width: 60 height: ( 60 * Aspect) truncated ).
  161.   ^aForm
  162.  
  163. help
  164.      "Provide help message"
  165.     selectedChoice == #blocks1
  166.        ifTrue: [replyStream nextPutAll:
  167.  'EXPLANATION: This is an animation of the 3 blocks problem'; cr ].
  168.     selectedChoice == #blocks2
  169.        ifTrue: [replyStream nextPutAll:
  170.  'EXPLANATION: This is an animation of the 3 blocks problem'; cr ].
  171.     selectedChoice == #blocks3
  172.      ifTrue: [replyStream nextPutAll:
  173.  'EXPLANATION: This is an animation of the 4 blocks problem'; cr ]
  174.  
  175.  
  176. initAnimation
  177.    " initialize Animation"
  178.     | blockImages |
  179.   blockImages :=
  180.         Array with: White.
  181.   animator := Animation new
  182.         initialize: RectPict.
  183.   animator add: blockImages
  184.         name: 'Black'
  185.         color: #black.
  186.   animator add: blockImages
  187.         name: 'LightGray'
  188.         color: #lightGray.
  189.    animator add: blockImages
  190.         name: 'Gray'
  191.         color:#gray.
  192.    selectedChoice ==  #blocks3
  193.      ifTrue: [ animator add: blockImages
  194.                    name: 'DarkGray'
  195.                    color: #darkGray].
  196.       " set speed, shift, background"
  197.    animator
  198.      setBackground;
  199.      speed: 8;
  200.      shiftRate: 10
  201.  
  202.  
  203. initialize1
  204.             "initialize Blocks"
  205.     | pen|
  206.      " draw bottom"
  207.  pen := Pen new.
  208.  pen defaultNib: 3 @ 2.
  209.  pen
  210.      place: (RectPict origin x + 5) @ (RectPict corner y - 5);
  211.      goto: (RectPict corner x - 5) @ (RectPict corner y - 5).
  212.      " assign between variable"
  213.  between := RectPict width // number.
  214.      "initialize animation and position"
  215.  self
  216.         initAnimation;
  217.         initPosition
  218.  
  219. initPosition
  220.         "Set the receiver's initial position"
  221.  position := Array new: number.
  222.  1 to: number do: [:index|
  223.                      position at: index
  224.                               put: OrderedCollection new]
  225.  
  226.  
  227. input
  228.         "Private - Answer an input text for
  229.          the selected choice (blocks1, blocks2 or blocks3)."
  230.    | text1 text2 text3 text|
  231.   text1 := 'FROM:  A on B, B on Table, C on Table
  232. TO  :  A on B, B on C, C on Table
  233.        ( COLORS: A- Black, B- LightGray, C- Gray)'.
  234.   text2 := 'FROM:  A on Table, B on Table, C on A
  235. TO  :  A on B, B on C, C on Table
  236.        ( COLORS: A- Black, B- LightGray, C- Gray)'.
  237.   text3 := 'FROM:  A on B, B on Table, C on Table, D on A
  238. TO  :  A on D, B on C, C on Table, D on B
  239.  ( COLORS: A- Black, B- LightGray, C- Gray, D- DarkGray)'.
  240.   selectedChoice == #blocks1
  241.      ifTrue: [text := text1].
  242.   selectedChoice == #blocks2
  243.      ifTrue: [text := text2].
  244.   selectedChoice == #blocks3
  245.      ifTrue: [text := text3].
  246.   ^text
  247. openOn
  248.         "Create a window on Blocks.
  249.          Define the type, behavior and relative
  250.          size of each pane and schedule the window."
  251.     | topPane replyPane|
  252.     topPane := TopPane new label: 'B L O C K S'.
  253.     topPane addSubpane:
  254.         (ListPane new
  255.             model: self;
  256.             name: #choices;
  257.             change: #choice:;
  258.             selection: 1;
  259.             framingRatio: ( 0 @ 0 extent: 1/4 @ (1/6) ) ).
  260.     selectedChoice := #blocks1.
  261.     topPane addSubpane:
  262.         (TextPane new
  263.             model: self;
  264.             name: #input;
  265.             menu: #doBlocksMenu;
  266.             framingRatio: ( 1/4 @ 0 extent:  3/4 @ (1/6) ) ).
  267.     topPane addSubpane:
  268.         (replyPane := TextPane new
  269.             model: self;
  270.             name: #reply;
  271.             framingRatio: ( 0 @ (1/6) extent: 1 @ (1/6) ) ).
  272.     topPane addSubpane:
  273.         (GraphPane new
  274.             model: self;
  275.             name: #graph:;
  276.             framingRatio: ( 0 @ (1/3) extent: 1 @ (2/3) ) ).
  277.     topPane reframe:
  278.         (Display boundingBox insetBy: 10@10).
  279.     replyStream := replyPane dispatcher.
  280.     topPane dispatcher openWindow scheduleWindow
  281.  
  282.  
  283. remove: block
  284.         "remove block (from the data structure only)"
  285.     | ordColl index col|
  286.  index := 1.
  287.  col := 0.
  288.  [index <= number
  289.     and: [col = 0] ]
  290.        whileTrue: [
  291.             ( (position at: index) includes: block )
  292.                 ifTrue: [ col := index].
  293.             index := index + 1].
  294.  ordColl := position at: col.
  295.  ordColl removeLast.
  296.  position at: col
  297.           put: ordColl
  298.  
  299.  
  300. reply
  301.     " Initiate reply pane with an empty String."
  302.   ^ String new
  303.  
  304.  
  305.  
  306. [LISTING THREE]
  307.  
  308. Blocks variableSubclass: #BlocksPro
  309.   instanceVariableNames: ''
  310.   classVariableNames: ''
  311.   poolDictionaries: ''
  312.  
  313.  
  314. BlocksPro class methods
  315.  
  316.  
  317. BlocksPro methods
  318.  
  319. "add on the Table"
  320. addDraw( x) :-
  321.     name( x, name1), col( x, col1),
  322.     is( _, self add: name1 value onTbl: col1 value).
  323.  
  324.  
  325. "add on the Block"
  326. addDraw( x, z) :-
  327.     name(x, name1), name( z, name2),
  328.     is( _, self add: name1 value onBl: name2 value).
  329.  
  330.  
  331. "arrange0 - the first part of arrange"
  332. arrange0( len, _, _, accum, accum) :-
  333.             length( accum, accumLen),
  334.             eq( len, accumLen).
  335. arrange0( len, master, prev, accum, ordered) :-
  336.             nextStep( master, prev, [], nextPrev),
  337.             append( nextPrev, accum, nextAccum),
  338.             arrange0( len, master, nextPrev, nextAccum, ordered).
  339.  
  340.  
  341. "arrange1 - the second step of arrange"
  342. arrange1( master, [#t], arrMaster, arrMaster).
  343. arrange1( master, [h|t], interm, arrMaster) :-
  344.             member( on(h,x), master),
  345.             arrange1( master, t, [on(h,x)| interm], arrMaster).
  346.  
  347.  
  348. "arrange ,i.e. [on(a,b),on(b,t),on(c,t),on(d,a)] -->
  349.     --> [d,a,b,c,t] --> [on(c,t), on(b,t), on(a,b), on(d,a)] "
  350. arrange( master, arrMaster) :-
  351.               length( master, len0),
  352.               is( len, len0 value + 1),
  353.               arrange0( len, master, [#t], [#t], ordered),
  354.               arrange1( master, ordered, [], arrMaster),
  355.               !.
  356.  
  357.  
  358. "blocks1"
  359. blocks1():- go( [on(#a,#b), on(#b,#t), on(#c,#t)],  [on(#a,#b),
  360.                 on(#b,#c), on(#c,#t)] ).
  361.  
  362.  
  363. "blocks2"
  364. blocks2():- go( [on(#a,#t), on(#b,#t), on(#c,#a)],  [on(#a,#b),
  365.                 on(#b,#c), on(#c,#t)] ).
  366.  
  367.  
  368. "blocks3"
  369. blocks3():- go( [on(#a,#b), on(#b,#t), on(#c,#t), on(#d,#a)],
  370.                 [on(#a,#d), on(#b,#c), on(#c,#t), on(#d,#b)] ).
  371.  
  372.  
  373. "clear"
  374. clear( x, state) :- not( member( on( _, x), state) ).
  375.  
  376.  
  377. "column"
  378. col( #a, 1).
  379. col( #b, 2).
  380. col( #c, 3).
  381. col( #d, 4).
  382.  
  383.  
  384. "go"
  385. go( start, goal) :- init( start),
  386.                     path( start, goal, [start]),
  387.                     is( _, self finish),
  388.                     !.
  389.  
  390.  
  391. "initialize"
  392. init( start) :- length( start, startSize),
  393.                 is( _, self assign: startSize value),
  394.                 is( _, self initialize1 ),
  395.                 arrange( start, arrStart),
  396.                 initDraw( arrStart),
  397.                 is( _, Menu message: 'Press button to start'),
  398.                 !.
  399.  
  400.  
  401. "initial drawing"
  402. initDraw( []).
  403. initDraw( [on(x,#t)|tail]) :- addDraw( x),
  404.                               initDraw( tail).
  405. initDraw( [on(x,z)|tail]) :-  addDraw( x,z),
  406.                               initDraw( tail).
  407.  
  408. "move"
  409. move(state1,state2,x,y,#t) :- member( on( x, y), state1),
  410.                        clear( x, state1),
  411.                        not( table( y) ),
  412.                        subst( on( x, y), state1, on( x, #t), state2).
  413. move(state1,state2,x,y,z) :- member( on( x, y), state1),
  414.                        clear( x, state1),
  415.                        member( on( z, _), state1),  ne( x, z),
  416.                        clear( z, state1),
  417.                        subst( on( x, y), state1, on( x, z), state2).
  418.  
  419.  
  420.       "draw Block --> Table"
  421. moveDraw( x, _, #t) :-
  422.     name( x, name1), col( x, col1),
  423.     is( _, self remove: name1 value),
  424.     is( _, self add: name1 value onTbl: col1 value).
  425.  
  426.       "draw Table --> Block; Block --> Block"
  427. moveDraw( x, _, z) :-
  428.     ne( z, #t),
  429.     name(x, name1), name( z, name2),
  430.     is( _, self remove: name1 value),
  431.     is( _, self add: name1 value onBl: name2 value).
  432.  
  433.  
  434. "draw In and Out"
  435. moveDrawInOut( block, placeFrom, placeTo) :-
  436.                         moveDraw( block, placeFrom, placeTo).
  437. moveDrawInOut( block, placeFrom, placeTo) :-
  438.                         moveDraw( block, placeTo, placeFrom),
  439.                         fail().                   " reverse back"
  440.  
  441.  
  442. "name"
  443. name( #a, 'Black').
  444. name( #b, 'LightGray').
  445. name( #c, 'Gray').
  446. name( #d, 'DarkGray').
  447.  
  448.  
  449. "nextStep - called from arrange0"
  450. nextStep( _, [], nextPrev, nextPrev).
  451. nextStep( master, [h|t], current, nextPrev) :-
  452.       findall( x, member( on( x,h), master), interm),
  453.       append( interm, current, current1),
  454.       nextStep( master, t, current1, nextPrev).
  455.  
  456.  
  457. "path"
  458. path( goal, goal, hist) :- is( _, self changed: #reply),
  459.                            printpath( hist).
  460. path( state, goal, hist) :- move(state, interm, block, placeFrom, placeTo),
  461.                             not( member( interm, hist) ),
  462.                             moveDrawInOut( block, placeFrom, placeTo),
  463.                             path( interm, goal, [interm| hist] ).
  464.  
  465. "printpath1"
  466. printpath1( [h]) :- is( _, replyStream nextPutAll:
  467.                                  (h value printString) ).
  468. printpath1( [h| t] ) :- is( _, replyStream nextPutAll:
  469.                                (  (h value printString), ', ' ) ),
  470.                         printpath1( t).
  471.  
  472.  
  473. "printpath - print list in the reverse order"
  474. printpath( []).
  475. printpath( [h| t] ) :- printpath( t),
  476.                        is( _, replyStream nextPutAll: '['),
  477.                        printpath1( h),
  478.                        is( _, replyStream nextPutAll: ']'),
  479.                        is( _, replyStream cr).
  480.  
  481.  
  482. "substitute"
  483. subst( _, [], _, []).
  484. subst( x, [x| l], a, [a| m]) :- !,
  485.                                 subst( x, l, a, m).
  486. subst( x, [y| l], a, [y| m]) :- subst( x, l, a, m).
  487.  
  488.  
  489. "table"
  490.  table( #t).
  491.  
  492.  
  493.  
  494.  
  495.