OOP in Lisp

By Jean Pascal J. Lange, Uebersyren, Luxembourg

Object-oriented programming in Allegro Common Lisp

[Due to an error on our part, part II of this article was printed in the July issue of this year; this is part I.-ed]

Allegro Common Lisp, by Coral Software Corp. (Cambridge, Massachusetts), has already been presented to MacTutor readers by Paul Snively (see his article “Lisp Listener, MacScheme versus Coral Lisp” in March 1988 issue). I do not intend to repeat what he and others did better than I could do, so the reader is supposed to already have a working knowledge of Common Lisp (some books on this topic: “Common Lisp” by Guy L. Steele Jr., Digital Press 1984 -the bible, heavy, indigestible, less than “Inside Macintosh” however, but a must-; “a programmer’s guide to Common Lisp” by Deborah G. Tatar, Digital Press 1987 -a good introduction to the aforementioned reference book-; “Lisp, third edition” by Patrick H. Winston and Berthold K. P. Horn, Addison-Wesley 1988 -a classic-).

Since Paul’s paper, however, a new release, 1.2, has been released. In addition to some cosmetics modifications and a few other add-ons, some bugs have been fixed but the main addition is a dump facility, which enables the user to create an image (snapshot) of his (her) Allegro Common Lisp environment.

Allegro Common Lisp offers thorough object-oriented programming facilities and, for some time, it has been the only complete implementation of Common Lisp on the Macintosh but another product, purely software, has arrived from Procyon Research ltd. (UK) in addition to the plug-in boards from Texas Instruments (micro-Explorer) and Symbolics (Ivory).

Two books are recommended to those people interested in object-oriented programming: “a taste of Smalltalk” by Ted Kaehler and Dave Patterson (W. W. Norton & company editors) for a first approach to Smalltalk -maybe the most renowned object-oriented programming language (developed at Xerox Palo Alto Research Center, like most of Macintosh ancestors and basic grounds)- and “Object-oriented programming for the Macintosh” by Kurt J. Schmucker (Hayden book company editor, Macintosh library) for a global overview of what is currently available in this field on the Macintosh -Kurt is already known to MacTutor readers as he published an article on MacApp in December 1986 issue (Vol. 2 n° 12).

This paper will focus mainly on the object-oriented programming features offered by Allegro Common Lisp.

Unlike other object-oriented programming languages, (e. g. Smalltalk-80), Allegro Common Lisp, as well as ObjectLogo from Coral software too, does not enforce a strict difference between class and instance. This greatly helps prototyping in the sense the user is not constrained to create an instance object in order to test (or use) on the fly some procedures: he/she can directly use the class name as an usual object instance, however this feature does not preclude to use class methods and variables (see further).

Another main difference is that Allegro Common Lisp does not use the message passing mechanism “à la SmallTalk” but well the traditional functional approach -Lisp obliges-. Although this choice was almost mandatory in a Lisp environment, Smalltalk programming style, which uses pure message passing, is lighter and clearer (interested readers should compare the examples given by Ted Kaehler and Dave Patterson in their above mentioned book with their translation in Allegro Common Lisp given further in this paper).

In addition, SmallTalk offers, from a personal point of view, a more complete and more attractive developing environment but at a much higher price in hardware requirements: a minimum of 5 Mb on disk (a hard disk is mandatory -Allegro Common Lisp does well with 2 800k drives-), at least 2 Mb in RAM (Allegro Common Lisp runs with 1 Mb, but is quite slow as it does a lot of garbage collection) and a quite large screen, 1024 x 640 as a minimum, which practically prevents its use on a Mac Plus (the programs presented in this paper were developed using a 2Mb Mac Plus, with 2 800k drives).

A last comparison: some other Lisp implementations (e.g. Procyon Common Lisp already mentioned, Le_Lisp -from ACT informatique, Paris, France-) offer a true file compiler generating double-clickable applications (including a run-time environment, not requiring the presence of the interpreter), although no actual SmallTalk implementation offers such a feature.

Everywhere in the following programs, a useful spelling convention has been used: in place of using the underscore character (_) to build self-speaking identifiers names, an upper-case character signals the beginning of a new “word”, so moveTower stands for move_tower. Unfortunately (?), Common Lisp does not keep the case (unless you tell it, which might be confusing as for the functions and variables defined by the language, one should keep using only upper-case names).

Traditional towers of Hanoï

A first example (listing 1) is the Allegro Common Lisp version of the “towers of Hanoï” game, given in its simplest way, the moves are printed in the Listener window (to which, by default, Allegro Common Lisp writes all the text it outputs -including error messages- or it is summoned to print). It does not include any object-oriented programming features at all and could be translated straightforward in any language providing recursion (like Pascal, Logo,...). Listing 2 shows the result of “evaluating” listing 1 and running some example.

Object-minded towers of Hanoï

The second example (listing 3) follows as closely as possible the version given in Kaehler and Patterson’s book (chapter 4) already mentioned. Here, object-oriented programming finally appears.

Some comments on the syntax: Allegro Common Lisp creates a new entity (either a class or an object) with the defObject function which takes one or more arguments: the first one is the name, the eventual next ones the parents -one or many, as multiple inheritance is supported-, if no parent is supplied, the new object will be a descendant of the root object, the ancestor common to every object, the Adam or Eve of the object kind.

Other ways to define a new entity are the functions kindOf which takes one or many arguments and oneOf to create a new instance object.

A method is created with the defObFun function whose first argument is a list of two items (the method name and the owner class name) and the second a mandatory method argument list -if no actual argument is required, it will be the empty list or nil-.

In order to avoid warning messages at compile time, it is necessary to declare the object variables (instance as well as class variables) as well as the parents classes and every other class referred to in the methods: if one does not want to insert a declare function at the beginning of every method body using an object variable, a proclaim declaration is inserted before any method definition, using an object-variable declaration specification.

Allegro Common Lisp sends messages (equivalent for “calls procedures” in traditional programming languages) using the ask function: the object to which the message is sent is the first argument, the message itself is enclosed, with its eventual arguments, in a list as the second argument (several messages may be sent to the same object, in sequence).

The exist method always requires the init-list argument, even if one does not intend to pass it any actual argument at all.

Listing 4 shows how an instance object (aTowerOfHanoi) of the class towerOfHanoi is created and how the game is started: every times the Allegro Common Lisp function oneOf is executed, it creates a new object of the class given as argument -one may pass more than one class as argument, this mechanism being defined as “multiple inheritance”-, gives the just created object access to every function defined for that class (or classes) and runs the function exist if it can find a function with this name defined for that class.

In the present example, such a function exists: it only furnishes the new object just created a variable called stacks -this variable is by no way any further defined nor precised in exist, but will be later on by the Hanoi method-.

Then the newly created object is required to execute the Hanoi method (in object-oriented programming terminology, method stands for function code).

The Hanoi method asks for the number of disks to be moved, sets up all the internal stuff -among others thing, it precises completely what the object variable stacks is- and then runs the moveTower method with the number of disks just given.

In this example, all disks are supposed to be moved from the first pin to the third one, using the second as a temporary repository.

