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
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "26-Jun-2022 18:21:17"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>IDLEHAX.;4 26796
|
||||
(FILECREATED "28-Sep-2022 19:53:38" {DSK}<home>larry>medley>lispusers>IDLEHAX.;2 31965
|
||||
|
||||
:CHANGES-TO (FNS KAL.ADVANCE)
|
||||
:CHANGES-TO (FNS IDLE-SWAP)
|
||||
|
||||
:PREVIOUS-DATE " 9-Feb-2022 13:53:05"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>IDLEHAX.;3)
|
||||
:PREVIOUS-DATE "23-Aug-2022 08:50:16" {DSK}<home>larry>medley>lispusers>IDLEHAX.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -98,7 +96,7 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
)
|
||||
|
||||
(CONNECTPOLYS
|
||||
[LAMBDA (FROMS TOS NSTEPS W OPERATION) (* ; "Edited 12-Jan-2022 15:22 by larry")
|
||||
[LAMBDA (FROMS TOS NSTEPS W OPERATION) (* ; "Edited 23-Aug-2022 08:10 by larry")
|
||||
(* lmm "30-Jul-85 17:19")
|
||||
(PROG (DIFFS)
|
||||
(CLEARW W)
|
||||
@@ -120,8 +118,8 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(fetch YC of FPT)
|
||||
(fetch XC of TPT)
|
||||
(fetch YC of TPT)
|
||||
1 OPERATION W))
|
||||
(DISMISS POLYGONWAIT2)
|
||||
1 OPERATION W)
|
||||
(DISMISS POLYGONWAIT2))
|
||||
(CLEARW W)
|
||||
(for I from 1 to POLYGONSTEPS do (DISMISS POLYGONWAIT3)
|
||||
(LINES2 FROMS 1 W OPERATION)
|
||||
@@ -148,7 +146,7 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
|
||||
(RPAQ? POLYGONSWINDOW )
|
||||
|
||||
(RPAQQ POLYGONWAIT2 250)
|
||||
(RPAQQ POLYGONWAIT2 25)
|
||||
|
||||
(RPAQQ POLYGONMINPTS 3)
|
||||
|
||||
@@ -191,8 +189,67 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(KALDEMO
|
||||
(LAMBDA (W PERIOD PERSISTENCE) (* lmm " 5-Aug-85 22:16") (OR PERIOD (SETQ PERIOD (RAND 8 128))) (OR PERSISTENCE (SETQ PERSISTENCE (LSH 1 (RAND 4 13)))) (SETQ W (DEMOWINDOW W)) (LET ((XSTATEB (create KALSTATE A _ 1 B _ -1849 C _ (RAND 2 4) PERIOD _ PERIOD PERIODCOUNT _ 1)) (XSTATEE (create KALSTATE)) (YSTATEB (create KALSTATE A _ 1 B _ -1809 C _ (RAND 0 20) PERIOD _ PERIOD PERIODCOUNT _ 1)) (YSTATEE (create KALSTATE)) (WINDOWSIDE (MIN (WINDOWPROP W (QUOTE HEIGHT)) (WINDOWPROP W (QUOTE WIDTH)))) (TIMER (SETUPTIMER 0 NIL (QUOTE TICKS))) (BLACK (NOT (VIDEOCOLOR))) XOFFSET) (SETQ XOFFSET (QUOTIENT (MAX (DIFFERENCE (WINDOWPROP W (QUOTE WIDTH)) WINDOWSIDE) 0) 2)) (SETQ XSTATEE (COPY XSTATEB)) (SETQ YSTATEE (COPY YSTATEB)) (from 1 to PERSISTENCE do (KAL.ADVANCE XSTATEB) (KAL.ADVANCE YSTATEB) (KAL.SPOTS (ffetch A of XSTATEB) (ffetch A of YSTATEB) WINDOWSIDE W BLACK XOFFSET) (PERIODIC.BLOCK TIMER)) (do (KAL.ADVANCE XSTATEE) (KAL.ADVANCE YSTATEE) (PROG ((X0 (LOGAND (LRSH (ffetch A of XSTATEE) 7) KAL.MASK)) (Y0 (LOGAND (LRSH (ffetch A of YSTATEE) 7) KAL.MASK)) X1 Y1) (COND ((ILESSP X0 Y0) (SETQ X1 (IDIFFERENCE (SUB1 WINDOWSIDE) X0)) (SETQ Y1 (IDIFFERENCE (SUB1 WINDOWSIDE) Y0)) (KAL.BMS W X0 Y0 X1 Y1 (if BLACK then 1 else 0) XOFFSET)))) (KAL.ADVANCE XSTATEB) (KAL.ADVANCE YSTATEB) (KAL.SPOTS (ffetch A of XSTATEB) (ffetch A of YSTATEB) WINDOWSIDE W BLACK XOFFSET) (PERIODIC.BLOCK TIMER))))
|
||||
)
|
||||
[LAMBDA (W PERIOD PERSISTENCE) (* ; "Edited 23-Aug-2022 08:49 by lmm")
|
||||
(* lmm " 5-Aug-85 22:16")
|
||||
(OR PERIOD (SETQ PERIOD (RAND 16 128)))
|
||||
[OR PERSISTENCE (SETQ PERSISTENCE (LSH 1 (RAND 14 23]
|
||||
(SETQ W (DEMOWINDOW W))
|
||||
(LET ((XSTATEB (create KALSTATE
|
||||
A _ 1
|
||||
B _ -1849
|
||||
C _ (RAND 2 4)
|
||||
PERIOD _ PERIOD
|
||||
PERIODCOUNT _ 1))
|
||||
(XSTATEE (create KALSTATE))
|
||||
(YSTATEB (create KALSTATE
|
||||
A _ 1
|
||||
B _ -1809
|
||||
C _ (RAND 0 20)
|
||||
PERIOD _ PERIOD
|
||||
PERIODCOUNT _ 1))
|
||||
(YSTATEE (create KALSTATE))
|
||||
[WINDOWSIDE (MIN (WINDOWPROP W 'HEIGHT)
|
||||
(WINDOWPROP W 'WIDTH]
|
||||
(TIMER (SETUPTIMER 0 NIL 'TICKS))
|
||||
(BLACK (NOT (VIDEOCOLOR)))
|
||||
XOFFSET)
|
||||
(SETQ XOFFSET (QUOTIENT (MAX (DIFFERENCE (WINDOWPROP W 'WIDTH)
|
||||
WINDOWSIDE)
|
||||
0)
|
||||
2))
|
||||
(SETQ XSTATEE (COPY XSTATEB))
|
||||
(SETQ YSTATEE (COPY YSTATEB))
|
||||
(from 1 to PERSISTENCE do (KAL.ADVANCE XSTATEB)
|
||||
(KAL.ADVANCE YSTATEB)
|
||||
(KAL.SPOTS (ffetch A of XSTATEB)
|
||||
(ffetch A of YSTATEB)
|
||||
WINDOWSIDE W BLACK XOFFSET)
|
||||
(BLOCK 100 TIMER))
|
||||
(do (KAL.ADVANCE XSTATEE)
|
||||
(KAL.ADVANCE YSTATEE)
|
||||
[PROG ((X0 (LOGAND (LRSH (ffetch A of XSTATEE)
|
||||
7)
|
||||
KAL.MASK))
|
||||
(Y0 (LOGAND (LRSH (ffetch A of YSTATEE)
|
||||
7)
|
||||
KAL.MASK))
|
||||
X1 Y1)
|
||||
(COND
|
||||
((ILESSP X0 Y0)
|
||||
(SETQ X1 (IDIFFERENCE (SUB1 WINDOWSIDE)
|
||||
X0))
|
||||
(SETQ Y1 (IDIFFERENCE (SUB1 WINDOWSIDE)
|
||||
Y0))
|
||||
(KAL.BMS W X0 Y0 X1 Y1 (if BLACK
|
||||
then 1
|
||||
else 0)
|
||||
XOFFSET]
|
||||
(KAL.ADVANCE XSTATEB)
|
||||
(KAL.ADVANCE YSTATEB)
|
||||
(KAL.SPOTS (ffetch A of XSTATEB)
|
||||
(ffetch A of YSTATEB)
|
||||
WINDOWSIDE W BLACK XOFFSET)
|
||||
(PERIODIC.BLOCK TIMER])
|
||||
|
||||
(KAL.ADVANCE
|
||||
[LAMBDA (STATE) (* ; "Edited 26-Jun-2022 18:20 by rmk")
|
||||
@@ -231,8 +288,59 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(BUBBLES
|
||||
(LAMBDA (W) (* lmm "30-Jul-85 20:35") (WINDOWPROP (SETQ W (DEMOWINDOW W)) (QUOTE RESHAPEFN) (FUNCTION (LAMBDA (W) (DSPFILL NIL (if (VIDEOCOLOR) then WHITESHADE else BLACKSHADE) (QUOTE REPLACE) W)))) (DSPFILL NIL (if (VIDEOCOLOR) then WHITESHADE else BLACKSHADE) (QUOTE REPLACE) W) (bind (ARRAY _ (ARRAY BUBBLECNT (QUOTE POINTER))) (I _ 1) CIRCLE eachtime (SETQ I (if (EQ I BUBBLECNT) then 1 else (ADD1 I))) do (* * first erase the circle at I in array) (SETQ CIRCLE (ELT ARRAY I)) (DSPOPERATION (if (VIDEOCOLOR) then (QUOTE ERASE) else (QUOTE PAINT)) W) (* there will be no circle at I the first time through) (AND CIRCLE (DRAWCIRCLE (CAR CIRCLE) (CADR CIRCLE) (CADDR CIRCLE) NIL NIL W)) (* * now put a new circle in array at I and draw it) (SETQ CIRCLE (SETA ARRAY I (BUBBLE.CREATE W))) (DSPOPERATION (QUOTE REPLACE) W) (* fill center w/ black so it ocludes ones under) (FILLCIRCLE (CAR CIRCLE) (CADR CIRCLE) (SUB1 (CADDR CIRCLE)) (if (VIDEOCOLOR) then WHITESHADE else BLACKSHADE) W) (DSPOPERATION (QUOTE INVERT) W) (DRAWCIRCLE (CAR CIRCLE) (CADR CIRCLE) (CADDR CIRCLE) NIL NIL W) (BLOCK)))
|
||||
)
|
||||
[LAMBDA (W) (* ; "Edited 23-Aug-2022 08:14 by larry")
|
||||
(* lmm "30-Jul-85 20:35")
|
||||
[WINDOWPROP (SETQ W (DEMOWINDOW W))
|
||||
'RESHAPEFN
|
||||
(FUNCTION (LAMBDA (W)
|
||||
(DSPFILL NIL (if (VIDEOCOLOR)
|
||||
then WHITESHADE
|
||||
else BLACKSHADE)
|
||||
'REPLACE W]
|
||||
(DSPFILL NIL (if (VIDEOCOLOR)
|
||||
then WHITESHADE
|
||||
else BLACKSHADE)
|
||||
'REPLACE W)
|
||||
(bind (ARRAY _ (ARRAY BUBBLECNT 'POINTER))
|
||||
(I _ 1)
|
||||
CIRCLE eachtime (SETQ I (if (EQ I BUBBLECNT)
|
||||
then 1
|
||||
else (ADD1 I))) do
|
||||
|
||||
(* * first erase the circle at I in array)
|
||||
|
||||
(SETQ CIRCLE (ELT ARRAY I))
|
||||
(DSPOPERATION (if (VIDEOCOLOR)
|
||||
then 'ERASE
|
||||
else 'PAINT)
|
||||
W)
|
||||
(* there will be no circle at I the
|
||||
first time through)
|
||||
(AND CIRCLE (DRAWCIRCLE (CAR CIRCLE)
|
||||
(CADR CIRCLE)
|
||||
(CADDR CIRCLE)
|
||||
NIL NIL W))
|
||||
|
||||
(* * now put a new circle in array at I and draw it)
|
||||
|
||||
(SETQ CIRCLE (SETA ARRAY I (BUBBLE.CREATE
|
||||
W)))
|
||||
(DSPOPERATION 'REPLACE W)
|
||||
(* fill center w/ black so it ocludes
|
||||
ones under)
|
||||
(FILLCIRCLE (CAR CIRCLE)
|
||||
(CADR CIRCLE)
|
||||
(SUB1 (CADDR CIRCLE))
|
||||
(if (VIDEOCOLOR)
|
||||
then WHITESHADE
|
||||
else BLACKSHADE)
|
||||
W)
|
||||
(DSPOPERATION 'INVERT W)
|
||||
(DRAWCIRCLE (CAR CIRCLE)
|
||||
(CADR CIRCLE)
|
||||
(CADDR CIRCLE)
|
||||
NIL NIL W)
|
||||
(BLOCK 100])
|
||||
|
||||
(BUBBLE.CREATE
|
||||
(LAMBDA (W) (* drc%: "29-Jul-85 13:51") (LET* ((REGION (WINDOWPROP W (QUOTE REGION))) (WIDTH (SUB1 (fetch WIDTH of REGION))) (HEIGHT (SUB1 (fetch HEIGHT of REGION))) (CENTERX (RAND 1 (SUB1 WIDTH))) (CENTERY (RAND 1 (SUB1 HEIGHT)))) (LIST CENTERX CENTERY (RAND 1 (IMIN (IDIFFERENCE WIDTH CENTERX) CENTERX (IDIFFERENCE HEIGHT CENTERY) CENTERY)))))
|
||||
@@ -243,8 +351,32 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(IDLE-WINDOWS
|
||||
(LAMBDA (W DELAY) (* lmm " 7-Jun-86 22:21") (SETQ W (DEMOWINDOW W)) (PROG ((D (WINDOWPROP W (QUOTE WIDTH))) (H (WINDOWPROP W (QUOTE HEIGHT))) (TIMER (SETUPTIMER 0 NIL (QUOTE TICKS)))) (LET ((TITLE (WINDOWPROP (CREATEW (LIST 0 0 D (HEIGHTIFWINDOW 0 T)) "Yet another window" NIL T) (QUOTE IMAGECOVERED)))) (while T do (PROG ((X (RAND 0 (- D (+ 2 2 100)))) (Y (RAND 0 (- H 8 100)))) (PROG ((D0 (MAX 100 (RAND 100 (- D X)))) (H0 (MAX 100 (RAND 100 (- H Y))))) (BITBLT NIL NIL NIL W X Y D0 2 (QUOTE TEXTURE) (QUOTE REPLACE) BLACKSHADE) (BITBLT NIL NIL NIL W X Y 2 H0 (QUOTE TEXTURE) (QUOTE REPLACE) BLACKSHADE) (BITBLT NIL NIL NIL W (+ X (- D0 2)) Y 2 H0 (QUOTE TEXTURE) (QUOTE REPLACE) BLACKSHADE) (BITBLT TITLE NIL (+ WBorder (QUOTIENT WBorder 2)) W X (+ Y H0) D0 NIL NIL (QUOTE REPLACE)) (BITBLT NIL NIL NIL W (+ X 2) (+ Y 2) (- D0 (+ 2 2)) (- H0 2) (QUOTE TEXTURE) (QUOTE ERASE) BLACKSHADE))) (if DELAY then (BLOCK DELAY) else (PERIODIC.BLOCK TIMER))))))
|
||||
)
|
||||
[LAMBDA (W DELAY) (* ; "Edited 23-Aug-2022 08:35 by lmm")
|
||||
(* lmm " 7-Jun-86 22:21")
|
||||
(SETQ W (DEMOWINDOW W))
|
||||
(PROG [(D (WINDOWPROP W 'WIDTH))
|
||||
(H (WINDOWPROP W 'HEIGHT]
|
||||
(LET [(TITLE (WINDOWPROP (CREATEW (LIST 0 0 D (HEIGHTIFWINDOW 0 T))
|
||||
"Yet another window" NIL T)
|
||||
'IMAGECOVERED]
|
||||
(while T do (PROG [[X (RAND 0 (- D (+ 2 2 100]
|
||||
(Y (RAND 0 (- H 8 100]
|
||||
(PROG [[D0 (MAX 100 (RAND 100 (- D X]
|
||||
(H0 (MAX 100 (RAND 100 (- H Y]
|
||||
(BITBLT NIL NIL NIL W X Y D0 2 'TEXTURE 'REPLACE BLACKSHADE)
|
||||
(BITBLT NIL NIL NIL W X Y 2 H0 'TEXTURE 'REPLACE BLACKSHADE)
|
||||
(BITBLT NIL NIL NIL W (+ X (- D0 2))
|
||||
Y 2 H0 'TEXTURE 'REPLACE BLACKSHADE)
|
||||
(BITBLT TITLE NIL (+ WBorder (QUOTIENT WBorder 2))
|
||||
W X (+ Y H0)
|
||||
D0 NIL NIL 'REPLACE)
|
||||
(BITBLT NIL NIL NIL W (+ X 2)
|
||||
(+ Y 2)
|
||||
(- D0 (+ 2 2))
|
||||
(- H0 2)
|
||||
'TEXTURE
|
||||
'ERASE BLACKSHADE)))
|
||||
(BLOCK (OR DELAY 500])
|
||||
)
|
||||
|
||||
|
||||
@@ -258,8 +390,18 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
)
|
||||
|
||||
(LINES1
|
||||
(LAMBDA (ENDPOINTS LINES DSP) (* lmm "30-Jul-85 17:33") (PROG (PTS) (COND ((SETQ PTS (CAR LINES)) (* ERASE OLD) (LINES3 (CAR LINES) 1 DSP (QUOTE INVERT) ENDPOINTS)) (T (RPLACA LINES (SETQ PTS (in ENDPOINTS collect (create NPOINT)))) (LINES2 ENDPOINTS 1 DSP (QUOTE INVERT)))) (for PT in PTS as EP in ENDPOINTS do (replace XC of PT with (fetch XC of EP)) (replace YC of PT with (fetch YC of EP)))))
|
||||
)
|
||||
[LAMBDA (ENDPOINTS LINES DSP) (* ; "Edited 23-Aug-2022 07:59 by larry")
|
||||
(* lmm "30-Jul-85 17:33")
|
||||
(PROG (PTS)
|
||||
[COND
|
||||
((SETQ PTS (CAR LINES)) (* ERASE OLD)
|
||||
(LINES3 (CAR LINES)
|
||||
1 DSP 'INVERT ENDPOINTS))
|
||||
(T [RPLACA LINES (SETQ PTS (in ENDPOINTS collect (create NPOINT]
|
||||
(LINES2 ENDPOINTS 1 DSP 'INVERT]
|
||||
(BLOCK 75)
|
||||
(for PT in PTS as EP in ENDPOINTS do (replace XC of PT with (fetch XC of EP))
|
||||
(replace YC of PT with (fetch YC of EP])
|
||||
|
||||
(LINES2
|
||||
(LAMBDA (ENDPOINTS WIDTH WINDOW OPERATION) (* lmm "30-Jul-85 17:14") (for (X _ ENDPOINTS) while (OR (CDR X) (if (CDDR ENDPOINTS) then X)) do (DRAWLINE (fetch XC (CAR X)) (fetch YC (CAR X)) (fetch XC (CAR (OR (SETQ X (CDR X)) ENDPOINTS))) (fetch YC (CAR (OR X ENDPOINTS))) WIDTH OPERATION WINDOW)))
|
||||
@@ -283,8 +425,20 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
)
|
||||
|
||||
(WARP
|
||||
(LAMBDA (W) (* hdj " 1-Apr-86 14:22") (do (CLEARW W) (LET ((OLDOP (DSPOPERATION (QUOTE INVERT) W))) (LET ((WIDTH (WINDOWPROP W (QUOTE WIDTH))) (HEIGHT (WINDOWPROP W (QUOTE HEIGHT)))) (LET ((CENTERX (RAND 0 WIDTH)) (CENTERY (RAND 0 HEIGHT))) (for RADIUS from (RAND 5 250) to 5 by -2 do (FILLCIRCLE (PLUS CENTERX (RAND 0 2)) (PLUS CENTERY (RAND 0 2)) RADIUS BLACKSHADE W) (BLOCK)))) (DSPOPERATION OLDOP W))))
|
||||
)
|
||||
[LAMBDA (W) (* ; "Edited 23-Aug-2022 08:01 by larry")
|
||||
(* hdj " 1-Apr-86 14:22")
|
||||
(do (CLEARW W)
|
||||
(LET ((OLDOP (DSPOPERATION 'INVERT W)))
|
||||
[LET [(WIDTH (WINDOWPROP W 'WIDTH))
|
||||
(HEIGHT (WINDOWPROP W 'HEIGHT]
|
||||
(LET ((CENTERX (RAND 0 WIDTH))
|
||||
(CENTERY (RAND 0 HEIGHT)))
|
||||
(for RADIUS from (RAND 5 250) to 5 by -2
|
||||
do (FILLCIRCLE (PLUS CENTERX (RAND 0 2))
|
||||
(PLUS CENTERY (RAND 0 2))
|
||||
RADIUS BLACKSHADE W)
|
||||
(BLOCK 75]
|
||||
(DSPOPERATION OLDOP W])
|
||||
)
|
||||
|
||||
|
||||
@@ -294,7 +448,8 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(IDLE-MELT
|
||||
[LAMBDA (WINDOW SIZE INITIAL PATH) (* ; "Edited 10-Jun-88 17:15 by MASINTER")
|
||||
[LAMBDA (WINDOW SIZE INITIAL PATH) (* ; "Edited 23-Aug-2022 08:20 by larry")
|
||||
(* ; "Edited 10-Jun-88 17:15 by MASINTER")
|
||||
(OR SIZE (SETQ SIZE MELT-BLOCK-SIZE))
|
||||
(SETQ WINDOW (DEMOWINDOW WINDOW))
|
||||
(PROG ((W (WINDOWPROP WINDOW 'WIDTH))
|
||||
@@ -307,37 +462,34 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
[SETQ BM (OR (CAR TAIL)
|
||||
(WINDOWPROP WINDOW 'IMAGECOVERED]
|
||||
(for BITMAP inside BM do (BITBLT (SETQ BITMAP (if (BITMAPP BITMAP)
|
||||
then BITMAP
|
||||
elseif (CL:SYMBOLP BITMAP)
|
||||
then (CAR (READBRUSHFILE
|
||||
BITMAP))
|
||||
else (IDLE.BITMAP NIL
|
||||
BITMAP)))
|
||||
NIL NIL WINDOW (RAND 0 (- W (BITMAPWIDTH BITMAP
|
||||
)))
|
||||
(RAND 0 (- H (BITMAPHEIGHT BITMAP)))
|
||||
NIL NIL (if (VIDEOCOLOR)
|
||||
then NIL
|
||||
else 'INVERT)
|
||||
'REPLACE))
|
||||
then BITMAP
|
||||
elseif (CL:SYMBOLP BITMAP)
|
||||
then (CAR (READBRUSHFILE BITMAP))
|
||||
else (IDLE.BITMAP NIL BITMAP)))
|
||||
NIL NIL WINDOW (RAND 0 (- W (BITMAPWIDTH BITMAP)))
|
||||
(RAND 0 (- H (BITMAPHEIGHT BITMAP)))
|
||||
NIL NIL (if (VIDEOCOLOR)
|
||||
then NIL
|
||||
else 'INVERT)
|
||||
'REPLACE))
|
||||
(if INITIAL
|
||||
then [SETQ TIMER (AND (CADR TAIL)
|
||||
(SETUPTIMER (CADR TAIL)
|
||||
TIMER
|
||||
'SECONDS
|
||||
'SECONDS]
|
||||
(SETQ TAIL (OR (CDDR TAIL)
|
||||
INITIAL)))
|
||||
(SETUPTIMER (CADR TAIL)
|
||||
TIMER
|
||||
'SECONDS
|
||||
'SECONDS]
|
||||
(SETQ TAIL (OR (CDDR TAIL)
|
||||
INITIAL)))
|
||||
[do (LET [(X (RAND 0 (- W SIZE)))
|
||||
(Y (RAND 0 (- H SIZE]
|
||||
(BITBLT WINDOW X Y WINDOW (+ X (RAND -1 1))
|
||||
(+ Y (RAND -1 1))
|
||||
SIZE SIZE NIL 'REPLACE))
|
||||
(BLOCK) repeatuntil (AND TIMER (TIMEREXPIRED? TIMER 'SECONDS]
|
||||
(Y (RAND 0 (- H SIZE]
|
||||
(BITBLT WINDOW X Y WINDOW (+ X (RAND -1 1))
|
||||
(+ Y (RAND -1 1))
|
||||
SIZE SIZE NIL 'REPLACE))
|
||||
(BLOCK 100) repeatuntil (AND TIMER (TIMEREXPIRED? TIMER 'SECONDS]
|
||||
(GO REPAINT])
|
||||
|
||||
(IDLE-SLIDE
|
||||
[LAMBDA (W SIZE SPEED COUNT SOURCE) (* ; "Edited 10-Jun-88 17:12 by MASINTER")
|
||||
[LAMBDA (W SIZE SPEED COUNT SOURCE) (* ; "Edited 10-Jun-88 17:12 by MASINTER")
|
||||
(OR SIZE (SETQ SIZE 128))
|
||||
(OR COUNT (SETQ COUNT 120))
|
||||
(OR SPEED (SETQ SPEED 2))
|
||||
@@ -354,28 +506,28 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
X Y DX DY (CNT 1)
|
||||
DDX DDY (TIMER (SETUPTIMER 0 NIL 'TICKS]
|
||||
(do (COND
|
||||
((OR (EQ (add CNT -1)
|
||||
0)
|
||||
(< X 0)
|
||||
(> X XMAX)
|
||||
(< Y 0)
|
||||
(> Y YMAX))
|
||||
(SETQ X (RAND 0 XMAX))
|
||||
(SETQ Y (RAND 0 YMAX))
|
||||
(SETQ DX (RAND (- SPEED)
|
||||
SPEED))
|
||||
(SETQ DY (RAND (- SPEED)
|
||||
SPEED))
|
||||
(BITBLT SOURCE X Y W X Y SIZE SIZE NIL 'REPLACE)
|
||||
(SETQ DDX DY)
|
||||
(SETQ DDY DX)
|
||||
(SETQ CNT COUNT)))
|
||||
(BITBLT W X Y W (+ X DDX)
|
||||
(+ Y DDY)
|
||||
SIZE SIZE NIL 'REPLACE)
|
||||
(add X DX)
|
||||
(add Y DY)
|
||||
(PERIODIC.BLOCK TIMER])
|
||||
((OR (EQ (add CNT -1)
|
||||
0)
|
||||
(< X 0)
|
||||
(> X XMAX)
|
||||
(< Y 0)
|
||||
(> Y YMAX))
|
||||
(SETQ X (RAND 0 XMAX))
|
||||
(SETQ Y (RAND 0 YMAX))
|
||||
(SETQ DX (RAND (- SPEED)
|
||||
SPEED))
|
||||
(SETQ DY (RAND (- SPEED)
|
||||
SPEED))
|
||||
(BITBLT SOURCE X Y W X Y SIZE SIZE NIL 'REPLACE)
|
||||
(SETQ DDX DY)
|
||||
(SETQ DDY DX)
|
||||
(SETQ CNT COUNT)))
|
||||
(BITBLT W X Y W (+ X DDX)
|
||||
(+ Y DDY)
|
||||
SIZE SIZE NIL 'REPLACE)
|
||||
(add X DX)
|
||||
(add Y DY)
|
||||
(PERIODIC.BLOCK TIMER])
|
||||
)
|
||||
|
||||
(RPAQQ MELT-BLOCK-SIZE 32)
|
||||
@@ -399,17 +551,16 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS PERIODIC.BLOCK MACRO [(TIMER)
|
||||
(if (TIMEREXPIRED? TIMER 'TICKS)
|
||||
then (BLOCK)
|
||||
(SETQ TIMER (SETUPTIMER 100 TIMER 'TICKS 'MILLISECONDS])
|
||||
(PUTPROPS PERIODIC.BLOCK MACRO ((TIMER)
|
||||
(BLOCK 100 TIMER)))
|
||||
)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Drain" 'IDLE-DRAIN))
|
||||
(DEFINEQ
|
||||
|
||||
(IDLE-DRAIN
|
||||
[LAMBDA (WINDOW) (* hdj "28-May-86 11:52")
|
||||
[LAMBDA (WINDOW) (* ; "Edited 23-Aug-2022 07:52 by larry")
|
||||
(* hdj "28-May-86 11:52")
|
||||
(do (BITBLT (WINDOWPROP WINDOW 'IMAGECOVERED)
|
||||
NIL NIL WINDOW NIL NIL NIL NIL 'INVERT 'REPLACE)
|
||||
(LET* ((WIDTH (WINDOWPROP WINDOW 'WIDTH))
|
||||
@@ -417,7 +568,7 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(HALF-WIDTH (IQUOTIENT WIDTH 2))
|
||||
(HALF-HEIGHT (IQUOTIENT HEIGHT 2)))
|
||||
(for EDGE from 0 to (MIN HALF-WIDTH HALF-HEIGHT)
|
||||
do (BLOCK)
|
||||
do (BLOCK 100)
|
||||
(BITBLT WINDOW EDGE 0 WINDOW (PLUS 1 EDGE)
|
||||
0
|
||||
(- HALF-WIDTH EDGE)
|
||||
@@ -452,13 +603,14 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(IDLE-SWAP
|
||||
[LAMBDA (WINDOW) (* hdj "29-May-86 23:41")
|
||||
[LAMBDA (WINDOW) (* ; "Edited 28-Sep-2022 19:48 by lmm")
|
||||
(* hdj "29-May-86 23:41")
|
||||
(DECLARE (GLOBALVARS IDLE-SWAP-SIZE))
|
||||
(BITBLT (WINDOWPROP WINDOW 'IMAGECOVERED)
|
||||
NIL NIL WINDOW NIL NIL NIL NIL 'INVERT 'REPLACE)
|
||||
(LET [(WIDTH (WINDOWPROP WINDOW 'WIDTH))
|
||||
(HEIGHT (WINDOWPROP WINDOW 'HEIGHT]
|
||||
(do (BLOCK (RAND 0 5000))
|
||||
(do (BLOCK 250)
|
||||
(LET [[RAND-X-1 (TIMES IDLE-SWAP-SIZE (RAND 0 (IQUOTIENT WIDTH IDLE-SWAP-SIZE]
|
||||
[RAND-Y-1 (TIMES IDLE-SWAP-SIZE (RAND 0 (IQUOTIENT HEIGHT IDLE-SWAP-SIZE]
|
||||
[RAND-X-2 (TIMES IDLE-SWAP-SIZE (RAND 0 (IQUOTIENT WIDTH IDLE-SWAP-SIZE]
|
||||
@@ -480,12 +632,12 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Swap" 'IDLE-SWAP))
|
||||
(PUTPROPS IDLEHAX COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1991 2022))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3812 7852 (POLYGONSDEMO 3822 . 3992) (POLYGONS 3994 . 4358) (CONNECTPOLYS 4360 . 6758)
|
||||
(DRAWPOLY1 6760 . 7397) (RANDOMPT 7399 . 7850)) (8489 12004 (KALDEMO 8499 . 9910) (KAL.ADVANCE 9912 .
|
||||
10846) (KAL.SPOTS 10848 . 11189) (KAL.BMS 11191 . 11678) (KAL.ORAND 11680 . 12002)) (12041 13527 (
|
||||
BUBBLES 12051 . 13157) (BUBBLE.CREATE 13159 . 13525)) (13554 14539 (IDLE-WINDOWS 13564 . 14537)) (
|
||||
14574 16845 (LINES 14584 . 15643) (LINES1 15645 . 16055) (LINES2 16057 . 16368) (LINES3 16370 . 16843)
|
||||
) (16905 18118 (WALKINGSPOKE 16915 . 17696) (WARP 17698 . 18116)) (18143 22426 (IDLE-MELT 18153 .
|
||||
20669) (IDLE-SLIDE 20671 . 22424)) (22597 22843 (DEMOWINDOW 22607 . 22841)) (23255 25128 (IDLE-DRAIN
|
||||
23265 . 25126)) (25160 26641 (IDLE-SWAP 25170 . 26639)))))
|
||||
(FILEMAP (NIL (3756 7833 (POLYGONSDEMO 3766 . 3936) (POLYGONS 3938 . 4302) (CONNECTPOLYS 4304 . 6739)
|
||||
(DRAWPOLY1 6741 . 7378) (RANDOMPT 7380 . 7831)) (8469 13548 (KALDEMO 8479 . 11454) (KAL.ADVANCE 11456
|
||||
. 12390) (KAL.SPOTS 12392 . 12733) (KAL.BMS 12735 . 13222) (KAL.ORAND 13224 . 13546)) (13585 17431 (
|
||||
BUBBLES 13595 . 17061) (BUBBLE.CREATE 17063 . 17429)) (17458 19241 (IDLE-WINDOWS 17468 . 19239)) (
|
||||
19276 21944 (LINES 19286 . 20345) (LINES1 20347 . 21154) (LINES2 21156 . 21467) (LINES3 21469 . 21942)
|
||||
) (22004 23625 (WALKINGSPOKE 22014 . 22795) (WARP 22797 . 23623)) (23650 27551 (IDLE-MELT 23660 .
|
||||
25872) (IDLE-SLIDE 25874 . 27549)) (27722 27968 (DEMOWINDOW 27732 . 27966)) (28212 30198 (IDLE-DRAIN
|
||||
28222 . 30196)) (30230 31810 (IDLE-SWAP 30240 . 31808)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,49 +1,53 @@
|
||||
(FILECREATED " 2-Apr-86 00:14:01" {ERIS}<LISPUSERS>KOTO>KINETIC.;2 1626
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to: (VARS KINETICCOMS)
|
||||
(FILECREATED "23-Sep-2022 08:19:41" {DSK}<home>larry>medley>lispusers>KINETIC.;2 1928
|
||||
|
||||
previous date: " 3-Dec-85 14:17:48" {ERIS}<LISPUSERS>KOTO>KINETIC.;1)
|
||||
:CHANGES-TO (FNS KINETIC)
|
||||
|
||||
:PREVIOUS-DATE " 2-Apr-86 00:14:01" {DSK}<home>larry>medley>lispusers>KINETIC.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1982, 1985, 1986 by Xerox Corporation. All rights reserved.)
|
||||
(* ; "
|
||||
Copyright (c) 1982, 1985-1986, 2022 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT KINETICCOMS)
|
||||
|
||||
(RPAQQ KINETICCOMS ((FNS KINETIC)
|
||||
(VARS (CHECKSHADE 63903)
|
||||
(KINETICWINDOW))
|
||||
(ALISTS (IDLE.FUNCTIONS Kinetic))))
|
||||
(VARS (CHECKSHADE 63903)
|
||||
(KINETICWINDOW))
|
||||
(ALISTS (IDLE.FUNCTIONS Kinetic))))
|
||||
(DEFINEQ
|
||||
|
||||
(KINETIC
|
||||
[LAMBDA (WINDOW) (* lmm " 3-Dec-85 14:16")
|
||||
(* test example (KINETICDEMO)
|
||||
(SETQ CHECKSHADE (EDITSHADE CHECKSHADE)))
|
||||
[OR (WINDOWP WINDOW)
|
||||
(SETQ WINDOW (OR KINETICWINDOW (SETQ KINETICWINDOW (CREATEW NIL "Kinetic Window"]
|
||||
(PROG ((WD (WINDOWPROP WINDOW (QUOTE WIDTH)))
|
||||
(HT (WINDOWPROP WINDOW (QUOTE HEIGHT)))
|
||||
X Y)
|
||||
(do (SETQ X (RAND 0 WD))
|
||||
(SETQ Y (RAND 0 HT))
|
||||
(BITBLT NIL NIL NIL WINDOW (RAND 0 (IDIFFERENCE WD X))
|
||||
(RAND 0 (IDIFFERENCE HT Y))
|
||||
X Y (QUOTE TEXTURE)
|
||||
(SELECTQ (RAND 0 5)
|
||||
(0 (QUOTE PAINT))
|
||||
(QUOTE INVERT))
|
||||
(SELECTQ (AND CHECKSHADE (RAND 0 12))
|
||||
(0 CHECKSHADE)
|
||||
BLACKSHADE))
|
||||
(BLOCK])
|
||||
[LAMBDA (WINDOW) (* ; "Edited 22-Sep-2022 22:07 by lmm")
|
||||
(* lmm " 3-Dec-85 14:16")
|
||||
(* test example (KINETICDEMO)
|
||||
(SETQ CHECKSHADE (EDITSHADE CHECKSHADE)))
|
||||
[OR (WINDOWP WINDOW)
|
||||
(SETQ WINDOW (OR KINETICWINDOW (SETQ KINETICWINDOW (CREATEW NIL "Kinetic Window"]
|
||||
(PROG ((WD (WINDOWPROP WINDOW 'WIDTH))
|
||||
(HT (WINDOWPROP WINDOW 'HEIGHT))
|
||||
X Y)
|
||||
(do (SETQ X (RAND 0 WD))
|
||||
(SETQ Y (RAND 0 HT))
|
||||
(BITBLT NIL NIL NIL WINDOW (RAND 0 (IDIFFERENCE WD X))
|
||||
(RAND 0 (IDIFFERENCE HT Y))
|
||||
X Y 'TEXTURE (SELECTQ (RAND 0 5)
|
||||
(0 'PAINT)
|
||||
'INVERT)
|
||||
(SELECTQ (AND CHECKSHADE (RAND 0 12))
|
||||
(0 CHECKSHADE)
|
||||
BLACKSHADE))
|
||||
(BLOCK 100])
|
||||
)
|
||||
|
||||
(RPAQQ CHECKSHADE 63903)
|
||||
|
||||
(RPAQQ KINETICWINDOW NIL)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS (Kinetic (QUOTE KINETIC)))
|
||||
(PUTPROPS KINETIC COPYRIGHT ("Xerox Corporation" 1982 1985 1986))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (447 1420 (KINETIC 457 . 1418)))))
|
||||
(ADDTOVAR IDLE.FUNCTIONS (Kinetic 'KINETIC))
|
||||
(PUTPROPS KINETIC COPYRIGHT ("Xerox Corporation" 1982 1985 1986 2022))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (573 1723 (KINETIC 583 . 1721)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,284 +1,187 @@
|
||||
(FILECREATED "30-Jun-86 18:01:00" {PHYLUM}<LANNING>LISP>USERS>PAC-MAN-IDLE.;11 14703
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to: (VARS PAC-MAN-IDLECOMS)
|
||||
(FNS Pac-Man-Eat-Window Slow-Fade Pac-Man-Idle)
|
||||
(FILECREATED "24-Aug-2022 08:54:17" {DSK}<home>larry>medley>lispusers>PAC-MAN-IDLE.;2 17389
|
||||
|
||||
previous date: " 2-May-86 18:42:49" {PHYLUM}<LANNING>LISP>USERS>PAC-MAN-IDLE.;10)
|
||||
:CHANGES-TO (FNS Pac-Man-Eat-Window Pac-Man-Scout-Food)
|
||||
|
||||
:PREVIOUS-DATE "30-Jun-86 18:01:00" {DSK}<home>larry>medley>lispusers>PAC-MAN-IDLE.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
|
||||
(* ; "
|
||||
Copyright (c) 1986 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT PAC-MAN-IDLECOMS)
|
||||
|
||||
(RPAQQ PAC-MAN-IDLECOMS [(* * The Pac-Man idle function)
|
||||
(FNS Pac-Man-Eat-Window Pac-Man-Idle)
|
||||
(VARS DefaultPacManEatMask DefaultPacManIcon DefaultPacManMask)
|
||||
(INITVARS (Pac-Man-Delay 100)
|
||||
(pacManHorizonFactor .75)
|
||||
(pacManStarvationTime 75)
|
||||
(pacManEatMask DefaultPacManEatMask)
|
||||
(pacManIcon DefaultPacManIcon)
|
||||
(pacManMask DefaultPacManMask))
|
||||
(GLOBALVARS Pac-Man-Delay pacManHorizonFactor pacManStarvationTime
|
||||
pacManEatMask pacManIcon pacManMask)
|
||||
(FNS Pac-Man-Scout-Food)
|
||||
(* * Stuff for counting the bits on in a bitmap)
|
||||
(FNS Pac-Man-Amount-Of-Food)
|
||||
(MACROS Pac-Man-Convert-Word)
|
||||
(VARS (Pac-Man-Convert-Byte-Array (\ALLOCBLOCK 256 T)))
|
||||
(GLOBALVARS Pac-Man-Convert-Byte-Array)
|
||||
[P (for i from 0 to 255 do (\PUTBASE Pac-Man-Convert-Byte-Array i
|
||||
(bind (j _ i)
|
||||
while
|
||||
(NOT (ZEROP j))
|
||||
count
|
||||
(SETQ j (LOGAND j (SUB1 j]
|
||||
(* * Another idle function)
|
||||
(FNS Slow-Fade)
|
||||
[INITVARS (Slow-Fade-Delay 1000)
|
||||
(Default-Slow-Fade-Idle-Function (LISTGET IDLE.PROFILE
|
||||
(QUOTE DISPLAYFN]
|
||||
(GLOBALVARS Slow-Fade-Delay Default-Slow-Fade-Idle-Function)
|
||||
(* * Add them as idle functions)
|
||||
(ADDVARS (IDLE.FUNCTIONS ("Pac-man" (QUOTE Pac-Man-Idle))
|
||||
("Slow fade" (QUOTE Slow-Fade])
|
||||
(RPAQQ PAC-MAN-IDLECOMS
|
||||
[(* * The Pac-Man idle function)
|
||||
(FNS Pac-Man-Eat-Window Pac-Man-Idle)
|
||||
(VARS DefaultPacManEatMask DefaultPacManIcon DefaultPacManMask)
|
||||
(INITVARS (Pac-Man-Delay 100)
|
||||
(pacManHorizonFactor 0.75)
|
||||
(pacManStarvationTime 75)
|
||||
(pacManEatMask DefaultPacManEatMask)
|
||||
(pacManIcon DefaultPacManIcon)
|
||||
(pacManMask DefaultPacManMask))
|
||||
(GLOBALVARS Pac-Man-Delay pacManHorizonFactor pacManStarvationTime pacManEatMask pacManIcon
|
||||
pacManMask)
|
||||
(FNS Pac-Man-Scout-Food)
|
||||
(* * Stuff for counting the bits on in a bitmap)
|
||||
(FNS Pac-Man-Amount-Of-Food)
|
||||
(MACROS Pac-Man-Convert-Word)
|
||||
(VARS (Pac-Man-Convert-Byte-Array (\ALLOCBLOCK 256 T)))
|
||||
(GLOBALVARS Pac-Man-Convert-Byte-Array)
|
||||
[P (for i from 0 to 255 do (\PUTBASE Pac-Man-Convert-Byte-Array i
|
||||
(bind (j _ i)
|
||||
while
|
||||
(NOT (ZEROP j))
|
||||
count
|
||||
(SETQ j (LOGAND j (SUB1 j]
|
||||
(* * Another idle function)
|
||||
(FNS Slow-Fade)
|
||||
[INITVARS (Slow-Fade-Delay 1000)
|
||||
(Default-Slow-Fade-Idle-Function (LISTGET IDLE.PROFILE 'DISPLAYFN]
|
||||
(GLOBALVARS Slow-Fade-Delay Default-Slow-Fade-Idle-Function)
|
||||
(* * Add them as idle functions)
|
||||
(ADDVARS (IDLE.FUNCTIONS ("Pac-man" 'Pac-Man-Idle)
|
||||
("Slow fade" 'Slow-Fade])
|
||||
(* * The Pac-Man idle function)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(Pac-Man-Eat-Window
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:38")
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:38")
|
||||
|
||||
(* * Comment)
|
||||
(* * Comment)
|
||||
|
||||
(RESETLST
|
||||
(bind (minX _ (MINUS (QUOTIENT (BITMAPWIDTH pacManIcon)
|
||||
2)))
|
||||
(minY _ (MINUS (QUOTIENT (BITMAPHEIGHT pacManIcon)
|
||||
2)))
|
||||
(maxX _ (DIFFERENCE (WINDOWPROP window 'WIDTH)
|
||||
(QUOTIENT (BITMAPWIDTH pacManIcon)
|
||||
2)))
|
||||
(maxY _ (DIFFERENCE (WINDOWPROP window 'HEIGHT)
|
||||
(QUOTIENT (BITMAPHEIGHT pacManIcon)
|
||||
2)))
|
||||
(minimumSpeed _ 0.2)
|
||||
(maximumSpeed _ 1.0)
|
||||
(icon _ (DEFERREDCONSTANT (BITMAPCOPY pacManIcon)))
|
||||
(delayTimer _ (DEFERREDCONSTANT (SETUPTIMER 250)))
|
||||
[horizon _ (FIX (MAX 2 (TIMES (MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon))
|
||||
pacManHorizonFactor]
|
||||
(delta _ '(0 . 0))
|
||||
possibleDeltas x y (xSpeed _ 0)
|
||||
(ySpeed _ 0)
|
||||
[maxSpeed _ (TIMES 10 (MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon]
|
||||
(maxAcceleration _ (MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon)))
|
||||
(stepsWithoutFood _ 0) first [SETQ possibleDeltas
|
||||
(for pair in '((0 . -1)
|
||||
(-1 . 0)
|
||||
(1 . 0)
|
||||
(0 . 1)
|
||||
(0.707 . 0.707)
|
||||
(-0.707 . 0.707)
|
||||
(0.707 . -0.707)
|
||||
(-0.707 . -0.707))
|
||||
collect (CONS (FIX (TIMES horizon (CAR pair)))
|
||||
(FIX (TIMES horizon (CDR pair]
|
||||
(* Pick a random starting place)
|
||||
(SELECTQ (RAND 0 1)
|
||||
(0 (SETQ x (TIMES (WINDOWPROP window 'WIDTH)
|
||||
(RAND 0 1)))
|
||||
[SETQ y (RAND 0 (WINDOWPROP window 'HEIGHT])
|
||||
(1 [SETQ x (RAND 0 (WINDOWPROP window 'WIDTH]
|
||||
(SETQ y (TIMES (WINDOWPROP window 'WIDTH)
|
||||
(RAND 0 1))))
|
||||
NIL) while T
|
||||
do
|
||||
|
||||
(RESETLST (bind (minX _(MINUS (QUOTIENT (BITMAPWIDTH pacManIcon)
|
||||
2)))
|
||||
(minY _(MINUS (QUOTIENT (BITMAPHEIGHT pacManIcon)
|
||||
2)))
|
||||
(maxX _(DIFFERENCE (WINDOWPROP window (QUOTE WIDTH))
|
||||
(QUOTIENT (BITMAPWIDTH pacManIcon)
|
||||
2)))
|
||||
(maxY _(DIFFERENCE (WINDOWPROP window (QUOTE HEIGHT))
|
||||
(QUOTIENT (BITMAPHEIGHT pacManIcon)
|
||||
2)))
|
||||
(minimumSpeed _ .2)
|
||||
(maximumSpeed _ 1.0)
|
||||
(icon _(DEFERREDCONSTANT (BITMAPCOPY pacManIcon)))
|
||||
(delayTimer _(DEFERREDCONSTANT (SETUPTIMER 250)))
|
||||
[horizon _(FIX (MAX 2 (TIMES (MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon))
|
||||
pacManHorizonFactor]
|
||||
(delta _(QUOTE (0 . 0)))
|
||||
possibleDeltas x y (xSpeed _ 0)
|
||||
(ySpeed _ 0)
|
||||
[maxSpeed _(TIMES 10 (MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon]
|
||||
(maxAcceleration _(MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon)))
|
||||
(stepsWithoutFood _ 0)
|
||||
first [SETQ possibleDeltas (for pair in (QUOTE ((0 . -1)
|
||||
(-1 . 0)
|
||||
(1 . 0)
|
||||
(0 . 1)
|
||||
(.707 . .707)
|
||||
(-.707 . .707)
|
||||
(.707 . -.707)
|
||||
(-.707 . -.707)))
|
||||
collect (CONS (FIX (TIMES horizon
|
||||
(CAR pair)))
|
||||
(FIX (TIMES horizon
|
||||
(CDR pair]
|
||||
(* Pick a random starting place)
|
||||
(SELECTQ (RAND 0 1)
|
||||
[0 (SETQ x (TIMES (WINDOWPROP window (QUOTE WIDTH))
|
||||
(RAND 0 1)))
|
||||
(SETQ y (RAND 0 (WINDOWPROP window (QUOTE HEIGHT]
|
||||
[1 [SETQ x (RAND 0 (WINDOWPROP window (QUOTE WIDTH]
|
||||
(SETQ y (TIMES (WINDOWPROP window (QUOTE WIDTH))
|
||||
(RAND 0 1]
|
||||
NIL)
|
||||
while T
|
||||
do
|
||||
(* * Try to figure out which direction to go.
|
||||
Pick the one that would get us the most food.
|
||||
Make sure to block, and don't move to quickly
|
||||
(hah!))
|
||||
|
||||
(* * Try to figure out which direction to go. Pick the one that would get us the most food.
|
||||
Make sure to block, and don't move to quickly (hah!))
|
||||
(SETQ delayTimer (SETUPTIMER Pac-Man-Delay delayTimer))
|
||||
[SETQ delta (Pac-Man-Scout-Food
|
||||
window x y pacManEatMask possibleDeltas delta
|
||||
(DEFERREDCONSTANT (BITMAPCREATE
|
||||
(PLUS (TIMES 16 (QUOTIENT (BITMAPWIDTH pacManMask)
|
||||
16))
|
||||
(if (ZEROP (REMAINDER (BITMAPWIDTH pacManMask)
|
||||
16))
|
||||
then 0
|
||||
else 16))
|
||||
(BITMAPHEIGHT pacManMask]
|
||||
(COND
|
||||
((NOT (NULL delta)) (* Found some food)
|
||||
NIL)
|
||||
((GREATERP stepsWithoutFood pacManStarvationTime)
|
||||
(* Starving, so make a random jump)
|
||||
(change xSpeed (RAND (DIFFERENCE minX x)
|
||||
(DIFFERENCE maxX x)))
|
||||
(change ySpeed (RAND (DIFFERENCE minY y)
|
||||
(DIFFERENCE maxY y)))
|
||||
(SETQ stepsWithoutFood 0)
|
||||
(SETQ delta (CONS xSpeed ySpeed)))
|
||||
(T (add stepsWithoutFood 1)
|
||||
(change xSpeed (RAND (MINUS maxAcceleration)
|
||||
maxAcceleration))
|
||||
(change xSpeed (MAX (DIFFERENCE minX x)
|
||||
(MIN (DIFFERENCE maxX x)
|
||||
DATUM)))
|
||||
(change ySpeed (RAND (MINUS maxAcceleration)
|
||||
maxAcceleration))
|
||||
(change ySpeed (MAX (DIFFERENCE minY y)
|
||||
(MIN (DIFFERENCE maxY y)
|
||||
DATUM)))
|
||||
(SETQ delta (CONS xSpeed ySpeed)))
|
||||
(T (SETQ stepsWithoutFood 0)
|
||||
(SETQ xSpeed 0)
|
||||
(SETQ ySpeed 0)))
|
||||
(do (BLOCK) repeatuntil (TIMEREXPIRED? delayTimer))
|
||||
|
||||
(* * Eat the food at the current location)
|
||||
|
||||
(SETQ delayTimer (SETUPTIMER Pac-Man-Delay delayTimer))
|
||||
[SETQ delta (Pac-Man-Scout-Food
|
||||
window x y pacManEatMask possibleDeltas delta
|
||||
(DEFERREDCONSTANT (BITMAPCREATE
|
||||
(PLUS (TIMES 16 (QUOTIENT (BITMAPWIDTH
|
||||
pacManMask)
|
||||
16))
|
||||
(if (ZEROP (REMAINDER (BITMAPWIDTH
|
||||
pacManMask)
|
||||
16))
|
||||
then 0
|
||||
else 16))
|
||||
(BITMAPHEIGHT pacManMask]
|
||||
(COND
|
||||
((NOT (NULL delta)) (* Found some food)
|
||||
NIL)
|
||||
((GREATERP stepsWithoutFood pacManStarvationTime)
|
||||
(* Starving, so make a random jump)
|
||||
(change xSpeed (RAND (DIFFERENCE minX x)
|
||||
(DIFFERENCE maxX x)))
|
||||
(change ySpeed (RAND (DIFFERENCE minY y)
|
||||
(DIFFERENCE maxY y)))
|
||||
(SETQ stepsWithoutFood 0)
|
||||
(SETQ delta (CONS xSpeed ySpeed)))
|
||||
(T (add stepsWithoutFood 1)
|
||||
(change xSpeed (RAND (MINUS maxAcceleration)
|
||||
maxAcceleration))
|
||||
(change xSpeed (MAX (DIFFERENCE minX x)
|
||||
(MIN (DIFFERENCE maxX x)
|
||||
DATUM)))
|
||||
(change ySpeed (RAND (MINUS maxAcceleration)
|
||||
maxAcceleration))
|
||||
(change ySpeed (MAX (DIFFERENCE minY y)
|
||||
(MIN (DIFFERENCE maxY y)
|
||||
DATUM)))
|
||||
(SETQ delta (CONS xSpeed ySpeed)))
|
||||
(T (SETQ stepsWithoutFood 0)
|
||||
(SETQ xSpeed 0)
|
||||
(SETQ ySpeed 0)))
|
||||
(do (BLOCK) repeatuntil (TIMEREXPIRED? delayTimer))
|
||||
(BITBLT pacManEatMask NIL NIL window x y NIL NIL 'INPUT 'ERASE)
|
||||
|
||||
(* * Eat the food at the current location)
|
||||
(* * Update my location)
|
||||
|
||||
|
||||
(BITBLT pacManEatMask NIL NIL window x y NIL NIL (QUOTE INPUT)
|
||||
(QUOTE ERASE))
|
||||
|
||||
(* * Update my location)
|
||||
|
||||
|
||||
[change x (FIX (MAX minX (MIN maxX (PLUS DATUM
|
||||
(TIMES (RAND
|
||||
minimumSpeed
|
||||
maximumSpeed)
|
||||
(CAR delta]
|
||||
[change y (FIX (MAX minY (MIN maxY (PLUS DATUM
|
||||
(TIMES (RAND
|
||||
minimumSpeed
|
||||
maximumSpeed)
|
||||
(CDR delta]
|
||||
(BITBLT window x y icon NIL NIL NIL NIL (QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
(BITBLT pacManMask NIL NIL icon NIL NIL NIL NIL (QUOTE INPUT)
|
||||
(QUOTE ERASE))
|
||||
(BITBLT pacManIcon NIL NIL icon NIL NIL NIL NIL (QUOTE INPUT)
|
||||
(QUOTE PAINT))
|
||||
(BITBLT icon NIL NIL window x y NIL NIL (QUOTE INPUT)
|
||||
(QUOTE REPLACE])
|
||||
[change x (FIX (MAX minX (MIN maxX (PLUS DATUM (TIMES (RAND minimumSpeed maximumSpeed)
|
||||
(CAR delta]
|
||||
[change y (FIX (MAX minY (MIN maxY (PLUS DATUM (TIMES (RAND minimumSpeed maximumSpeed)
|
||||
(CDR delta]
|
||||
(BITBLT window x y icon NIL NIL NIL NIL 'INPUT 'REPLACE)
|
||||
(BITBLT pacManMask NIL NIL icon NIL NIL NIL NIL 'INPUT 'ERASE)
|
||||
(BITBLT pacManIcon NIL NIL icon NIL NIL NIL NIL 'INPUT 'PAINT)
|
||||
(BITBLT icon NIL NIL window x y NIL NIL 'INPUT 'REPLACE)))])
|
||||
|
||||
(Pac-Man-Idle
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:41")
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:41")
|
||||
|
||||
(* * A hungry idle function)
|
||||
(* * A hungry idle function)
|
||||
|
||||
|
||||
(BITBLT (WINDOWPROP window (QUOTE IMAGECOVERED))
|
||||
NIL NIL window NIL NIL NIL NIL (QUOTE INVERT)
|
||||
(QUOTE REPLACE))
|
||||
(BITBLT (WINDOWPROP window 'IMAGECOVERED)
|
||||
NIL NIL window NIL NIL NIL NIL 'INVERT 'REPLACE)
|
||||
(Pac-Man-Eat-Window window])
|
||||
)
|
||||
|
||||
(RPAQ DefaultPacManEatMask (READBITMAP))
|
||||
(27 27
|
||||
"@@AO@@@@"
|
||||
"@@GOL@@@"
|
||||
"@AOOO@@@"
|
||||
"@GOOOL@@"
|
||||
"@OOOON@@"
|
||||
"AOOOOO@@"
|
||||
"AOOOOO@@"
|
||||
"COOOOOH@"
|
||||
"COOOOOH@"
|
||||
"GOOOOOL@"
|
||||
"GOOOOOL@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"GOOOOOL@"
|
||||
"GOOOOOL@"
|
||||
"COOOOOH@"
|
||||
"COOOOOH@"
|
||||
"AOOOOO@@"
|
||||
"AOOOOO@@"
|
||||
"@OOOON@@"
|
||||
"@GOOOL@@"
|
||||
"@AOOO@@@"
|
||||
"@@GOL@@@"
|
||||
"@@AO@@@@")
|
||||
(RPAQQ DefaultPacManEatMask #*(27 27)@@AO@@@@@@GOL@@@@AOOO@@@@GOOOL@@@OOOON@@AOOOOO@@AOOOOO@@COOOOOH@COOOOOH@GOOOOOL@GOOOOOL@OOOOOON@OOOOOON@OOOOOON@OOOOOON@OOOOOON@GOOOOOL@GOOOOOL@COOOOOH@COOOOOH@AOOOOO@@AOOOOO@@@OOOON@@@GOOOL@@@AOOO@@@@@GOL@@@@@AO@@@@
|
||||
)
|
||||
|
||||
(RPAQ DefaultPacManIcon (READBITMAP))
|
||||
(27 27
|
||||
"@@AE@@@@"
|
||||
"@@EED@@@"
|
||||
"@@JJJ@@@"
|
||||
"@BJJJH@@"
|
||||
"@EEEED@@"
|
||||
"AEEGME@@"
|
||||
"@JJONJ@@"
|
||||
"BJJONJH@"
|
||||
"AEEEEE@@"
|
||||
"EEEEEED@"
|
||||
"BJJJJJH@"
|
||||
"JJJJJJJ@"
|
||||
"EEEEEED@"
|
||||
"EEEEEED@"
|
||||
"JJJH@@@@"
|
||||
"JJJJ@@@@"
|
||||
"EEEE@@@@"
|
||||
"EEEE@@@@"
|
||||
"BJJJH@@@"
|
||||
"BJJJJ@@@"
|
||||
"AEEEE@@@"
|
||||
"AEEEE@@@"
|
||||
"@JJJJH@@"
|
||||
"@BJJJH@@"
|
||||
"@AEEE@@@"
|
||||
"@@EED@@@"
|
||||
"@@@J@@@@")
|
||||
(RPAQQ DefaultPacManIcon #*(27 27)@@AE@@@@@@EED@@@@@JJJ@@@@BJJJH@@@EEEED@@AEEGME@@@JJONJ@@BJJONJH@AEEEEE@@EEEEEED@BJJJJJH@JJJJJJJ@EEEEEED@EEEEEED@JJJH@@@@JJJJ@@@@EEEE@@@@EEEE@@@@BJJJH@@@BJJJJ@@@AEEEE@@@AEEEE@@@@JJJJH@@@BJJJH@@@AEEE@@@@@EED@@@@@@J@@@@
|
||||
)
|
||||
|
||||
(RPAQ DefaultPacManMask (READBITMAP))
|
||||
(27 27
|
||||
"@@AO@@@@"
|
||||
"@@GOL@@@"
|
||||
"@AOOO@@@"
|
||||
"@GOOOL@@"
|
||||
"@OOOON@@"
|
||||
"AOOOOO@@"
|
||||
"AOOOOO@@"
|
||||
"COOOOOH@"
|
||||
"COOOOOH@"
|
||||
"GOOOOOL@"
|
||||
"GOOOOOL@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"OOOL@@@@"
|
||||
"OOON@@@@"
|
||||
"GOOO@@@@"
|
||||
"GOOOH@@@"
|
||||
"COOOL@@@"
|
||||
"COOON@@@"
|
||||
"AOOOO@@@"
|
||||
"AOOOOH@@"
|
||||
"@OOOOL@@"
|
||||
"@GOOOL@@"
|
||||
"@AOOO@@@"
|
||||
"@@GOL@@@"
|
||||
"@@AO@@@@")
|
||||
(RPAQQ DefaultPacManMask #*(27 27)@@AO@@@@@@GOL@@@@AOOO@@@@GOOOL@@@OOOON@@AOOOOO@@AOOOOO@@COOOOOH@COOOOOH@GOOOOOL@GOOOOOL@OOOOOON@OOOOOON@OOOOOON@OOOL@@@@OOON@@@@GOOO@@@@GOOOH@@@COOOL@@@COOON@@@AOOOO@@@AOOOOH@@@OOOOL@@@GOOOL@@@AOOO@@@@@GOL@@@@@AO@@@@
|
||||
)
|
||||
|
||||
(RPAQ? Pac-Man-Delay 100)
|
||||
|
||||
(RPAQ? pacManHorizonFactor .75)
|
||||
(RPAQ? pacManHorizonFactor 0.75)
|
||||
|
||||
(RPAQ? pacManStarvationTime 75)
|
||||
|
||||
@@ -287,164 +190,150 @@
|
||||
(RPAQ? pacManIcon DefaultPacManIcon)
|
||||
|
||||
(RPAQ? pacManMask DefaultPacManMask)
|
||||
(DECLARE: DOEVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS Pac-Man-Delay pacManHorizonFactor pacManStarvationTime pacManEatMask pacManIcon
|
||||
pacManMask)
|
||||
pacManMask)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(Pac-Man-Scout-Food
|
||||
[LAMBDA (window x y mask possibleDeltas prevDelta tempBitMap)
|
||||
(* smL "29-Apr-86 12:55")
|
||||
|
||||
(* * Return the x-y pair of directions to go to get the most food)
|
||||
(* smL "29-Apr-86 12:55")
|
||||
|
||||
(* * Return the x-y pair of directions to go to get the most food)
|
||||
|
||||
(for i from 1 to 8 bind direction
|
||||
thereis [SETQ direction (for offsetPair in [for x in possibleDeltas
|
||||
collect (CONS (TIMES i
|
||||
(CAR x))
|
||||
(TIMES i
|
||||
(CDR x]
|
||||
bind xoffset yoffset amountOfFood (mostFood _ 0)
|
||||
(mostFoodDirections _ NIL)
|
||||
do (SETQ xoffset (CAR offsetPair))
|
||||
(SETQ yoffset (CDR offsetPair))
|
||||
thereis [SETQ direction (for offsetPair in [for x in possibleDeltas
|
||||
collect (CONS (TIMES i (CAR x))
|
||||
(TIMES i (CDR x]
|
||||
bind xoffset yoffset amountOfFood (mostFood _ 0)
|
||||
(mostFoodDirections _ NIL)
|
||||
do (SETQ xoffset (CAR offsetPair))
|
||||
(SETQ yoffset (CDR offsetPair))
|
||||
|
||||
(* * Build a bitmap of the food available at the location. -
|
||||
This requires computing the number of bits that are black both in the window and in the mask.
|
||||
-
|
||||
We want black bits in the window because things have been inverted by idle and we are trying to eat white bits, and
|
||||
we want black bits in the mask because that is what defines the mask.)
|
||||
|
||||
(* Copy the screen bits into the temp bitmap.)
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL
|
||||
(QUOTE TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
WHITESHADE)
|
||||
(BITBLT window (PLUS xoffset x)
|
||||
(PLUS yoffset y)
|
||||
tempBitMap NIL NIL NIL NIL (QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
(* Or in the white bits of the mask at the appropriate
|
||||
location.)
|
||||
(BITBLT mask NIL NIL tempBitMap NIL NIL NIL NIL
|
||||
(QUOTE INVERT)
|
||||
(QUOTE ERASE))
|
||||
(* Clear out the image of the current position of the
|
||||
mask.)
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL
|
||||
(QUOTE TEXTURE)
|
||||
(QUOTE INVERT)
|
||||
BLACKSHADE)
|
||||
(BITBLT mask (MAX 0 xoffset)
|
||||
(MAX 0 yoffset)
|
||||
tempBitMap
|
||||
(MAX 0 (MINUS xoffset))
|
||||
(MAX 0 (MINUS yoffset))
|
||||
NIL NIL (QUOTE INPUT)
|
||||
(QUOTE PAINT))
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL
|
||||
(QUOTE TEXTURE)
|
||||
(QUOTE INVERT)
|
||||
BLACKSHADE)
|
||||
(* Compute the amount of food)
|
||||
(SETQ amountOfFood (Pac-Man-Amount-Of-Food tempBitMap))
|
||||
(* Remember the directions with the most food)
|
||||
(if (LESSP amountOfFood mostFood)
|
||||
then (* This direction loses)
|
||||
NIL
|
||||
elseif (EQP amountOfFood mostFood)
|
||||
then (* This is a possible direction)
|
||||
(push mostFoodDirections offsetPair)
|
||||
else (* This direction dominates)
|
||||
(SETQ mostFood amountOfFood)
|
||||
(SETQ mostFoodDirections (LIST offsetPair)))
|
||||
finally (RETURN (if (ZEROP mostFood)
|
||||
then NIL
|
||||
else (CAR (NTH mostFoodDirections
|
||||
(RAND
|
||||
1
|
||||
(LENGTH
|
||||
mostFoodDirections]
|
||||
finally (RETURN direction])
|
||||
(* * Build a bitmap of the food available at the location.
|
||||
-
|
||||
This requires computing the number of bits that are black both in the window and
|
||||
in the mask. -
|
||||
We want black bits in the window because things have been inverted by idle and we
|
||||
are trying to eat white bits, and we want black bits in the mask because that is
|
||||
what defines the mask.)
|
||||
(* Copy the screen bits into the temp
|
||||
bitmap.)
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL 'TEXTURE
|
||||
'REPLACE WHITESHADE)
|
||||
(BITBLT window (PLUS xoffset x)
|
||||
(PLUS yoffset y)
|
||||
tempBitMap NIL NIL NIL NIL 'INPUT 'REPLACE)
|
||||
(* Or in the white bits of the mask at
|
||||
the appropriate location.)
|
||||
(BITBLT mask NIL NIL tempBitMap NIL NIL NIL NIL 'INVERT
|
||||
'ERASE) (* Clear out the image of the current
|
||||
position of the mask.)
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL 'TEXTURE
|
||||
'INVERT BLACKSHADE)
|
||||
(BITBLT mask (MAX 0 xoffset)
|
||||
(MAX 0 yoffset)
|
||||
tempBitMap
|
||||
(MAX 0 (MINUS xoffset))
|
||||
(MAX 0 (MINUS yoffset))
|
||||
NIL NIL 'INPUT 'PAINT)
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL 'TEXTURE
|
||||
'INVERT BLACKSHADE)
|
||||
(* Compute the amount of food)
|
||||
(SETQ amountOfFood (Pac-Man-Amount-Of-Food tempBitMap))
|
||||
(* Remember the directions with the
|
||||
most food)
|
||||
(if (LESSP amountOfFood mostFood)
|
||||
then (* This direction loses)
|
||||
NIL
|
||||
elseif (EQP amountOfFood mostFood)
|
||||
then (* This is a possible direction)
|
||||
(push mostFoodDirections offsetPair)
|
||||
else (* This direction dominates)
|
||||
(SETQ mostFood amountOfFood)
|
||||
(SETQ mostFoodDirections (LIST offsetPair)))
|
||||
finally (RETURN (if (ZEROP mostFood)
|
||||
then NIL
|
||||
else (CAR (NTH mostFoodDirections
|
||||
(RAND 1 (LENGTH mostFoodDirections
|
||||
]
|
||||
finally (RETURN direction])
|
||||
)
|
||||
(* * Stuff for counting the bits on in a bitmap)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(Pac-Man-Amount-Of-Food
|
||||
[LAMBDA (bitMap) (* smL "29-Apr-86 13:23")
|
||||
[LAMBDA (bitMap) (* smL "29-Apr-86 13:23")
|
||||
|
||||
(* * How much food is there in the bitmap?)
|
||||
(* * How much food is there in the bitmap?)
|
||||
|
||||
|
||||
(for j from 0 to (QUOTIENT (TIMES (BITMAPHEIGHT bitMap)
|
||||
(BITMAPWIDTH bitMap))
|
||||
16)
|
||||
bind (bitmapBase _(fetch (BITMAP BITMAPBASE) of bitMap)) sum (Pac-Man-Convert-Word
|
||||
(\GETBASE bitmapBase
|
||||
j])
|
||||
(for j from 0 to (QUOTIENT (TIMES (BITMAPHEIGHT bitMap)
|
||||
(BITMAPWIDTH bitMap))
|
||||
16) bind (bitmapBase _ (fetch (BITMAP BITMAPBASE) of bitMap))
|
||||
sum (Pac-Man-Convert-Word (\GETBASE bitmapBase j])
|
||||
)
|
||||
(DECLARE: EVAL@COMPILE
|
||||
[DEFMACRO Pac-Man-Convert-Word (word)
|
||||
(* * Count up the number of bits on in the word)
|
||||
(BQUOTE (PLUS (\GETBASE Pac-Man-Convert-Byte-Array (LRSH , word 8))
|
||||
(\GETBASE Pac-Man-Convert-Byte-Array (LOGAND , word 255]
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PROGN (DEFMACRO Pac-Man-Convert-Word (word)
|
||||
|
||||
|
||||
(* * Count up the number of bits on in the word)
|
||||
|
||||
`(PLUS (\GETBASE Pac-Man-Convert-Byte-Array (LRSH %, word 8))
|
||||
(\GETBASE Pac-Man-Convert-Byte-Array (LOGAND %, word 255))))
|
||||
NIL)
|
||||
)
|
||||
|
||||
(RPAQ Pac-Man-Convert-Byte-Array (\ALLOCBLOCK 256 T))
|
||||
(DECLARE: DOEVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS Pac-Man-Convert-Byte-Array)
|
||||
)
|
||||
[for i from 0 to 255 do (\PUTBASE Pac-Man-Convert-Byte-Array i (bind (j _ i)
|
||||
while
|
||||
(NOT (ZEROP j))
|
||||
count
|
||||
(SETQ j (LOGAND j (SUB1 j]
|
||||
|
||||
[for i from 0 to 255 do (\PUTBASE Pac-Man-Convert-Byte-Array i (bind (j _ i)
|
||||
while (NOT (ZEROP j))
|
||||
count (SETQ j (LOGAND j
|
||||
(SUB1 j]
|
||||
(* * Another idle function)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(Slow-Fade
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:16")
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:16")
|
||||
|
||||
(* * Slowly fade the idle window to black)
|
||||
(* * Slowly fade the idle window to black)
|
||||
|
||||
|
||||
(BITBLT (WINDOWPROP window (QUOTE IMAGECOVERED))
|
||||
NIL NIL window NIL NIL NIL NIL (QUOTE INVERT)
|
||||
(QUOTE REPLACE))
|
||||
[LET [(fadeTextures (for i from 0 to 15 collect (LLSH 1 i]
|
||||
(BITBLT (WINDOWPROP window 'IMAGECOVERED)
|
||||
NIL NIL window NIL NIL NIL NIL 'INVERT 'REPLACE)
|
||||
[LET [(fadeTextures (for i from 0 to 15 collect (LLSH 1 i]
|
||||
(while fadeTextures bind selectedTexture
|
||||
do (BLOCK Slow-Fade-Delay)
|
||||
(SETQ selectedTexture (LLSH 1 (RAND 0 15)))
|
||||
(BITBLT NIL NIL NIL window NIL NIL NIL NIL (QUOTE TEXTURE)
|
||||
(QUOTE ERASE)
|
||||
selectedTexture)
|
||||
(SETQ fadeTextures (DREMOVE selectedTexture fadeTextures]
|
||||
(BLOCK Slow-Fade-Delay)
|
||||
(APPLY* (OR Default-Slow-Fade-Idle-Function (FUNCTION IDLE.BOUNCING.BOX))
|
||||
window])
|
||||
do (BLOCK Slow-Fade-Delay)
|
||||
(SETQ selectedTexture (LLSH 1 (RAND 0 15)))
|
||||
(BITBLT NIL NIL NIL window NIL NIL NIL NIL 'TEXTURE 'ERASE selectedTexture)
|
||||
(SETQ fadeTextures (DREMOVE selectedTexture fadeTextures]
|
||||
(BLOCK Slow-Fade-Delay)
|
||||
(APPLY* (OR Default-Slow-Fade-Idle-Function (FUNCTION IDLE.BOUNCING.BOX))
|
||||
window])
|
||||
)
|
||||
|
||||
(RPAQ? Slow-Fade-Delay 1000)
|
||||
|
||||
(RPAQ? Default-Slow-Fade-Idle-Function (LISTGET IDLE.PROFILE (QUOTE DISPLAYFN)))
|
||||
(DECLARE: DOEVAL@COMPILE DONTCOPY
|
||||
(RPAQ? Default-Slow-Fade-Idle-Function (LISTGET IDLE.PROFILE 'DISPLAYFN))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS Slow-Fade-Delay Default-Slow-Fade-Idle-Function)
|
||||
)
|
||||
(* * Add them as idle functions)
|
||||
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Pac-man" (QUOTE Pac-Man-Idle))
|
||||
("Slow fade" (QUOTE Slow-Fade)))
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Pac-man" 'Pac-Man-Idle)
|
||||
("Slow fade" 'Slow-Fade))
|
||||
(PUTPROPS PAC-MAN-IDLE COPYRIGHT ("Xerox Corporation" 1986))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (1826 7263 (Pac-Man-Eat-Window 1836 . 6918) (Pac-Man-Idle 6920 . 7261)) (8683 12226 (
|
||||
Pac-Man-Scout-Food 8693 . 12224)) (12282 12768 (Pac-Man-Amount-Of-Food 12292 . 12766)) (13370 14261 (
|
||||
Slow-Fade 13380 . 14259)))))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2093 8924 (Pac-Man-Eat-Window 2103 . 8625) (Pac-Man-Idle 8627 . 8922)) (10090 14734 (
|
||||
Pac-Man-Scout-Food 10100 . 14732)) (14790 15275 (Pac-Man-Amount-Of-Food 14800 . 15273)) (16137 16947 (
|
||||
Slow-Fade 16147 . 16945)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,18 +1,20 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
|
||||
(FILECREATED "12-Aug-87 03:05:50" {PHYLUM}<SHRAGER>LISP>QIX.\;3 11097
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
|changes| |to:| (VARS QIXCOMS)
|
||||
(FILECREATED "24-Aug-2022 07:58:48" |{DSK}<home>larry>medley>lispusers>QIX.;2| 11276
|
||||
|
||||
|previous| |date:| " 1-Aug-87 17:04:27" {PHYLUM}<SHRAGER>LISP>QIX.\;2)
|
||||
:CHANGES-TO (FNS QIX.IDLE)
|
||||
|
||||
:PREVIOUS-DATE "12-Aug-87 03:05:50" |{DSK}<home>larry>medley>lispusers>QIX.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1987 by Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT QIXCOMS)
|
||||
|
||||
(RPAQQ QIXCOMS ((FNS QIX.GROW QIX.IDLE QIX.MOVE.POINT QIX.PLAY)
|
||||
(RECORDS QIX.POINT)
|
||||
(P (SETQ IDLE.FUNCTIONS (CONS '("5 Qix's" 'QIX.IDLE) IDLE.FUNCTIONS)))))
|
||||
(P (SETQ IDLE.FUNCTIONS (CONS '("5 Qix's" 'QIX.IDLE)
|
||||
IDLE.FUNCTIONS)))))
|
||||
(DEFINEQ
|
||||
|
||||
(QIX.GROW
|
||||
@@ -109,16 +111,18 @@
|
||||
(GO LOOP))))
|
||||
|
||||
(QIX.IDLE
|
||||
(LAMBDA (W) (* \; "Edited 1-Aug-87 16:58 by JEFF.SHRAGER")
|
||||
|
||||
(* * CLOBBER ANY OLD QIXS THAT WERE LEFT AROUND
|
||||
(WASTING SPACE) FROM BEFORE.)
|
||||
(LAMBDA (W) (* \; "Edited 24-Aug-2022 07:53 by larry")
|
||||
(* \;
|
||||
"Edited 1-Aug-87 16:58 by JEFF.SHRAGER")
|
||||
|
||||
(* * CLOBBER ANY OLD QIXS THAT WERE LEFT AROUND
|
||||
(WASTING SPACE) FROM BEFORE.)
|
||||
|
||||
(AND (BOUNDP '*OLD-QIXS*)
|
||||
(FOR Q IN *OLD-QIXS* DO (RPLACD Q NIL)))
|
||||
(PROG (P P2 L QIXS)
|
||||
|
||||
(* * P |and| P2 |define| \a QIX.)
|
||||
|
||||
(* * P |and| P2 |define| \a QIX.)
|
||||
|
||||
(SETQ QIXS (|for| I |from| 1 |to| 5
|
||||
|collect| (PROGN (SETQ P (|create| QIX.POINT
|
||||
@@ -131,10 +135,10 @@
|
||||
Y _ (RAND 1 100)
|
||||
VH _ (RAND 1 20)
|
||||
VV _ (RAND 1 20)))
|
||||
|
||||
(* * L |is| |the| |tail| |list.| I\t |starts| |out| |full| |of| NIL\s |and|
|
||||
|gets| |filled| |as| |the| QIX |moves.| I\t |is| |also| |inserted| |in| |it's|
|
||||
|own| |mouth| |so| |that| |the| |whole| |thing| |wraps| |around.|)
|
||||
|
||||
(* * L |is| |the| |tail| |list.| I\t |starts| |out| |full| |of| NIL\s |and|
|
||||
|gets| |filled| |as| |the| QIX |moves.| I\t |is| |also| |inserted| |in| |it's|
|
||||
|own| |mouth| |so| |that| |the| |whole| |thing| |wraps| |around.|)
|
||||
|
||||
(SETQ L
|
||||
(APPEND (|for| X |from| 1 |to| (RAND 5 25)
|
||||
@@ -148,12 +152,12 @@
|
||||
(LIST P P2 L))))
|
||||
(SETQ *OLD-QIXS* QIXS)
|
||||
LOOP
|
||||
(DISMISS)
|
||||
(BLOCK 25)
|
||||
(|for| Q |in| QIXS |do| (SETQ P (CAR Q))
|
||||
(SETQ P2 (CADR Q))
|
||||
(SETQ L (CADDR Q))
|
||||
|
||||
(* * |Draw| |the| |QIX's| |head| |line.|)
|
||||
|
||||
(* * |Draw| |the| |QIX's| |head| |line.|)
|
||||
|
||||
(MOVETO (|fetch| X P)
|
||||
(|fetch| Y P)
|
||||
@@ -162,13 +166,13 @@
|
||||
(|fetch| Y P2)
|
||||
1
|
||||
'REPLACE W)
|
||||
|
||||
(* * |Move| |the| |points| |according| |to| |their| X |and| Y |velocities.|)
|
||||
|
||||
(* * |Move| |the| |points| |according| |to| |their| X |and| Y |velocities.|)
|
||||
|
||||
(QIX.MOVE.POINT P W)
|
||||
(QIX.MOVE.POINT P2 W)
|
||||
|
||||
(* * |Delete| |the| |first| |object| |on| |the| |tail| |list.|)
|
||||
|
||||
(* * |Delete| |the| |first| |object| |on| |the| |tail| |list.|)
|
||||
|
||||
(COND
|
||||
((EQ (CAAR L)
|
||||
@@ -181,10 +185,10 @@
|
||||
(CADDDR OLD)
|
||||
1
|
||||
'ERASE W))))
|
||||
|
||||
(* * |Replace| |the| |current| |point| |with| |the| |new| |head,| |which|
|
||||
|effectively| |adds| |it| |to| |the| |end| |of| |the| |list,| |since| |we| THEN
|
||||
|immediately| |move| |to| |the| |next| |elt| |in| |this| |circular| |list.|)
|
||||
|
||||
(* * |Replace| |the| |current| |point| |with| |the| |new| |head,| |which|
|
||||
|effectively| |adds| |it| |to| |the| |end| |of| |the| |list,| |since| |we| THEN
|
||||
|immediately| |move| |to| |the| |next| |elt| |in| |this| |circular| |list.|)
|
||||
|
||||
(RPLACA (CAR L)
|
||||
(|fetch| X P))
|
||||
@@ -247,9 +251,11 @@
|
||||
|
||||
(RECORD QIX.POINT (X Y VH VV))
|
||||
)
|
||||
(SETQ IDLE.FUNCTIONS (CONS '("5 Qix's" 'QIX.IDLE) IDLE.FUNCTIONS))
|
||||
|
||||
(SETQ IDLE.FUNCTIONS (CONS '("5 Qix's" 'QIX.IDLE)
|
||||
IDLE.FUNCTIONS))
|
||||
(PUTPROPS QIX COPYRIGHT ("Xerox Corporation" 1987))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (539 10893 (QIX.GROW 549 . 4105) (QIX.IDLE 4107 . 8821) (QIX.MOVE.POINT 8823 . 10205) (
|
||||
QIX.PLAY 10207 . 10891)))))
|
||||
(FILEMAP (NIL (592 11044 (QIX.GROW 602 . 4158) (QIX.IDLE 4160 . 8972) (QIX.MOVE.POINT 8974 . 10356) (
|
||||
QIX.PLAY 10358 . 11042)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,11 +1,14 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED " 6-Nov-92 09:25:48" {DSK}<project>medley2.0>lispusers>READBRUSH.;1 9607
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
previous date%: "23-Jun-88 02:13:42" {DSK}<import>lisp>medley>lispusers>readbrush.;1)
|
||||
(FILECREATED "24-Aug-2022 07:58:48" {DSK}<home>larry>medley>lispusers>READBRUSH.;2 9288
|
||||
|
||||
:CHANGES-TO (FNS IDLE.GLIDING.BOX)
|
||||
|
||||
:PREVIOUS-DATE " 6-Nov-92 09:25:48" {DSK}<home>larry>medley>lispusers>READBRUSH.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1984, 1985, 1986, 1988, 1992 by Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1984-1986, 1988, 1992 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT READBRUSHCOMS)
|
||||
@@ -93,17 +96,18 @@ Copyright (c) 1984, 1985, 1986, 1988, 1992 by Xerox Corporation. All rights res
|
||||
'PRESS])
|
||||
|
||||
(IDLE.GLIDING.BOX
|
||||
[LAMBDA (WIN BITMAPS WAIT WAITSEQ MAXD) (* ; "Edited 23-Jun-88 01:53 by masinter")
|
||||
[LAMBDA (WIN BITMAPS WAIT WAITSEQ MAXD) (* ; "Edited 24-Aug-2022 07:57 by larry")
|
||||
(* ; "Edited 23-Jun-88 01:53 by masinter")
|
||||
(OR BITMAPS (SETQ BITMAPS IDLE.BOUNCING.BOX))
|
||||
[OR WIN (SETQ WIN (OR POLYGONSWINDOW (SETQ POLYGONSWINDOW (CREATEW]
|
||||
(OR MAXD (SETQ MAXD 4))
|
||||
(OR WAIT (SETQ WAIT 50))
|
||||
[SETQ BITMAPS (for X inside BITMAPS
|
||||
collect (if (LITATOM X)
|
||||
then [OR (GETPROP X 'BITMAP)
|
||||
(PUTPROP X 'BITMAP (OR (CAR (READBRUSHFILE
|
||||
X))
|
||||
(BITMAPCREATE 10 10]
|
||||
else (IDLE.BITMAP NIL X]
|
||||
then [OR (GETPROP X 'BITMAP)
|
||||
(PUTPROP X 'BITMAP (OR (CAR (READBRUSHFILE X))
|
||||
(BITMAPCREATE 10 10]
|
||||
else (IDLE.BITMAP NIL X]
|
||||
(LET ((W (for X in BITMAPS largest (BITMAPWIDTH X) finally (RETURN $$EXTREME)))
|
||||
(H (for X in BITMAPS largest (BITMAPHEIGHT X) finally (RETURN $$EXTREME)))
|
||||
(REG (DSPCLIPPINGREGION NIL WIN)))
|
||||
@@ -123,51 +127,49 @@ Copyright (c) 1984, 1985, 1986, 1988, 1992 by Xerox Corporation. All rights res
|
||||
(BITBLT (SETQ THISBITMAP (CAR BITMAPS))
|
||||
NIL NIL WIN X Y NIL NIL NIL 'INVERT)
|
||||
(while T do [COND
|
||||
((ILEQ CNT 0)
|
||||
(SETQ ORIGX X)
|
||||
(SETQ ORIGY Y)
|
||||
(SETQ TOX (RAND 1 (SUB1 MAXX)))
|
||||
(SETQ TOY (RAND 1 (SUB1 MAXY)))
|
||||
(SETQ CNT (SETQ STEPS
|
||||
(QUOTIENT (PLUS (MAX (ABS (DIFFERENCE TOX X))
|
||||
(ABS (DIFFERENCE TOY Y)))
|
||||
MAXD -1)
|
||||
MAXD)))
|
||||
(QUOTIENT (PLUS (ABS (DIFFERENCE TOX X))
|
||||
STEPS -1)
|
||||
STEPS))
|
||||
(T (SETQ CNT (SUB1 CNT]
|
||||
(SETQ NEWX (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGX TOX))
|
||||
STEPS)
|
||||
TOX))
|
||||
(if (GREATERP (ABS (SETQ DX (DIFFERENCE NEWX X)))
|
||||
MAXD)
|
||||
then (SHOULDNT))
|
||||
(SETQ NEWY (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGY TOY))
|
||||
STEPS)
|
||||
TOY))
|
||||
(if (GREATERP (ABS (SETQ DY (DIFFERENCE NEWY Y)))
|
||||
MAXD)
|
||||
then (SHOULDNT))
|
||||
(BITBLT NIL NIL NIL XBM NIL NIL NIL NIL 'TEXTURE 'ERASE BLACKSHADE)
|
||||
(BITBLT THISBITMAP NIL NIL XBM MAXD MAXD NIL NIL NIL 'INVERT)
|
||||
(BITBLT THISBITMAP NIL NIL XBM (PLUS MAXD DX)
|
||||
(PLUS MAXD DY)
|
||||
NIL NIL NIL 'INVERT)
|
||||
(BITBLT XBM NIL NIL WIN (DIFFERENCE X MAXD)
|
||||
(DIFFERENCE Y MAXD)
|
||||
NIL NIL NIL 'INVERT)
|
||||
(add X DX)
|
||||
(add Y DY)
|
||||
(DISMISS WAIT])
|
||||
((ILEQ CNT 0)
|
||||
(SETQ ORIGX X)
|
||||
(SETQ ORIGY Y)
|
||||
(SETQ TOX (RAND 1 (SUB1 MAXX)))
|
||||
(SETQ TOY (RAND 1 (SUB1 MAXY)))
|
||||
(SETQ CNT (SETQ STEPS (QUOTIENT (PLUS (MAX (ABS (DIFFERENCE TOX X))
|
||||
(ABS (DIFFERENCE TOY Y)))
|
||||
MAXD -1)
|
||||
MAXD)))
|
||||
(QUOTIENT (PLUS (ABS (DIFFERENCE TOX X))
|
||||
STEPS -1)
|
||||
STEPS))
|
||||
(T (SETQ CNT (SUB1 CNT]
|
||||
(SETQ NEWX (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGX TOX))
|
||||
STEPS)
|
||||
TOX))
|
||||
(if (GREATERP (ABS (SETQ DX (DIFFERENCE NEWX X)))
|
||||
MAXD)
|
||||
then (SHOULDNT))
|
||||
(SETQ NEWY (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGY TOY))
|
||||
STEPS)
|
||||
TOY))
|
||||
(if (GREATERP (ABS (SETQ DY (DIFFERENCE NEWY Y)))
|
||||
MAXD)
|
||||
then (SHOULDNT))
|
||||
(BITBLT NIL NIL NIL XBM NIL NIL NIL NIL 'TEXTURE 'ERASE BLACKSHADE)
|
||||
(BITBLT THISBITMAP NIL NIL XBM MAXD MAXD NIL NIL NIL 'INVERT)
|
||||
(BITBLT THISBITMAP NIL NIL XBM (PLUS MAXD DX)
|
||||
(PLUS MAXD DY)
|
||||
NIL NIL NIL 'INVERT)
|
||||
(BITBLT XBM NIL NIL WIN (DIFFERENCE X MAXD)
|
||||
(DIFFERENCE Y MAXD)
|
||||
NIL NIL NIL 'INVERT)
|
||||
(add X DX)
|
||||
(add Y DY)
|
||||
(DISMISS WAIT])
|
||||
)
|
||||
|
||||
(FILESLOAD BITMAPFNS)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS ["Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen"
|
||||
(SUBITEMS ("Pick image from MesaHacks" (PROGN (CHOOSE.IDLE.BITMAP
|
||||
)
|
||||
'IDLE.GLIDING.BOX])
|
||||
(SUBITEMS ("Pick image from MesaHacks" (PROGN (CHOOSE.IDLE.BITMAP)
|
||||
'IDLE.GLIDING.BOX])
|
||||
|
||||
(RPAQ? IDLE.BITMAP )
|
||||
|
||||
@@ -178,6 +180,6 @@ Copyright (c) 1984, 1985, 1986, 1988, 1992 by Xerox Corporation. All rights res
|
||||
(RPAQ? BRUSHDIRECTORY "{goofy:osbu north:xerox}<hacks>data>brushes>")
|
||||
(PUTPROPS READBRUSH COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1988 1992))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1444 8940 (CHOOSE.IDLE.BITMAP 1454 . 2452) (READBRUSHFILE 2454 . 3500) (READBRUSH 3502
|
||||
. 4314) (READROOTPICTURE 4316 . 4655) (IDLE.GLIDING.BOX 4657 . 8938)))))
|
||||
(FILEMAP (NIL (1467 8713 (CHOOSE.IDLE.BITMAP 1477 . 2475) (READBRUSHFILE 2477 . 3523) (READBRUSH 3525
|
||||
. 4337) (READROOTPICTURE 4339 . 4678) (IDLE.GLIDING.BOX 4680 . 8711)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,23 +1,96 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 5-Aug-88 15:17:16" |{POGO:AISNORTH:XEROX}<ROOMS>MEDLEY>USERS>SCREENPAPER.;1| 10019
|
||||
|
||||
changes to%: (FNS SCREENPAPER KALSHOW SCREENPAPERNEWREGIONFN) (VARS SCREENPAPERCOMS)
|
||||
(FILECREATED "24-Aug-2022 07:49:42" {DSK}<home>larry>medley>lispusers>SCREENPAPER.;2 12374
|
||||
|
||||
previous date%: " 4-Aug-88 13:46:25" {ERINYES}<LISPUSERS>MEDLEY>SCREENPAPER.;4)
|
||||
:CHANGES-TO (FNS SCREENPAPER)
|
||||
|
||||
:PREVIOUS-DATE " 5-Aug-88 15:17:16" {DSK}<home>larry>medley>lispusers>SCREENPAPER.;1)
|
||||
|
||||
|
||||
(* "
|
||||
Copyright (c) 1901, 1986, 1988 by Xerox Corporation. All rights reserved.
|
||||
(* ; "
|
||||
Copyright (c) 1901, 1986, 1988 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT SCREENPAPERCOMS)
|
||||
|
||||
(RPAQQ SCREENPAPERCOMS ((FNS SCREENPAPER SCREENPAPERNEWREGIONFN KALSHOW DOPOINT MAPN) (ADDVARS (IDLE.FUNCTIONS ("Screen wallpaper" (QUOTE SCREENPAPER)))) (* ;;; "faster versions of editbitmap functions") (FNS INVERT.BITMAP.HORIZONTALLY INVERT.BITMAP.VERTICALLY ROTATE.BITMAP) (VARS SCREENPAPERSIZE SCREENPERIOD SCREENREPEAT)))
|
||||
(RPAQQ SCREENPAPERCOMS
|
||||
((FNS SCREENPAPER SCREENPAPERNEWREGIONFN KALSHOW DOPOINT MAPN)
|
||||
[ADDVARS (IDLE.FUNCTIONS ("Screen wallpaper" 'SCREENPAPER]
|
||||
|
||||
|
||||
(* ;;; "faster versions of editbitmap functions")
|
||||
|
||||
(FNS INVERT.BITMAP.HORIZONTALLY INVERT.BITMAP.VERTICALLY ROTATE.BITMAP)
|
||||
(VARS SCREENPAPERSIZE SCREENPERIOD SCREENREPEAT)))
|
||||
(DEFINEQ
|
||||
|
||||
(SCREENPAPER
|
||||
(LAMBDA (WINDOW REGION.OR.SIZE OPTION) (* ; "Edited 5-Aug-88 15:07 by drc:") (OR WINDOW (SETQ WINDOW (CREATEW))) (OR REGION.OR.SIZE (SETQ REGION.OR.SIZE (if (EQ OPTION (QUOTE PICK)) then (GETREGION 0 0 NIL (FUNCTION SCREENPAPERNEWREGIONFN)) else SCREENPAPERSIZE))) (LET ((SIZE (if (REGIONP REGION.OR.SIZE) then (fetch (REGION WIDTH) REGION.OR.SIZE) else REGION.OR.SIZE)) TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY (CNT SCREENPERIOD)) (DECLARE (SPECVARS TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY CNT)) (SETQ TRIANGLE (BITMAPCREATE SIZE SIZE)) (SETQ BUF1 (BITMAPCREATE SIZE SIZE)) (SETQ STREAM (DSPCREATE TRIANGLE)) (FILLPOLYGON (LIST (QUOTE (-1 . -1)) (CONS SIZE SIZE) (CONS -1 SIZE)) BLACKSHADE STREAM) (SETQ BUF2 (BITMAPCREATE SIZE SIZE)) (SETQ BUF3 (BITMAPCREATE SIZE SIZE)) (SETQ 2SIZE (PLUS SIZE SIZE)) (SETQ BIGBUF (BITMAPCREATE 2SIZE 2SIZE)) (SETQ PBT (create PILOTBBT)) (DSPDESTINATION BUF1 STREAM) (if (EQ OPTION (QUOTE PICK)) then (bind POS do (RESETFORM (CURSOR CROSSHAIRS) (until (MOUSESTATE (OR LEFT MIDDLE RIGHT)))) (if (LASTMOUSESTATE (ONLY MIDDLE)) then (RETURN BIGBUF) elseif (LASTMOUSESTATE (ONLY RIGHT)) then (RETURN NIL) elseif (REGIONP REGION.OR.SIZE) then (SETQ POS (CONS (fetch (REGION LEFT) REGION.OR.SIZE) (fetch (REGION BOTTOM) REGION.OR.SIZE))) (SETQ REGION.OR.SIZE) else (SETQ POS (GETBOXPOSITION SIZE SIZE))) (BITBLT (SCREENBITMAP) (CAR POS) (CDR POS) BUF1 0 0 SIZE SIZE) (KALSHOW BUF1 WINDOW SIZE (if (SHIFTDOWNP (QUOTE SHIFT)) then (QUOTE INVERT) else NIL))) else (MAPN WINDOW (FUNCTION (LAMBDA (X Y) (BITBLT (WINDOWPROP WINDOW (QUOTE IMAGECOVERED)) X Y BUF1 0 0 SIZE SIZE) (DRAWLINE (SUB1 SIZE) 0 (RAND 0 (SUB1 SIZE)) (RAND 0 (SUB1 SIZE)) 1 (QUOTE INVERT) STREAM) (KALSHOW BUF1 WINDOW SIZE (if (VIDEOCOLOR) then NIL else (QUOTE INVERT))) (if (LEQ (add CNT -1) 0) then (SETQ CNT SCREENPERIOD) (to SCREENREPEAT do (BITBLT WINDOW 0 0 BUF1) (KALSHOW BUF1 WINDOW SIZE)))))))))
|
||||
)
|
||||
[LAMBDA (WINDOW REGION.OR.SIZE OPTION) (* ; "Edited 24-Aug-2022 07:46 by larry")
|
||||
(* ; "Edited 5-Aug-88 15:07 by drc:")
|
||||
(OR WINDOW (SETQ WINDOW (CREATEW)))
|
||||
(OR REGION.OR.SIZE (SETQ REGION.OR.SIZE (if (EQ OPTION 'PICK)
|
||||
then (GETREGION 0 0 NIL (FUNCTION
|
||||
SCREENPAPERNEWREGIONFN))
|
||||
else SCREENPAPERSIZE)))
|
||||
(LET ((SIZE (if (REGIONP REGION.OR.SIZE)
|
||||
then (fetch (REGION WIDTH)
|
||||
REGION.OR.SIZE)
|
||||
else REGION.OR.SIZE))
|
||||
TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY (CNT SCREENPERIOD))
|
||||
(DECLARE (SPECVARS TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY CNT))
|
||||
(SETQ TRIANGLE (BITMAPCREATE SIZE SIZE))
|
||||
(SETQ BUF1 (BITMAPCREATE SIZE SIZE))
|
||||
(SETQ STREAM (DSPCREATE TRIANGLE))
|
||||
(FILLPOLYGON (LIST '(-1 . -1)
|
||||
(CONS SIZE SIZE)
|
||||
(CONS -1 SIZE))
|
||||
BLACKSHADE STREAM)
|
||||
(SETQ BUF2 (BITMAPCREATE SIZE SIZE))
|
||||
(SETQ BUF3 (BITMAPCREATE SIZE SIZE))
|
||||
(SETQ 2SIZE (PLUS SIZE SIZE))
|
||||
(SETQ BIGBUF (BITMAPCREATE 2SIZE 2SIZE))
|
||||
(SETQ PBT (create PILOTBBT))
|
||||
(DSPDESTINATION BUF1 STREAM)
|
||||
(if (EQ OPTION 'PICK)
|
||||
then (bind POS do [RESETFORM (CURSOR CROSSHAIRS)
|
||||
(until (MOUSESTATE (OR LEFT MIDDLE RIGHT]
|
||||
(if (LASTMOUSESTATE (ONLY MIDDLE))
|
||||
then (RETURN BIGBUF)
|
||||
elseif (LASTMOUSESTATE (ONLY RIGHT))
|
||||
then (RETURN NIL)
|
||||
elseif (REGIONP REGION.OR.SIZE)
|
||||
then (SETQ POS (CONS (fetch (REGION LEFT)
|
||||
REGION.OR.SIZE)
|
||||
(fetch (REGION BOTTOM)
|
||||
REGION.OR.SIZE)))
|
||||
(SETQ REGION.OR.SIZE)
|
||||
else (SETQ POS (GETBOXPOSITION SIZE SIZE)))
|
||||
(BITBLT (SCREENBITMAP)
|
||||
(CAR POS)
|
||||
(CDR POS)
|
||||
BUF1 0 0 SIZE SIZE)
|
||||
(KALSHOW BUF1 WINDOW SIZE (if (SHIFTDOWNP 'SHIFT)
|
||||
then 'INVERT
|
||||
else NIL)))
|
||||
else (MAPN WINDOW (FUNCTION (LAMBDA (X Y)
|
||||
(BITBLT (WINDOWPROP WINDOW 'IMAGECOVERED)
|
||||
X Y BUF1 0 0 SIZE SIZE)
|
||||
(DRAWLINE (SUB1 SIZE)
|
||||
0
|
||||
(RAND 0 (SUB1 SIZE))
|
||||
(RAND 0 (SUB1 SIZE))
|
||||
1
|
||||
'INVERT STREAM)
|
||||
(KALSHOW BUF1 WINDOW SIZE (if (VIDEOCOLOR)
|
||||
then NIL
|
||||
else 'INVERT))
|
||||
(BLOCK 100)
|
||||
(if (LEQ (add CNT -1)
|
||||
0)
|
||||
then (SETQ CNT SCREENPERIOD)
|
||||
(to SCREENREPEAT
|
||||
do (BITBLT WINDOW 0 0 BUF1)
|
||||
(KALSHOW BUF1 WINDOW SIZE])
|
||||
|
||||
(SCREENPAPERNEWREGIONFN
|
||||
(LAMBDA (FP MP) (* BN "17-Sep-84 10:40") (COND (MP (with POSITION MP (PROG ((DX (IDIFFERENCE XCOORD (fetch (POSITION XCOORD) of FP))) (DY (IDIFFERENCE YCOORD (fetch (POSITION YCOORD) of FP)))) (COND ((IGREATERP (IABS DX) (IABS DY)) (SETQ YCOORD (IPLUS (fetch (POSITION YCOORD) of FP) (ITIMES DX (COND ((MINUSP (ITIMES DX DY)) -1) (T 1)))))) (T (SETQ XCOORD (IPLUS (fetch (POSITION XCOORD) of FP) (ITIMES DY (COND ((MINUSP (ITIMES DX DY)) -1) (T 1))))))) (RETURN MP)))) (T FP)))
|
||||
@@ -66,7 +139,7 @@ Copyright (c) 1901, 1986, 1988 by Xerox Corporation. All rights reserved.
|
||||
(SETQ Y NY])
|
||||
)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Screen wallpaper" (QUOTE SCREENPAPER)))
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Screen wallpaper" 'SCREENPAPER))
|
||||
|
||||
|
||||
|
||||
@@ -142,14 +215,14 @@ Copyright (c) 1901, 1986, 1988 by Xerox Corporation. All rights reserved.
|
||||
BM2])
|
||||
)
|
||||
|
||||
(RPAQQ SCREENPAPERSIZE 64)
|
||||
(RPAQQ SCREENPAPERSIZE 64)
|
||||
|
||||
(RPAQQ SCREENPERIOD 100)
|
||||
(RPAQQ SCREENPERIOD 100)
|
||||
|
||||
(RPAQQ SCREENREPEAT 0)
|
||||
(RPAQQ SCREENREPEAT 0)
|
||||
(PUTPROPS SCREENPAPER COPYRIGHT ("Xerox Corporation" 1901 1986 1988))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (805 5979 (SCREENPAPER 815 . 2782) (SCREENPAPERNEWREGIONFN 2784 . 3291) (KALSHOW 3293 .
|
||||
4283) (DOPOINT 4285 . 4657) (MAPN 4659 . 5977)) (6106 9848 (INVERT.BITMAP.HORIZONTALLY 6116 . 7233) (
|
||||
INVERT.BITMAP.VERTICALLY 7235 . 8611) (ROTATE.BITMAP 8613 . 9846)))))
|
||||
(FILEMAP (NIL (770 8325 (SCREENPAPER 780 . 5128) (SCREENPAPERNEWREGIONFN 5130 . 5637) (KALSHOW 5639 .
|
||||
6629) (DOPOINT 6631 . 7003) (MAPN 7005 . 8323)) (8449 12191 (INVERT.BITMAP.HORIZONTALLY 8459 . 9576) (
|
||||
INVERT.BITMAP.VERTICALLY 9578 . 10954) (ROTATE.BITMAP 10956 . 12189)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
1038
lispusers/SOLITAIRE
1038
lispusers/SOLITAIRE
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -1,13 +1,14 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "17-Aug-88 03:26:58" {ERINYES}<LISPUSERS>MEDLEY>STARBG.;2 16928
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS Cosmos)
|
||||
(FILECREATED "24-Aug-2022 08:54:17" {DSK}<home>larry>medley>lispusers>STARBG.;2 16815
|
||||
|
||||
previous date%: "12-Oct-87 17:02:01" {ERINYES}<LISP>LYRIC>LISPUSERS>STARBG.;2)
|
||||
:CHANGES-TO (FNS Cosmos)
|
||||
|
||||
:PREVIOUS-DATE "17-Aug-88 03:26:58" {DSK}<home>larry>medley>lispusers>STARBG.;1)
|
||||
|
||||
|
||||
(* "
|
||||
Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved.
|
||||
(* ; "
|
||||
Copyright (c) 1984-1988 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT STARBGCOMS)
|
||||
@@ -109,10 +110,10 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
|
||||
|
||||
(RPAQQ supernova #*(13 13)OMOHOMOHOHOHN@CHN@CHL@AH@@@@L@AHN@CHN@CHOHOHOMOHOMOH)
|
||||
|
||||
(RPAQQ STARBGParameters (SBM BM1 BM2 BM3 BM4 BM5 nova supernova stars1 stars2 stars3 stars4
|
||||
stars5 changeStars eventPause clusters clusterRadius constellations
|
||||
starsInCluster superClusters superClusterRadius interiorClusters
|
||||
starsInterior))
|
||||
(RPAQQ STARBGParameters (SBM BM1 BM2 BM3 BM4 BM5 nova supernova stars1 stars2 stars3 stars4 stars5
|
||||
changeStars eventPause clusters clusterRadius constellations
|
||||
starsInCluster superClusters superClusterRadius interiorClusters
|
||||
starsInterior))
|
||||
|
||||
(RPAQQ trekNotes (<A+ D/ G+ F# E/ D/ D@/ C))
|
||||
(DEFINEQ
|
||||
@@ -140,39 +141,39 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
|
||||
)
|
||||
|
||||
(Cosmos
|
||||
[LAMBDA (starWindow) (* ; "Edited 17-Aug-88 03:25 by EWEAVER")
|
||||
[LAMBDA (starWindow) (* ; "Edited 24-Aug-2022 08:05 by larry")
|
||||
(* ; "Edited 17-Aug-88 03:25 by EWEAVER")
|
||||
(OR starWindow (SETQ starWindow (CREATEW WHOLESCREEN NIL 0)))
|
||||
(if (VIDEOCOLOR)
|
||||
then (RESETLST
|
||||
(RESETSAVE voidShade WHITESHADE)
|
||||
(RESETSAVE starShade BLACKSHADE)
|
||||
(DSPFILL NIL voidShade 'REPLACE starWindow)
|
||||
(RESETSAVE BM1 (InvertBM BM1))
|
||||
(RESETSAVE BM2 (InvertBM BM2))
|
||||
(RESETSAVE BM3 (InvertBM BM3))
|
||||
(RESETSAVE BM4 (InvertBM BM4))
|
||||
(RESETSAVE BM5 (InvertBM BM5))
|
||||
(RESETSAVE cursorFollower (ICONW darkSaucer saucerMask (CREATEPOSITION 0 0)
|
||||
T))
|
||||
(RESETSAVE nova (InvertBM nova))
|
||||
(RESETSAVE supernova (InvertBM supernova))
|
||||
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (starWindow)
|
||||
(if changeStars
|
||||
then (BITBLT (InvertBM starWindow
|
||||
'inPlace)
|
||||
0 0 SBM)
|
||||
(CLOSEW starWindow)
|
||||
(CHANGEBACKGROUND SBM)
|
||||
(CLOSEW cursorFollower]
|
||||
starWindow))
|
||||
(DSPOPERATION 'REPLACE starWindow)
|
||||
(while T do (SomethingCosmic starWindow)
|
||||
(BLOCK eventPause)))
|
||||
(RESETSAVE voidShade WHITESHADE)
|
||||
(RESETSAVE starShade BLACKSHADE)
|
||||
(DSPFILL NIL voidShade 'REPLACE starWindow)
|
||||
(RESETSAVE BM1 (InvertBM BM1))
|
||||
(RESETSAVE BM2 (InvertBM BM2))
|
||||
(RESETSAVE BM3 (InvertBM BM3))
|
||||
(RESETSAVE BM4 (InvertBM BM4))
|
||||
(RESETSAVE BM5 (InvertBM BM5))
|
||||
(RESETSAVE cursorFollower (ICONW darkSaucer saucerMask (CREATEPOSITION 0 0)
|
||||
T))
|
||||
(RESETSAVE nova (InvertBM nova))
|
||||
(RESETSAVE supernova (InvertBM supernova))
|
||||
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (starWindow)
|
||||
(if changeStars
|
||||
then (BITBLT (InvertBM starWindow 'inPlace)
|
||||
0 0 SBM)
|
||||
(CLOSEW starWindow)
|
||||
(CHANGEBACKGROUND SBM)
|
||||
(CLOSEW cursorFollower]
|
||||
starWindow))
|
||||
(DSPOPERATION 'REPLACE starWindow)
|
||||
(while T do (SomethingCosmic starWindow)
|
||||
(BLOCK eventPause)))
|
||||
else (DSPFILL NIL voidShade 'REPLACE starWindow)
|
||||
(DSPOPERATION 'REPLACE starWindow)
|
||||
(while T do (SomethingCosmic starWindow)
|
||||
(BLOCK))
|
||||
(CLOSEW starWindow])
|
||||
(DSPOPERATION 'REPLACE starWindow)
|
||||
(while T do (SomethingCosmic starWindow)
|
||||
(BLOCK 100))
|
||||
(CLOSEW starWindow])
|
||||
|
||||
(InvertBM
|
||||
(LAMBDA (bm inPlace?) (* gsf " 2-Jan-86 14:32") (LET ((bitmap (if inPlace? then bm else (BITMAPCOPY bm)))) (BITBLT bm NIL NIL bitmap NIL NIL NIL NIL (QUOTE INVERT) (QUOTE REPLACE)) bitmap))
|
||||
@@ -267,12 +268,12 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
|
||||
then (PUSH IDLE.FUNCTIONS '("Cosmos" 'Cosmos "Go where no one has gone before... "]
|
||||
(PUTPROPS STARBG COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4118 16416 (Between 4128 . 4281) (BlackHole 4283 . 4570) (Catastrophe 4572 . 4838) (
|
||||
ChanceIn 4840 . 4926) (CloseFollower 4928 . 5008) (Constellation 5010 . 5560) (Cosmos 5562 . 7701) (
|
||||
InvertBM 7703 . 7904) (FillWithStars 7906 . 9356) (Marble 9358 . 9953) (OneChanceIn 9955 . 10022) (
|
||||
LowerBound 10024 . 10108) (OpenFollower 10110 . 10207) (PlusOrMinus 10209 . 10311) (RandGrey 10313 .
|
||||
10792) (SaucerOn 10794 . 11029) (SaucerOff 11031 . 11211) (STARBG 11213 . 11497) (StarCluster 11499 .
|
||||
12245) (SuperCluster 12247 . 12588) (SomethingCosmic 12590 . 14445) (StarFollowCursor 14447 . 14744) (
|
||||
StarryWindow 14746 . 15217) (Stomp 15219 . 15666) (TimePasses 15668 . 15775) (UFO 15777 . 16328) (
|
||||
UpperBound 16330 . 16414)))))
|
||||
(FILEMAP (NIL (4087 16303 (Between 4097 . 4250) (BlackHole 4252 . 4539) (Catastrophe 4541 . 4807) (
|
||||
ChanceIn 4809 . 4895) (CloseFollower 4897 . 4977) (Constellation 4979 . 5529) (Cosmos 5531 . 7588) (
|
||||
InvertBM 7590 . 7791) (FillWithStars 7793 . 9243) (Marble 9245 . 9840) (OneChanceIn 9842 . 9909) (
|
||||
LowerBound 9911 . 9995) (OpenFollower 9997 . 10094) (PlusOrMinus 10096 . 10198) (RandGrey 10200 .
|
||||
10679) (SaucerOn 10681 . 10916) (SaucerOff 10918 . 11098) (STARBG 11100 . 11384) (StarCluster 11386 .
|
||||
12132) (SuperCluster 12134 . 12475) (SomethingCosmic 12477 . 14332) (StarFollowCursor 14334 . 14631) (
|
||||
StarryWindow 14633 . 15104) (Stomp 15106 . 15553) (TimePasses 15555 . 15662) (UFO 15664 . 16215) (
|
||||
UpperBound 16217 . 16301)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user