(FILECREATED " 1-Apr-86 20:34:48" {ERIS}<LISPUSERS>KOTO>IDLEHAX.;8 23507
changes to: (FNS WARP)
previous date: "19-Mar-86 17:50:58" {ERIS}<LISPUSERS>KOTO>IDLEHAX.;7)
(* 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]
(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)))
(COMS (* line drawing demo)
(FNS LINES LINES1 LINES2 LINES3)
(VARS LINECNT))
(COMS (* circles and lines)
(FNS WALKINGSPOKE WARP))
(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)))
(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)
(* 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])
)
(* 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 (3718 7586 (POLYGONSDEMO 3728 . 3975) (POLYGONS 3977 . 4513) (CONNECTPOLYS 4515 . 6174)
(DRAWPOLY1 6176 . 7215) (RANDOMPT 7217 . 7584)) (8487 13621 (KALDEMO 8497 . 11341) (KAL.ADVANCE 11343
. 11956) (KAL.SPOTS 11958 . 12438) (KAL.BMS 12440 . 13155) (KAL.ORAND 13157 . 13619)) (13654 15881 (
BUBBLES 13664 . 15339) (BUBBLE.CREATE 15341 . 15879)) (15938 19511 (LINES 15948 . 17736) (LINES1 17738
. 18368) (LINES2 18370 . 18816) (LINES3 18818 . 19509)) (19567 22589 (WALKINGSPOKE 19577 . 21729) (
WARP 21731 . 22587)) (22612 22980 (DEMOWINDOW 22622 . 22978)))))
STOP