Note the moveDisk method has completely been freed from the implementation details, in this case the way the disks are represented on the various pegs, this further step towards data independence is provided by object-oriented programming and would be much more difficult to implement with traditional languages.

The Hanoi method has been improved respect to the original SmallTalk code as it loops on howMany until it gets an integer value, in order to avoid errors later on.

Note also, how an object variable, stacks, can be used as any other Lisp symbol and passed as an argument to a usual function, addFirst or getAndRemoveFirst, by noway tight to some object.

Some annoying restriction (is-it a bug or just a feature?): Allegro Common Lisp does not like to know about a “global” function and an object method sharing the same name. Moreover, the order in which they are defined is relevant: if the “global” function like Hanoi or moveDisk (see listing 1) is defined first, trying to define an object (class or instance) method having the same name as for towerOfHanoi (see listing 3) produces a “fatal” error message (listing 5), defining first the method and then the function just gives a “continuable” error (listing 6).

Animated towers of Hanoï

The previous example did not depart very much from conventional programming style and did not take profit at all from Macintosh’s graphics capabilities.

The third example illustrates quite well the way object-oriented programming allows to enrich a given program, just adding new features without having to rebuild from scratch the whole code.

The whole game has been divided in two distinct parts: the game itself (the class animatedTowerOfHanoi), which does not draw anything but the general frame in which it will take part, and the actual disks animation (the class HanoiDisk).

A overall sketch of all the classes presented in this paper, and their hierarchical relationship, is presented on table 1, where classes are named within rounded-rectangles; the thin arrows indicate the pointed class uses the origin one and the bold arrows show the hierarchical dependencies.

Table 1.

Before going any further, some additional tool has to be build: the class rectangle which will allow to create and manipulate rectangles (“abstract” objects) and rectangular images.

Listing 7 shows a possible implementation of this class: it is a straightforward -and incomplete- translation of the equivalent Smalltalk-80 class, as Allegro Common Lisp does not furnish any but offers some facility under the form of records “à la Pascal”, which are intended to be used only in conjunction with ToolBox low-level calls.

A rectangle record is defined as the traditional QuickDraw 4-tuple (top-left-bottom-right) or as the variant pair (topLeft-bottomRight), or any valid combination of these two (top-left-bottomRight or topLeft-bottom-right). These various ways to define a rectangle record is the cause of the rather complicated code of the exist method -by the way, the interested reader is invited to refine the way conflicting coordinates are managed, giving a warning message, and no more an error message, if there is just some redundancy in the coordinates, e.g. ‘top 10 passed along with ‘topLeft #@(10 10)-. So, a rectangle object can be defined using one of these four “complete” possibilities, plus two other ones: origin-corner and origin-extent, which are converted to the usual one; the eventually missing coordinates are defaulted to 0. Some more definition possibilities might be added, e.g. center-width-height etc

All but three methods modify only the internal representation of the concerned rectangle. These three methods, border, erase and invertRect, cope with visible rectangular images and take an optional argument, window, telling in which window the drawing has to take place, by default, if no actual argument is furnished, the front window. At the early beginning of this listing, the require functions tell Allegro Common Lisp to assure the records and quickdraw modules are present (have been loaded) before compiling, evaluating or loading the rest of the file.

Listing 8 represents the class animatedTowerOfHanoi, the animated version of the game: two new functions have been added: setupDisks which draws the box where the animation will take place, initializes the class variables, creates and draws the disks and howMany which outputs the number of disks actually used in this animation. All the methods defined in the parent class towerOfHanoi, but moveTower (plus the two functions addFirst and getAndRemoveFirst) have been redefined, but exist refers to its parent function, prefixing its name with usual (the Smalltalk counterpart is super). setUpDisks first calls the HanoiDisk class method whichTowers in order to initialize the variables of that class (see listing 9); these variables will be shared by every instance object of that class and thus allow all the objects pertaining to a given class to share common data in addition to the common methods. The use of the function self (in setUpDisks) illustrates how an object can be lexically bound in order to be passed to some other objects (here an animatedTowerOfHanoi is passed to the HanoiDisk class).

Unlike Smalltalk, Allegro Common Lisp does not force the programmer to define the class and instance variables all together at the same time. Moreover, it allows some of them to share the same name and uses the following conflict resolution strategy: it first looks in the instance variables for such a name, if not found, it searches the class variables for that name and finally starts the search among the ancestors of the current class, starting from the parent(s) class(es).

Usually, the instance variables are created inside the exist function which is executed automatically whenever a new instance is created (using the oneOf function): this ensures that every instance will have at its disposal such a variable. It is advisable to create class variables (using the have function) inside a function to be called only by that class (in this example, whichTowers ).

A syntactic remark: in addition to the usual “end-of-line” comment (beginning with a semi-colon and terminated by a carriage return, i.e. the end of line), Allegro Common Lisp allows to enclose comments anywhere inside the code surrounding them by #| and |#, which is very useful for debugging purposes or when some comment takes many line.

In this case, the format function call printing out the disk movements has been commented in order to keep the drawing readable: one may draw in the Listener window, in which Allegro Common Lisp communicates with the programmer, but drawing is not scrollable, so the produced output interferes very quickly with the drawing and it is advisable to keep written output as low as possible (a further example will alleviate this restriction, which has been kept in order to follow as strictly as possible the original SmallTalk coding).

HanoiDisk class code is given at listing 9. Have a look to the class method whichTowers which initializes the class variables shared among all the class instances (the HanoiDisks): it just looks like any other, only the way it is used determines it is a class method.

Listing 10 features animatedTowerOfHanoi+ which just slightly modifies the animatedTowerOfHanoi class, of which it is a direct descendant, in order to avoid the trouble just mentioned: it creates a window in which all the graphics will take place, so the text output will not interfere any more (but in speed) with the graphics.

Just two methods have been redefined, in addition to exist, which just calls its parent method with usual-exist, Hanoi (in order to create the window in which all the drawings will take place) and setupDisks.(in order to use HanoiDisk+s in place of HanoiDisks). The text output produced by an animatedTowerOfHanoi+ game is the same produced by an instance of towerOfHanoi (see listing 4).

Listing 11 shows the only modification brought to HanoiDisk+ respect to its direct ancestor HanoiDisk from whom it keeps every method but widthPole which treats the graphic positioning of the disks in the window, in addition to exist just calling usual-exist.

Figures 1 to 3 give some snapshots of the animated game, just after the setUpDisks, during the game and when all disks have been moved (the heuristic version produces similar graphical effects, but eventually for the position of the destination pole which is 2 or 3 depending on the number of disks moved).

Figure 1.

Figure 2.

Figure 3.

Heuristic towers of Hanoï

Kaehler and Patterson propose an heuristic version of this game; although it is less readable than the recursive counterpart, it offers an interesting feature, from a syntactical point of view: the passing of block of code as argument to a function. The blocks, a Smalltalk peculiar syntactic construction, represent a deferred sequence of actions, to which one (or several) argument(s) may be passed, and return a value which is an object that can execute these actions when summoned to do so (from Adele Goldberg and David Robson: Smalltalk-80, the language and its implementation, Addison-Wesley).

