(FILECREATED " 7-Jun-86 22:22:54" {ERIS}<LISPUSERS>KOTO>IDLEHAX.;10 30067
changes to: (VARS KAL.MASK IDLEHAXCOMS MELT-BLOCK-SIZE)
(FNS IDLE-WINDOWS IDLE-SLIDE)
(RECORDS KALSTATE)
previous date: " 7-Jun-86 21:41:56" {ERIS}<LISPUSERS>KOTO>IDLEHAX.;8)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT IDLEHAXCOMS)
(RPAQQ IDLEHAXCOMS ([COMS [ADDVARS (IDLE.FUNCTIONS (Lines (QUOTE LINES))
(Warp-Out (QUOTE WARP))
(Radar (QUOTE WALKINGSPOKE))
[Triangles (FUNCTION (LAMBDA (W)
(LINES W 3 1 40]
[RandAngles (FUNCTION (LAMBDA (W)
(LINES W (RAND 3 7)
(RAND 1 16)
(RAND 25 100]
(Polygons (QUOTE POLYGONS))
(Bubbles (QUOTE BUBBLES))
(Kaleidoscope (QUOTE KALDEMO))
(Windows (QUOTE IDLE-WINDOWS]
(VARS (IDLE.DEFAULTFN (QUOTE LINES]
[COMS (* for drawing polygons)
(FNS POLYGONSDEMO POLYGONS CONNECTPOLYS DRAWPOLY1 RANDOMPT)
(INITVARS (POLYGONSWINDOW))
(VARS POLYGONWAIT2 POLYGONMINPTS POLYGONMAXPTS POLYGONSTEPS POLYGONWAIT)
(RECORDS NPOINT)
(P (DEFPRINT (QUOTE NPOINT)
(QUOTE (LAMBDA (PT FL)
(CONS (CONCAT "(" (fetch XC of PT)
","
(fetch YC of PT)
")")
(PACK]
(COMS (* and dots)
(DECLARE: DONTCOPY (RECORDS KALSTATE)
(CONSTANTS KAL.MASK))
(FNS KALDEMO KAL.ADVANCE KAL.SPOTS KAL.BMS KAL.ORAND))
(COMS (* Fun with circles...)
(FNS BUBBLES BUBBLE.CREATE)
(VARS (BUBBLECNT 20))
(FNS IDLE-WINDOWS))
(COMS (* line drawing demo)
(FNS LINES LINES1 LINES2 LINES3)
(VARS LINECNT))
(COMS (* circles and lines)
(FNS WALKINGSPOKE WARP))
[COMS (* melting)
(FNS IDLE-MELT IDLE-SLIDE)
(VARS MELT-BLOCK-SIZE)
(ADDVARS (IDLE.FUNCTIONS ("Melt screen" (QUOTE IDLE-MELT))
("Slide screen" (QUOTE IDLE-SLIDE]
(COMS (* utilities)
(FNS DEMOWINDOW)
(GLOBALVARS BLOCKTIMER)
(MACROS PERIODIC.BLOCK))))
(ADDTOVAR IDLE.FUNCTIONS (Lines (QUOTE LINES))
(Warp-Out (QUOTE WARP))
(Radar (QUOTE WALKINGSPOKE))
[Triangles (FUNCTION (LAMBDA (W)
(LINES W 3 1 40]
[RandAngles (FUNCTION (LAMBDA (W)
(LINES W (RAND 3 7)
(RAND 1 16)
(RAND 25 100]
(Polygons (QUOTE POLYGONS))
(Bubbles (QUOTE BUBBLES))
(Kaleidoscope (QUOTE KALDEMO))
(Windows (QUOTE IDLE-WINDOWS)))
(RPAQQ IDLE.DEFAULTFN LINES)
(* for drawing polygons)
(DEFINEQ
(POLYGONSDEMO
[LAMBDA NIL (* hts: "20-AUG-83 22:55")
(POLYGONS [OR POLYGONSWINDOW (SETQ POLYGONSWINDOW (CREATEW (QUOTE (200 150 600 500]
T
(SETUPTIMER 10000])
(POLYGONS
[LAMBDA (W) (* lmm "30-Jul-85 20:31")
(SETQ W (DEMOWINDOW W))
(LET [(OP (if (VIDEOCOLOR) then (QUOTE PAINT) else (QUOTE ERASE]
(bind NPOINTS
do (SETQ NPOINTS (RAND POLYGONMINPTS POLYGONMAXPTS))
(CONNECTPOLYS (for I from 1 to NPOINTS collect (RANDOMPT W))
(for I from 1 to NPOINTS collect (RANDOMPT W))
POLYGONSTEPS W OP)
(DISMISS POLYGONWAIT])
(CONNECTPOLYS
[LAMBDA (FROMS TOS NSTEPS W OPERATION) (* lmm "30-Jul-85 17:19")
(PROG (DIFFS)
(CLEARW W)
(LINES2 FROMS 3 W OPERATION)
(SETQ DIFFS (for FPT in FROMS as TPT in TOS bind DX DY
collect (SETQ DX (IQUOTIENT (IDIFFERENCE (fetch XC
of TPT)
(fetch XC
of FPT))
POLYGONSTEPS))
(SETQ DY (IQUOTIENT (IDIFFERENCE (fetch YC
of TPT)
(fetch YC
of FPT))
POLYGONSTEPS))
(replace XC of TPT with (IPLUS (fetch XC
of FPT)
(ITIMES POLYGONSTEPS
DX)))
(replace YC of TPT with (IPLUS (fetch YC
of FPT)
(ITIMES POLYGONSTEPS
DY)))
(CONS DX DY)))
(LINES2 TOS 3 W OPERATION)
(for FPT in FROMS as TPT in TOS do (DRAWLINE (fetch XC of FPT)
(fetch YC of FPT)
(fetch XC of TPT)
(fetch YC of TPT)
1 OPERATION W))
(DISMISS POLYGONWAIT2)
(CLEARW W)
(for I from 1 to POLYGONSTEPS
do (BLOCK)
(LINES2 FROMS 1 W OPERATION)
(for PT in FROMS as DIF in DIFFS
do (add (fetch XC of PT)
(CAR DIF))
(add (fetch YC of PT)
(CDR DIF)))
finally (LINES2 FROMS 1 W OPERATION])
(DRAWPOLY1
[LAMBDA (PTLIST WIDTH OPERATION W NOBLOCK) (* edited: "19-AUG-83 04:14")
(* draws a closed polygon of the points given If
OPERATION is not given, use the one from the default
DS.)
[COND
(PTLIST (OR OPERATION (SETQ OPERATION (DSPOPERATION NIL W)))
(PROG ((PTS PTLIST))
(while (CDR PTS)
do (DRAWLINE (fetch XC of (CAR PTS))
(fetch YC of (CAR PTS))
(fetch XC of (CADR PTS))
(fetch YC of (CADR PTS))
WIDTH OPERATION W)
(pop PTS)
finally (DRAWLINE (fetch XC of (CAR PTS))
(fetch YC of (CAR PTS))
(fetch XC of (CAR PTLIST))
(fetch YC of (CAR PTLIST))
WIDTH OPERATION W]
(COND
(NOBLOCK (ALLOW.BUTTON.EVENTS))
(T (BLOCK])
(RANDOMPT
[LAMBDA (DS) (* edited: "18-AUG-83 16:22")
(PROG ((REG (DSPCLIPPINGREGION NIL DS)))
(RETURN (create NPOINT
XC ←(RAND (fetch LEFT of REG)
(fetch RIGHT of REG))
YC ←(RAND (fetch BOTTOM of REG)
(fetch TOP of REG])
)
(RPAQ? POLYGONSWINDOW )
(RPAQQ POLYGONWAIT2 250)
(RPAQQ POLYGONMINPTS 3)
(RPAQQ POLYGONMAXPTS 9)
(RPAQQ POLYGONSTEPS 35)
(RPAQQ POLYGONWAIT 2000)
[DECLARE: EVAL@COMPILE
(DATATYPE NPOINT ((XC XPOINTER)
(YC XPOINTER)))
]
(/DECLAREDATATYPE (QUOTE NPOINT)
(QUOTE (XPOINTER XPOINTER))
(QUOTE ((NPOINT 0 XPOINTER)
(NPOINT 2 XPOINTER)))
(QUOTE 4))
[DEFPRINT (QUOTE NPOINT)
(QUOTE (LAMBDA (PT FL)
(CONS (CONCAT "(" (fetch XC of PT)
","
(fetch YC of PT)
")")
(PACK]
(* and dots)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD KALSTATE (A B C PERIODCOUNT PERIOD))
]
(DECLARE: EVAL@COMPILE
(RPAQQ KAL.MASK 65535)
(CONSTANTS KAL.MASK)
)
)
(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])
(KAL.ADVANCE
[LAMBDA (STATE) (* lmm "30-Jul-85 20:16")
(freplace A of STATE with (KAL.ORAND (ffetch A of STATE)
(ffetch B of STATE)))
(freplace PERIODCOUNT of STATE with (SUB1 (ffetch PERIODCOUNT of STATE)))
(COND
((EQ (ffetch PERIODCOUNT of STATE)
0)
(freplace B of STATE with (KAL.ORAND (ffetch B of STATE)
(ffetch C of STATE)))
(freplace PERIODCOUNT of STATE with (ffetch PERIOD of STATE])
(KAL.SPOTS
[LAMBDA (X Y WINDOWSIDE W BLACK XOFFSET) (* lmm " 3-Aug-85 21:59")
(PROG ((X0 (LRSH X 7))
(Y0 (LRSH Y 7))
X1 Y1 C)
(COND
((ILESSP X0 Y0)
(SETQ X1 (IDIFFERENCE (SUB1 WINDOWSIDE)
X0))
(SETQ Y1 (IDIFFERENCE (SUB1 WINDOWSIDE)
Y0))
(SETQ C (LOGAND X 1))
(KAL.BMS W X0 Y0 X1 Y1 (if BLACK then (DIFFERENCE 1 C) else C)
XOFFSET])
(KAL.BMS
[LAMBDA (W X0 Y0 X1 Y1 C XOFFSET) (* lmm "30-Jul-85 19:38")
(UNINTERRUPTABLY
(if (EQUAL (GETWINDOWPROP W (QUOTE REGION))
WHOLESCREEN)
then
(TOTOPW W)
(SETQ W (SCREENBITMAP)))
(BITMAPBIT W (PLUS XOFFSET X0)
Y0 C)
(BITMAPBIT W (PLUS XOFFSET Y0)
X0 C)
(BITMAPBIT W (PLUS XOFFSET X1)
Y0 C)
(BITMAPBIT W (PLUS XOFFSET Y0)
X1 C)
(BITMAPBIT W (PLUS XOFFSET X1)
Y1 C)
(BITMAPBIT W (PLUS XOFFSET Y1)
X1 C)
(BITMAPBIT W (PLUS XOFFSET X0)
Y1 C)
(BITMAPBIT W (PLUS XOFFSET Y1)
X0 C))])
(KAL.ORAND
[LAMBDA (A B) (* DECLARATIONS: (BLOCKRECORD BOX
((VALUE FIXP))))
(* lmm " 3-Aug-85 21:58")
(LET [(BOX (CONSTANT (NCREATE (QUOTE FIXP]
(replace (BOX VALUE) of BOX with A)
(\BOXIPLUS BOX B)
(LOGXOR (LOGAND BOX KAL.MASK)
(LOGAND B KAL.MASK])
)
(* Fun with circles...)
(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])
(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])
)
(RPAQQ BUBBLECNT 20)
(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])
)
(* line drawing demo)
(DEFINEQ
(LINES
[LAMBDA (W N LCNT STEPS ODDSTEP) (* lmm "27-Sep-85 00:50")
(SETQ W (DEMOWINDOW W))
(OR STEPS (SETQ STEPS POLYGONSTEPS))
(OR N (SETQ N 2))
(RESETLST (PROG ((LINES (to (OR LCNT (if (NEQ N 2) then (ADD1 (QUOTIENT LINECNT
N))
else LINECNT))
collect NIL))
(CNT 0)
FROMPTS TOPTS DXS (ODDSTART))
(RESETSAVE NIL (LIST (FUNCTION RPLACD)
LINES))
(NCONC LINES LINES)
(SETQ FROMPTS (to N collect (RANDOMPT W)))
(bind (TIMER ←(SETUPTIMER 0 NIL (QUOTE TICKS))) while T
do [COND
((ILEQ CNT 0)
[SETQ TOPTS (bind (ODDP ←(SETQ ODDSTART (NOT ODDSTART)))
for X in FROMPTS
collect (if (AND ODDSTEP (SETQ ODDP
(NOT ODDP)))
then X else (RANDOMPT W]
[SETQ DXS (for TP in TOPTS as FP in FROMPTS
collect (create NPOINT
XC ←(QUOTIENT
(DIFFERENCE (fetch
XC TP)
(fetch
XC FP))
STEPS)
YC ←(QUOTIENT
(DIFFERENCE (fetch
YC TP)
(fetch
YC FP))
STEPS]
(SETQ CNT STEPS))
(T (SETQ CNT (SUB1 CNT]
(LINES1 FROMPTS LINES W)
(for X in FROMPTS as D in DXS
do (add (fetch XC X)
(fetch XC D))
(add (fetch YC X)
(fetch YC D)))
(SETQ LINES (CDR LINES))
(PERIODIC.BLOCK TIMER])
(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])
(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])
(LINES3
[LAMBDA (ENDPOINTS WIDTH WINDOW OPERATION EP2) (* lmm "30-Jul-85 17:33")
(for (X ← ENDPOINTS) while (OR (CDR X)
(if (CDDR ENDPOINTS) then X))
bind (Y ← EP2)
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)
(DRAWLINE (fetch XC (CAR Y))
(fetch YC (CAR Y))
(fetch XC (CAR (OR (SETQ Y (CDR Y))
EP2)))
(fetch YC (CAR (OR Y EP2)))
WIDTH OPERATION WINDOW])
)
(RPAQQ LINECNT 100)
(* circles and lines)
(DEFINEQ
(WALKINGSPOKE
[LAMBDA (W) (* lmm
"19-Mar-86 17:49")
(LET ((W (DEMOWINDOW W))
(SINARRAY (ARRAY 360 NIL NIL 0))
(MARGIN (QUOTIENT MAX.SMALLP SCREENWIDTH)))
[for N from 0 to 359 do (SETA SINARRAY N (FIXR (TIMES MARGIN (SIN N]
(CLEARW W)
(do
(PROG [(WIDTH (WINDOWPROP W (QUOTE WIDTH)))
(HEIGHT (WINDOWPROP W (QUOTE HEIGHT] (* for YY from 0 to 298
do (DRAWLINE 0 YY 298
YY 1 (QUOTE INVERT)
RADARWINDOW))
(LET ((R (QUOTIENT (RAND (MIN 100 WIDTH HEIGHT)
(MIN WIDTH HEIGHT))
2)))
(LET [(X (RAND R (DIFFERENCE WIDTH R)))
(Y (RAND R (DIFFERENCE HEIGHT R]
(RPTQ 2
(for N from 0 to 359
do (DRAWLINE X Y
(PLUS X (QUOTIENT (TIMES R
(ELT SINARRAY
(IMOD (PLUS N 90)
360)))
MARGIN))
(PLUS Y (QUOTIENT (TIMES R (ELT SINARRAY N))
MARGIN))
2
(QUOTE INVERT)
W)
(BLOCK))
(RECLAIM])
(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])
)
(* melting)
(DEFINEQ
(IDLE-MELT
[LAMBDA (WINDOW SIZE INITIAL PATH) (* lmm "30-May-86 03:32")
(OR SIZE (SETQ SIZE MELT-BLOCK-SIZE))
(SETQ WINDOW (DEMOWINDOW WINDOW))
(PROG ((W (WINDOWPROP WINDOW (QUOTE WIDTH)))
(H (WINDOWPROP WINDOW (QUOTE HEIGHT)))
BM
(TAIL INITIAL)
TIMER)
REPAINT
(CLEARW WINDOW)
[SETQ BM (OR (CAR TAIL)
(WINDOWPROP WINDOW (QUOTE IMAGECOVERED]
[for BITMAP inside BM do (BITBLT (SETQ BITMAP (if (BITMAPP BITMAP)
then BITMAP elseif (SYMBOLP BITMAP)
then
(CAR (READBRUSHFILE BITMAP))
else
(IDLE.BITMAP NIL BITMAP)))
NIL NIL WINDOW (RAND 0 (- W (BITMAPWIDTH BITMAP)))
(RAND 0 (- H (BITMAPHEIGHT BITMAP]
(if INITIAL then [SETQ TIMER (AND (CADR TAIL)
(SETUPTIMER (CADR TAIL)
TIMER
(QUOTE SECONDS)
(QUOTE 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 (QUOTE REPLACE)))
(BLOCK)
repeatuntil
(AND TIMER (TIMEREXPIRED? TIMER (QUOTE SECONDS]
(GO REPAINT])
(IDLE-SLIDE
[LAMBDA (W SIZE SPEED COUNT SOURCE) (* lmm " 7-Jun-86 21:49")
(OR SIZE (SETQ SIZE 128))
(OR COUNT (SETQ COUNT 120))
(OR SPEED (SETQ SPEED 2))
(SETQ W (DEMOWINDOW W))
(BITBLT [OR SOURCE (SETQ SOURCE (WINDOWPROP W (QUOTE IMAGECOVERED]
NIL NIL W NIL NIL NIL NIL NIL (QUOTE REPLACE))
(LET [(D (WINDOWPROP W (QUOTE WIDTH)))
(H (WINDOWPROP W (QUOTE HEIGHT]
(LET [(XMAX (- D SIZE))
(YMAX (- H SIZE))
X Y DX DY (CNT 1)
DDX DDY (TIMER (SETUPTIMER 0 NIL (QUOTE TICKS]
(LOOP (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 (QUOTE REPLACE))
(SETQ DDX DY)
(SETQ DDY DX)
(SETQ CNT COUNT)))
(BITBLT W X Y W (+ X DDX)
(+ Y DDY)
SIZE SIZE NIL (QUOTE REPLACE))
(add X DX)
(add Y DY)
(PERIODIC.BLOCK TIMER])
)
(RPAQQ MELT-BLOCK-SIZE 32)
(ADDTOVAR IDLE.FUNCTIONS ("Melt screen" (QUOTE IDLE-MELT))
("Slide screen" (QUOTE IDLE-SLIDE)))
(* utilities)
(DEFINEQ
(DEMOWINDOW
[LAMBDA (W) (* lmm "30-Jul-85 20:34")
[OR W (SETQ W (OR POLYGONSWINDOW (SETQ POLYGONSWINDOW (CREATEW]
(DSPTEXTURE (if (VIDEOCOLOR) then WHITESHADE else BLACKSHADE)
W)
(DSPOPERATION (QUOTE INVERT)
W)
(CLEARW W)
W])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS BLOCKTIMER)
)
(DECLARE: EVAL@COMPILE
[PUTPROPS PERIODIC.BLOCK MACRO ((TIMER)
(if (TIMEREXPIRED? TIMER (QUOTE TICKS))
then
(BLOCK)
(SETQ TIMER (SETUPTIMER 100 TIMER (QUOTE TICKS)
(QUOTE MILLISECONDS]
)
(PUTPROPS IDLEHAX COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4315 8183 (POLYGONSDEMO 4325 . 4572) (POLYGONS 4574 . 5110) (CONNECTPOLYS 5112 . 6771)
(DRAWPOLY1 6773 . 7812) (RANDOMPT 7814 . 8181)) (9084 14218 (KALDEMO 9094 . 11938) (KAL.ADVANCE 11940
. 12553) (KAL.SPOTS 12555 . 13035) (KAL.BMS 13037 . 13752) (KAL.ORAND 13754 . 14216)) (14251 16478 (
BUBBLES 14261 . 15936) (BUBBLE.CREATE 15938 . 16476)) (16505 18746 (IDLE-WINDOWS 16515 . 18744)) (
18777 22350 (LINES 18787 . 20575) (LINES1 20577 . 21207) (LINES2 21209 . 21655) (LINES3 21657 . 22348)
) (22406 25428 (WALKINGSPOKE 22416 . 24568) (WARP 24570 . 25426)) (25449 28990 (IDLE-MELT 25459 .
27376) (IDLE-SLIDE 27378 . 28988)) (29171 29539 (DEMOWINDOW 29181 . 29537)))))
STOP