(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(FILECREATED "21-Aug-2022 18:08:56" {DSK}<home>larry>medley>lispusers>HANOI.;2
 22228  

      :CHANGES-TO (VARS HANOICOMS)

      :PREVIOUS-DATE "25-Feb-86 19:07:01" {DSK}<home>larry>medley>lispusers>HANOI.;1)


(* ; "
Copyright (c) 1982-1986 by Xerox Corporation.
")

(PRETTYCOMPRINT HANOICOMS)

(RPAQQ HANOICOMS

       ((FNS DISPLAYPEGSANDRINGS DOHANOI FINDOTHER HANOI HANOIDEMO MOVEDIS MOVERING RINGSHADE 
             SETUPRINGBITMAPS TRACK WHANOI XHANOI)
        (VARS (HANOIWINDOW))
        (DECLARE%: DONTCOPY (RECORDS PEG RING)
               (CONSTANTS XRINGSHADE ORINGSHADE XPEGSHADE)
               (CONSTANTS PEGMIN HANOIMARGIN (MAXVERTSPEED 30)
                      (MAXHORIZSPEED 44))
               (MACROS PEGN))
        (VARS EVENRINGSHADE ODDRINGSHADE PEGSHADE)
        (ALISTS (IDLE.FUNCTIONS Hanoi HanoiUsername))))
(DEFINEQ

(DISPLAYPEGSANDRINGS

  [LAMBDA (PEGS W)                                           (* edited%: " 1-Oct-84 12:41")

                                                             (* displays the pegs and the rings on 

                                                             them.)

    (for
 PEG in
 PEGS do
 (\CLEARBM W PEGSHADE (fetch
 PEGREGION of
 PEG))
                        (for
 RING in
 (fetch
 RINGS of
 PEG)
                           do
 (\CLEARBM W (RINGSHADE
 (fetch
 RINGNUMBER of
 RING))
                                     (fetch
 RINGREGION of
 RING))
                              (COND
                                 ((fetch
 RINGLABEL of
 RING)
                                  (CENTERPRINTINREGION (fetch
 RINGLABEL of
 RING)
                                         (fetch
 RINGREGION of
 RING)
                                         W])

(DOHANOI

  [LAMBDA (N SRC DST W)                                      (* lmm " 8-MAR-82 12:05")

    (COND
       ((EQ N 1)
        (MOVERING
 SRC DST W))
       (T (DOHANOI
 (SUB1 N)
                 SRC
                 (FINDOTHER
 SRC DST)
                 W)
          (MOVERING
 SRC DST W)
          (DOHANOI
 (SUB1 N)
                 (FINDOTHER
 SRC DST)
                 DST W])

(FINDOTHER

  [LAMBDA (S D)                                              (* bas%: "10-DEC-80 14:01")

    (for
 Z from
 1 to
 3 thereis
 (NOT (OR (EQ Z S)
                                        (EQ Z D])

(HANOI

  [LAMBDA (NRINGS WINDOW FONT ONCE)                          (* lmm " 9-MAR-82 09:52")

    (WHANOI
 NRINGS WINDOW FONT ONCE])

(HANOIDEMO

  [LAMBDA NIL                                                (* lmm "17-Feb-86 14:58")

    (PROG (HANOI.MOUSE.SPEED)
          (WHANOI
 7
                 [COND
                    ((TYPENAMEP HANOIWINDOW 'WINDOW)
                     HANOIWINDOW)
                    (T (SETQ HANOIWINDOW
                        (CREATEW (create
 REGION
                                        LEFT _ 4
                                        BOTTOM _ 340
                                        WIDTH _ 500
                                        HEIGHT _ 300]
                 NIL T])

(MOVEDIS

  [LAMBDA (RING DY SX DX W)                                  (* lmm "17-Feb-86 14:58")


         (* moves RING from its position on the source peg whose left is SX to the peg 

         whose left is DX at a height of DY)


    (PROG ((RINGREGION (fetch
 RINGREGION of
 RING))
           RINGWIDTH HORIZWIDTH MOVERIGHTFLG)
          [COND
             (HANOI.MOUSE.SPEED (GETMOUSESTATE)              (* IPLUS 16 is because cursor can go 

                                                             negative.)

                    (SETQ VERTSPEED (IMIN (IMAX (IDIFFERENCE 17 (IQUOTIENT LASTMOUSEY 50))
                                                1)
                                          MAXVERTSPEED))
                    (SETQ HORIZSPEED (IMIN (IMAX (ADD1 (IQUOTIENT LASTMOUSEX 50))
                                                 1)
                                           MAXHORIZSPEED]
          (SETUPRINGBITMAPS
 RING (SETQ RINGWIDTH (fetch
 WIDTH of
 RINGREGION))
                 (SETQ MOVERIGHTFLG (IGREATERP DX SX))
                 W)                                          (* PROG is because FOR loop bug.)

          (PROG ((I (fetch
 BOTTOM of
 RINGREGION))
                 (TOPLIMIT (IDIFFERENCE PEGTOP VERTSPEED)))
            LP  (COND
                   ((IGREATERP TOPLIMIT I)
                    (BITBLT UPRINGBM 0 0 W SX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
                           'INPUT
                           'REPLACE)
                    (SETQ I (IPLUS VERTSPEED I))
                    (GO LP)))
                (BITBLT UPRINGBM 0 (IDIFFERENCE I TOPLIMIT)
                       W SX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
                       'INPUT
                       'REPLACE))
          (BITBLT TOPUPRINGBM 0 0 W SX PEGTOP RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
                 'INPUT
                 'REPLACE)
          (SETQ HORIZWIDTH (IPLUS RINGWIDTH HORIZSPEED))
          (for
 I from
 (COND
                         (MOVERIGHTFLG SX)
                         (T (IDIFFERENCE SX HORIZSPEED)))
             to
 (COND
                   (MOVERIGHTFLG (SUB1 (IDIFFERENCE DX HORIZSPEED)))
                   (T (ADD1 DX))) by
 (ITIMES (COND
                                                ((IGREATERP DX SX)
                                                 1)
                                                (T -1))
                                            HORIZSPEED) do
 (BITBLT HORIZRINGBM 0 0 W I
                                                                  (IPLUS PEGTOP VERTSPEED)
                                                                  HORIZWIDTH RINGHEIGHT 'INPUT
                                                                  'REPLACE))
          (BITBLT HORIZRINGBM 0 0 W (COND
                                       (MOVERIGHTFLG (IDIFFERENCE DX HORIZSPEED))
                                       (T DX))
                 (IPLUS PEGTOP VERTSPEED)
                 HORIZWIDTH NIL 'INPUT 'REPLACE)             (* Update the ring region's left)

          (replace
 LEFT of
 RINGREGION with
 (IPLUS (fetch
 LEFT of
 RINGREGION)
                                                  (IDIFFERENCE DX SX)))
          (for
 I from
 PEGTOP to
 (SUB1 (IDIFFERENCE PEGTOP RINGHEIGHT)) by
 (IMINUS VERTSPEED)
             do
 (BITBLT TOPDOWNRINGBM NIL NIL W DX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
                       'INPUT
                       'REPLACE))
          (BITBLT TOPDOWNRINGBM NIL NIL W DX (IDIFFERENCE PEGTOP RINGHEIGHT)
                 RINGWIDTH
                 (IPLUS RINGHEIGHT VERTSPEED)
                 'INPUT
                 'REPLACE)
          (PROG [(I (IDIFFERENCE PEGTOP (IPLUS VERTSPEED RINGHEIGHT]
            LP  (COND
                   ((IGREATERP DY I)                         (* blt last ring image)

                    (BITBLT DOWNRINGBM 0 0 W DX DY RINGWIDTH (COND
                                                                ((IGREATERP VERTSPEED RINGHEIGHT)
                                                                 (IDIFFERENCE (IPLUS RINGHEIGHT 
                                                                                     VERTSPEED)
                                                                        (IDIFFERENCE DY I)))
                                                                (T (IPLUS RINGHEIGHT VERTSPEED)))
                           'INPUT
                           'REPLACE)
                    (RETURN)))
                (BITBLT DOWNRINGBM 0 0 W DX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
                       'INPUT
                       'REPLACE)
                (SETQ I (IDIFFERENCE I VERTSPEED))
                (GO LP))
          (replace
 BOTTOM of
 RINGREGION with
 DY)
          (RETURN RING])

(MOVERING

  [LAMBDA (SRC DST W)                                        (* rrb " 2-AUG-82 17:41")

    (PROG ([X (fetch
 RINGREGION of
 (CAR (fetch
 RINGS of
 (PEGN DST]
           RING)
          (push
 (fetch
 RINGS of
 (PEGN DST))
                (MOVEDIS
 [SETQ RING (pop
 (fetch
 RINGS of
 (PEGN SRC]
                       (IPLUS (fetch
 BOTTOM of
 X)
                              (fetch
 HEIGHT of
 X))
                       (TRACK
 SRC (fetch
 RINGREGION of
 RING))
                       (TRACK
 DST (fetch
 RINGREGION of
 RING))
                       W))
          (BLOCK])

(RINGSHADE

  [LAMBDA (RINGN)                                            (* rrb " 9-JUN-81 15:11")

    (COND
       ((EQ RINGN 'BASE)
        PEGSHADE)
       ((ZEROP (LOGAND RINGN 1))
        EVENRINGSHADE)
       (T ODDRINGSHADE])

(SETUPRINGBITMAPS

  [LAMBDA (RING RINGWIDTH MOVERIGHTFLG W)                    (* edited%: " 1-Oct-84 12:43")


         (* sets up the ring bitmaps. There are 5 ring bitmaps%: up while on peg, up above 

         peg, horizontal, down above peg and down while on peg.)


    (PROG ((PEGOFFSET (IQUOTIENT (IDIFFERENCE RINGWIDTH PEGWIDTH)
                             2))
           (RINGREGION (fetch
 RINGREGION of
 RING))
           (RINGN (fetch
 RINGNUMBER of
 RING)))
          (AND FONT (DSPFONT FONT RDEST))
          (DSPOPERATION 'ERASE RDEST)
          [PROGN (\CLEARBM UPRINGBM)
                 (BITBLT NIL NIL NIL UPRINGBM 0 VERTSPEED RINGWIDTH RINGHEIGHT 'TEXTURE 'REPLACE
                        (RINGSHADE
 RINGN))                   (* put in peg)

                 (BITBLT NIL NIL NIL UPRINGBM PEGOFFSET 0 PEGWIDTH VERTSPEED 'TEXTURE 'REPLACE 
                        PEGSHADE)
                 (COND
                    ((fetch
 RINGLABEL of
 RING)               (* print in label if there is one.)

                     (DSPDESTINATION UPRINGBM RDEST)
                     (CENTERPRINTINAREA (fetch
 RINGLABEL of
 RING)
                            0 VERTSPEED RINGWIDTH RINGHEIGHT RDEST]
          [PROGN (\CLEARBM TOPUPRINGBM)
                 (BITBLT NIL NIL NIL TOPUPRINGBM 0 VERTSPEED RINGWIDTH RINGHEIGHT 'TEXTURE
                        'REPLACE
                        (RINGSHADE
 RINGN))
                 (COND
                    ((fetch
 RINGLABEL of
 RING)               (* print in label if there is one.)

                     (DSPDESTINATION TOPUPRINGBM RDEST)
                     (CENTERPRINTINAREA (fetch
 RINGLABEL of
 RING)
                            0 VERTSPEED RINGWIDTH RINGHEIGHT RDEST]
          (PROGN (\CLEARBM DOWNRINGBM)
                 (BITBLT NIL NIL NIL DOWNRINGBM 0 0 RINGWIDTH RINGHEIGHT 'TEXTURE 'REPLACE
                        (RINGSHADE
 RINGN))
                 (COND
                    ((fetch
 RINGLABEL of
 RING)               (* print in label if there is one.)

                     (DSPDESTINATION DOWNRINGBM RDEST)
                     (CENTERPRINTINAREA (fetch
 RINGLABEL of
 RING)
                            0 0 RINGWIDTH RINGHEIGHT RDEST)))(* put in peg)

                 (BITBLT NIL NIL NIL DOWNRINGBM PEGOFFSET RINGHEIGHT PEGWIDTH VERTSPEED 'TEXTURE
                        'REPLACE PEGSHADE))
          [PROGN (\CLEARBM TOPDOWNRINGBM)
                 (BITBLT NIL NIL NIL TOPDOWNRINGBM 0 0 RINGWIDTH RINGHEIGHT 'TEXTURE 'REPLACE
                        (RINGSHADE
 RINGN))
                 (COND
                    ((fetch
 RINGLABEL of
 RING)               (* print in label if there is one.)

                     (DSPDESTINATION TOPDOWNRINGBM RDEST)
                     (CENTERPRINTINAREA (fetch
 RINGLABEL of
 RING)
                            0 0 RINGWIDTH RINGHEIGHT RDEST]
          [PROGN (\CLEARBM HORIZRINGBM)
                 (BITBLT NIL NIL NIL HORIZRINGBM (COND
                                                    (MOVERIGHTFLG HORIZSPEED)
                                                    (T 0))
                        0 RINGWIDTH RINGHEIGHT 'TEXTURE 'REPLACE (RINGSHADE
 RINGN))
                 (COND
                    ((fetch
 RINGLABEL of
 RING)               (* print in label if there is one.)

                     (DSPDESTINATION HORIZRINGBM RDEST)
                     (CENTERPRINTINAREA (fetch
 RINGLABEL of
 RING)
                            (COND
                               (MOVERIGHTFLG HORIZSPEED)
                               (T 0))
                            0 RINGWIDTH RINGHEIGHT RDEST]
          (RETURN])

(TRACK

  [LAMBDA (PN REGION)                                        (* lmm " 8-MAR-82 12:10")

                                                             (* returns the track offset for ring 

                                                             movement on a peg.)

    (IPLUS HANOIMARGIN (IPLUS (ITIMES RINGLARGEST (SUB1 PN))
                              (IQUOTIENT (IDIFFERENCE RINGLARGEST (fetch
 WIDTH of
 REGION))
                                     2])

(WHANOI

  [LAMBDA (RINGS W FONT ONCE)                                (* lmm " 3-Dec-85 12:51")

                                                             (* runs hanoi in a region of a 

                                                             displaystream)

    (PROG ([REGION (DSPCLIPPINGREGION NIL (SETQ W (COND
                                                     [(NULL W)
                                                      (OR HANOIWINDOW (SETQ HANOIWINDOW (CREATEW]
                                                     ((WINDOWP W))
                                                     (T (CREATEW W]
           [NRINGS (COND
                      ((NUMBERP RINGS)
                       RINGS)
                      (T (LENGTH RINGS]
           (HORIZSPEED 21)
           (VERTSPEED 17)
           PEGS RINGBM TOPUPRINGBM RINGLARGEST TOPDOWNRINGBM PEGWIDTH BASEWIDTH RINGHEIGHT 
           MOVEMENTHEIGHT BASEHEIGHT PEGTOP RINGDISPLAYSTREAM HANOIWINDOW RINGDELTA UPRINGBM 
           HORIZRINGBM DOWNRINGBM (RDEST (DSPCREATE)))
          (DECLARE
 (SPECVARS . T))
          (PROG (IMAGEHEIGHT)
                (SETQ BASEWIDTH (IDIFFERENCE (fetch
 WIDTH of
 REGION)
                                       (ITIMES HANOIMARGIN 2)))
                (SETQ RINGLARGEST (IQUOTIENT BASEWIDTH 3))   (* RINGDELTA is the difference in peg 

                                                             size on each side.)

                (COND
                   ([ZEROP (SETQ RINGDELTA (IQUOTIENT (IDIFFERENCE RINGLARGEST PEGMIN)
                                                  (ADD1 (ITIMES NRINGS 2]
                    (HELP "Not enough width for a display.")))

         (* leave one ring width for base, one for top of peg and two above peg for 

         movement. Doesn't really use two heights at top, only one plus VERTSPEED)


                (SETQ RINGHEIGHT (IQUOTIENT (SETQ IMAGEHEIGHT (IDIFFERENCE (fetch
 HEIGHT of
 REGION)
                                                                     (ITIMES HANOIMARGIN 2)))
                                        (IPLUS NRINGS 4)))
                (COND
                   ((ZEROP RINGHEIGHT)
                    (HELP "Not enough height for display.")))
                (SETQ PEGWIDTH (IQUOTIENT (IDIFFERENCE RINGLARGEST (ITIMES RINGDELTA (SUB1 NRINGS)
                                                                          2))
                                      3))                    (* put extra in base if it comes out 

                                                             closer to pegwidth.)

                (COND
                   [(IGREATERP PEGWIDTH RINGHEIGHT)
                    (SETQ BASEHEIGHT (IMIN PEGWIDTH (IPLUS RINGHEIGHT (IDIFFERENCE
                                                                       IMAGEHEIGHT
                                                                       (ITIMES (IPLUS NRINGS 4)
                                                                              RINGHEIGHT]
                   (T (SETQ BASEHEIGHT RINGHEIGHT)))
                (SETQ MOVEMENTHEIGHT (IPLUS [SETQ PEGTOP (IPLUS HANOIMARGIN BASEHEIGHT
                                                                (ITIMES RINGHEIGHT (ADD1 NRINGS]
                                            VERTSPEED))
                (DSPFONT FONT RDEST)
                (DSPFONT FONT W)
                (DSPOPERATION 'ERASE RDEST)
                (DSPOPERATION 'ERASE W))
          [PROG ((BASE (create
 REGION
                              LEFT _ HANOIMARGIN
                              BOTTOM _ HANOIMARGIN
                              WIDTH _ BASEWIDTH
                              HEIGHT _ BASEHEIGHT)))
                (SETQ PEGS (for
 PLEFT from
 (IPLUS HANOIMARGIN (IQUOTIENT (IDIFFERENCE RINGLARGEST 
                                                                                PEGWIDTH)
                                                                     2)) by
 RINGLARGEST as
 I
                              from
 1 to
 3
                              collect
 (create
 PEG
                                             PEGREGION _ (create
 REGION
                                                                LEFT _ PLEFT
                                                                BOTTOM _ (IPLUS BASEHEIGHT 
                                                                                HANOIMARGIN)
                                                                WIDTH _ PEGWIDTH
                                                                HEIGHT _ (ITIMES RINGHEIGHT
                                                                                (ADD1 NRINGS)))
                                             RINGS _ (LIST (create
 RING
                                                                  RINGREGION _ BASE
                                                                  RINGNUMBER _ 'BASE]
          [PROG [(SOURCEPEG (PEGN 1))
                 (RINGLABELS (COND
                                ((LISTP RINGS)
                                 (REVERSE RINGS))
                                (T                           (* collect n NILs as lables.)

                                   (for
 I from
 1 to
 RINGS collect
 NIL]
                (for
 RINGBOTTOM from
 (IPLUS HANOIMARGIN BASEHEIGHT) by
 RINGHEIGHT as
 RINGLEFT
                   from
 (IPLUS HANOIMARGIN (ITIMES RINGLARGEST (SUB1 1))) by
 RINGDELTA as
 I
                   from
 0 to
 (SUB1 NRINGS) as
 LABEL in
 RINGLABELS
                   do
 (push
 (fetch
 RINGS of
 SOURCEPEG)
                            (create
 RING
                                   RINGREGION _ (create
 REGION
                                                       LEFT _ RINGLEFT
                                                       BOTTOM _ RINGBOTTOM
                                                       WIDTH _ (IDIFFERENCE RINGLARGEST
                                                                      (ITIMES I 2 RINGDELTA))
                                                       HEIGHT _ RINGHEIGHT)
                                   RINGNUMBER _ (ADD1 (IDIFFERENCE NRINGS I))
                                   RINGLABEL _ LABEL)))      (* allocate bitmaps for ring movement)

                (SETQ HORIZRINGBM (BITMAPCREATE (IPLUS RINGLARGEST MAXHORIZSPEED)
                                         RINGHEIGHT))
                (SETQ UPRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED)))
                (SETQ DOWNRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED)))
                (SETQ TOPUPRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED)))
                (SETQ TOPDOWNRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED]
          (\CLEARBM W)
          (DISPLAYPEGSANDRINGS
 PEGS W)
          (bind
 (HERE _ 1)
                (THERE _ 3) do
 (DOHANOI
 NRINGS HERE THERE W)
                               (COND
                                  (ONCE (RETURN)))
                               (DISMISS 2000)
                               (SETQ HERE (PROG1 THERE
                                              (SETQ THERE (FINDOTHER
 HERE THERE)))])

(XHANOI

  [LAMBDA NIL                                                (* lmm " 8-MAR-82 15:59")

    (PROG ((EVENRINGSHADE XRINGSHADE)
           (ODDRINGSHADE ORINGSHADE)
           (PEGSHADE XPEGSHADE))
          (WHANOI
 '(X E R O X)
                 '(0 0 400 280)
                 (FONTCREATE 'LOGO 24])
)

(RPAQQ HANOIWINDOW
 NIL)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD PEG
 (PEGREGION RINGS))

(RECORD RING
 (RINGREGION RINGNUMBER RINGLABEL))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ XRINGSHADE
 42405)

(RPAQQ ORINGSHADE
 60375)

(RPAQQ XPEGSHADE
 65535)


(CONSTANTS XRINGSHADE ORINGSHADE XPEGSHADE)
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ PEGMIN
 2)

(RPAQQ HANOIMARGIN
 5)

(RPAQQ MAXVERTSPEED
 30)

(RPAQQ MAXHORIZSPEED
 44)


(CONSTANTS PEGMIN HANOIMARGIN (MAXVERTSPEED 30)
       (MAXHORIZSPEED 44))
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS PEGN
 MACRO
 [(N)
                      (CAR (SELECTQ N
                               (1 PEGS)
                               (2 (CDR PEGS))
                               (CDDR PEGS])
)
)

(RPAQQ EVENRINGSHADE
 42405)

(RPAQQ ODDRINGSHADE
 61375)

(RPAQQ PEGSHADE
 65535)

(ADDTOVAR IDLE.FUNCTIONS
 [Hanoi (FUNCTION (LAMBDA (W)
                                                 (HANOI (UNPACK "Interlisp.org")
                                                        W
                                                        '(TIMESROMAND 36])
(PUTPROPS HANOI COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (920 20991 (DISPLAYPEGSANDRINGS 930 . 1875) (DOHANOI 1877 . 2288) (FINDOTHER 2290 . 2512
) (HANOI 2514 . 2657) (HANOIDEMO 2659 . 3254) (MOVEDIS 3256 . 8151) (MOVERING 8153 . 8808) (RINGSHADE 
8810 . 9049) (SETUPRINGBITMAPS 9051 . 12799) (TRACK 12801 . 13291) (WHANOI 13293 . 20670) (XHANOI 
20672 . 20989)))))
STOP