IDLE.PROFILE has LOGOUT and SAVEVM options; add some delays in IDLE hacks (#948)
* IFLE.PROFILE has LOGOUT and SAVEVM options; add some delays in IDLE hacks * add extra delays so the demos work more like intended * IDLEDEMO loads lispusers with idle hacks * make sure NOTIFY.EVENT \IDLING.OVER is called * clean up resetsave * slow down KINETIC * Redo logic to minimize diffs with 1992 version * minor tweaks to \IDLER for making sure mouse doesn't hang
This commit is contained in:
Larry Masinter
GitHub
645
lispusers/HANOI
645
lispusers/HANOI
@@ -1,70 +1,74 @@
|
||||
(FILECREATED "25-Feb-86 19:07:01" {ERIS}<LISPUSERS>KOTO>HANOI.;7 19947
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to: (VARS HANOICOMS)
|
||||
(FILECREATED "21-Aug-2022 18:08:56" {DSK}<home>larry>medley>lispusers>HANOI.;2 22228
|
||||
|
||||
previous date: "17-Feb-86 14:59:01" {ERIS}<LISPUSERS>KOTO>HANOI.;5)
|
||||
:CHANGES-TO (VARS HANOICOMS)
|
||||
|
||||
:PREVIOUS-DATE "25-Feb-86 19:07:01" {DSK}<home>larry>medley>lispusers>HANOI.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
|
||||
(* ; "
|
||||
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))))
|
||||
(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])
|
||||
[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])
|
||||
[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])
|
||||
[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")
|
||||
[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")
|
||||
[LAMBDA NIL (* lmm "17-Feb-86 14:58")
|
||||
(PROG (HANOI.MOUSE.SPEED)
|
||||
(WHANOI 7
|
||||
[COND
|
||||
((TYPENAMEP HANOIWINDOW (QUOTE WINDOW))
|
||||
((TYPENAMEP HANOIWINDOW 'WINDOW)
|
||||
HANOIWINDOW)
|
||||
(T (SETQ HANOIWINDOW
|
||||
(CREATEW (create REGION
|
||||
@@ -75,18 +79,16 @@
|
||||
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)
|
||||
[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.)
|
||||
(HANOI.MOUSE.SPEED (GETMOUSESTATE) (* IPLUS 16 is because cursor can go
|
||||
negative.)
|
||||
(SETQ VERTSPEED (IMIN (IMAX (IDIFFERENCE 17 (IQUOTIENT LASTMOUSEY 50))
|
||||
1)
|
||||
MAXVERTSPEED))
|
||||
@@ -95,333 +97,298 @@
|
||||
MAXHORIZSPEED]
|
||||
(SETUPRINGBITMAPS RING (SETQ RINGWIDTH (fetch WIDTH of RINGREGION))
|
||||
(SETQ MOVERIGHTFLG (IGREATERP DX SX))
|
||||
W) (* PROG is because
|
||||
FOR loop bug.)
|
||||
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)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(SETQ I (IPLUS VERTSPEED I))
|
||||
(GO LP)))
|
||||
(BITBLT UPRINGBM 0 (IDIFFERENCE I TOPLIMIT)
|
||||
W SX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE)))
|
||||
'INPUT
|
||||
'REPLACE))
|
||||
(BITBLT TOPUPRINGBM 0 0 W SX PEGTOP RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(SETQ HORIZWIDTH (IPLUS RINGWIDTH HORIZSPEED))
|
||||
(for I from (COND
|
||||
(MOVERIGHTFLG SX)
|
||||
(T (IDIFFERENCE SX HORIZSPEED)))
|
||||
(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 (QUOTE INPUT)
|
||||
(QUOTE REPLACE)))
|
||||
(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 (QUOTE INPUT)
|
||||
(QUOTE REPLACE)) (* Update the ring
|
||||
region's left)
|
||||
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)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE)))
|
||||
(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)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(PROG [(I (IDIFFERENCE PEGTOP (IPLUS VERTSPEED RINGHEIGHT]
|
||||
LP (COND
|
||||
((IGREATERP DY I) (* blt last ring
|
||||
image)
|
||||
((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)))
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(RETURN)))
|
||||
(BITBLT DOWNRINGBM 0 0 W DX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
'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)
|
||||
[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])
|
||||
(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 (QUOTE BASE))
|
||||
PEGSHADE)
|
||||
((ZEROP (LOGAND RINGN 1))
|
||||
EVENRINGSHADE)
|
||||
(T ODDRINGSHADE])
|
||||
[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")
|
||||
[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.)
|
||||
(* 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 (QUOTE ERASE)
|
||||
RDEST)
|
||||
[PROGN (\CLEARBM UPRINGBM)
|
||||
(BITBLT NIL NIL NIL UPRINGBM 0 VERTSPEED RINGWIDTH RINGHEIGHT (QUOTE TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
(RINGSHADE RINGN)) (* put in peg)
|
||||
(BITBLT NIL NIL NIL UPRINGBM PEGOFFSET 0 PEGWIDTH VERTSPEED (QUOTE TEXTURE)
|
||||
(QUOTE 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 (QUOTE TEXTURE)
|
||||
(QUOTE 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 (QUOTE TEXTURE)
|
||||
(QUOTE 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 (QUOTE
|
||||
TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
PEGSHADE))
|
||||
[PROGN (\CLEARBM TOPDOWNRINGBM)
|
||||
(BITBLT NIL NIL NIL TOPDOWNRINGBM 0 0 RINGWIDTH RINGHEIGHT (QUOTE TEXTURE)
|
||||
(QUOTE 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 (QUOTE TEXTURE)
|
||||
(QUOTE 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])
|
||||
(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])
|
||||
[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.")))
|
||||
[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)
|
||||
(* 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 (QUOTE ERASE)
|
||||
RDEST)
|
||||
(DSPOPERATION (QUOTE 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 _(QUOTE
|
||||
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])
|
||||
(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 (QUOTE (X E R O X))
|
||||
(QUOTE (0 0 400 280))
|
||||
(FONTCREATE (QUOTE LOGO)
|
||||
24])
|
||||
[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
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD PEG (PEGREGION RINGS))
|
||||
|
||||
(RECORD RING (RINGREGION RINGNUMBER RINGLABEL))
|
||||
]
|
||||
)
|
||||
|
||||
(DECLARE: EVAL@COMPILE
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ XRINGSHADE 42405)
|
||||
|
||||
@@ -429,10 +396,11 @@
|
||||
|
||||
(RPAQQ XPEGSHADE 65535)
|
||||
|
||||
|
||||
(CONSTANTS XRINGSHADE ORINGSHADE XPEGSHADE)
|
||||
)
|
||||
|
||||
(DECLARE: EVAL@COMPILE
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ PEGMIN 2)
|
||||
|
||||
@@ -442,15 +410,18 @@
|
||||
|
||||
(RPAQQ MAXHORIZSPEED 44)
|
||||
|
||||
|
||||
(CONSTANTS PEGMIN HANOIMARGIN (MAXVERTSPEED 30)
|
||||
(MAXHORIZSPEED 44))
|
||||
(MAXHORIZSPEED 44))
|
||||
)
|
||||
|
||||
(DECLARE: EVAL@COMPILE
|
||||
[PUTPROPS PEGN MACRO ((N)
|
||||
(CAR (SELECTQ N (1 PEGS)
|
||||
(2 (CDR PEGS))
|
||||
(CDDR PEGS]
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS PEGN MACRO [(N)
|
||||
(CAR (SELECTQ N
|
||||
(1 PEGS)
|
||||
(2 (CDR PEGS))
|
||||
(CDDR PEGS])
|
||||
)
|
||||
)
|
||||
|
||||
@@ -461,17 +432,13 @@
|
||||
(RPAQQ PEGSHADE 65535)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS [Hanoi (FUNCTION (LAMBDA (W)
|
||||
(HANOI (UNPACK (QUOTE "Xerox AI Systems"))
|
||||
W
|
||||
(QUOTE (TIMESROMAND 36]
|
||||
[HanoiUsername (FUNCTION (LAMBDA (W)
|
||||
(HANOI (UNPACK (USERNAME NIL T T))
|
||||
W
|
||||
(QUOTE (TIMESROMAND 36])
|
||||
(HANOI (UNPACK "Interlisp.org")
|
||||
W
|
||||
'(TIMESROMAND 36])
|
||||
(PUTPROPS HANOI COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (797 18810 (DISPLAYPEGSANDRINGS 807 . 1479) (DOHANOI 1481 . 1818) (FINDOTHER 1820 . 2022
|
||||
) (HANOI 2024 . 2167) (HANOIDEMO 2169 . 2861) (MOVEDIS 2863 . 8440) (MOVERING 8442 . 8994) (RINGSHADE
|
||||
8996 . 9245) (SETUPRINGBITMAPS 9247 . 12568) (TRACK 12570 . 12983) (WHANOI 12985 . 18479) (XHANOI
|
||||
18481 . 18808)))))
|
||||
(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
|
||||
|
||||
Reference in New Issue
Block a user