Listings 12 (class TowerByRules) and 13 (class HanoiDiskRules) show how blocks have been translated in Allegro Common Lisp, using a lambda expression (sort of unnamed function): see towerByRules decide method which calls towerByRules topsOtherThan and HanoiDiskRules hasLegalMove calling towerByRules polesOtherThan. In addition, note how topsOtherThan and polesOtherThan use the “block” passed as argument calling funCall. Once more, one takes profit of the inheritance mechanism and uses the previously defined method, using the usual- prefix: e.g. in towerByRules’ exist, HanoiDiskRules’ exist, widthPole and moveUpon.

If one wants to eliminate the defect already mentioned for animatedTowerOfHanoi and HanoiDisk classes and affecting also the just defined classes (i. e. the practical impossibility to write and draw in the same window) and use the whole screen, one can just define a new towerByRules++ class (see listing 14), direct descendant of towerByRules, redefining just the two procedures setting up the scene, Hanoi and setUpDisks. At the contrary, the situation is not as easy with the new HanoiDiskRules+ class for which all the methods are to be redefined, just by the fact that the direct ancestor is no more HanoiDisk but well HanoiDisk+ (see listing 15). This situation, quite harmless in this example, might be very annoying in real life situations for it might oblige to duplicate whole pieces of code with very little modifications.

Multiple inheritance

Fortunately, Allegro Common Lisp provides the multiple inheritance facility: the new HanoiDiskRules+ class is created as the descendant of HanoiDiskRules and HanoiDisk+, in that order (see listing 16). Now, only the exist method has to be redefined in the new class by calling only its super-method usual-exist.

This mechanism works due to the fact that when looking for a method, the parents list is browsed before going to look into the grand-parents methods, in expert-systems terminology, this is called breadth-first search.

In the present case, when widthPole is summoned, the method found in HanoiDiskRules is fired first, calling usual-widthPole which is looked for and found in the second parent (HanoiDisk+) methods in place of looking for such a method in HanoiDiskRules parent (i. e. HanoiDisk). This sequence of actions explains why the order in which the parents are listed is of uttermost importance: should the parent classes have been permuted, widthPole would have been found in HanoiDisk+ class and the instance variable previousPole would have been left undefined. The length of the resulting code is considerably shorter (3 lines of code in place of 36, roughly a 10-fold factor ), reducing the risk of errors.

The multiple inheritance facility exists also in Smalltalk-80, but is not used at all in the whole system which limits itself to pure inheritance (every class has only one direct parent) and is scarcely documented: almost nothing in the blue book (Smalltalk-80, the language and its implementation by Adele Goldberg and David Robson, Addison-Wesley: the Smalltalk-80 bible, as unreadable as Inside Macintosh or almost), a few hints in “a little Smalltalk” by Timothy Budd (Addison-Wesley editor) and some more in “Smalltalk-80” by Alain Mével and Thierry Guéguen (Eyrolles editor, in french! ).

Bugs and features

Even if Allegro Common Lisp is among the best Macintosh programming languages -and the only valid Common Lisp implementation until very recently-, some bugs (or features) are present, most of which being really of minor importance (but the very poor foreign keyboards support).

The function machine-instance output returns “machine-instance unspecified”, although software-type returns the hardware used (e. g. Macintosh Plus).

The calls (room) and (room nil) produce the same result although the standard states the first one should output an intermediate amount of information between the minimum produced by (room nil) and the maximum given by (room t).

An erroneous call to append, like (append ‘(a . b) ‘d), outputs an irrelevant error message (in that case: B is not a valid argument to CAR).

The support of foreign keyboards is particularly weak and depends heavily on the system version and the “nationality” of the keyboard used: e.g. the keyboard equivalents, command-. and command-/ respectively, of the abort and continue commands are unusable on those keyboards where the dot and slash characters figure at the upper-case keyboard floor; many commands of the FRED editor (Fred Resembles Emacs Deliberately ) are unusable as they heavily use control-keys (clover key), command-keys (shift-clover key) as well as meta-keys (option-key) -some kind of extension of the command key, largely found on Lisp machines, such as Symbolics, TI’s Explorers, .-, e.g. meta-” becomes meta-a on a french keyboard or meta-% on an Italian one.

step does not allow nor to read nor to use object-oriented programming. Most of the *nx- * variables are in fact compiled functions and I did not succeed to use them at all; moreover, they are not on-line documented.

When opening a source file brought from a large screen Mac to another one with a reduced screen (e.g. MacPlus), the edition window may be well beyond the actual screen limits. To recuperate it, without having to go back to the source Mac, one has two solutions: either, with the aid of the function windows, one gets the object number of the window beyond the screen limits and then passing two messages, one changes the offending coordinates, either, one goes back to the listener (at that time, the offending window becomes the second one in the front to back order) and one gives a pair of messages to the hidden window (see listing 17).

Interested readers can write me: Jean-Pascal J. Lange, BP 120, CH-6988 Ponte-Tresa, Switzerland or by fax: int+39-332/78 90 98 (not forgetting to put my name on the front page, please).

Listing 1
; towers of Hanoï game
; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

