(FILECREATED " 5-Aug-85 22:19:02" {ERIS}<LISPUSERS>LINEDEMO.;12 17208
changes to: (VARS LINEDEMOCOMS)
(FNS KAL)
previous date: " 3-Aug-85 22:04:43" {ERIS}<LISPUSERS>LINEDEMO.;11)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LINEDEMOCOMS)
(RPAQQ LINEDEMOCOMS ([COMS [ADDVARS (IDLE.FUNCTIONS (Lines (QUOTE LINES))
[Triangles (FUNCTION (LAMBDA (W)
(LINES W 3 1 40]
(Polygons (QUOTE POLYGONS))
(Bubbles (QUOTE BUBBLES))
(Kaleidoscope (QUOTE KAL]
(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 KAL 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 (* utilities)
(FNS DEMOWINDOW)
(GLOBALVARS BLOCKTIMER)
(MACROS PERIODIC.BLOCK))))
(ADDTOVAR IDLE.FUNCTIONS (Lines (QUOTE LINES))
[Triangles (FUNCTION (LAMBDA (W)
(LINES W 3 1 40]
(Polygons (QUOTE POLYGONS))
(Bubbles (QUOTE BUBBLES))
(Kaleidoscope (QUOTE KAL)))
(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
(KAL
[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) (* lmm "30-Jul-85 20:31")
(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)
(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 (to N collect (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)
(* 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 LINEDEMO COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1794 5450 (POLYGONSDEMO 1804 . 2041) (POLYGONS 2043 . 2609) (CONNECTPOLYS 2611 . 4145)
(DRAWPOLY1 4147 . 5094) (RANDOMPT 5096 . 5448)) (6211 10617 (KAL 6221 . 8323) (KAL.ADVANCE 8325 . 8934
) (KAL.SPOTS 8936 . 9465) (KAL.BMS 9467 . 10153) (KAL.ORAND 10155 . 10615)) (10650 12963 (BUBBLES
10660 . 12418) (BUBBLE.CREATE 12420 . 12961)) (13020 16406 (LINES 13030 . 14531) (LINES1 14533 . 15185
) (LINES2 15187 . 15665) (LINES3 15667 . 16404)) (16454 16836 (DEMOWINDOW 16464 . 16834)))))
STOP