#|
  use: (Hanoi #disks tower1 tower2 tower3)
  e.g.: (Hanoi 3 “A” “B” “C”)
|#

(deFun Hanoi (nDisks fromPin toPin usingPin)
  (cond ((> nDisks 0)
         (Hanoi (1- nDisks) fromPin usingPin toPin)
         (moveDisk fromPin toPin)
         (Hanoi (1- nDisks) usingPin toPin fromPin) ) ))

(deFun moveDisk (fromPin toPin)
  (format t “~&~D -> ~D” fromPin toPin) )

Listing 2
Welcome to Allegro CL Version 1.2!
? 
HANOI
MOVEDISK
? (Hanoi 3 “A” “B” “C”)
A -> B
A -> C
B -> C
A -> B
C -> A
C -> B
A -> B
NIL
? 

Listing 3
; Ted Kaehler and Dave Patterson: a taste of SmallTalk
; W. W. Norton ed., chapter 4, pp. 44 ff.
; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

#|
  use: (setf aTower (oneOf towerOfHanoi))
            (ask aTower (Hanoi))
|#

(defObject towerOfHanoi)

(proclaim ‘(object-variable stacks) )

(defObFun (exist towerOfHanoi) (init-list)
  (declare (ignore init-list))
  (usual-exist)
  (have ‘stacks) )

(defObFun (Hanoi towerOfHanoi) ()
  (let ((height nil))
    (do ()
        ((integerP height))
      (format t “~&Please type the number of disks in the tower: “)
      (setq height (read)) )
    (format t “~&tower of Hanoï for ~D disk~:P.” height)
    (setq stacks (make-array 3 :initial-element nil) )
    (do ((each height (1- each)))
        ((zerop each))
      (addFirst stacks 0 (code-char (+ (char-code #\A) (1- each)))) )
    (moveTower height 1 3 2) ) )

(defObFun (moveDisk towerOfHanoi) (fromPin toPin)
  (let ((disk (getAndRemoveFirst stacks (1- fromPin))))
    (addFirst stacks (1- toPin) disk)
    (format t “~&~D -> ~D ~A” fromPin toPin disk) ) )

(defObFun (moveTower towerOfHanoi) (nDisks fromPin toPin usingPin)
  (cond ((> nDisks 0)
         (moveTower (1- nDisks) fromPin usingPin toPin)
         (moveDisk fromPin toPin)
         (moveTower (1- nDisks) usingPin toPin fromPin) ) ) )

(deFun addFirst (array index item)
  (setf (aref array index)
        (cons item (aref array index)) ) )

(deFun getAndRemoveFirst (array index)
  (let ((first (car (aref array index))))
    (setf (aref array index)
          (cdr (aref array index))  )
    first ) )

Listing 4
Welcome to Allegro CL Version 1.2!
? 
TOWEROFHANOI
NIL
EXIST
HANOI
MOVEDISK
MOVETOWER
ADDFIRST
GETANDREMOVEFIRST
? (setf toh (oneOf towerOfHanoi))
#<Object #252, a TOWEROFHANOI>
? (ask toh (Hanoi))
Please type the number of disks in the tower: 3
tower of Hanoï for 3 disks.
1 -> 3 A
1 -> 2 B
3 -> 2 A
1 -> 3 C
2 -> 1 A
2 -> 3 B
1 -> 3 A
NIL
? 

Listing 5
Welcome to Allegro CL Version 1.2!
? 
HANOI
MOVEDISK
? 
TOWEROFHANOI
NIL
EXIST
> Error: Cannot object-bind global function HANOI
> While executing: FHAVE
> Type Command-/ to continue, Command-. to abort.
1 > Continuing...
? (setf toh (oneOf towerOfHanoi))
#<Object #248, a TOWEROFHANOI>
? (ask toh (Hanoi))
> Error: TOH is not a valid argument to NIL .
> While executing: HANOI
> Type Command-/ to continue, Command-. to abort.
1 > 
Aborted
? 

Listing 6
Welcome to Allegro CL Version 1.2!
? 
TOWEROFHANOI
NIL
EXIST
HANOI
MOVEDISK
MOVETOWER
ADDFIRST
GETANDREMOVEFIRST
? 
> Continuable Error: Attempt to globally define object function HANOI
> While executing: FSET-GLOBALLY
> If Continued: Bind HANOI in the root object
> Type Command-/ to continue, Command-. to abort.
1 > Continuing...
HANOI
> Continuable Error: Attempt to globally define object function MOVEDISK
> While executing: FSET-GLOBALLY
> If Continued: Bind MOVEDISK in the root object
> Type Command-/ to continue, Command-. to abort.
1 > Continuing...
MOVEDISK
? (Hanoi 3 “A” “B” “C”)
A -> B
A -> C
B -> C
A -> B
C -> A
C -> B
A -> B
NIL
? 

Listing 7
; rectangle class
; from Smalltalk-80, the language and its implementation.
; Adele Goldberg and David Robson. Addison-Wesley, pp. 344-349
; implemented in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

(eval-when
  (compile eval load)
  (require ‘quickDraw)
  (require ‘records) )

(proclaim ‘(object-variable wptr)) ; from *window* class

(defObject rectangle)

(proclaim ‘(object-variable rect) )

(defObFun (exist rectangle) (init-list)
  (usual-exist)
  (have ‘rect (make-record :rect))
  (if init-list
    (let ((top (getf init-list ‘top))
          (left (getf init-list ‘left))
          (topLeft (getf init-list ‘topLeft))
          (bottom (getf init-list ‘bottom))
          (right (getf init-list ‘right))
          (bottomRight (getf init-list ‘bottomRight)) )
      (if topLeft
        (cond (top
               (error “Conflicting coordinates: ~
                       top (~A) and topLeft (~A)”
                      top (point-string topLeft) ) )
              (left
               (error “Conflicting coordinates: ~
                       left (~A) and topLeft (~A)”
                      left (point-string topLeft) ) )
              (t (rSet rect rect.topLeft topLeft)) )
        (progn
          (if top (rSet rect rect.top top))
          (if left (rSet rect rect.left left)) ) )
      (if bottomRight
        (cond (bottom
               (error “Conflicting coordinates: ~
                       bottom (~A) and bottomRight (~A)”
                      bottom (point-string bottomRight) ) )
              (right
               (error “Conflicting coordinates: ~
                       right (~A) and bottomRight (~A)”
                      right (point-string bottomRight) ) )
              (t (rSet rect rect.bottomRight bottomRight)) )
        (progn
          (if bottom (rSet rect rect.bottom bottom))
          (if right (rSet rect rect.right right)) ) ) ) ) )

(defObFun (leftRightTopBottom rectangle) (left right top bottom)
  (oneOf rectangle
         ‘top top ‘left left ‘bottom bottom ‘right right ) )

(defObFun (originCorner rectangle) (origin corner)
  (oneOf rectangle ‘topLeft origin ‘bottomRight corner) )

(defObFun (originExtent rectangle) (origin extent)
  (oneOf rectangle ‘topLeft origin
         ‘bottomRight (add-points origin extent) ) )

(defObFun (origin rectangle) ()
  (rRef rect rect.topLeft) )

(defObFun (corner rectangle) ()
  (rRef rect rect.bottomRight) )

(defObFun (center rectangle) ()
  (let ((origin (origin)))
    (add-points origin (/ (subtract-points (corner) origin) 2)) ) )

(defObFun (extent rectangle) ()
  (subtract-points (corner) (origin)) )

(defObFun (setOrigin rectangle) (origin)
  (rSet rect rect.topLeft origin) )

(defObFun (setCorner rectangle) (corner)
  (rSet rect rect.bottomRight corner) )

(defObFun (setCenter rectangle) (aPoint)
  ; move the rectangle so it is centered on the point,
  ; but keep the width and height unchanged
  (let ((extent (extent)))
    (setOrigin (add-points (origin)
                          (subtract-points aPoint (center)) ))
    (setCorner (add-points (origin) extent)) ) )

(defObFun (border rectangle)
          (width &optional (window (front-window)))
  (let* ((rect rect)
         (oldPenState (ask window (pen-state))) )
    (with-port (ask window wptr)
      (ask window (pen-normal)
           (set-pen-size (make-point width width))
           (frame-rect rect)
           (set-pen-state oldPenState) ) )
    (dispose-record oldPenState) ) )

(defObFun (erase rectangle) (&optional(window (front-window)))
  (let ((rectangle rect))
    (ask window (erase-rect rectangle)) ) )

(defObFun (invertRect rectangle)
          (&optional (window (front-window)))
  (let ((rectangle rect))
    (ask window (invert-rect rectangle)) ) )

Listing 8
; Ted Kaehler and Dave Patterson: a taste of SmallTalk
; W. W. Norton ed., chapter 5, pp. 65 ff.
; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

#|
  use: after loaded towerOfHanoi, rectangle and HanoiDisk
       classes, load this file, then  
       (setf aTower (oneOf animatedTowerOfHanoi))
       (ask aTower (Hanoi))
|#

(proclaim ‘(object-variable towerOfHanoi) ) ; towerOfHanoi class

(defObject animatedTowerOfHanoi towerOfHanoi)

(proclaim ‘(object-variable HanoiDisk) ) ; HanoiDisk class

(proclaim ‘(object-variable rectangle) ) ; rectangle class

(proclaim ‘(object-variable stacks) ) ; towerOfHanoi object variable

(proclaim ‘(object-variable howMany mockDisks) ) ; new object variables

(defObFun (exist animatedTowerOfHanoi) (init-list)
  (declare (ignore init-list))
  (usual-exist nil)
#| An object of this class represents the game. It inherits 
   variable stacks from class TowerOfHanoi.
   The new instance variables are:
     howMany: the number of disks,
     mockDisks: an array of fake disks (when a disk asks what disk it 
can move on top of, and the pole is empty, we return
                a mock disk; it has nearly infinite width). |#
  (have ‘howMany)
  (have ‘mockDisks) )

; the game

(defObFun (Hanoi animatedTowerOfHanoi) ()
  ; asks user how many disks, set up game and move disks until
  ; we are done
  (do ()
      ((integerp howMany))
 (format t “~&Please type the number of disks in the tower: “)
    (setq howMany (read)) )
  
  (setUpDisks)     ; create the disks and stacks
  (moveTower (howMany) 1 3 2)
  ; so on next run, howMany will be re-initialized
  (setq howMany nil) )

(defObFun (setUpDisks animatedTowerOfHanoi) ()
  ; Creates the disks and set up the poles.
  ; Tells all disks what game they are in and set disk thickness and 
gap.
  (let ((self (self)))
    (ask HanoiDisk (whichTowers self)) )
  (let ((displayBox
       (ask rectangle (originCorner #@(20 80) #@(380 300))) ))
    (ask displayBox (erase))
    (ask displayBox (border 2)) )
  ; poles are an array of three stacks. Each stack is a list.
  (setq stacks (make-array 3 :initial-element nil))
  (let ((disk)
        (size (howMany)) )
    (doTimes (i (howMany))
      (setq disk (oneOf HanoiDisk))        ; create a disk
      (ask disk (widthPole size 1))
      ; don’t forget: first element of array is at index 0 !!!
      (addFirst stacks 0 disk)        ; push it onto a stack
      (ask disk (invert))             ; show on the screen
      (setq size (1- size)) ) )
  
  ; When pole has no disk, one of these mock disks acts as a
  ; bottom disk. A moving disk will ask a mock disk its width and pole 
number.
  (setq mockDisks (make-array 3 :initial-element nil))
  (let ((disk))
    (doTimes (index 3)
      (setq disk (oneOf HanoiDisk))
      ; don’t forget: a doTimes-loop index starts at 0 !!!
      (ask disk (widthPole 1000 (1+ index)))
      ; don’t forget: first element array is at index 0 !!!
      (setf (aRef mockDisks index) disk) ) ) )

(defObFun (moveDisk animatedTowerOfHanoi) (fromPin toPin)
  ; move disk from a pin to another pin.
  ; Print the results in the listener window.
  
  ; don’t forget: the first element array is at index 0 !!!
  (let ((supportDisk (if (aRef stacks (1- toPin))
                       (car (aRef stacks (1- toPin)))
                       (aRef mockDisks (1- toPin)) ))
        (disk (getAndRemoveFirst stacks (1- fromPin))) )
    (addFirst stacks (1- toPin) disk)
    ; inform the disk and show move
    (ask disk (moveUpon supportDisk))
    #|(format t “~&~D -> ~D: ~A” fromPin toPin (ask disk (name)))|# )
  (sleep 0.3) )

(defObFun (howMany animatedTowerOfHanoi) ()
    ; returns the number of disks
    howMany )

Listing 9
; Ted Kaehler and Dave Patterson: a taste of SmallTalk
; W. W. Norton ed., chapter 5, pp. 65 ff.
; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

(defObject HanoiDisk)

(proclaim ‘(object-variable rectangle) ) ; rectangle class

(proclaim ‘(object-variable name width pole diskRectangle
            theTowers thickness diskGap ) )

(defObFun (exist HanoiDisk) (init-list)
  (declare (ignore init-list))
  (usual-exist)
; disk in game is represented by object of class HanoiDisk.
; It has
;       name: name of this disk (a character),
;      width: size of the disk (1 is the smallest disk width),
;       pole: number telling which pole the disk is on,
;       diskRectangle: rectangle on screen that disk occupies.
  (have ‘name)
  (have ‘width)
  (have ‘pole)
  (have ‘diskRectangle (oneOf rectangle)) )

; access

(defObFun (pole HanoiDisk) () ; return pole this disk is on
  pole )

(defObFun (name HanoiDisk) () ; return name of this disk
  name )

(defObFun (whichTowers HanoiDisk) (aTowerOfHanoi)
; There are three variables shared across the whole class:
;       TheTowers: the object that represents whole game and
;                  holds the stacks of disks,
;       Thickness: the thickness of a disk in screen dots,
;     DiskGap: number of screen dots between disks in a stack.
    ; install the object representing the towers
    (have ‘theTowers aTowerOfHanoi)
    (have ‘thickness 14) ; thickness of a disk in screen dots
    (have ‘diskGap 2) )  ; distance between disks

(defObFun (widthPole HanoiDisk) (size whichPole)
  ; set the values for this disk
  (setq width size)
  (setq pole whichPole)
  ; compute the center of the disk on the screen
  (let ((where))
    (cond ((not (>= size 1000))
           (setq name ; a normal disk
                 (code-char (+ (char-code #\A) (1- size))))
           (let ((y (- 289 (* (- (ask theTowers (howMany)) size)
                              (+ thickness diskGap) ))))
             (setq where (make-point 100 y)) ) )
          (t (setq name ‘m) ; a mock disk
             (setq where (make-point (* 100 whichPole)
                             (+ 289 thickness diskGap) ) ) ) )
    ; create rectangle, specify its size and locate its center
    (let ((extent (make-point (* size 14) thickness)))
      (setq diskRectangle
            (ask rectangle (originExtent #@(0 0) extent)) ) )
    ; locate the rectangle center
    (ask diskRectangle (setCenter where)) ) )

(defObFun (center HanoiDisk) ()
; returns a point that is the current center of this disk
  (ask diskRectangle (center)) )

(defObFun (moveUpon HanoiDisk) (destination)
  ; this disk just moved. Record the new pole and tell user.
  (setq pole (ask destination (pole)))
  ; remove the old image
  (invert)
  ; reposition
  (let ((point (make-point 0 (+ thickness diskGap))))
    (ask diskRectangle
      (setCenter (subtract-points (ask destination (center))
                                  point )) ) )
  ; display the new one
  (invert) )

(defObFun (invert HanoiDisk) ()
  ; shows a disk on the screen by turning white to black
  ; in a rectangular region
  (ask diskRectangle (invertRect)) )

Listing 10
; Ted Kaehler and Dave Patterson: a taste of SmallTalk
; W. W. Norton ed., chapter 5, pp. 65 ff.
; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

#|
  use: after having loaded the towerOfHanoi, rectangle, HanoiDisk, HanoiDisk+ 
and animatedTowerOfHanoi classes, load this file,
       then   (setf aTower (oneOf animatedTowerOfHanoi+))
              (ask aTower (Hanoi))
|#

; animatedTowerOfHanoi class
(proclaim ‘(object-variable animatedTowerOfHanoi) )

(defObject animatedTowerOfHanoi+ animatedTowerOfHanoi)

(proclaim ‘(object-variable HanoiDisk+) ) ; HanoiDisk+ class

(proclaim ‘(object-variable rectangle) ) ; rectangle class

(proclaim ‘(object-variable stacks) ) ;defined in towerOfHanoi

(proclaim ‘(object-variable howMany mockDisks) )

(defObFun (exist animatedTowerOfHanoi+) (init-list)
  (usual-exist init-list) )

; the game

(defObFun (Hanoi animatedTowerOfHanoi+) ()
  ; asks the user how many disks, set up the game
  ; and move disks until we are done
  (do ()
      ((integerp howMany))
 (format t “~&Please type the number of disks in the tower: “)
    (setq howMany (read)) )
  (oneOf *window*
         :window-title “animated towers of Hanoï”
         :window-position #@(20 100)
         :window-size #@(360 220)
         :window-type :single-edge-box )
    (setUpDisks)     ; create the disks and stacks
    (moveTower (howMany) 1 3 2)
    (setq howMany nil) )

(defObFun (setUpDisks animatedTowerOfHanoi+) ()
  ; Creates the disks and set up the poles.
  ; Tells all disks what game they are in and set disk thickness and 
gap.
  (let ((self (self)))
    (ask HanoiDisk+ (whichTowers self)) )
  (let ((displayBox
         (ask rectangle
           (originCorner #@(0 0)
                     (ask (front-window) (window-size)) ) ) ))
    (ask displayBox (erase))
    (ask displayBox (border 2)) )
  ; poles are an array of three stacks. Each stack is a list.
  (setq stacks (make-array 3 :initial-element nil))
  (let ((disk)
        (size (howMany)) )
    (doTimes (i (howMany))
      (setq disk (oneOf HanoiDisk+))        ; create a disk
      (ask disk (widthPole size 1))
      ; don’t forget: first element of array is at index 0 !!!
      (addFirst stacks 0 disk)       ; push it onto a stack
      (ask disk (invert))            ; show on the screen
      (setq size (1- size)) ) )
  
  ; When a pole has no disk, one of these mock disks acts as a
  ; bottom disk. A moving disk will ask a mock disk its width and pole 
number.
  (setq mockDisks (make-array 3 :initial-element nil))
  (let ((disk))
    (doTimes (index 3)
      (setq disk (oneOf HanoiDisk+))
      ; don’t forget: a doTimes-loop index starts at 0 !!!
      (ask disk (widthPole 1000 (1+ index)))
      ; don’t forget: first element of array is at index 0 !!!
      (setf (aRef mockDisks index) disk) ) ) )

Listing 11:
; Ted Kaehler and Dave Patterson: a taste of SmallTalk
; W. W. Norton ed., chapter 5, pp. 65 ff.
; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

(proclaim ‘(object-variable HanoiDisk) ) ; HanoiDisk class

(defObject HanoiDisk+ HanoiDisk)

(proclaim ‘(object-variable rectangle) ) ; rectangle class

(proclaim ‘(object-variable name width pole diskRectangle
            theTowers thickness diskGap ) )

(defObFun (exist HanoiDisk+) (init-list)
  (usual-exist init-list) )

; access

(defObFun (widthPole HanoiDisk+) (size whichPole)
  ; set the values for this disk
  (setq width size)
  (setq pole whichPole)
  ; compute the center of the disk on the screen
  (let* ((where)
         (window-size (ask (front-window) (window-size)))
         (window-height (point-v window-size))
         (window-width (point-h window-size))
         (x0 (floor window-width 6))
         (y0 (- window-height 11))
         (h-distance (floor window-width 3)) )
    (cond ((not (>= size 1000))
           (setq name ; a normal disk
                 (code-char (+ (char-code #\A) (1- size))))
          (let ((y (- y0 (* (- (ask theTowers (howMany)) size)
                              (+ thickness diskGap) ))))
             (setq where (make-point x0 y)) ) )
          (t (setq name ‘m) ; a mock disk
             (setq where (make-point (- (* h-distance whichPole) x0)
                             (+ y0 thickness diskGap) ) ) ) )
    ; create rectangle, specify its size and locate its center
    (let ((extent (make-point (* size 14) thickness)))
      (setq diskRectangle
            (ask rectangle (originExtent #@(0 0) extent)) ) )
    ; locate the rectangle center
    (ask diskRectangle (setCenter where)) ) )

Listing 12:
; Ted Kaehler and Dave Patterson: a taste of SmallTalk
; W. W. Norton ed., chapter 6, pp. 83 ff.
; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

#|
  use: after having loaded the towerOfHanoi, rectangle, HanoiDisk,
       animatedTowerOfHanoi and HanoiDiskRules classes,
       load this file, then   (setf aTower (oneOf towerByRules))
                              (ask aTower (Hanoi))
|#

; animatedTowerOfHanoi class
(proclaim ‘(object-variable animatedTowerOfHanoi) )

(defObject towerByRules animatedTowerOfHanoi)

(proclaim ‘(object-variable rectangle) ) ; rectangle class

(proclaim ‘(object-variable HanoiDiskRules) ) ; HanoiDiskRules class

(proclaim ‘(object-variable stacks) ) ; defined in towerOfHanoi

; defined in animatedTowerOfHanoi
(proclaim ‘(object-variable howMany mockDisks) )

(proclaim ‘(object-variable pole) ) ; defined in HanoiDiskRules

(proclaim ‘(object-variable oldDisk currentDisk destinationDisk) )

(defObFun (exist towerByRules) (init-list)
#| An object of this class represents the game. It holds an array of 
stacks that hold disks. It also keeps track of which disk just moved 
and which disk should move next.
   The new instance variables are
       oldDisk the disk that was moved last time,
       currentDisk we are considering moving this disk,
       destinationDisk and putting it on top of this disk.|#
  (have ‘oldDisk)
  (have ‘currentDisk)
  (have ‘destinationDisk)
  ; to get the instance variables stacks from class TowerOfHanoi and
  ; howMany and mockDisks from class AnimatedTowerOfHanoi
  (usual-exist init-list) ) ; exist

; initialize

(defObFun (Hanoi towerByRules) ()
  ; asks the user how many disks, set up the game and move disks until
  ; we are done
  (do ()
      ((integerp howMany))
 (format t “~&Please type the number of disks in the tower: “)
    (setq howMany (read)) )
  (setUpDisks)     ; create the disks and stacks
  (loop ; iterate until all disks are on one tower again.
    (let* ((currentDisk (decide))
           ; decide which to move and also set destinationDisk
           (currentPole (ask currentDisk (pole)))
           (destinationPole (ask destinationDisk (pole))) )
      (removeFirst stacks (1- currentPole))
      (addFirst stacks (1- destinationPole) currentDisk)
      ; tell the disk where it is now
      (let ((destinationDisk destinationDisk))
        (ask currentDisk (moveUpon destinationDisk)))
      (setq oldDisk currentDisk) ) ; get ready for next move
    (when (allOnOneTower) (return)) ) ; test if done
  ; so on next run, howMany will be re-initialized
  (setq howMany nil) ) ; Hanoi

(defObFun (setUpDisks towerByRules) ()
  ; Creates the disks and set up the poles.
  ; Tells all disks what game they are in and set disk thickness and 
gap.
  (let ((self (self)))
    (ask HanoiDiskRules (whichTowers self)) )
  (let ((displayBox
       (ask rectangle (originCorner #@(20 80) #@(380 300))) ))
    (ask displayBox (erase))
    (ask displayBox (border 2)) )
  ; poles are an array of three stacks. Each stack is a list.
  (setq stacks (make-array 3 :initial-element nil))
  (let ((disk)
        (size (howMany)) )
    (doTimes (i (howMany))
      (setq disk (oneOf HanoiDiskRules))       ; create a disk
      (ask disk (widthPole size 1))
      ; don’t forget: first element of array is at index 0 !!!
      (addFirst stacks 0 disk)   ; push it onto a stack
      (ask disk (invert))        ; show on the screen
      (setq size (1- size)) ) )
  
  ; When pole has no disk, one of these mock disks acts as a
  ; bottom disk. A moving disk will ask a mock disk its width and pole 
number.
  (setq mockDisks (make-array 3 :initial-element nil))
  (let ((disk))
    (doTimes (index 3)
      (setq disk (oneOf HanoiDiskRules))
      ; don’t forget: a doTimes-loop index starts at 0 !!!
      (ask disk (widthPole 1000 (1+ index)))
      (setf (aRef mockDisks index) disk) ) )
  ; on first move, look for another disk (a real one) to move
  ; don’t forget: the first element of array is at index 0 !!!
  (setq oldDisk (aRef mockDisks 2)) ) ; setUpDisks

; moves

(defObFun (allOnOneTower towerByRules) ()
  ; return true if all of the disks are on one tower
  (doTimes (index (length stacks) nil)
    (if (= (length (aRef stacks index))
           (howMany) )
      (return t) ) ) ) ; allOnOneTower

(defObFun (decide towerByRules) ()
  ; use last disk moved (oldDisk) to find a new disk to move
  ; (currentDisk) and disk to put it top of (destinationDisk).
  (topsOtherThan
   oldDisk
   #’(lambda (movingDisk)
       (cond ((ask movingDisk (hasLegalMove))
              ; remember the disk upon which to move
            (setq destinationDisk (ask movingDisk (bestMove)))
              ; return the disk that moves
              movingDisk )) ) ) ) ; decide

(defObFun (polesOtherThan towerByRules) (thisDisk aBlock)
  ; evaluate block of code using the top disk on each of other
  ; two poles. If pole is empty, use mock disk for that pole.
  (doTimes (aPole 3)
    ; Want a pole other than the pole of thisDisk
    ; don’t forget: a doTimes-loop index starts at 0 !!!
    (if (not (= (1+ aPole) (ask thisDisk (pole))))
      (let
        ((result
          (if (null (aRef stacks aPole))
            ; if the pole is empty, use a mock disk 
            (funCall aBlock (aRef mockDisks aPole)) ; execute the block
            ;  else use the top disk
            (funCall aBlock ; execute the block
                     (first (aRef stacks aPole)) ) )) )
        (when result (return result)) ) ) ) ) ; polesOtherThan

(defObFun (topsOtherThan towerByRules) (thisDisk aBlock)
  ; evaluate the block of code using the top disk on each of the other
  ; two poles. If a pole is empty, ignore it. This is for actual disks.
  (doTimes (aPole 3)
    ; If pole does not have thisDisk and is not empty, then
    ; execute aBlock (don’t forget: a doTimes-loop index starts at 0)
    (if (and (not (= (1+ aPole) (ask thisDisk (pole))))
             (not (null (aRef stacks aPole))) )
      (let ((result (funcall aBlock ; execute the block
                             (first (aRef stacks aPole)) )))
        (when result (return result)) ) ) ) ) ; topsOtherThan

(deFun removeFirst (array index)
  ; removeFirst is the procedure for pop.
  (setf (aRef array index) (cdr (aRef array index))) ) ; removeFirst

Listing 13:
; Ted Kaehler and Dave Patterson a taste of SmallTalk
; W. W. Norton ed., chapter 6, pp. 83 ff.
; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

(proclaim ‘(object-variable HanoiDisk) ) ; HanoiDisk class

(defObject HanoiDiskRules HanoiDisk)

(proclaim ‘(object-variable width theTowers) ) ; from HanoiDisk

(proclaim ‘(object-variable previousPole) )

(defObFun (exist HanoiDiskRules) (init-list)
  ; previousPole number of pole this disk was on previously.
  (have ‘previousPole)
  ; to get instance variables name, width, pole and rectangle
  ; from class HanoiDisk
  (usual-exist init-list) ) ; exist

; access

(defObFun (width HanoiDiskRules) ()
  ; return the size of this disk
  width ) ; width

(defObFun (widthPole HanoiDiskRules) (size whichPole)
  ; invoke widthPole in the superclass
  (usual-widthPole size whichPole)
  (setq previousPole 1) ) ; widthPole

; moving

(defObFun (bestMove HanoiDiskRules) ()
  ; If self can move two places, which is best? Return the top
  ; disk of the pole that this disk has not been on recently.
  (let ((self (self))
        (secondBest) )
    (cond ((ask TheTowers
             (polesOtherThan
              self
              #’(lambda (targetDisk)
                  (cond ((< (ask self (width))
                            (ask targetDisk (width)) )
                         (setq secondBest targetDisk)
                         (if (not (= (ask targetDisk (pole))
                                    (ask self previousPole) ))
                           targetDisk ) )) ) ) ))
          ; as a last resort, return a pole it was on recently
          (t secondBest ) ) ) ) ; bestMove

(defObFun (hasLegalMove HanoiDiskRules) ()
  ; do either of other two poles have a top disk large enough
  ; for this disk to rest on?
  (let ((self (self)))
    (ask TheTowers
      (polesOtherThan
       self
       ; when a pole has no disk,
       ; targetDisk is a mock disk with infinite width
       #’(lambda (targetDisk)
           (< (ask self (width))
              (ask targetDisk (width)) ) ) ) ) ) ) ; hasLegalMove

(defObFun (moveUpon HanoiDiskRules) (destination)
  ; this disk just moved. Record the new pole and tell user.
  (setq previousPole (pole))
  ; run the version of moveUpon defined in class HanoiDisk
  (usual-moveUpon destination) ) ; moveUpon

Listing 14:
; Ted Kaehler and Dave Patterson a taste of SmallTalk
; W. W. Norton ed., chapter 6, pp. 83 ff.
; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

#|
  use: after having loaded the towerOfHanoi, rectangle, HanoiDisk, animatedTowerOfHanoi, 
HanoiDiskRules and HanoiDiskRules+ classes, load this file, then   (setf 
aTower (oneOf towerByRules++))
                              (ask aTower (Hanoi))
|#

(proclaim ‘(object-variable towerByRules) ) ; towerByRules class

(defObject towerByRules++ towerByRules)

(proclaim ‘(object-variable rectangle) ) ; rectangle class

(proclaim ‘(object-variable HanoiDiskRules+) ) ; HanoiDiskRules+ class

(proclaim ‘(object-variable stacks) ) ; defined in towerOfHanoi

; defined in animatedTowerOfHanoi
(proclaim ‘(object-variable howMany mockDisks) )

(proclaim ‘(object-variable pole) ) ; defined in HanoiDiskRules+

(proclaim ‘(object-variable oldDisk currentDisk destinationDisk) )

(defObFun (exist towerByRules++) (init-list)
  (usual-exist init-list) ) ; exist

; initialize

(defObFun (Hanoi towerByRules++) ()
  ; asks user how many disks, set up game and move disks until
  ; we are done
  (do ()
      ((integerp howMany))
 (format t “~&Please type the number of disks in the tower: “)
    (setq howMany (read)) )
  (oneOf *window*
         :window-title “animated towers of Hanoï”
         :window-position #@(0 0)
         :window-size (make-point *screen-width* *screen-height*)
         :window-type :single-edge-box )
  (setUpDisks)     ; create the disks and stacks
  
  (loop ; iterate until all disks are on one tower again.
    (let* ((currentDisk (decide))
           ; decide which to move and also set destinationDisk
           (currentPole (ask currentDisk (pole)))
           (destinationPole (ask destinationDisk (pole))) )
      (removeFirst stacks (1- currentPole))
      (addFirst stacks (1- destinationPole) currentDisk)
      ; tell the disk where it is now
      (let ((destinationDisk destinationDisk))
        (ask currentDisk (moveUpon destinationDisk)))
      (setq oldDisk currentDisk) ) ; get ready for next move
    (when (allOnOneTower) (return)) ) ; test if done
  (setq howMany nil) ) ; Hanoi

(defObFun (setUpDisks towerByRules++) ()
  ; Creates the disks and set up the poles.
  ; Tells all disks what game they are in and set disk thickness and 
gap.
  (let ((self (self)))
    (ask HanoiDiskRules+ (whichTowers self)) )
  ; poles are an array of three stacks. Each stack is a list.
  (setq stacks (make-array 3 :initial-element nil))
  (let ((disk)
        (size (howMany)) )
    (doTimes (i (howMany))
      (setq disk (oneOf HanoiDiskRules+))      ; create a disk
      (ask disk (widthPole size 1))
      ; don’t forget: first element of array is at index 0 !!!
      (addFirst stacks 0 disk)         ; push it onto a stack
      (ask disk (invert))             ; show on the screen
      (setq size (1- size)) ) )
  
  ; When pole has no disk, one of these mock disks acts as a
  ; bottom disk. A moving disk will ask a mock disk its width and pole 
number.
  (setq mockDisks (make-array 3 :initial-element nil))
  (let ((disk))
    (doTimes (index 3)
      (setq disk (oneOf HanoiDiskRules+))
      ; don’t forget: a doTimes-loop index starts at 0 !!!
      (ask disk (widthPole 1000 (1+ index)))
      (setf (aRef mockDisks index) disk) ) )
  ; on first move, look for another disk (a real one) to move
  ; don’t forget: first element of an array is at index 0 !!!
  (setq oldDisk (aRef mockDisks 2)) ) ; setUpDisks

Listing 15:
; Ted Kaehler and Dave Patterson a taste of SmallTalk
; W. W. Norton ed., chapter 6, pp. 83 ff.
; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

(proclaim ‘(object-variable HanoiDisk+) ) ; HanoiDisk+ class

(defObject HanoiDiskRules+ HanoiDisk+)

(proclaim ‘(object-variable width theTowers) ) ; from HanoiDisk

(proclaim ‘(object-variable previousPole) )

(defObFun (exist HanoiDiskRules+) (init-list)
  ; previousPole number of the pole this disk was on previously.
  (have ‘previousPole)
  ; to get instance variables name, width, pole and rectangle
  ; from class HanoiDisk
  (usual-exist init-list) ) ; exist

; access

(defObFun (width HanoiDiskRules+) ()
  ; return the size of this disk
  width ) ; width

(defObFun (widthPole HanoiDiskRules+) (size whichPole)
  ; invoke widthPole in the superclass
  (usual-widthPole size whichPole)
  (setq previousPole 1) ) ; widthPole

; moving

(defObFun (bestMove HanoiDiskRules+) ()
  ; If self can move two places, which is best? Return the top
  ; disk of the pole that this disk has not been on recently.
  (let ((self (self))
        (secondBest) )
    (cond ((ask TheTowers
             (polesOtherThan
              self
              #’(lambda (targetDisk)
                  (cond ((< (ask self (width))
                            (ask targetDisk (width)) )
                         (setq secondBest targetDisk)
                         (if (not (= (ask targetDisk (pole))
                                    (ask self previousPole) ))
                           targetDisk ) )) ) ) ))
          ; as a last resort, return a pole it was on recently
          (t secondBest ) ) ) ) ; bestMove

(defObFun (hasLegalMove HanoiDiskRules+) ()
  ; do either of other two poles have a top disk large enough
  ; for this disk to rest on?
  (let ((self (self)))
    (ask TheTowers
      (polesOtherThan
       self
       ; when a pole has no disk,
       ; targetDisk is a mock disk with infinite width
       #’(lambda (targetDisk)
           (< (ask self (width))
              (ask targetDisk (width)) ) ) ) ) ) ) ; hasLegalMove

(defObFun (moveUpon HanoiDiskRules+) (destination)
  ; this disk just moved. Record the new pole and tell user.
  (setq previousPole (pole))
  ; run the version of moveUpon defined in class HanoiDisk
  (usual-moveUpon destination) ) ; moveUpon

Listing 16:
; Ted Kaehler and Dave Patterson a taste of SmallTalk
; W. W. Norton ed., chapter 6, pp. 83 ff.
; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
; © Copyright 1988 Jean-Pascal J. LANGE.

(proclaim ‘(object-variable HanoiDisk+) ) ; HanoiDisk+ class
(proclaim ‘(object-variable HanoiDiskRules) ) ; HanoiDiskRules class

(defObject HanoiDiskRules+ HanoiDiskRules HanoiDisk+)
(defObFun (exist HanoiDiskRules+) (init-list)
  (usual-exist init-list) ) ; exist

Listing 17:
Welcome to Allegro CL Version 1.2!
? (windows)
(#<Object #151, “Listener”, a *LISTENER*>
 #<Object #230, “towersOfHanoi”, a *FRED-WINDOW*>
 #<Object #227, “rectangle”, a *FRED-WINDOW*>)
? (ask (license-to-object 230) (set-window-size 512 304))
19923456
? (ask (license-to-object 230) (set-window-position 0 38))
2490368
? (ask (second (windows)) (set-window-size 512 304)(set-window-position 
0 38))
2490368
?