From ecc2b222075f15dfa379f456e9d1afad77cba474 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Wed, 28 Sep 2022 22:39:31 -0700 Subject: [PATCH] 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 --- lispusers/HANOI | 645 +++++++++++----------- lispusers/HANOI.LCOM | Bin 7040 -> 7040 bytes lispusers/IDLEHAX | 318 ++++++++--- lispusers/IDLEHAX.LCOM | Bin 16275 -> 15814 bytes lispusers/KINETIC | 66 +-- lispusers/KINETIC.LCOM | Bin 1110 -> 1224 bytes lispusers/PAC-MAN-IDLE | 617 +++++++++------------ lispusers/PAC-MAN-IDLE.LCOM | Bin 8283 -> 8090 bytes lispusers/QIX | 66 ++- lispusers/QIX.LCOM | Bin 2862 -> 2906 bytes lispusers/READBRUSH | 106 ++-- lispusers/READBRUSH.LCOM | Bin 4299 -> 4378 bytes lispusers/SCREENPAPER | 103 +++- lispusers/SCREENPAPER.LCOM | Bin 5712 -> 5714 bytes lispusers/SOLITAIRE | 1038 ++++++++++++++++------------------- lispusers/SOLITAIRE.LCOM | Bin 10709 -> 10488 bytes lispusers/STARBG | 95 ++-- lispusers/STARBG.LCOM | Bin 16381 -> 16439 bytes sources/IDLER | 500 +++++++++++++---- sources/IDLER.LCOM | Bin 24731 -> 24993 bytes 20 files changed, 1926 insertions(+), 1628 deletions(-) diff --git a/lispusers/HANOI b/lispusers/HANOI index cc1ccf2b..99143961 100644 --- a/lispusers/HANOI +++ b/lispusers/HANOI @@ -1,70 +1,74 @@ -(FILECREATED "25-Feb-86 19:07:01" {ERIS}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}larry>medley>lispusers>HANOI.;2 22228 - previous date: "17-Feb-86 14:59:01" {ERIS}KOTO>HANOI.;5) + :CHANGES-TO (VARS HANOICOMS) + + :PREVIOUS-DATE "25-Feb-86 19:07:01" {DSK}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 diff --git a/lispusers/HANOI.LCOM b/lispusers/HANOI.LCOM index b7a348722565a1098fe3b18b652ece28d226bc42..108adda30761c6dff04662c890ad768bd10949cc 100644 GIT binary patch delta 986 zcma)5OK;Oa5LO=`SP&Gb+9XBM$P&VqaIjtSz=eoyc9U4Oy{_#flmk-QSfOejRoV(w z6>4vsOKt`612}N$58z+$2lxjZk$9|a(pFRm_ArP29y2>LdyqfKZ-|7J4V%hk!=$od zml>oTTw1~v3W8z#)HMyy5g_eSOnkg({&BsCJqoHKAtZ(lB~J4x0YOt`ywjF7Mbkhn z=t@D)<_{sU|DxXwik;?Quv_c~txm98?5uBX?ra5vtzs41%*ZTg5+FfS&gfNLeZVaQ zSY7LPH#>J*u-*fqTr*8L%gbak0<@ajL5t@)7=WL~kiE%acHNTv|6+&65ef@ALj?S-Bjn%7q-L4|OH4E9zf!9zK~) zBElzN;uVKhJZux!uqz(uq=1GSW1psxZJ0=u5Mfcu7$}avpBVvsx`g>v>c-I5@y9nu z&>01upeKsxnox_yigy#+w~?qS&v(pG}UT;pBVeaIe`7Bz}qUdAXR@hqc;nW-AHbWlyOd(W9_BE=zw>>2s+=m%#Wkad^A^?^)EjVgfX31MVw~ZsoWdPpGM!Aff-Oamt## z7tLls&Z%)ljmx|WwhVf_bW${Exk9l;S2hVFD+R4YjMy`UGjk~g>aS{@eY+0>M+I?P zvncq4JTa*RsN1vOG@XOKUquB$R<3eVYMMula&C@EOJSt*0!3}NjMu4F(k-L3PGM2c zBKPOm=UG%Tib#}@PW;>eIKOrFcnGW+C7rMWwgRYed->rIx~90ejjt5`wT?{^D5k~- z3rLjXQ1zUud~^~r$u{P-e8R=q_>1u|<)Yi5XfB?I-J`(Lk&{ptlx#{u;H!GVCp z46JGt`>qtTO4%c=8qCznm-gL>_n!Ua^v5aBo>^LcGcfovtvwpPr8;`d#lj4`%N4If zi~M{SGAGf_2z7sljwX-6A8J_oWS2#wlHJ6d~IFIK@CgP7d{aEG9hpxKQKARy^k6@+2*KzjaA7u~!WkFy97Urrc=5izMcaJO0%F0T(X; A9RL6T diff --git a/lispusers/IDLEHAX b/lispusers/IDLEHAX index 7afd3120..57c76286 100644 --- a/lispusers/IDLEHAX +++ b/lispusers/IDLEHAX @@ -1,12 +1,10 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "26-Jun-2022 18:21:17"  -{DSK}kaplan>Local>medley3.5>working-medley>lispusers>IDLEHAX.;4 26796 +(FILECREATED "28-Sep-2022 19:53:38" {DSK}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}kaplan>Local>medley3.5>working-medley>lispusers>IDLEHAX.;3) + :PREVIOUS-DATE "23-Aug-2022 08:50:16" {DSK}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 diff --git a/lispusers/IDLEHAX.LCOM b/lispusers/IDLEHAX.LCOM index fa3f4b92688fb4f76baa5b84e3a9c2b9bddba2d6..5bc2a3694c96064cdaba1fa37e33a92b700d8e01 100644 GIT binary patch delta 2478 zcmZ`*TWl0%6yBMZ0t+oI3#Ak(r;EaDWy}0?+nELm+udn*=yqnaJM9)kE;7vrA{bI`{mzqDFHQr=kKc2tc$xS?m+lFmT}qCr_L@=1w>;c@n~KE}0vCe81hzFOiCyLwYW1TfhYe%^XzE8iBq{Rv$C0(Ofi%Ti_02G=BDoUm;%YlQBo- ze=5R|qQcIz9WV%j3K=WCcgQmHal;lP!0za5D7G%?V%Bzt63YX4<)!0o>{_eG;;zq* z(LGH&JM&8E#hlg29_*a6I@p69bA^SE^6GN>Qd4-v%8=D_eEwihVewJ=MblF$C%{R( z3~9sEbC{YYL(<5N7`YsXF`;HF5+t+nya&Vl#R^`~2qe;aJe#M_F73(&Ihl`vnXwGh z2ASt8rX)*MQ>p?)S*&V~~pki-(ro)vz%F%!_S-Ktud(x79r# z^eXTGJ2&voaks@?N8elVIa@qJudLj(+I6g!(rc^$rrYuUH}ulVp5;|Hy{DP5vv1IS z&9L;be@Dx`SG zKn#-JLxH_`mth?564-{F*6H7CH??VyADEnSCZ@3J>E%p-rK`BEhPH46J=}gb(@39g z?^2pvCpB`pROwG#XV3MEu5*5m>lmi*`_y%YOTOVYcG*$K**#)fEiOx8-5UCPdt=jx z>9SU9Ww~<1dwF@j>Xgz)^Q#?~y*lrG*g9{u9CeO(O>g#lTZ-ti-Us;3Wu5uU812Nm z&Y2}AnLo;PSXc;fqM%e7i{u?J?18imf}&MTQLUQ1P%#O%wTvYq581ex1VYM&7V{md z)&i*uF)>Y zEOm!VrJ^U{nS_cdmlP0_svjp-?EbyVS~1VexE$BO+1~C6~bx*@k6ewKaNe%QW(LY-^X# z-$%AyVANtG2h7e2)zh;drc1Oag_?b3uy}KYpQSmKiEK_qH&dlOEN47LC;6zgAcrqfc(@7A4e|R^gR5B5vC* zCc{8HF+7yDM$Ke&uc4=t^z&`6tiuh71cSzS2FHx(8-gm(hoTu&HvX3Jpo-qb^Cu`SjT%J*U*Hg+sVt!4J^$L*8Ph%3m=aTVLd!44_73P!?U`;QChb^SXt1h zx015)_o`&5cu>!Q$0gBm_~wWXANYmv1d|Qu{v;%^CZ!H`wbk z&YSgqg$S0n`oF=)5ma6UhZD-jHK5w)Rq-B1rvKnwp_`@6OpFdmVOCL#d!@!@#REHj bV%mJ|5=^B;#z=&|yK^JGscoRY^}qfvMOK5* delta 2937 zcmbVOO>7(25!TYOBr_sonNsa2sWhb{XDOS~zWw75WW^M@l-6AB(p<`vi?pt6GM210 z<;X6CAV_HxEgHmVn)n51n?n!jp#{<=ri2D?8&m-bv_LOO0IF`?HUWCbxvdNJ(#oCP zC0CS@OUlFUym{Z7c{B6PEPwj~t-U&bMvk8TdNs;(JP#zET~JcRtde;Mg^`gYiTxju;4NYa8ItLlls>JP(V_utRyV=lcI5~p z^9ALsYRs9@Osc40#uCwNseyNP}6^?pX!*k&5Ot_b+zgT9Twbq+C4 zu%VKCpaXwt=UEb$`+Nh&sKMS}*Xcml$%DqA@BHAVam082$Yy=#P7k%Z!v04>#^`e6 z{OIj((I0kwJ6q{sMUDqe)fJNmA;H6xW~6f<#0X>xsgk_`0?)M&d?F5MO-U6>z#}-L znzO2D(r3Ge3ISH)1km$_suw}TbhSi@^F+}D2(qUYB+>#1BJYWUK>yJF)y@DL32elB zp4cZq7Dx=9DWtXBtg30MsiX}(69MMaKBi+|>Mg6sy5YAIa>2Jb_48$`(+be%9(lj> zR=wk0y3#wGFoKutZ3nYH(qqe;M({WG`<4;>rsW&%vgI|aTngXYJ|D!~VXBVY{xL20 zj&h&(H2r=r>3p;P;2ZS!y>P}{u0P1z$&T;gxyX?{YeAM;6_DakRA-ffGM`rqO6F-0 zM9IOLd823o{YP(jT5uFovnDcBZXV>N#6t&pQEofP^NBq!d7h^?0=JR@R)|ZGRp;|q zeN46^NCMhQ=g@v!c2#^#YzmUt+@t+L_6q?PVljx4IF|q{GYVn?D_019abI76B{CG0 zyp~EU5xb!DM&Bg!3Ek}bQ_w9#{lSF}mM1a#(?g#!0s6hrSDeDrzlXMuCt!wyJj5Ym zzhZC>pEAtjQ^E@rH3cQ!4ViWi3_nh|&mzeyex}1mUp_Vz^y++hyYFZxoga9T*-u{_ z7?QiK@{GRa(BoHDId}h-Rlbq4%Bm4`mG4<)%~5K7z5|Qp@+sX28VBhI1B2ZtSw77STg{F+UyvgNzma1I@67zY>24jTiGzfH%S<#SHqrsXR)wv0n) z2Tg`*p-}1BcTvL?GGTWM%jqo$vSxRI4O~d+86Z4q3dndzlaSnZOoC@r z-JB~ZB~{NDC5Un0Ol+kD=wwDwr)P?4wz-L9omS}J;n7+Txc%?2wqOc^d?0V{1c*HJd?f zUL1%3B{fr=L7sywK=@qcIxJLIt}mk7wWVr#Wi5J41Q;@zBfkx#9j} zc9VGHkx1VBBt&e@M8d`BTf^h-O#FEG!%pVA^qnV*%sA~F0pb!uzp~T#_3aNsq0r1J zhgzZfgS8Hp2ohv)a^x{dMb*%OV6&A*p2ueUXk^H3w)-PD8F{02449LyEp7ddwoAJ8 zpVfE%ja0%ZzjrV>OmRLNcD|=_^e<0MGCBGf`|kb#i(d@dU<}&MUKSn>ed?FO8@7%S`+hek5&ZIKP4tr)c$!;^>(-XXdt0(PvvWq8Jcn?pI zaZP-JqkZGkHO?aokKZ|uX_5r0o}a^R;@f$a*hO$+6M=Ko(~>qD#Ir#J?64-c39`RwO(h2Q{N9QL~iFM@{w1n0Oq~EgaX% z2}$7Ly*LslEgW`WD>FDR9>&>z@hH8_1H;jq{0Kv6oj=O(bc+vf91#B1&2St4P5zmw zEj6OYrblkfizwW$Y^ diff --git a/lispusers/KINETIC b/lispusers/KINETIC index e3b9892a..48cafeaa 100644 --- a/lispusers/KINETIC +++ b/lispusers/KINETIC @@ -1,49 +1,53 @@ -(FILECREATED " 2-Apr-86 00:14:01" {ERIS}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}larry>medley>lispusers>KINETIC.;2 1928 - previous date: " 3-Dec-85 14:17:48" {ERIS}KOTO>KINETIC.;1) + :CHANGES-TO (FNS KINETIC) + + :PREVIOUS-DATE " 2-Apr-86 00:14:01" {DSK}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 diff --git a/lispusers/KINETIC.LCOM b/lispusers/KINETIC.LCOM index 62c65885bbaf1299e72c83ffaedde7109e482160..e6e4c426151c89357e68ce131cb5f388584284f5 100644 GIT binary patch delta 573 zcmah`O>5gg5RKy;nx%ylN-=E-kG)hn$Y|GcDvOe4Ev@23LUJsnKDCfW3NiH;CQw2t z{S86A6HHtBL5Dfbym|B9%=LrI^^Zm%LzPG?RI#*F5~kSf3qKOO z5>zF*9K?$vq@1L zoRo#$_~*Ps&Hu`B7;WHlkVRi!|4rLF4%Xo=JijNBU71;V3L{K1f=FL2SH20aKag)# zx}RBr_6`beiTT2Ew_w{IbM9^YbHUR`WJv@sa7lGkQ?>KzqW10CxL9A&@%`d_#b9k4 z-8l6lFo&ahzdEmx>T1<#5Cg0Y8jYsq$>?2T&wLmz=0_enu(?cvWm4jmQ)USE=(`8 zIH3`wJtnzzh(B&5@gNJ+KFwc>3wMAx#Sjlh$;4U5ih(tqgY$1=vK~Rqe1|kj=nW_} z(HeEXb=7K>gQzoPx!mtnmawE?&Ey31XPP2fSzk1CkR&W?Sd!TkH}J@~ao6<7@hNcw zvgNnhtu5a>a@(F=-Bdu<6&=EhPOnP`FibJ2;ir29q_Iy{L)~ z4Mn2{tVgb6&G@PMw`rbL$pV^&!m4AS{G;dLISP>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}larry>medley>lispusers>PAC-MAN-IDLE.;2 17389 - previous date: " 2-May-86 18:42:49" {PHYLUM}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}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 diff --git a/lispusers/PAC-MAN-IDLE.LCOM b/lispusers/PAC-MAN-IDLE.LCOM index b0d225398e516b6f63903176315dc5c704c9e99b..4dda4e77e61f022275c983aef859e76a36b935b4 100644 GIT binary patch delta 1695 zcmcIk&2Jk;6qln?%C<#KYBz?E^~<(Vy@ieJb&TDmYP|7|?RD3?8?V!fsv=r!7pnLJ z1xHbYz;NNhDH?I%Z$L;8A&xy2goJwPjSCX@-nsGKxa*`SloKQC{XD<-J#S`zFMYGN zowiuTc9~YO9j4iC#RJ(l%eTxb1I2b*tm)W+uYlZSrqwdnoqy2lX22kuQ6(u&5z1)R zViqX+s%Gwfpy?T1hfLAPuNv9n0VHQX9QM06d*RN`{>^^3)9daZlwKR_s)Qc7BM&`i z#3);iokyaTFJ1Q7{lijwx%|NrTeNb{4t-d?Zif=;} z+sGQ3i~`cXCRvC{{JU84Rl_PuY1eEp2yDYRd=islGl+l8@Y6BraP-Q|3>xm8{Q~7* zXV){5AGWndIM7%)((XJMbcTB%LinIVlLf35w5S>%vLYbgKDUMO_;2U%ywgR&3A0W2 zj_q2=snd`)jz$FISI_qsq_n<@5q-xj-C2(O)7k1A@j-96r&YqvB>Z7@t`S4+*B8HUpc=7OLLL`+)3SscI*!p!tf?Y0 zcotUZDG%|-G0ICwg@^>lP&iUyks%pSfN29Ibd&J+tbKm45Fh`~<9^|^aVR(ryasrS zN@8jeQX4d88XF-Qh%rY<26TVOAi9qyjT_ZbyK4}AEv#-Y+{aHgezSRO5zb8B!y4e@ zN*-qd*LE=9ft<&vzsPNrZ>E+}ZlvBoIY{{^AExf2d>wAQB%!(VH`J5FTmS$7 delta 1998 zcmcgt&u<$=6qW-C0XhYO?F5>bVMSprvDU8ZG>(aq-NYMb&3e7{I<1N-qK&;2gX2vT zr%_Z@Rxex-P?#Hs3UTKYjz}Ef#ECPAe*x|Y5Z}!DSA;4R4veg~pWl4%?R%f!j6Yxd zS=Z%F%QiP^rcpPGRHDm@7wjv`IjZFfnpViE5|yP!xVPVG2TdAwK)F-&-n_fgZXND7 z!h?YQ6uZ!)M9Sus@=;qvE)}x*LhiCecX?p@wI*#Lt`aoc!3oVSD#p=G&dX#n5^efj z-?Qee5jxJ?s8+l*yA^xkeXkuJ zE1P~ZpswFgDt0wIVsYu2`vX>=tHiwL^ZEToS zTc(zC)vVRe1bB_`sH<#-VN-;io=GfZ{^K5%Y zp5gl=t+@!NpUhNZi2mjI52NUI{AGOoI3B=$nuxRMgb5T&#@TM-3eeXHA2ylXg*{0& zVRw-H_hbo(q;9YWvrhosLi69xZgJn-4(#6C4cH&%yeT5rT;mG6pGfqmjI&T&x9Szc zO{2x^62(W-b)%|dNgS4{b{`tmDtB{l2@q}$fvS#xe4jJm9fKRfy9F$OrGgfujs$Jloj&#^A8H-kCzjIvMY8tm~l`WF!$(<8sns@Q#1f?qW=Fc&r94 zkB4e&4z%s*rdb^5TrQXUa2;?f64%56gDYy9r3xYe^>VrDfD8yKU?eUWSi&t30wab< z2Z$$M+#3;kf-y$ME?z8B2xbI1A@ULt*k|<19KIwXiz@yBQSz{-QG2iIoE?$%p%z?R zook`sG9%Fq+(S6%cSy?!}Y-^#SE`~mP};S%+liEJKY!4>~;Nv+kUqd zcIvIYfR698KjJU42Z?E1Ef3~jf&EU{-{yCwW!K*Js7%;L3l}Htnzu#Sy#;N~u9gg^ zNMEPqI6P?LA969x7hyjxEFyj?)qs63brJS{Y998hlneV;>MhvoFRe@x$Fj-aH*ohx diff --git a/lispusers/QIX b/lispusers/QIX index ba5b24a5..cdc179f8 100644 --- a/lispusers/QIX +++ b/lispusers/QIX @@ -1,18 +1,20 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "12-Aug-87 03:05:50" {PHYLUM}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}larry>medley>lispusers>QIX.;2| 11276 - |previous| |date:| " 1-Aug-87 17:04:27" {PHYLUM}LISP>QIX.\;2) + :CHANGES-TO (FNS QIX.IDLE) + + :PREVIOUS-DATE "12-Aug-87 03:05:50" |{DSK}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 diff --git a/lispusers/QIX.LCOM b/lispusers/QIX.LCOM index a9c3baf495bcb223af88a5f2aa0413e84536a381..f2d28cc1553ba4c28e054ce27413032e48981ece 100644 GIT binary patch delta 718 zcmb7CO^ee&7&h8<-MNWa@UpxFl;n^wnQ1oZsD*4ZsoBOPn{; zZ=SqJeu8)sL|jDt1%f|8|A%;VQmOVJikIPihxd8rd7gRSRKHYjC@%N>kZYbFaLo_B z2sUG<*>+kSWIyciB=FN%esTHAeA`Jm7+6I}DTkX0cRJh!nbb6AcBBzZ2w;nuHZu(w z6!~yGJn0Xz9*jpIL;l1~+fQ#DkB3=f(49<98^f$O$W9xB{`6!v%_h^vu76LzNpcmC zOz3Y;LK(Fgo|}T?(Ii{a=8zvAcSlFrl;u!DeK+8c_eVL%-d+&EDu=G?0^RFA&U*Qu z=`C6PyRW%0R+bG_xy??lKPNB95 zZsHsWS#%4--DsbeCB=(0%T|vgu>wHF$Ci>;uZ-FfOX}tlOUycK2T`+Ke7ZQhiWF+u zz>{)qXbpn{6kEmadi6R|z@T+d97w?hPyH!-g?=Ia`TA{1i2r=)d+~MSzNlWKor)@k Ui)Uz4w69Ps&TojWq0kS|5B#jfjsO4v delta 728 zcmaKo-)qxQ6vvHpOsheBu#a-MK9~*?lH6wbu~~@C?V6c3@!r_AAn0tvEY!BNt02qh z-yr=DeDcYcvOi=`g8zr$-n_T7C=7hLoO{mqob&mfAEj?4qy(fMwuo8}Bcg__dJK;# z@q^TV9uYvDT7*77e6%RbiV)OzDJ20QqoT5GqPi6@9M5n)OGluf-uT00FwFWe9sz>< zEMPCr_lJYoq&J>sRT0c**>qNY8FsWiBQJxDOh-MO57&ci&vd-XE^mA%1`VI~bI1py z98hzS^@rIfFfG-ep9rz0XI41D_?0ZuF{o zzRw!eKOnRkg)CXaz23uM7`kgi-g|#MI$2~h&T=~Ta!}enWxyTO;wIw`^2s#&I2g}` zK=5!00%NnxusyxvnKpv|Ei=oqILQHxkH8BYSxLZ!I0_&E3p)H=T}fYWOY-tdfl3#v zp9M*h?kumiF5X7B6zpIKsDG5kfGr1_ahr(HbOfX(zFHE8t(2$q8!5xw^qMZ-^qQ6p zLCBgRW6S&7^F&s#y$gi;i~zmedley2.0>lispusers>READBRUSH.;1 9607 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - previous date%: "23-Jun-88 02:13:42" {DSK}lisp>medley>lispusers>readbrush.;1) +(FILECREATED "24-Aug-2022 07:58:48" {DSK}larry>medley>lispusers>READBRUSH.;2 9288 + + :CHANGES-TO (FNS IDLE.GLIDING.BOX) + + :PREVIOUS-DATE " 6-Nov-92 09:25:48" {DSK}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}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 diff --git a/lispusers/READBRUSH.LCOM b/lispusers/READBRUSH.LCOM index f409905834aec75f699d7588e016e747192f1f89..49b092151adecc4095159826dc2a241c6c948bdb 100644 GIT binary patch delta 1197 zcmb7D%}>-&5N8n-n(*NfW6011Lu0nKecRn`Az-_GyZb`7EqyHz4@MSNAXz>FVnU4W zKj4Mz%`=H7PlPk^suxcjJ$dt=aJnrYi6&|fZ{|&ZGxM8yGhe4Zh>vC*T4f&1SD8!m z%&Yn^8CaD?t42X&UPMEe@jyJeKk?YMI0aRa1YsrtS3+t<)B#Z|~FVQ8?e5$w!7InoHl_uE|qI8bC_3?ZGRQEcR{Sit_!!L$Q@Z0VPowT z`u;I~NtFItN5K%`jl&n;&i!jKP}U3s%u3zrcs0uNkq8yrO5Z zGdLFM@Sx(dAiyyWX^r_FXbPmiS8z0oS^=21Op&UdFv(Ob^GYo=RG?w9lsYLwL|3CY zq(BI{LZ}G7BCjWed*g6bl^=VRY=tnLBy?v-CUGX7jl9J3^GJ;6-q>_^Zq!2U-DqNE z<4+z)QnokT^(`k0iW80jHPzg|Vu~d-^HhF$dVjI-r#4n9o$98Rpbfj&92uhnMA4nBK zk=TFRxa}ar`8p&(2!ow)E z=-z2T2Oa8B3t$hpx>tefxZ4H)aM&AcBz^at%{o!)pD`LAgB0f`D5;{!oaATMb+yDXgz+S%{- z2BXz(XV_1MjqrHb9t>9p?VZ-{U_5*x-Xl4#Qga-iiKbyOv1|r)-3851xU35@glmT5 zrSy+fiaY*w>3dkd%x+abCVB0~%V>moLQxFs<_dw*cyl9={rmwkWynqkfV|->78ul!$+i2IqZ^4=)%MZg#bPMJhUrRXd5z0@uD-SQ=en>n=AwnvncX;N aJjV%Kvl7OQ`RU6HL$}YF`YdOg7WW%1@*!XV diff --git a/lispusers/SCREENPAPER b/lispusers/SCREENPAPER index b2cf62fd..63e87ba5 100644 --- a/lispusers/SCREENPAPER +++ b/lispusers/SCREENPAPER @@ -1,23 +1,96 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 5-Aug-88 15:17:16" |{POGO:AISNORTH:XEROX}MEDLEY>USERS>SCREENPAPER.;1| 10019 - changes to%: (FNS SCREENPAPER KALSHOW SCREENPAPERNEWREGIONFN) (VARS SCREENPAPERCOMS) +(FILECREATED "24-Aug-2022 07:49:42" {DSK}larry>medley>lispusers>SCREENPAPER.;2 12374 - previous date%: " 4-Aug-88 13:46:25" {ERINYES}MEDLEY>SCREENPAPER.;4) + :CHANGES-TO (FNS SCREENPAPER) + + :PREVIOUS-DATE " 5-Aug-88 15:17:16" {DSK}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 diff --git a/lispusers/SCREENPAPER.LCOM b/lispusers/SCREENPAPER.LCOM index 88f3b4c97e4f3140e4ba19395e372ed0b1361b73..257b5ac74952b82faf214ab314cdfe1d3353927a 100644 GIT binary patch delta 756 zcmb7BQESss7$vQ9_A*^Y|O1qAB6NgCg zMGypsc@_lm!RJ1T;7?HB{R!e<@N03}2Or$a;rrm+bI&>7m-TP!XPaX}q`KqsYQU|C z*Fa>NY@O`OOl1sI-PCTI8WTYh_Xho=ZZGb@;1EQ3QVSbT?;Z^Lai!ND4o@rnxYLVI zE4}XM=wuWRN0ks2x!1IsJW%ei0uYfE|0=VhSu{+wB#z<1F#e;xchElEk4HC6n0pRg z{ITA0U6@x;6h(wi`xqVlQ(6}b|C4Nd;V3{^QP;q%Zdu+Y59P=wAl1Ea-f{uVX25qG zzZJ?g>=hd;&B7Z7(2_}Yla@sw*y6@TYNQ2{2&t?@I=^)+fWRg}|2UdoL<%V1SeV|kayJ0(#?M7f|V7q>`k-SR>w}_-O zaJ(HJM4%bJrt%OmM>o-Yv3amg=SgviDK delta 744 zcmZWmO-~b16iti9lJJa>7DyN5I?*^|Xq`8m$}o_cDSg1mbf&yFAS_I%?F5@t+O%L) zX!rrTP-o%F#EmPLT^s!gMt^|6z=cb9-hL1&Zcgrf_nvdlz3=<{xB1s=7LiwNhpljC z`K$mE)l(v9rWSRehN&%>8kInnDvc-2T0N*j;{YT$E{KiJa=q4WRvN7!d>ENMr3w&9 zGg9}D>U}N}4O71>!J{6veya*KWEO*JJ$MdUHf0^{_xjT5v;@`iAu3DfuT(Wv&D0kq z<$^gF5Df!p)}#w2#Q`VBC2y_lnU*bFkNfN94&&ZVXPJ9mQRIrO;IQ4?mS9}u1a8UP zl2u|ny+ludsw!OsQh8iH*bmxp*tlteyy^-VX@m{S5$oQA@Lp`@Q~`P0;{ViFaEb!W zR`9geIBNHIK@}o_-ruojHG_vRwJhF^aogQxqO$Y5kZPEklhiYf{To3SL;UdCP_ z&W^v0knX4PuTf0u6D>@BP8>!snVY)NeRefG3)O4CFzn7vP4+s~_#Wb$xP|y5UPUw# pz4%2UkN7!}OcI%wtj*1{ufofEh2Dqa{NIUbY>G{@%fz)E@)tii!mKOTO>SOLITAIRE.;5 23494 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to: (VARS SOLITAIRECOMS) - (FNS SOLO DEALDECK NXTCARD CARDIMAGE COUNTCARDS GOODMOVE? MOVESSS CARDNAME - CREATEHAND CREATESTACK STACKLOC POSTVALUE) - (MACROS KINGP) +(FILECREATED "24-Aug-2022 08:54:17" {DSK}larry>medley>lispusers>SOLITAIRE.;2 26883 - previous date: "15-Dec-85 22:01:18" {ERIS}KOTO>SOLITAIRE.;3) + :CHANGES-TO (FNS SOLO DEALDECK GETCARD) + (VARS SOLITAIRECOMS) + + :PREVIOUS-DATE "15-Jan-86 23:32:05" {DSK}larry>medley>lispusers>SOLITAIRE.;1) -(* Copyright (c) 1982, 1985, 1986 by Xerox Corporation. All rights reserved.) +(* ; " +Copyright (c) 1982, 1985-1986 by Xerox Corporation. +") (PRETTYCOMPRINT SOLITAIRECOMS) -(RPAQQ SOLITAIRECOMS [(FNS SOLO SOLITAIRE) - (FNS CARDIMAGE COUNTCARDS CREATEHAND CREATESTACK DEALDECK FLIPSTACK GETCARD GOODMOVE? HTOS? - MOVECARD DOMOVE MOVEHS MOVES MOVES1 UPCARD MOVESSS NXTCARD PUSHCARD POSTVALUE - SEARCHSTACKS SHOWCARDSTACK SHUFFLEDECK STACKLOC STOS? TOPSUITSTACK) - (FNS HIST ARRAYMAX) - (DECLARE: DONTCOPY (FNS SHOWCONFIG PRINTCARDSTACK CARDNAME)) - (DECLARE: EVAL@COMPILE DONTCOPY (MACROS BOTTOM KINGP STACK TOP) - (RECORDS CARD CARDSTACK) - (CONSTANTS (Spades 0) - (Clubs 1) - (Diamonds 2) - (Hearts 3) - (CostOfDeck 50) - (PayForCard 5) - (NStacks 7) - (NSuits 4) - (CardsPerSuit 13) - (TotalCards 52)) - (CONSTANTS (BACKSHADE 52275) - (BetweenStacks 2) - (Overlap .667) - (CardWidth 30) - (CardHeight 45)) - (GLOBALVARS HAND STACKS SUITSTACKS DECK SOLORESULTS) - (GLOBALVARS MaxCardMove WaitBetweenMoves)) - (INITRECORDS CARD CARDSTACK) - (BITMAPS SpadesBits ClubsBits DiamondsBits HeartsBits 10Bits) - (INITVARS (MaxCardMove 8) - (WaitBetweenMoves 10) - (DECK) - (SOLORESULTS)) - (ADDVARS (IDLE.FUNCTIONS ("Solitaire" (QUOTE SOLO]) +(RPAQQ SOLITAIRECOMS + [(FNS SOLO SOLITAIRE) + (FNS CARDIMAGE COUNTCARDS CREATEHAND CREATESTACK DEALDECK FLIPSTACK GETCARD GOODMOVE? HTOS? + MOVECARD DOMOVE MOVEHS MOVES MOVES1 UPCARD MOVESSS NXTCARD PUSHCARD POSTVALUE + SEARCHSTACKS SHOWCARDSTACK SHUFFLEDECK STACKLOC STOS? TOPSUITSTACK) + (FNS HIST ARRAYMAX) + (DECLARE%: DONTCOPY (FNS SHOWCONFIG PRINTCARDSTACK CARDNAME)) + (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS BOTTOM KINGP STACK TOP) + (RECORDS CARD CARDSTACK) + (CONSTANTS (Spades 0) + (Clubs 1) + (Diamonds 2) + (Hearts 3) + (CostOfDeck 50) + (PayForCard 5) + (NStacks 7) + (NSuits 4) + (CardsPerSuit 13) + (TotalCards 52)) + (CONSTANTS (BACKSHADE 52275) + (BetweenStacks 2) + (Overlap 0.667) + (CardWidth 30) + (CardHeight 45)) + (GLOBALVARS HAND STACKS SUITSTACKS DECK SOLORESULTS) + (GLOBALVARS MaxCardMove WaitBetweenMoves)) + (INITRECORDS CARD CARDSTACK) + (BITMAPS SpadesBits ClubsBits DiamondsBits HeartsBits 10Bits) + (INITVARS (MaxCardMove 8) + (WaitBetweenMoves 100) + (DECK) + (SOLORESULTS)) + (ADDVARS (IDLE.FUNCTIONS ("Solitaire" 'SOLO]) (DEFINEQ (SOLO - [LAMBDA (W) (* bas: "15-Jan-86 23:31") - (if (AND (BOUNDP (QUOTE SOLORESULTS)) - (ARRAYP SOLORESULTS)) - else (SETQ SOLORESULTS (ARRAY (ADD1 TotalCards) - (QUOTE FIXP) - 0 0))) - (if (WINDOWP W) - else (SETQ W (CREATEW [GETREGION (CONSTANT (ITIMES (IPLUS BetweenStacks - (ITIMES NStacks - (ADD1 - - BetweenStacks))) - CardWidth)) - (CONSTANT (ITIMES CardHeight - (IPLUS 5 (FTIMES - CardsPerSuit - Overlap] - "Just waiting Patiently...")) - (DSPTEXTURE 1088 W) - (DSPFONT (FONTCREATE (QUOTE HELVETICA) - 18) - W)) - (bind X - do (SETQ X (SOLITAIRE W)) - (DISMISS 1500) - (SETA SOLORESULTS X (ADD1 (ELT SOLORESULTS X))) - (HIST SOLORESULTS W "Number of cards up") - (DISMISS 1500]) + [LAMBDA (W) (* bas%: "15-Jan-86 23:31") + (if (AND (BOUNDP 'SOLORESULTS) + (ARRAYP SOLORESULTS)) + else (SETQ SOLORESULTS (ARRAY (ADD1 TotalCards) + 'FIXP 0 0))) + (if (WINDOWP W) + else (SETQ W (CREATEW [GETREGION (CONSTANT (ITIMES (IPLUS BetweenStacks (ITIMES NStacks + (ADD1 + BetweenStacks + ))) + CardWidth)) + (CONSTANT (ITIMES CardHeight (IPLUS 5 (FTIMES CardsPerSuit Overlap + ] + "Just waiting Patiently...")) + (DSPTEXTURE 1088 W) + (DSPFONT (FONTCREATE 'HELVETICA 18) + W)) + (bind X do (SETQ X (SOLITAIRE W)) + (DISMISS 1500) + (SETA SOLORESULTS X (ADD1 (ELT SOLORESULTS X))) + (HIST SOLORESULTS W "Number of cards up") + (DISMISS 1500]) (SOLITAIRE - [LAMBDA (SOLOW REPLAY) (* bas: "15-Dec-85 21:33") - (DECLARE (SPECVARS SOLOW)) - (CLEARW SOLOW) + [LAMBDA (SOLOW REPLAY) (* bas%: "15-Dec-85 21:33") + (DECLARE (SPECVARS SOLOW)) + (CLEARW SOLOW) (DEALDECK REPLAY) - (PROG ((GAMEVALUE (IMINUS CostOfDeck))) - (DECLARE (SPECVARS GAMEVALUE)) - (POSTVALUE GAMEVALUE) - (while (OR [for I from NStacks to 1 by -1 thereis - (MOVES (STACK I) - (STOS? (STACK I] - (MOVESSS HAND) - (MOVEHS HAND (HTOS? HAND)) - (for I to NStacks thereis (MOVESSS (STACK I))) - (FLIPSTACK HAND)) - do (DISMISS WaitBetweenMoves))) + (PROG ((GAMEVALUE (IMINUS CostOfDeck))) + (DECLARE (SPECVARS GAMEVALUE)) + (POSTVALUE GAMEVALUE) + (while (OR [for I from NStacks to 1 by -1 thereis (MOVES (STACK I) + (STOS? (STACK I] + (MOVESSS HAND) + (MOVEHS HAND (HTOS? HAND)) + (for I to NStacks thereis (MOVESSS (STACK I))) + (FLIPSTACK HAND)) do (DISMISS WaitBetweenMoves))) (COUNTCARDS]) ) (DEFINEQ (CARDIMAGE - [LAMBDA (C) (* bas: "15-Jan-86 21:37") - (PROG [(BM (BITMAPCREATE CardWidth CardHeight)) - (SUITBM (SELECTQ (fetch SUIT of C) - (0 SpadesBits) - (1 ClubsBits) - (2 DiamondsBits) - (3 HeartsBits) - (SHOULDNT))) - (RANKBM (if (EQ 10 (fetch (CARD RANK) of C)) - then 10Bits - else (GETCHARBITMAP (SELECTQ (fetch (CARD RANK) of C) - (13 (CHARCODE K)) - (12 (CHARCODE Q)) - (11 (CHARCODE J)) - (IPLUS (fetch (CARD RANK) of C) - (CHARCODE 0))) - (FONTCREATE (QUOTE HELVETICA) - 18] - (BLTSHADE BLACKSHADE BM 0 0 CardWidth CardHeight (QUOTE REPLACE)) - (BLTSHADE WHITESHADE BM 1 1 (IDIFFERENCE CardWidth 2) - (IDIFFERENCE CardHeight 2) - (QUOTE REPLACE)) - (BITBLT SUITBM 0 0 BM 2 32 NIL NIL (QUOTE INPUT) - (QUOTE REPLACE)) - (BITBLT RANKBM 0 0 BM (IQUOTIENT (IDIFFERENCE CardWidth (fetch BITMAPWIDTH - of RANKBM)) - 2) - (IQUOTIENT (IDIFFERENCE CardHeight (fetch BITMAPHEIGHT of RANKBM)) - 2) - NIL NIL (QUOTE INPUT) - (QUOTE REPLACE)) - (BITBLT SUITBM 0 0 BM 17 3 NIL NIL (QUOTE INPUT) - (QUOTE REPLACE)) - (RETURN BM]) + [LAMBDA (C) (* bas%: "15-Jan-86 21:37") + (PROG [(BM (BITMAPCREATE CardWidth CardHeight)) + (SUITBM (SELECTQ (fetch SUIT of C) + (0 SpadesBits) + (1 ClubsBits) + (2 DiamondsBits) + (3 HeartsBits) + (SHOULDNT))) + (RANKBM (if (EQ 10 (fetch (CARD RANK) of C)) + then 10Bits + else (GETCHARBITMAP (SELECTQ (fetch (CARD RANK) of C) + (13 (CHARCODE K)) + (12 (CHARCODE Q)) + (11 (CHARCODE J)) + (IPLUS (fetch (CARD RANK) of C) + (CHARCODE 0))) + (FONTCREATE 'HELVETICA 18] + (BLTSHADE BLACKSHADE BM 0 0 CardWidth CardHeight 'REPLACE) + (BLTSHADE WHITESHADE BM 1 1 (IDIFFERENCE CardWidth 2) + (IDIFFERENCE CardHeight 2) + 'REPLACE) + (BITBLT SUITBM 0 0 BM 2 32 NIL NIL 'INPUT 'REPLACE) + (BITBLT RANKBM 0 0 BM (IQUOTIENT (IDIFFERENCE CardWidth (fetch BITMAPWIDTH of RANKBM)) + 2) + (IQUOTIENT (IDIFFERENCE CardHeight (fetch BITMAPHEIGHT of RANKBM)) + 2) + NIL NIL 'INPUT 'REPLACE) + (BITBLT SUITBM 0 0 BM 17 3 NIL NIL 'INPUT 'REPLACE) + (RETURN BM]) (COUNTCARDS - [LAMBDA NIL (* bas: "15-Jan-86 21:37") + [LAMBDA NIL (* bas%: "15-Jan-86 21:37") (for S from Spades to Hearts sum (fetch (CARD RANK) of (TOPSUITSTACK S]) (CREATEHAND - [LAMBDA (F) (* bas: "15-Jan-86 23:25") + [LAMBDA (F) (* bas%: "15-Jan-86 23:25") (FLIPSTACK (SHOWCARDSTACK (create CARDSTACK - FACEUP _ NIL - FACEDOWN _(for I from F to TotalCards - collect (GETCARD I)) - CSX _(fetch CSX of (STACK 1)) - CSY _(FIX (FTIMES CardHeight .6)) - XO _(FIX (FTIMES CardWidth Overlap)) - YO _ 0]) + FACEUP _ NIL + FACEDOWN _ (for I from F to TotalCards collect (GETCARD I)) + CSX _ (fetch CSX of (STACK 1)) + CSY _ (FIX (FTIMES CardHeight 0.6)) + XO _ (FIX (FTIMES CardWidth Overlap)) + YO _ 0]) (CREATESTACK - [LAMBDA (N) (* bas: "15-Jan-86 23:00") + [LAMBDA (N) (* bas%: "15-Jan-86 23:00") (FLIPSTACK (SHOWCARDSTACK (create CARDSTACK - FACEUP _ NIL - FACEDOWN _(for I - from (ADD1 (IQUOTIENT - (ITIMES N (SUB1 N)) - 2)) - as J to N collect (GETCARD I)) - CSX _(STACKLOC N NStacks) - CSY _(ITIMES CardHeight (IPLUS 2 (FTIMES - CardsPerSuit - Overlap))) - XO _ 0 - YO _(FIX (FTIMES CardHeight (FMINUS Overlap]) + FACEUP _ NIL + FACEDOWN _ (for I from (ADD1 (IQUOTIENT (ITIMES N (SUB1 N)) + 2)) as J to N + collect (GETCARD I)) + CSX _ (STACKLOC N NStacks) + CSY _ (ITIMES CardHeight (IPLUS 2 (FTIMES CardsPerSuit Overlap)) + ) + XO _ 0 + YO _ (FIX (FTIMES CardHeight (FMINUS Overlap]) (DEALDECK - [LAMBDA (REDEAL) (* bas: "11-Jan-86 20:14") - (OR (AND REDEAL (ARRAYP DECK)) - (SHUFFLEDECK)) - (SETQ SUITSTACKS (ARRAY NSuits (QUOTE POINTER) - (create CARD - RANK _ 0) - 0)) - (SETQ STACKS (ARRAY NStacks (QUOTE POINTER))) - (for I to NStacks do (SETA STACKS I (CREATESTACK I))) - (SETQ HAND (CREATEHAND (CONSTANT (ADD1 (IQUOTIENT (ITIMES NStacks (ADD1 NStacks)) - 2]) + [LAMBDA (REDEAL) (* bas%: "11-Jan-86 20:14") + (OR (AND REDEAL (ARRAYP DECK)) + (SHUFFLEDECK)) + (SETQ SUITSTACKS (ARRAY NSuits 'POINTER (create CARD + RANK _ 0) + 0)) + (SETQ STACKS (ARRAY NStacks 'POINTER)) + (for I to NStacks do (SETA STACKS I (CREATESTACK I))) + (SETQ HAND (CREATEHAND (CONSTANT (ADD1 (IQUOTIENT (ITIMES NStacks (ADD1 NStacks)) + 2]) (FLIPSTACK - [LAMBDA (H) (* bas: "29-JUL-82 15:07") + [LAMBDA (H) (* bas%: "29-JUL-82 15:07") (if (fetch FACEDOWN of H) - then (PUSHCARD H (NXTCARD H)) - H + then (PUSHCARD H (NXTCARD H)) + H else NIL]) (GETCARD - [LAMBDA (I) (* bas: "30-JUL-82 19:04") + [LAMBDA (I) (* bas%: "30-JUL-82 19:04") (PROG ((C (ELT DECK I))) (if (fetch FACE of C) - else (replace FACE of C with (CARDIMAGE C)) - (replace SAV of C with (BITMAPCREATE CardWidth CardHeight))) + else (replace FACE of C with (CARDIMAGE C)) + (replace SAV of C with (BITMAPCREATE CardWidth CardHeight))) (replace CX of C with (replace CY of C with NIL)) (RETURN C]) (GOODMOVE? - [LAMBDA (TOP BOT) (* bas: "15-Jan-86 21:38") + [LAMBDA (TOP BOT) (* bas%: "15-Jan-86 21:38") (if TOP - then (AND (EQ (fetch (CARD RANK) of TOP) - (ADD1 (fetch (CARD RANK) of BOT))) - (NEQ (fetch (CARD COLOR) of TOP) - (fetch (CARD COLOR) of BOT))) + then (AND (EQ (fetch (CARD RANK) of TOP) + (ADD1 (fetch (CARD RANK) of BOT))) + (NEQ (fetch (CARD COLOR) of TOP) + (fetch (CARD COLOR) of BOT))) else (KINGP BOT]) (HTOS? - [LAMBDA (H) (* bas: "30-JUL-82 19:30") + [LAMBDA (H) (* bas%: "30-JUL-82 19:30") (if (TOP H) - then (SEARCHSTACKS (TOP H]) + then (SEARCHSTACKS (TOP H]) (MOVECARD - [LAMBDA (C X Y) (* lmm " 6-Aug-85 00:04") + [LAMBDA (C X Y) (* lmm " 6-Aug-85 00:04") (if (fetch CX of C) - then (DOMOVE (fetch FACE of C) - (fetch CX of C) - (fetch CY of C) - X Y (fetch SAV of C)) - else (BITBLT SOLOW X Y (fetch SAV of C) - NIL NIL NIL NIL (QUOTE INPUT) - (QUOTE REPLACE)) - (BITBLT (fetch FACE of C) - NIL NIL SOLOW X Y NIL NIL (QUOTE INPUT) - (QUOTE REPLACE))) + then (DOMOVE (fetch FACE of C) + (fetch CX of C) + (fetch CY of C) + X Y (fetch SAV of C)) + else (BITBLT SOLOW X Y (fetch SAV of C) + NIL NIL NIL NIL 'INPUT 'REPLACE) + (BITBLT (fetch FACE of C) + NIL NIL SOLOW X Y NIL NIL 'INPUT 'REPLACE)) (replace CX of C with X) (replace CY of C with Y) C]) (DOMOVE - [LAMBDA (IMAGE LEFT BOTTOM NX NY SAVE) (* lmm " 6-Aug-85 00:04") - (PROG (N YWP YFP XWP XFP) - (SETQ N (IQUOTIENT (IPLUS (IMAX (ABS (IDIFFERENCE NX LEFT)) - (ABS (IDIFFERENCE NY BOTTOM))) - (SUB1 MaxCardMove)) - MaxCardMove)) (* Number of steps) - (SETQ XWP (IQUOTIENT (IDIFFERENCE NX LEFT) - N)) - (SETQ XFP (IREMAINDER (IDIFFERENCE NX LEFT) - N)) - (SETQ YWP (IQUOTIENT (IDIFFERENCE NY BOTTOM) - N)) - (SETQ YFP (IREMAINDER (IDIFFERENCE NY BOTTOM) - N)) + [LAMBDA (IMAGE LEFT BOTTOM NX NY SAVE) (* lmm " 6-Aug-85 00:04") + (PROG (N YWP YFP XWP XFP) + (SETQ N (IQUOTIENT (IPLUS (IMAX (ABS (IDIFFERENCE NX LEFT)) + (ABS (IDIFFERENCE NY BOTTOM))) + (SUB1 MaxCardMove)) + MaxCardMove)) (* Number of steps) + (SETQ XWP (IQUOTIENT (IDIFFERENCE NX LEFT) + N)) + (SETQ XFP (IREMAINDER (IDIFFERENCE NX LEFT) + N)) + (SETQ YWP (IQUOTIENT (IDIFFERENCE NY BOTTOM) + N)) + (SETQ YFP (IREMAINDER (IDIFFERENCE NY BOTTOM) + N)) (bind OLDLEFT OLDLOW (XFC _ 0) - (YFC _ 0) until (AND (EQ LEFT NX) - (EQ BOTTOM NY)) - do (SETQ OLDLEFT LEFT) - (SETQ OLDLOW BOTTOM) - [add LEFT XWP (PROG1 (IQUOTIENT (add XFC XFP) - N) - (SETQ XFC (IREMAINDER XFC N] - [add BOTTOM YWP (PROG1 (IQUOTIENT (add YFC YFP) - N) - (SETQ YFC (IREMAINDER YFC N] - (BITBLT SAVE 0 0 SOLOW OLDLEFT OLDLOW CardWidth CardHeight (QUOTE INPUT) - (QUOTE REPLACE)) - (BITBLT SOLOW LEFT BOTTOM SAVE 0 0 CardWidth CardHeight (QUOTE INPUT) - (QUOTE REPLACE)) - (BITBLT IMAGE 0 0 SOLOW LEFT BOTTOM CardWidth CardHeight (QUOTE INPUT) - (QUOTE REPLACE]) + (YFC _ 0) until (AND (EQ LEFT NX) + (EQ BOTTOM NY)) + do (SETQ OLDLEFT LEFT) + (SETQ OLDLOW BOTTOM) + [add LEFT XWP (PROG1 (IQUOTIENT (add XFC XFP) + N) + (SETQ XFC (IREMAINDER XFC N)))] + [add BOTTOM YWP (PROG1 (IQUOTIENT (add YFC YFP) + N) + (SETQ YFC (IREMAINDER YFC N)))] + (BITBLT SAVE 0 0 SOLOW OLDLEFT OLDLOW CardWidth CardHeight 'INPUT 'REPLACE) + (BITBLT SOLOW LEFT BOTTOM SAVE 0 0 CardWidth CardHeight 'INPUT 'REPLACE) + (BITBLT IMAGE 0 0 SOLOW LEFT BOTTOM CardWidth CardHeight 'INPUT 'REPLACE]) (MOVEHS - [LAMBDA (H SN) (* bas: "30-JUL-82 19:30") + [LAMBDA (H SN) (* bas%: "30-JUL-82 19:30") (if SN - then (PUSHCARD SN (pop (fetch FACEUP of H))) - (OR (TOP H) - (FLIPSTACK H)) - SN]) + then (PUSHCARD SN (pop (fetch FACEUP of H))) + (OR (TOP H) + (FLIPSTACK H)) + SN]) (MOVES - [LAMBDA (S1 S2) (* bas: "30-JUL-82 12:47") + [LAMBDA (S1 S2) (* bas%: "30-JUL-82 12:47") (if S2 - then (MOVES1 (fetch FACEUP of S1) - NIL S2) - (replace FACEUP of S1 with NIL) - (FLIPSTACK S1) - S2]) + then (MOVES1 (fetch FACEUP of S1) + NIL S2) + (replace FACEUP of S1 with NIL) + (FLIPSTACK S1) + S2]) (MOVES1 - [LAMBDA (L P S2) (* bas: "30-JUL-82 19:12") + [LAMBDA (L P S2) (* bas%: "30-JUL-82 19:12") (if L - then (MOVES1 (CDR L) - (CAR L) - S2) - (UPCARD (CAR L) - P) - (PUSHCARD S2 (CAR L]) + then (MOVES1 (CDR L) + (CAR L) + S2) + (UPCARD (CAR L) + P) + (PUSHCARD S2 (CAR L]) (UPCARD - [LAMBDA (X Y) (* lmm " 6-Aug-85 00:04") - (* Brings up X image which is assumed to be overlapped  - by Y image. Assumes YOFFSET only) + [LAMBDA (X Y) (* lmm " 6-Aug-85 00:04") + + (* Brings up X image which is assumed to be overlapped by Y image. + Assumes YOFFSET only) + (if Y - then (PROG [(DY (IDIFFERENCE (fetch CY of X) - (fetch CY of Y] - (BITBLT (fetch SAV of X) - 0 0 (fetch SAV of Y) - 0 DY CardWidth (IDIFFERENCE CardHeight DY) - (QUOTE INPUT) - (QUOTE REPLACE)) - (BITBLT SOLOW (fetch CX of X) - (fetch CY of X) - (fetch SAV of X) - 0 0 CardWidth (IDIFFERENCE CardHeight DY) - (QUOTE INPUT) - (QUOTE REPLACE)) - (BITBLT (fetch FACE of X) - 0 0 SOLOW (fetch CX of X) - (fetch CY of X) - CardWidth - (IDIFFERENCE CardHeight DY) - (QUOTE INPUT) - (QUOTE REPLACE]) + then (PROG [(DY (IDIFFERENCE (fetch CY of X) + (fetch CY of Y] + (BITBLT (fetch SAV of X) + 0 0 (fetch SAV of Y) + 0 DY CardWidth (IDIFFERENCE CardHeight DY) + 'INPUT + 'REPLACE) + (BITBLT SOLOW (fetch CX of X) + (fetch CY of X) + (fetch SAV of X) + 0 0 CardWidth (IDIFFERENCE CardHeight DY) + 'INPUT + 'REPLACE) + (BITBLT (fetch FACE of X) + 0 0 SOLOW (fetch CX of X) + (fetch CY of X) + CardWidth + (IDIFFERENCE CardHeight DY) + 'INPUT + 'REPLACE]) (MOVESSS - [LAMBDA (S) (* bas: "15-Jan-86 23:23") - (PROG (STS (TS (TOP S))) - (DECLARE (USEDFREE GAMEVALUE)) - (AND TS [EQ (fetch (CARD RANK) of TS) - (ADD1 (fetch (CARD RANK) of (TOPSUITSTACK (SETQ STS - (fetch SUIT - of TS] - (PROGN [SETA SUITSTACKS STS (MOVECARD (pop (fetch FACEUP of S)) - (STACKLOC (ADD1 STS) - NSuits) - (IPLUS (fetch CSY - of (STACK NStacks)) - (FTIMES CardHeight 1.5] - (OR (TOP S) - (FLIPSTACK S)) - (POSTVALUE (add GAMEVALUE PayForCard)) - (RETURN T]) + [LAMBDA (S) (* bas%: "15-Jan-86 23:23") + (PROG (STS (TS (TOP S))) + (DECLARE (USEDFREE GAMEVALUE)) + (AND TS [EQ (fetch (CARD RANK) of TS) + (ADD1 (fetch (CARD RANK) of (TOPSUITSTACK (SETQ STS (fetch SUIT of TS] + (PROGN [SETA SUITSTACKS STS (MOVECARD (pop (fetch FACEUP of S)) + (STACKLOC (ADD1 STS) + NSuits) + (IPLUS (fetch CSY of (STACK NStacks)) + (FTIMES CardHeight 1.5] + (OR (TOP S) + (FLIPSTACK S)) + (POSTVALUE (add GAMEVALUE PayForCard)) + (RETURN T]) (NXTCARD - [LAMBDA (S) (* bas: "15-Jan-86 21:44") - (PROG1 (pop (fetch FACEDOWN of S)) - (if (fetch FACEDOWN of S) - else (* Last card up, replace surface of card table and  - adjust saved image for possibly overlapping exposed  - card in the pile) - (BLTSHADE (DSPTEXTURE NIL SOLOW) - SOLOW - (fetch CSX of S) - [IPLUS (fetch CSY of S) - (if (OR (NULL (fetch FACEUP of S)) - (ZEROP (fetch YO of S))) - then 0 - else (IPLUS CardHeight (fetch YO of S] - (if (OR (NULL (fetch FACEUP of S)) - (ZEROP (fetch XO of S))) - then CardWidth - else (fetch XO of S)) - (if (OR (NULL (fetch FACEUP of S)) - (ZEROP (fetch YO of S))) - then CardHeight - else (IMINUS (fetch YO of S))) - (QUOTE REPLACE)) - (if (fetch FACEUP of S) - then (BLTSHADE (DSPTEXTURE NIL SOLOW) - (fetch SAV of (BOTTOM S)) - 0 - (IMINUS (fetch YO of S)) - (IDIFFERENCE CardWidth (fetch XO of S)) - CardHeight - (QUOTE REPLACE]) + [LAMBDA (S) (* bas%: "15-Jan-86 21:44") + (PROG1 (pop (fetch FACEDOWN of S)) + [if (fetch FACEDOWN of S) + else + + (* Last card up, replace surface of card table and adjust saved image for + possibly overlapping exposed card in the pile) + + (BLTSHADE (DSPTEXTURE NIL SOLOW) + SOLOW + (fetch CSX of S) + [IPLUS (fetch CSY of S) + (if (OR (NULL (fetch FACEUP of S)) + (ZEROP (fetch YO of S))) + then 0 + else (IPLUS CardHeight (fetch YO of S] + (if (OR (NULL (fetch FACEUP of S)) + (ZEROP (fetch XO of S))) + then CardWidth + else (fetch XO of S)) + (if (OR (NULL (fetch FACEUP of S)) + (ZEROP (fetch YO of S))) + then CardHeight + else (IMINUS (fetch YO of S))) + 'REPLACE) + (if (fetch FACEUP of S) + then (BLTSHADE (DSPTEXTURE NIL SOLOW) + (fetch SAV of (BOTTOM S)) + 0 + (IMINUS (fetch YO of S)) + (IDIFFERENCE CardWidth (fetch XO of S)) + CardHeight + 'REPLACE])]) (PUSHCARD - [LAMBDA (S C) (* bas: "30-JUL-82 14:37") + [LAMBDA (S C) (* bas%: "30-JUL-82 14:37") [MOVECARD C (IPLUS (fetch XO of S) - (if (fetch FACEUP of S) - then (fetch CX of (CAR (fetch FACEUP of S))) - else (fetch CSX of S))) - (IPLUS (fetch YO of S) - (if (fetch FACEUP of S) - then (fetch CY of (CAR (fetch FACEUP of S))) - else (fetch CSY of S] + (if (fetch FACEUP of S) + then (fetch CX of (CAR (fetch FACEUP of S))) + else (fetch CSX of S))) + (IPLUS (fetch YO of S) + (if (fetch FACEUP of S) + then (fetch CY of (CAR (fetch FACEUP of S))) + else (fetch CSY of S] (push (fetch FACEUP of S) - C]) + C]) (POSTVALUE - [LAMBDA (V) (* bas: "15-Jan-86 23:25") - (MOVETO (CONSTANT (FIX (FTIMES 25 Overlap CardWidth))) - CardHeight SOLOW) - (DSPFONT (FONTCREATE (QUOTE HELVETICA) - 18) - SOLOW) - (BLTSHADE (DSPTEXTURE NIL SOLOW) - SOLOW - (DSPXPOSITION NIL SOLOW) - (IDIFFERENCE (DSPYPOSITION NIL SOLOW) - (FONTPROP (DSPFONT NIL SOLOW) - (QUOTE DESCENT))) - 1000 - (FONTPROP (DSPFONT NIL SOLOW) - (QUOTE HEIGHT)) - (QUOTE REPLACE)) - (DSPOPERATION (PROG1 (DSPOPERATION (QUOTE PAINT) - SOLOW) - (if (ILESSP V 0) - then (printout SOLOW "Down by $" (IMINUS V) - " ") - elseif (ZEROP V) - then (printout SOLOW "Dead even! ") - else (printout SOLOW "Ahead by $" V " "))) - SOLOW]) + [LAMBDA (V) (* bas%: "15-Jan-86 23:25") + (MOVETO (CONSTANT (FIX (FTIMES 25 Overlap CardWidth))) + CardHeight SOLOW) + (DSPFONT (FONTCREATE 'HELVETICA 18) + SOLOW) + (BLTSHADE (DSPTEXTURE NIL SOLOW) + SOLOW + (DSPXPOSITION NIL SOLOW) + (IDIFFERENCE (DSPYPOSITION NIL SOLOW) + (FONTPROP (DSPFONT NIL SOLOW) + 'DESCENT)) + 1000 + (FONTPROP (DSPFONT NIL SOLOW) + 'HEIGHT) + 'REPLACE) + (DSPOPERATION (PROG1 (DSPOPERATION 'PAINT SOLOW) + (if (ILESSP V 0) + then (printout SOLOW "Down by $" (IMINUS V) + " ") + elseif (ZEROP V) + then (printout SOLOW "Dead even! ") + else (printout SOLOW "Ahead by $" V " "))) + SOLOW]) (SEARCHSTACKS - [LAMBDA (K) (* bas: "30-JUL-82 19:19") + [LAMBDA (K) (* bas%: "30-JUL-82 19:19") (for I to NStacks when (GOODMOVE? (TOP (STACK I)) - K) - do (RETURN (STACK I]) + K) do (RETURN (STACK I]) (SHOWCARDSTACK - [LAMBDA (S) (* lmm " 6-Aug-85 00:04") + [LAMBDA (S) (* lmm " 6-Aug-85 00:04") (if (fetch FACEDOWN of S) - then (BITBLT NIL NIL NIL SOLOW (fetch CSX of S) - (fetch CSY of S) - CardWidth CardHeight (QUOTE TEXTURE) - (QUOTE REPLACE) - BLACKSHADE) - (BITBLT NIL NIL NIL SOLOW (ADD1 (fetch CSX of S)) - (ADD1 (fetch CSY of S)) - (IDIFFERENCE CardWidth 2) - (IDIFFERENCE CardHeight 2) - (QUOTE TEXTURE) - (QUOTE REPLACE) - BACKSHADE)) + then (BITBLT NIL NIL NIL SOLOW (fetch CSX of S) + (fetch CSY of S) + CardWidth CardHeight 'TEXTURE 'REPLACE BLACKSHADE) + (BITBLT NIL NIL NIL SOLOW (ADD1 (fetch CSX of S)) + (ADD1 (fetch CSY of S)) + (IDIFFERENCE CardWidth 2) + (IDIFFERENCE CardHeight 2) + 'TEXTURE + 'REPLACE BACKSHADE)) S]) (SHUFFLEDECK - [LAMBDA NIL (* bas: "30-JUL-82 14:08") - [if (AND (BOUNDP (QUOTE DECK)) - (ARRAYP DECK)) - else (SETQ DECK (ARRAY TotalCards (QUOTE POINTER))) - (bind (I _ 0) for S from Spades to Hearts - do (for R to CardsPerSuit do (SETA DECK (add I 1) - (create CARD - SUIT _ S - RANK _ R] + [LAMBDA NIL (* bas%: "30-JUL-82 14:08") + [if (AND (BOUNDP 'DECK) + (ARRAYP DECK)) + else (SETQ DECK (ARRAY TotalCards 'POINTER)) + (bind (I _ 0) for S from Spades to Hearts + do (for R to CardsPerSuit do (SETA DECK (add I 1) + (create CARD + SUIT _ S + RANK _ R] (bind Y for I to TotalCards do (SETQ Y (RAND 1 TotalCards)) - (SETA DECK I (PROG1 (ELT DECK Y) - (SETA DECK Y (ELT DECK I]) + (SETA DECK I (PROG1 (ELT DECK Y) + (SETA DECK Y (ELT DECK I)))]) (STACKLOC - [LAMBDA (I N) (* bas: "15-Jan-86 22:21") - (IPLUS [ITIMES I (FIXR (FQUOTIENT (IDIFFERENCE (WINDOWPROP SOLOW (QUOTE WIDTH)) - (ITIMES N CardWidth)) - (ADD1 N] - (ITIMES CardWidth (SUB1 I]) + [LAMBDA (I N) (* bas%: "15-Jan-86 22:21") + (IPLUS [ITIMES I (FIXR (FQUOTIENT (IDIFFERENCE (WINDOWPROP SOLOW 'WIDTH) + (ITIMES N CardWidth)) + (ADD1 N] + (ITIMES CardWidth (SUB1 I]) -(STOS? - [LAMBDA (SN) (* bas: " 7-JAN-81 22:01") +(STOS? + [LAMBDA (SN) (* bas%: " 7-JAN-81 22:01") (AND (fetch FACEUP of SN) - [OR (fetch FACEDOWN of SN) - (NOT (KINGP (BOTTOM SN] - (SEARCHSTACKS (BOTTOM SN]) + [OR (fetch FACEDOWN of SN) + (NOT (KINGP (BOTTOM SN] + (SEARCHSTACKS (BOTTOM SN]) -(TOPSUITSTACK - [LAMBDA (I) (* bas: " 4-JAN-81 01:39") +(TOPSUITSTACK + [LAMBDA (I) (* bas%: " 4-JAN-81 01:39") (ELT SUITSTACKS I]) ) (DEFINEQ (HIST - [LAMBDA (A W L) (* bas: "15-Dec-85 20:22") - (PROG ((WH (WINDOWPROP W (QUOTE HEIGHT))) - (WW (WINDOWPROP W (QUOTE WIDTH))) - (HM NIL) - (VM (IPLUS (FONTPROP (DSPFONT NIL W) - (QUOTE HEIGHT)) - 4))) - (SETQ HM VM) (* Margins could be different eg if Y labels were  - used) - (BLTSHADE WHITESHADE W 0 0 WW WH (QUOTE REPLACE)) - [PROG [(HS (IQUOTIENT (IDIFFERENCE WW (ITIMES HM 2)) - (ARRAYSIZE A))) - (VS (FQUOTIENT (IDIFFERENCE WH (ITIMES VM 2)) - (ARRAYMAX A] - (for I from (ARRAYORIG A) to (IPLUS (ARRAYSIZE A) - (ARRAYORIG A) - -1) - do (BLTSHADE GRAYSHADE W (IPLUS HM (ITIMES I HS)) - VM HS (FIX (FTIMES VS (ELT A I))) - (QUOTE REPLACE] - (DRAWLINE HM VM (IDIFFERENCE WW HM) - VM 2 (QUOTE REPLACE) - W) - (DRAWLINE HM VM HM (IDIFFERENCE WH VM) - 2 - (QUOTE REPLACE) - W) - (MOVETO (IDIFFERENCE (IDIFFERENCE WW HM) - (STRINGWIDTH L (DSPFONT NIL W))) - (IPLUS (FONTPROP (DSPFONT NIL W) - (QUOTE DESCENT)) - 2) - W) - (PRIN1 L W]) + [LAMBDA (A W L) (* bas%: "15-Dec-85 20:22") + (PROG ((WH (WINDOWPROP W 'HEIGHT)) + (WW (WINDOWPROP W 'WIDTH)) + (HM NIL) + (VM (IPLUS (FONTPROP (DSPFONT NIL W) + 'HEIGHT) + 4))) + (SETQ HM VM) (* Margins could be different eg if Y + labels were used) + (BLTSHADE WHITESHADE W 0 0 WW WH 'REPLACE) + [PROG [(HS (IQUOTIENT (IDIFFERENCE WW (ITIMES HM 2)) + (ARRAYSIZE A))) + (VS (FQUOTIENT (IDIFFERENCE WH (ITIMES VM 2)) + (ARRAYMAX A] + (for I from (ARRAYORIG A) to (IPLUS (ARRAYSIZE A) + (ARRAYORIG A) + -1) + do (BLTSHADE GRAYSHADE W (IPLUS HM (ITIMES I HS)) + VM HS (FIX (FTIMES VS (ELT A I))) + 'REPLACE] + (DRAWLINE HM VM (IDIFFERENCE WW HM) + VM 2 'REPLACE W) + (DRAWLINE HM VM HM (IDIFFERENCE WH VM) + 2 + 'REPLACE W) + (MOVETO (IDIFFERENCE (IDIFFERENCE WW HM) + (STRINGWIDTH L (DSPFONT NIL W))) + (IPLUS (FONTPROP (DSPFONT NIL W) + 'DESCENT) + 2) + W) + (PRIN1 L W]) (ARRAYMAX - [LAMBDA (A) (* bas: " 5-AUG-82 14:59") + [LAMBDA (A) (* bas%: " 5-AUG-82 14:59") (bind (M _ 0) for I from (ARRAYORIG A) to (IPLUS (ARRAYSIZE A) - (ARRAYORIG A) - -1) - when (LESSP M (ELT A I)) do (SETQ M (ELT A I)) finally (RETURN M]) + (ARRAYORIG A) + -1) when (LESSP M (ELT A I)) + do (SETQ M (ELT A I)) finally (RETURN M]) ) -(DECLARE: DONTCOPY +(DECLARE%: DONTCOPY (DEFINEQ (SHOWCONFIG - [LAMBDA NIL (* bas: "30-JUL-82 19:20") - (printout NIL "Suits: " 10) - (for I from Spades to Hearts do (printout NIL (CARDNAME (TOPSUITSTACK I)) - ,)) + [LAMBDA NIL (* bas%: "30-JUL-82 19:20") + (printout NIL "Suits: " 10) + (for I from Spades to Hearts do (printout NIL (CARDNAME (TOPSUITSTACK I)) + %,)) (TERPRI) (for I to NStacks do (PRINTCARDSTACK (STACK I) - (CONCAT "Stack " I))) + (CONCAT "Stack " I))) (PRINTCARDSTACK HAND "Hand"]) (PRINTCARDSTACK - [LAMBDA (X S) (* bas: " 6-JAN-81 16:47") - (printout NIL S ":" 10 .I2 (LENGTH (fetch FACEDOWN X)) - " down. Up: ") - (for J in (fetch FACEUP of X) do (printout NIL (CARDNAME J) - ,)) + [LAMBDA (X S) (* bas%: " 6-JAN-81 16:47") + (printout NIL S ":" 10 .I2 (LENGTH (fetch FACEDOWN X)) + " down. Up: ") + (for J in (fetch FACEUP of X) do (printout NIL (CARDNAME J) + %,)) (TERPRI]) (CARDNAME - [LAMBDA (C) (* bas: "15-Jan-86 21:40") - (if (ZEROP (fetch (CARD RANK) of C)) - then "None" - else (PACK (LIST (SELECTQ (fetch (CARD SUIT) of C) - (0 (QUOTE S)) - (1 (QUOTE C)) - (2 (QUOTE D)) - (3 (QUOTE H)) - (SHOULDNT)) - (SELECTQ (fetch (CARD RANK) of C) - (1 (QUOTE A)) - (11 (QUOTE J)) - (12 (QUOTE Q)) - (13 (QUOTE K)) - (fetch (CARD RANK) of C]) + [LAMBDA (C) (* bas%: "15-Jan-86 21:40") + (if (ZEROP (fetch (CARD RANK) of C)) + then "None" + else (PACK (LIST (SELECTQ (fetch (CARD SUIT) of C) + (0 'S) + (1 'C) + (2 'D) + (3 'H) + (SHOULDNT)) + (SELECTQ (fetch (CARD RANK) of C) + (1 'A) + (11 'J) + (12 'Q) + (13 'K) + (fetch (CARD RANK) of C]) ) ) -(DECLARE: EVAL@COMPILE DONTCOPY -(DECLARE: EVAL@COMPILE -[PUTPROPS BOTTOM MACRO ((S) - (CAR (LAST (fetch FACEUP of S] -[PUTPROPS KINGP MACRO ((C) - (EQ CardsPerSuit (fetch (CARD RANK) - of C] -(PUTPROPS STACK MACRO ((N) - (ELT STACKS N))) -[PUTPROPS TOP MACRO ((S) - (CAR (fetch FACEUP of S] +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS BOTTOM MACRO [(S) + (CAR (LAST (fetch FACEUP of S]) + +(PUTPROPS KINGP MACRO ((C) + (EQ CardsPerSuit (fetch (CARD RANK) of C)))) + +(PUTPROPS STACK MACRO ((N) + (ELT STACKS N))) + +(PUTPROPS TOP MACRO ((S) + (CAR (fetch FACEUP of S)))) ) -[DECLARE: EVAL@COMPILE +(DECLARE%: EVAL@COMPILE (DATATYPE CARD (SUIT RANK FACE SAV CX CY) - (ACCESSFNS CARD (COLOR (ILESSP (fetch SUIT of DATUM) - Diamonds)))) + (ACCESSFNS CARD (COLOR (ILESSP (fetch SUIT of DATUM) + Diamonds)))) (RECORD CARDSTACK (FACEUP FACEDOWN CSX CSY XO YO)) -] -(/DECLAREDATATYPE (QUOTE CARD) - (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)) - (QUOTE ((CARD 0 POINTER) - (CARD 2 POINTER) - (CARD 4 POINTER) - (CARD 6 POINTER) - (CARD 8 POINTER) - (CARD 10 POINTER))) - (QUOTE 12)) +) -(DECLARE: EVAL@COMPILE +(/DECLAREDATATYPE 'CARD '(POINTER POINTER POINTER POINTER POINTER POINTER) + '((CARD 0 POINTER) + (CARD 2 POINTER) + (CARD 4 POINTER) + (CARD 6 POINTER) + (CARD 8 POINTER) + (CARD 10 POINTER)) + '12) + +(DECLARE%: EVAL@COMPILE (RPAQQ Spades 0) @@ -593,152 +569,88 @@ (RPAQQ TotalCards 52) + (CONSTANTS (Spades 0) - (Clubs 1) - (Diamonds 2) - (Hearts 3) - (CostOfDeck 50) - (PayForCard 5) - (NStacks 7) - (NSuits 4) - (CardsPerSuit 13) - (TotalCards 52)) + (Clubs 1) + (Diamonds 2) + (Hearts 3) + (CostOfDeck 50) + (PayForCard 5) + (NStacks 7) + (NSuits 4) + (CardsPerSuit 13) + (TotalCards 52)) ) -(DECLARE: EVAL@COMPILE +(DECLARE%: EVAL@COMPILE (RPAQQ BACKSHADE 52275) (RPAQQ BetweenStacks 2) -(RPAQQ Overlap .667) +(RPAQQ Overlap 0.667) (RPAQQ CardWidth 30) (RPAQQ CardHeight 45) + (CONSTANTS (BACKSHADE 52275) - (BetweenStacks 2) - (Overlap .667) - (CardWidth 30) - (CardHeight 45)) + (BetweenStacks 2) + (Overlap 0.667) + (CardWidth 30) + (CardHeight 45)) ) -(DECLARE: DOEVAL@COMPILE DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS HAND STACKS SUITSTACKS DECK SOLORESULTS) ) -(DECLARE: DOEVAL@COMPILE DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MaxCardMove WaitBetweenMoves) ) ) -(/DECLAREDATATYPE (QUOTE CARD) - (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)) - (QUOTE ((CARD 0 POINTER) - (CARD 2 POINTER) - (CARD 4 POINTER) - (CARD 6 POINTER) - (CARD 8 POINTER) - (CARD 10 POINTER))) - (QUOTE 12)) -(RPAQ SpadesBits (READBITMAP)) -(11 11 -"@D@@" -"@N@@" -"AO@@" -"COH@" -"GOL@" -"GOL@" -"GOL@" -"COH@" -"@D@@" -"AO@@" -"COH@") +(/DECLAREDATATYPE 'CARD '(POINTER POINTER POINTER POINTER POINTER POINTER) + '((CARD 0 POINTER) + (CARD 2 POINTER) + (CARD 4 POINTER) + (CARD 6 POINTER) + (CARD 8 POINTER) + (CARD 10 POINTER)) + '12) -(RPAQ ClubsBits (READBITMAP)) -(11 11 -"@D@@" -"@N@@" -"AO@@" -"@N@@" -"BDH@" -"GEL@" -"OON@" -"GEL@" -"BDH@" -"@N@@" -"COH@") +(RPAQQ SpadesBits #*(11 11)@D@@@N@@AO@@COH@GOL@GOL@GOL@COH@@D@@AO@@COH@) -(RPAQ DiamondsBits (READBITMAP)) -(11 11 -"@D@@" -"@N@@" -"AK@@" -"CAH@" -"F@L@" -"L@F@" -"F@L@" -"CAH@" -"AK@@" -"@N@@" -"@D@@") +(RPAQQ ClubsBits #*(11 11)@D@@@N@@AO@@@N@@BDH@GEL@OON@GEL@BDH@@N@@COH@) -(RPAQ HeartsBits (READBITMAP)) -(11 11 -"@@@@" -"CAH@" -"GKL@" -"DND@" -"D@D@" -"F@L@" -"CAH@" -"AK@@" -"@N@@" -"@D@@" -"@@@@") +(RPAQQ DiamondsBits #*(11 11)@D@@@N@@AK@@CAH@F@L@L@F@F@L@CAH@AK@@@N@@@D@@) -(RPAQ 10Bits (READBITMAP)) -(20 18 -"@@@@@@@@" -"@F@GL@@@" -"@N@ON@@@" -"GNALG@@@" -"GNAHC@@@" -"@FAHC@@@" -"@FAHC@@@" -"@FAHC@@@" -"@FAHC@@@" -"@FAHC@@@" -"@FAHC@@@" -"@FALG@@@" -"@F@ON@@@" -"@F@GL@@@" -"@@@@@@@@" -"@@@@@@@@" -"@@@@@@@@" -"@@@@@@@@") +(RPAQQ HeartsBits #*(11 11)@@@@CAH@GKL@DND@D@D@F@L@CAH@AK@@@N@@@D@@@@@@) + +(RPAQQ 10Bits #*(20 18)@@@@@@@@@F@GL@@@@N@ON@@@GNALG@@@GNAHC@@@@FAHC@@@@FAHC@@@@FAHC@@@@FAHC@@@@FAHC@@@@FAHC@@@@FALG@@@@F@ON@@@@F@GL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +) (RPAQ? MaxCardMove 8) -(RPAQ? WaitBetweenMoves 10) +(RPAQ? WaitBetweenMoves 100) (RPAQ? DECK ) (RPAQ? SOLORESULTS ) -(ADDTOVAR IDLE.FUNCTIONS ("Solitaire" (QUOTE SOLO))) +(ADDTOVAR IDLE.FUNCTIONS ("Solitaire" 'SOLO)) (PUTPROPS SOLITAIRE COPYRIGHT ("Xerox Corporation" 1982 1985 1986)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (1624 3406 (SOLO 1634 . 2699) (SOLITAIRE 2701 . 3404)) (3407 17559 (CARDIMAGE 3417 . -4854) (COUNTCARDS 4856 . 5068) (CREATEHAND 5070 . 5525) (CREATESTACK 5527 . 6136) (DEALDECK 6138 . -6687) (FLIPSTACK 6689 . 6909) (GETCARD 6911 . 7339) (GOODMOVE? 7341 . 7706) (HTOS? 7708 . 7867) ( -MOVECARD 7869 . 8491) (DOMOVE 8493 . 9921) (MOVEHS 9923 . 10158) (MOVES 10160 . 10429) (MOVES1 10431 - . 10672) (UPCARD 10674 . 11691) (MOVESSS 11693 . 12456) (NXTCARD 12458 . 13928) (PUSHCARD 13930 . -14484) (POSTVALUE 14486 . 15427) (SEARCHSTACKS 15429 . 15654) (SHOWCARDSTACK 15656 . 16269) ( -SHUFFLEDECK 16271 . 16859) (STACKLOC 16861 . 17182) (STOS? 17184 . 17423) (TOPSUITSTACK 17425 . 17557) -) (17560 19275 (HIST 17570 . 18957) (ARRAYMAX 18959 . 19273)) (19296 20605 (SHOWCONFIG 19306 . 19716) -(PRINTCARDSTACK 19718 . 20040) (CARDNAME 20042 . 20603))))) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1950 4087 (SOLO 1960 . 3297) (SOLITAIRE 3299 . 4085)) (4088 20454 (CARDIMAGE 4098 . +5754) (COUNTCARDS 5756 . 5969) (CREATEHAND 5971 . 6576) (CREATESTACK 6578 . 7427) (DEALDECK 7429 . +8012) (FLIPSTACK 8014 . 8249) (GETCARD 8251 . 8701) (GOODMOVE? 8703 . 9100) (HTOS? 9102 . 9269) ( +MOVECARD 9271 . 9910) (DOMOVE 9912 . 11543) (MOVEHS 11545 . 11816) (MOVES 11818 . 12129) (MOVES1 12131 + . 12433) (UPCARD 12435 . 13651) (MOVESSS 13653 . 14595) (NXTCARD 14597 . 16369) (PUSHCARD 16371 . +17033) (POSTVALUE 17035 . 18036) (SEARCHSTACKS 18038 . 18281) (SHOWCARDSTACK 18283 . 18912) ( +SHUFFLEDECK 18914 . 19718) (STACKLOC 19720 . 20052) (STOS? 20054 . 20316) (TOPSUITSTACK 20318 . 20452) +) (20455 22457 (HIST 20465 . 22054) (ARRAYMAX 22056 . 22455)) (22479 24001 (SHOWCONFIG 22489 . 22951) +(PRINTCARDSTACK 22953 . 23305) (CARDNAME 23307 . 23999))))) STOP diff --git a/lispusers/SOLITAIRE.LCOM b/lispusers/SOLITAIRE.LCOM index fc9baf2d249aed61588164362fbcda143e9d1043..55216b3ee060a0a3fb34ed7a80c686f4236daca4 100644 GIT binary patch delta 2052 zcmah~TWBLy7^d4Tv}b!w@Al&9w6Qa4VrFt_47#1^T#_-9nPg^?ws?W*X4Gn%u5GGT zD}B^OeOR(Sx+sDm_*TIOAAA%+Rs;nf6h!b*VG%@pQ2%o#O=_*{gq$vS#4^JQGi6Vo3&XT-n*ay0uuvn>Ea6Wy8Ry^`g-zgR5TMuY$*a+b=QP|AxgcF%$S@ z#mT?&(D|`pA(c+YaYoKbW>$3~u7z2onGSX=!@`Ox8Hy_BaaMI@$yPYbRwSE(x-03n zDq97I!nGX82^}5w8|Wry!k7T%f6<^P=daC7M8pddnzjbo^__Mn?x~ zR62KI{k$_XK(N3WrV62puM>rvT~-LO93o-q1=3K8{?*le0nqO5cZMlyl}#GCL*d3J z-SP}#g#@PAPz~Bs$X*FFrh49sA(l^L$Av+0pu{+lz_Dm5wS?pJ27FQ*st_3c((~CO zGIax#lQ0ofIl%`v9BNgOMA-NaeF*`6cq!9&c(Id&;jS0e`NPKTOT#oF&CrXdsK~;ie!|VS>7D~n6OkPHCW%C%!iPpO17K}<{*gw zk4f)-#Kx1&;lTXK9gGQwoSd~v9G~jmt9Owm4NgTy0)?`s87h6E=(LumristmG<#+k z-krXW=0d3qOAg$BKmFJQVpDikSKM6SvfbIz%oBIRX!Gp^U90Gnb@x;_w`RiAPz>A> zllg}E&>c4@<-lx;JU$xUr|u=&mevc>THyW*e69PWtBuF!W#`x)YPj(c^KeJFaht(_gyso;K-VAWnqBZf^1(uN1g(0T^%cMVg74P~JJ0)j@V;%} za1r3=!o=*`uz!R~WeZ*`yud-cc2O#ouyfU``g<#z^*ua)FU#|o=Q&XkMbQ*R$r44` z%86OaX#L5V;3rs%NZ#7txC0O2J6chIOf^KyGU-mv1R$g>B4yLt-l5PQ85)TP|jrmwKfwUJ1LO>k4~B+AiXp( zYmggLgq%b%Yf45o*mE+GYf^hZIx9H;ObH+)N(g)4fau=gLd~R?alw00_I9ge2ynV3 sCF9Y!hZ|UcuP|->GJKWfeCt5I9JcC|4Hss)vBo7}WZvZDE;^`x1APJpwEzGB delta 2337 zcmb7FL2TP(6jo^m9qYfY?Ygn9E3a;=If8~bO|sT>Yh2q&yf}91-`Q3TCfvqAP?uC~ zI){#%&;RfcO8llMJSbMbYm+|NGwi z-uK@7oj=!pq**a%n7ZodimPiNKxY2z-q!q53KEi>O34dJ0YqW5ae2G8a89b)< zTO_yt>f7k+BkfE5JGkEMmxsIB1Hi<P#Xvtr45V$FLK0iF( z(80Ut^7FywFmustW(}(E4c}tb9~|+xi5Uts2zPbF8tn}i9^V_ujXiWM1#oHfV&}Y4 z?s9)J`Tz-Tj(vQHaYy6I(z-1l?qlT3)&w#@}L)-;W3*%pGr9 zp&ME_x-m<{RFZceq*L7~=*)Pa@{6N)Sd`a}<#7G{SaFn4U2)U`??tFQHEH7b{9%?EEmU$jQ|EV=XMXYcB;&j~DIVw#HX&J&!{!b>+EsnN|$9Cz+p4%uQk`pmWS79jC*f zZcu{bQyF%V9N6RZisLBjCFMdue-AzwjC$IxO-~{4#$`Kz>(@EI zMb;{|tAmt`VXjVDSp&N5RsG%7T5}gfyvN$A;g*y#GfNWSSIBDFtbh-TKNOokRJ*_q z^S1flM`#QEdL3e|kW}5;+jwHmFoRVspw>CHZCgBp;8$o1kvx$|r&jYWH(K@T6VMg| zsS4-IWjUXj%`v|4mm1iV02$J9;Sp`Y_jZ~c&eo&qo9(5^7dee)X^ck0SpSC&+ry$n zq*CHh{Y)mHg)e0e<#62QvUxM$$K<{9 diff --git a/lispusers/STARBG b/lispusers/STARBG index 95401a20..3ae661c5 100644 --- a/lispusers/STARBG +++ b/lispusers/STARBG @@ -1,13 +1,14 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "17-Aug-88 03:26:58" {ERINYES}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}larry>medley>lispusers>STARBG.;2 16815 - previous date%: "12-Oct-87 17:02:01" {ERINYES}LYRIC>LISPUSERS>STARBG.;2) + :CHANGES-TO (FNS Cosmos) + + :PREVIOUS-DATE "17-Aug-88 03:26:58" {DSK}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 (v0H-U}w&+$6m>H*M-oa+BOOCTVV}+t{*Z$<-F} zrzB}dD6D;g;n>$~kWH1Ki;djn={(k3t zxqsDvykZ&SLRwglYxb}n)9iXYoPd#}8k|-m8nAjit)*hRk!07844w(7h6YZ7XBdtK z2UD7w)0p=;xC%{g1O=^EL0bls%E9? zH_~b<5OMfK9vD`1wF-zX#U(3(hlQ^zX0BXZTqu}%$jxUu@+&$Y*PqfJN*7ttzqnd)%Fc%OPX>+llwOKRCx_rw5c^REPSDG_qq+*P&_y}N>4j%^dLqI@K5pZoc{yoXmt70zD8pmE3{I( z@Hrkb!Z0S1RdEveRGdQ&y0XYu@&LKvO7t+`01waez~#ukx1U(txJ(jtUqn7?@R%ou z`f7uF9-4c0oLcUW=aJn~2KmNsBiAGiwO^#^V+@x{sxwnyE}NxVGK>Fvz;A~*y*Cy$@UQgnCko|!VNyblaRrjB<;v8x` nWN2wfV-`pey2vgDPduJ~kfum}iZ=XR;*pzEpL8;DJ;wY4XfIC8 delta 1234 zcmZ8gO>7%g5RQ{3bp%`95Ubmatj^i~gsVa)Gmte{D zMqVdSLY0Dm3#amgT8V%-a;XGL5kEpyRi&N~J@f*XoIrvDmvZ5PV4j^cqI>w}d-G<# zH#6_;*Vh97Z1Q~8%GpIr%-MNMw2Qe#2$wB0TQSpl3pl%2vC4VdDRI{ik8TQtXJHu( zs90IxASN!XHAP(oNj6l)P&E#CuI61{Z8Y6Fcr6Us$U0}Q&NdtVYRzlANk-Oux9umL zidjydjwECO2nPx(wV0AD8EVv!bPir&Ld~fMU#V1;;8o$%2*5Tg#8DQ$UXCiUzgU zs;$ix*N2XG(f~eJbRgsTmpxw~u-bOl8{V4Vtp;~FSrHd&9Z`#e95*DzkmM)NO6Hf# zb|$%h?A|mKfu!Be>#o}ZBdZbK1_@THjkW-N&(KGKQh;n{`qcoMHwF%(q1O()i1^Ea z9J*leN9Ou-=oS!O!?~53)tZZw5J<0BQ<5aPD@?bJZ+f)64k^P|F{=Z_J zibM!pr02=`r-Oa?-TC6LK3pc!Ep^SIHn*b#x5e>99u>_Ix@L^EHuT6pMUmY7Z+(QY@^1l@F?r{-Z=E5 z`SrvETLmZ13}Mug@C_pC+$FY9abol$G^W^i{-=>LR|QGX6&wOEWd(x4U>ORz?11jCpoqb;L~kB}6?n zPVdGoWS=6N)J{bRUoM$TDR9@_R;N_OHxCltM9;}y(~9eKs%;;Nc3!}1)Iym2Nf*D< zCXnxFCj#U{eHCIU(zR$zpulg$71xlI!Y7jA@u*G3y6Q~ClSNO^TE9s`lX6$ z)His~{6iVe2 zTBs+r1TC+OEw_F5T%+!KyWM@3xG_L5+?f5iYk%Ig>vM~&k~ucc=_FnkeJ>eB{5E-t oprBdII#vZLn0X<7nhp6N!4(!pFQwSne@L-Teork75*#D>4>vGR6aWAK diff --git a/sources/IDLER b/sources/IDLER index 7ff312e7..2101da77 100644 --- a/sources/IDLER +++ b/sources/IDLER @@ -1,14 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "23-Mar-92 13:38:29" |{PELE:MV:ENVOS}SOURCES>IDLER.;3| 39952 - changes to%: (VARS IDLERCOMS) - (FNS \IDLERKEYACTION) +(FILECREATED "28-Sep-2022 19:54:40" {DSK}larry>medley>sources>IDLER.;10 47564 - previous date%: "16-May-90 18:17:31" |{PELE:MV:ENVOS}SOURCES>IDLER.;2|) + :CHANGES-TO (FNS IDLE.RANDOM) + + :PREVIOUS-DATE "22-Sep-2022 16:50:17" {DSK}larry>medley>sources>IDLER.;1) (* ; " -Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. +Copyright (c) 1985-1990, 1992, 2022 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT IDLERCOMS) @@ -24,15 +24,13 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat \IDLERKEYACTION) (INITVARS (IDLE.PROFILE '(TIMEOUT 0)) (* ; - "so that it doesn't start idling during the loadup") + "so that it doesn't start idling during the loadup") (\IDLING) (CH.DEFAULT.DOMAIN) (DEFAULTREGISTRY) (IDLE.KEYACTIONTABLE)) (ADDVARS (SYSTEMINITVARS (IDLE.PROFILE ALLOWED.LOGINS NIL FORGET NIL TIMEOUT 0 DISPLAYFN - IDLE.BOUNCING.BOX SAVEVM 10 AUTHENTICATE T LOGIN.TIMEOUT 30) - ) - (* ; "the real default") + IDLE.RANDOM SAVEVM 5 LOGOUT 5)) (IDLE.SUSPEND.PROCESS.NAMES MOUSE) (IDLE.RESETVARS (PUPTRACEFLG NIL) (XIPTRACEFLG NIL))) @@ -109,12 +107,12 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (COMS (* ;; "Default idle display") - (FNS IDLE.BOUNCING.BOX IDLE.BITMAP) + (FNS IDLE.BOUNCING.BOX IDLE.BITMAP IDLE.RANDOM) [INITVARS (IDLE.BOUNCING.BOX (BITMAPCOPY LOGOBITMAP)) - (IDLE.FUNCTIONS '(("Bouncing Box" 'IDLE.BOUNCING.BOX) - ("Bouncing Username" '(LAMBDA (W) - (IDLE.BOUNCING.BOX W - (USERNAME NIL NIL T] + (IDLE.FUNCTIONS '(["Bouncing Box" #'(LAMBDA (W) + (IDLE.BOUNCING.BOX W + (USERNAME NIL NIL T] + (Random 'IDLE.RANDOM] (GLOBALVARS IDLE.FUNCTIONS IDLE.BOUNCING.BOX)))) @@ -124,8 +122,7 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (DEFINEQ (IDLE - [LAMBDA (FROMTIMEOUT) (* ; "Edited 20-Nov-87 11:22 by Snow") - + [LAMBDA (FROMTIMEOUT) (* ; "Edited 20-Nov-87 11:22 by Snow") (COND ((NOT \IDLING) (OR (FNTYP (LISTGET IDLE.PROFILE 'DISPLAYFN)) @@ -136,7 +133,7 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat 'RESTARTABLE T 'NAME 'IDLE 'KEYACTION (\IDLERKEYACTION]) (IDLE.SET.OPTION - [LAMBDA (OPTION X) (* drc%: " 3-Jan-86 11:47") + [LAMBDA (OPTION X) (* drc%: " 3-Jan-86 11:47") (CLEARW PROMPTWINDOW) (IDLE.SHOW.OPTION OPTION "Old") (LET @@ -162,7 +159,7 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (UNLOCKED NIL) (T (UNION (LIST T) OLD.OPTION)) - (ADD (LET [(GROUP (PROMPTFORWORD "Add to allowed login list:" NIL NIL PROMPTWINDOW + (ADD (LET [(GROUP (PROMPTFORWORD "Add to allowed login list:" NIL NIL PROMPTWINDOW NIL 'TTY] (TERPRI PROMPTWINDOW) (COND @@ -196,7 +193,7 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (IDLE.SHOW.OPTION OPTION "New"]) (IDLE.SHOW.OPTIONS - [LAMBDA NIL (* bvm%: "16-Oct-85 00:23") + [LAMBDA NIL (* bvm%: "16-Oct-85 00:23") (FRESHLINE PROMPTWINDOW) (for TAIL on IDLE.PROFILE by (CDDR TAIL) do (IDLE.SHOW.OPTION (CAR TAIL) NIL @@ -206,7 +203,7 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (T "."]) (IDLE.SHOW.OPTION - [LAMBDA (OPTION STRING SEPR) (* bvm%: "16-Oct-85 00:23") + [LAMBDA (OPTION STRING SEPR) (* bvm%: "16-Oct-85 00:23") (LET ((VALUE (LISTGET IDLE.PROFILE OPTION))) (OR SEPR (FRESHLINE PROMPTWINDOW)) (COND @@ -230,7 +227,9 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (ALLOWED.LOGINS (COND ((LISTP VALUE) - (SUBPAIR '(T *) '("" "") VALUE)) + (SUBPAIR '(T *) + '("" "") + VALUE)) (T "Unlocked"))) (MKSTRING VALUE))) (COND @@ -238,8 +237,174 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (T (TERPRI PROMPTWINDOW]) (\IDLER -(LAMBDA (FROMTIMEOUT) (* ; "Edited 29-Jun-88 14:36 by drc:") (* ;; "This is the main idling loop. ") (RESETLST (RESETSAVE NIL (QUOTE (SETTOPVAL \IDLING NIL))) (PROG ((START.TIME (ALTO.TO.LISP.DATE \LASTUSERACTION)) W SAVEVM.TIMER IDLE.PROCESS NO.ERROR EXIT? INTERRUPTED.STRING IDLING.KEYACTIONS) (COND ((NOT (\OK.TO.IDLE?)) (* ; "Somebody in password prompt, better not idle") (RETURN))) (SETQ \IDLE.PASSWORD.SET) (COND ((EQ (LISTGET IDLE.PROFILE (QUOTE FORGET)) (QUOTE FIRST)) (* ;; "do things like dump cache listings and flush files to servers *before* passwords get smashed") (\USEREVENT (QUOTE BEFORESAVEVM)) (\DEVICEEVENT (QUOTE BEFORESAVEVM)) (\USEREVENT (QUOTE AFTERDOSAVEVM)) (\DEVICEEVENT (QUOTE AFTERDOSAVEVM)))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA NIL (NOTIFY.EVENT \IDLING.OVER))))) (for X in IDLE.SUSPEND.PROCESS.NAMES bind PROC do (* ; "Turn off things like CROCK, LAFITEMAILWATCH, SPACEWINDOW, REMINDERS") (COND ((SETQ PROC (FIND.PROCESS X)) (PROCESS.EVAL PROC (QUOTE (\IDLE.WAIT)))))) (RESETSAVE (GCGAG NIL)) (RESETSAVE \AFTERLOGINFNS NIL) (* ; "So that SETPASSWORD doesn't trigger any activity") (for X in IDLE.RESETVARS do (* ; "turn off things like pup-trace, xiptrace and the like") (RESETSAVE (SETTOPVAL (CAR X) (EVAL (CADR X))) (LIST (FUNCTION SETTOPVAL) (CAR X) (GETTOPVAL (CAR X))))) (* ; "so that mouse buttons will trigger READP") (COND ((EQ (LISTGET IDLE.PROFILE (QUOTE FORGET)) (QUOTE FIRST)) (SETQ \IDLE.PASSWORD.SET (QUOTE CLEAR)) (SETPASSWORD NIL (USERNAME NIL NIL T) ""))) (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (* ;; "Note that IDLE has set up our KEYACTION table (in the add.process) to ignore interrupts and make mouse clicks trigger readp.") (RESETSAVE (CHANGENAME (QUOTE \LOGIN.READ) (QUOTE PROVIDE.PROMPTING.WINDOW) (QUOTE \IDLE.PROMPTING.WINDOW)) (QUOTE (CHANGENAME \LOGIN.READ \IDLE.PROMPTING.WINDOW PROVIDE.PROMPTING.WINDOW))) (COND ((OR (AND FROMTIMEOUT (NOT (LET ((TIMEOUT (LISTGET IDLE.PROFILE (QUOTE TIMEOUT)))) (AND (SMALLP TIMEOUT) (\SECONDSCLOCKGREATERP \LASTUSERACTION (TIMES TIMEOUT 60)))))) (NOT (\OK.TO.IDLE?))) (* ;; "Check again if it's ok, since somebody could have fallen into a password prompter between then and now. Anybody who does after this is ok, because the CHANGENAME above is now in effect. Also check timeout again, in case there was a user interaction during the BEFORESAVEVM stuff") (RETURN))) (CLEARW PROMPTWINDOW) (SETQ W (CREATEW WHOLESCREEN NIL 0 T)) (RESETSAVE NIL (LIST (FUNCTION CLOSEW) W)) (RESETSAVE (CURSOR (CURSORCREATE (BITMAPCREATE 0 0)))) (CASE (MACHINETYPE) (DORADO (* ;; "this is the only way we can get the background border to be black on a dorado") (RESETSAVE (VIDEOCOLOR T)))) (IF (VIDEOCOLOR) THEN (* ;; "make sure border is black") (RESETSAVE (CHANGEBACKGROUNDBORDER WHITESHADE)) (OPENW W) ELSE (DSPOPERATION (QUOTE ERASE) W) (DSPTEXTURE BLACKSHADE W) (RESETSAVE (CHANGEBACKGROUNDBORDER BLACKSHADE)) (CLEARW W)) (COND ((AND (SMALLP (LISTGET IDLE.PROFILE (QUOTE SAVEVM))) (\FLUSHVMOK? (QUOTE SAVEVM) T)) (* ; "Set up timer to go off when a SAVEVM should be done. Don't do it if it's not safe") (SETQ SAVEVM.TIMER (SETUPTIMER (TIMES (LISTGET IDLE.PROFILE (QUOTE SAVEVM)) 60000))))) (SETQ IDLE.PROCESS (ADD.PROCESS (CONS (LISTGET IDLE.PROFILE (QUOTE DISPLAYFN)) (CONS W (LISTGET IDLE.PROFILE (QUOTE DISPLAY.DATA)))) (QUOTE NAME) (QUOTE IDLE.DISPLAY))) (RESETSAVE NIL (LIST (FUNCTION DEL.PROCESS) IDLE.PROCESS)) (BLOCK) (* ; "Let the demo get started first") WAIT.FOR.CHAR (COND ((NOT (READP T T)) (BLOCK 250) (\DIRTYBACKGROUND) (COND ((\SAVEVMBACKGROUND) (SETQ SAVEVM.TIMER))) (COND ((OR (KEYDOWNP (QUOTE LSHIFT)) (KEYDOWNP (QUOTE RSHIFT))) (AND (PROCESSP IDLE.PROCESS) (SUSPEND.PROCESS IDLE.PROCESS)) (CLEARW PROMPTWINDOW) (PRINTOUT PROMPTWINDOW (USERNAME NIL NIL T) " Idle " (\IDLE.TIME START.TIME) T) (until (NOT (OR (KEYDOWNP (QUOTE LSHIFT)) (KEYDOWNP (QUOTE RSHIFT)))) do (BLOCK 250)) (AND IDLE.PROCESS (WAKE.PROCESS IDLE.PROCESS)))) (COND ((AND SAVEVM.TIMER (NOT \VMEM.INHIBIT.WRITE) (TIMEREXPIRED? SAVEVM.TIMER)) (COND ((\FLUSHVMOK? (QUOTE SAVEVM) T) (* ; "if SAVEVM not allowed forget it forever") (RESETFORM (CURSOR SAVINGCURSOR) (NLSETQ (SAVEVM))))) (SETQ SAVEVM.TIMER))) (TTY.PROCESS (THIS.PROCESS)) (* ; "Keep us the tty process, even if someone else tries for it") (GO WAIT.FOR.CHAR))) (COND ((PROCESSP IDLE.PROCESS) (SUSPEND.PROCESS IDLE.PROCESS))) (SETQ NO.ERROR (NLSETQ (SETQ EXIT? (\IDLE.EXIT?)))) (COND ((NOT NO.ERROR) (SETQ INTERRUPTED.STRING "ERROR while checking Allowed Logins") (SETPASSWORD NIL (USERNAME NIL NIL T) "") (SETQ \IDLE.PASSWORD.SET (QUOTE CLEAR))) ((NOT EXIT?) (SETQ INTERRUPTED.STRING (CONCAT "Someone tried to use the machine at " (DATE (DATEFORMAT NO.DATE)))) (AND IDLE.PROCESS (WAKE.PROCESS IDLE.PROCESS)) (CLEARBUF T) (GO WAIT.FOR.CHAR))) EXIT (CLOSEW W) (FRESHLINE PROMPTWINDOW) (AND INTERRUPTED.STRING (PRINTOUT PROMPTWINDOW INTERRUPTED.STRING T)) (PRINTOUT PROMPTWINDOW "Idle time " (\IDLE.TIME START.TIME)))) (COND (\IDLE.PASSWORD.SET (* ; "Notify anyone who cares about login change, since we suppressed it earlier") (MAPC \AFTERLOGINFNS (FUNCTION APPLY*))))) -) + [LAMBDA (FROMTIMEOUT) (* ; "Edited 28-Sep-2022 09:05 by lmm") + (* ; "Edited 22-Sep-2022 15:04 by lmm") + (* ; "Edited 29-Jun-88 14:36 by drc:") + + (* ;; "This is the main idling loop. ") + + (RESETLST + (RESETSAVE NIL '(SETTOPVAL \IDLING NIL)) + (PROG [(START.TIME (ALTO.TO.LISP.DATE \LASTUSERACTION)) + VMEM.SAVED W SAVEVM.TIMER IDLE.PROCESS NO.ERROR EXIT? INTERRUPTED.STRING + IDLING.KEYACTIONS (IDLE.TIMEOUT (LISTGET IDLE.PROFILE 'TIMEOUT)) + (SAVEVM (LISTGET IDLE.PROFILE 'SAVEVM)) + (LOGOUT (LISTGET IDLE.PROFILE 'LOGOUT] + (COND + ((NOT (\OK.TO.IDLE?)) (* ; + "'Somebody in password prompt, better not idle") + (RETURN))) + (SETQ \IDLE.PASSWORD.SET NIL) + [COND + ((EQ (LISTGET IDLE.PROFILE 'FORGET) + 'FIRST) + + (* ;; + "do things like dump cache listings and flush files to servers *before* passwords get smashed") + + (\USEREVENT 'BEFORESAVEVM) + (\DEVICEEVENT 'BEFORESAVEVM) + (\DEVICEEVENT 'AFTERDOSAVEVM) + (\USEREVENT 'AFTERDOSAVEVM] + (RESETSAVE NIL (LIST (FUNCTION NOTIFY.EVENT) + \IDLING.OVER)) + [for X in IDLE.SUSPEND.PROCESS.NAMES bind PROC do + (* ; + "Turn off things like CROCK, LAFITEMAILWATCH, SPACEWINDOW, REMINDERS") + (COND + ((SETQ PROC (FIND.PROCESS X)) + (PROCESS.EVAL PROC '(\IDLE.WAIT] + (RESETSAVE \AFTERLOGINFNS NIL) (* ; + "So that SETPASSWORD doesn't trigger any activity") + [for X in IDLE.RESETVARS do (* ; + "turn off things like pup-trace, xiptrace and the like") + (RESETSAVE (SETTOPVAL (CAR X) + (EVAL (CADR X))) + (LIST (FUNCTION SETTOPVAL) + (CAR X) + (GETTOPVAL (CAR X] + (* ; + "so that mouse buttons will trigger READP") + (COND + ((EQ (LISTGET IDLE.PROFILE 'FORGET) + 'FIRST) + (SETQ \IDLE.PASSWORD.SET 'CLEAR) + (SETPASSWORD NIL (USERNAME NIL NIL T) + ""))) + (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) + + (* ;; "Note that IDLE has set up our KEYACTION table (in the add.process) to ignore interrupts and make mouse clicks trigger readp.") + + (RESETSAVE (CHANGENAME '\LOGIN.READ 'PROVIDE.PROMPTING.WINDOW '\IDLE.PROMPTING.WINDOW) + '(CHANGENAME \LOGIN.READ \IDLE.PROMPTING.WINDOW PROVIDE.PROMPTING.WINDOW)) + (COND + ((OR [AND FROMTIMEOUT (NOT (AND (SMALLP IDLE.TIMEOUT) + (\SECONDSCLOCKGREATERP \LASTUSERACTION + (TIMES IDLE.TIMEOUT 60] + (NOT (\OK.TO.IDLE?))) + + (* ;; "Check again if it's ok, since somebody could have fallen into a password prompter between then and now. Anybody who does after this is ok, because the CHANGENAME above is now in effect. Also check timeout again, in case there was a user interaction during the BEFORESAVEVM stuff") + + (RETURN))) + (CLEARW PROMPTWINDOW) + (SETQ W (CREATEW WHOLESCREEN NIL 0 T)) + (RESETSAVE NIL (LIST (FUNCTION CLOSEW) + W)) + [RESETSAVE (CURSOR (CURSORCREATE (BITMAPCREATE 0 0] + (SETQ VMEM.SAVED "Vmem not saved") + (if (VIDEOCOLOR) + then (OPENW W) + else (DSPOPERATION 'ERASE W) + (DSPTEXTURE BLACKSHADE W) + (CLEARW W)) + (CL:UNLESS (AND (SMALLP SAVEVM) + (> SAVEVM 0)) + (SETQ SAVEVM)) + (CL:UNLESS (AND (SMALLP LOGOUT) + (> LOGOUT 0)) + (SETQ LOGOUT)) + (if (AND SAVEVM LOGOUT (IGEQ SAVEVM LOGOUT)) + then + (* ;; "if LOGOUT is sooner than SAVEVM") + + (SETQ SAVEVM NIL)) + [if (OR SAVEVM LOGOUT) + then (SETQ SAVEVM.TIMER (SETUPTIMER (ITIMES (OR SAVEVM LOGOUT) + 60000] + (SETQ IDLE.PROCESS (ADD.PROCESS [CONS (LISTGET IDLE.PROFILE 'DISPLAYFN) + (CONS W (LISTGET IDLE.PROFILE 'DISPLAY.DATA] + 'NAME + 'IDLE.DISPLAY)) + (RESETSAVE NIL (LIST (FUNCTION DEL.PROCESS) + IDLE.PROCESS)) + (BLOCK) (* ; "Let the idler get started first") + WAIT.FOR.CHAR + (COND + ((NOT (READP T T)) + (BLOCK 250) (* ; "(\DIRTYBACKGROUND)") + (CL:WHEN (AND SAVEVM.TIMER (TIMEREXPIRED? SAVEVM.TIMER)) + (if SAVEVM + then (if (SAVEVM) + then + (* ;; "restarting after SaVEVM, end idle") + + (GO EXIT)) + (SETQ VM.SAVED (CONCAT "VM saved at " (DATE))) + (if LOGOUT + then (SETQ SAVEVM.TIMER (SETUPTIMER (CL:* (- LOGOUT SAVEVM) + 60000))) + (SETQ SAVEVM)) + elseif LOGOUT + then (LOGOUT) (* ; " could do (LOGOUT T) if SAVEVM") + + (* ;; "must be returning later") + + (GO EXIT))) + [COND + ((OR (KEYDOWNP 'LSHIFT) + (KEYDOWNP 'RSHIFT)) + (AND (PROCESSP IDLE.PROCESS) + (SUSPEND.PROCESS IDLE.PROCESS)) + (CLEARW PROMPTWINDOW) + (PRINTOUT PROMPTWINDOW (USERNAME NIL NIL T) + " Idle " + (\IDLE.TIME START.TIME) + T VMEM.SAVED T) + (until [NOT (OR (KEYDOWNP 'LSHIFT) + (KEYDOWNP 'RSHIFT] do (BLOCK 250)) + (AND IDLE.PROCESS (WAKE.PROCESS IDLE.PROCESS] + (TTY.PROCESS (THIS.PROCESS)) (* ; + "Keep us the tty process, even if someone else tries for it") + (GO WAIT.FOR.CHAR))) + (COND + ((PROCESSP IDLE.PROCESS) + (SUSPEND.PROCESS IDLE.PROCESS))) + [SETQ NO.ERROR (NLSETQ (SETQ EXIT? (\IDLE.EXIT?] + (COND + ((NOT NO.ERROR) + (SETQ INTERRUPTED.STRING "ERROR while checking Allowed Logins") + (SETPASSWORD NIL (USERNAME NIL NIL T) + "") + (SETQ \IDLE.PASSWORD.SET 'CLEAR)) + ((NOT EXIT?) + [SETQ INTERRUPTED.STRING (CONCAT "Someone tried to use the machine at " + (DATE (DATEFORMAT NO.DATE] + (AND IDLE.PROCESS (WAKE.PROCESS IDLE.PROCESS)) + (CLEARBUF T) + (GO WAIT.FOR.CHAR))) + EXIT + (CLOSEW W) + (FRESHLINE PROMPTWINDOW) + (AND INTERRUPTED.STRING (PRINTOUT PROMPTWINDOW INTERRUPTED.STRING T)) + (PRINTOUT PROMPTWINDOW "Idle time " (\IDLE.TIME START.TIME)) + + (* ;; "should be unnecessary (see RESETSAVE above)") + + (NOTIFY.EVENT \IDLING.OVER))) + (COND + (\IDLE.PASSWORD.SET (* ; + "Notify anyone who cares about login change, since we suppressed it earlier") + (MAPC \AFTERLOGINFNS (FUNCTION APPLY*]) (\IDLE.WAIT [LAMBDA NIL @@ -247,17 +412,18 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (while \IDLING do (BLOCK 500]) (\OK.TO.IDLE? - [LAMBDA NIL (* bvm%: " 4-Dec-85 15:05") - (RESETLST (OBTAIN.MONITORLOCK \GETPASSWORD.LOCK T T]) + [LAMBDA NIL (* bvm%: " 4-Dec-85 15:05") + (RESETLST + (OBTAIN.MONITORLOCK \GETPASSWORD.LOCK T T))]) (\IDLE.TIME - [LAMBDA (START.TIME) (* bvm%: "15-Oct-85 23:35") + [LAMBDA (START.TIME) (* bvm%: "15-Oct-85 23:35") (LET [(GONE (IDIFFERENCE (IDATE) START.TIME)) (ONEDAY (CONSTANT (IDIFFERENCE (IDATE "2-Jan-80 00:00:00") (IDATE "1-Jan-80 00:00:00"] (COND - ((ILESSP GONE ONEDAY) (* ; "Express in hours:min:sec") + ((ILESSP GONE ONEDAY) (* ; "Express in hours:min:sec") (GDATE (IPLUS (IDATE "1-Jan-80 00:00:00") GONE) (DATEFORMAT NO.DATE))) @@ -269,7 +435,7 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (T "."]) (\IDLE.OUT - [LAMBDA NIL (* bvm%: "16-Sep-85 18:34") + [LAMBDA NIL (* bvm%: "16-Sep-85 18:34") (AND (NOT \IDLING) (LET [(TIMEOUT (LISTGET IDLE.PROFILE 'TIMEOUT] (AND (SMALLP TIMEOUT) @@ -278,35 +444,98 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (IDLE T]) (\IDLE.EXIT? -(LAMBDA NIL (* ; "Edited 22-Nov-88 15:25 by drc:") (RESETLST (RESETSAVE (TTYDISPLAYSTREAM PROMPTWINDOW)) (CLEARBUF T) (PROG ((GROUP (LISTGET IDLE.PROFILE (QUOTE ALLOWED.LOGINS))) (AUTHTYPE (LISTGET IDLE.PROFILE (QUOTE AUTHENTICATE))) (TIMEOUT (LISTGET IDLE.PROFILE (QUOTE LOGIN.TIMEOUT))) (NAME (USERNAME NIL NIL T)) PWD WATCHER) (COND ((NLISTP GROUP) (* ; "no login check at all") (COND ((LISTGET IDLE.PROFILE (QUOTE FORGET)) (SETPASSWORD NIL NAME ""))) (RETURN T))) (COND ((EQ 0 (NCHARS NAME)) (* ; "Not logged in, so don't complain about anything") (RETURN T))) (OBTAIN.MONITORLOCK \GETPASSWORD.LOCK NIL T) (* ; "Lock out anyone else trying to prompt for a password") (CLEARW PROMPTWINDOW) (* ; "prompt for password, maybe new username") (SETQ PWD (COND ((AND (EQUAL GROUP (QUOTE (T))) NAME) (* ; "Only previous user allowed to login") (PROMPTFORWORD (CONCAT NAME " password:") NIL NIL NIL (QUOTE *) TIMEOUT)) (T (if TIMEOUT then (* ; "spawn process to watch for login. Done this way rather than timeout in \LOGIN.READ because we want to blow away timed-out password prompt, too.") (RESETSAVE NIL (LIST (QUOTE DEL.PROCESS) (SETQ WATCHER (ADD.PROCESS (BQUOTE (\IDLE.PROMPT.WATCHER (QUOTE (\, (THIS.PROCESS))) (\, TIMEOUT)))))))) (PROG1 (CDR (SETQ NAME (CAR (NLSETQ (\LOGIN.READ NIL NAME NIL NIL (QUOTE NS)))))) (SETQ NAME (MKSTRING (CAR NAME))) (if WATCHER then (DEL.PROCESS WATCHER)))))) (* ; "decide whether NAME and PWD are in GROUP") (RETURN (COND ((NULL PWD) NIL) ((AND (OR (MEMB T GROUP) (MEMB (QUOTE *) GROUP)) (\IDLE.IS.PREVIOUS NAME PWD (EQUAL GROUP (QUOTE (T))))) (* ;; "Previous user is allowed to login. Also, if only allowed login is old user, but old password is unknown, allow it") T) ((\IDLE.ISMEMBER GROUP NAME PWD) (COND ((OR (NULL AUTHTYPE) (\IDLE.AUTHENTICATE NAME PWD AUTHTYPE (NOT (MEMB T GROUP)) PROMPTWINDOW)) (SETPASSWORD NIL NAME PWD) (SETQ \IDLE.PASSWORD.SET T) T) (T (DISMISS 5000) (* ; "Let the error message be visible") NIL))) (T (PRINTOUT PROMPTWINDOW "login incorrect" T) (DISMISS 5000) (* ; "Let the error message be visible") NIL)))))) -) + [LAMBDA NIL (* ; "Edited 22-Nov-88 15:25 by drc:") + (RESETLST + (RESETSAVE (TTYDISPLAYSTREAM PROMPTWINDOW)) + (CLEARBUF T) + [PROG ((GROUP (LISTGET IDLE.PROFILE 'ALLOWED.LOGINS)) + (AUTHTYPE (LISTGET IDLE.PROFILE 'AUTHENTICATE)) + (TIMEOUT (LISTGET IDLE.PROFILE 'LOGIN.TIMEOUT)) + (NAME (USERNAME NIL NIL T)) + PWD WATCHER) + (COND + ((NLISTP GROUP) (* ; "no login check at all") + (COND + ((LISTGET IDLE.PROFILE 'FORGET) + (SETPASSWORD NIL NAME ""))) + (RETURN T))) + (COND + ((EQ 0 (NCHARS NAME)) (* ; + "Not logged in, so don't complain about anything") + (RETURN T))) + (OBTAIN.MONITORLOCK \GETPASSWORD.LOCK NIL T) (* ; + "Lock out anyone else trying to prompt for a password") + (CLEARW PROMPTWINDOW) (* ; + "prompt for password, maybe new username") + [SETQ PWD + (COND + ((AND (EQUAL GROUP '(T)) + NAME) (* ; + "Only previous user allowed to login") + (PROMPTFORWORD (CONCAT NAME " password:") + NIL NIL NIL '* TIMEOUT)) + (T [if TIMEOUT + then (* ; "spawn process to watch for login. Done this way rather than timeout in \LOGIN.READ because we want to blow away timed-out password prompt, too.") + (RESETSAVE NIL (LIST 'DEL.PROCESS + (SETQ WATCHER + (ADD.PROCESS `(\IDLE.PROMPT.WATCHER + ',(THIS.PROCESS) + ,TIMEOUT] + (PROG1 [CDR (SETQ NAME (CAR (NLSETQ (\LOGIN.READ NIL NAME NIL NIL 'NS] + (SETQ NAME (MKSTRING (CAR NAME))) + (if WATCHER + then (DEL.PROCESS WATCHER)))] (* ; + "decide whether NAME and PWD are in GROUP") + (RETURN (COND + ((NULL PWD) + NIL) + ([AND (OR (MEMB T GROUP) + (MEMB '* GROUP)) + (\IDLE.IS.PREVIOUS NAME PWD (EQUAL GROUP '(T] + + (* ;; "Previous user is allowed to login. Also, if only allowed login is old user, but old password is unknown, allow it") + + T) + ((\IDLE.ISMEMBER GROUP NAME PWD) + (COND + ((OR (NULL AUTHTYPE) + (\IDLE.AUTHENTICATE NAME PWD AUTHTYPE (NOT (MEMB T GROUP)) + PROMPTWINDOW)) + (SETPASSWORD NIL NAME PWD) + (SETQ \IDLE.PASSWORD.SET T) + T) + (T (DISMISS 5000) (* ; "Let the error message be visible") + NIL))) + (T (PRINTOUT PROMPTWINDOW "login incorrect" T) + (DISMISS 5000) (* ; "Let the error message be visible") + NIL])]) (\IDLE.PROMPT.WATCHER - [LAMBDA (PROC TIMEOUT) (* ; "Edited 3-Apr-87 13:56 by bvm:") - - (* ;; "Aborts proc if it goes for longer than TIMEOUT (in seconds) with no user action") + [LAMBDA (PROC TIMEOUT) (* ; "Edited 3-Apr-87 13:56 by bvm:") + + (* ;; "Aborts proc if it goes for longer than TIMEOUT (in seconds) with no user action") (do [DISMISS (TIMES 1000 (IMAX 1 (- TIMEOUT (- (\DAYTIME0 (create FIXP)) \LASTUSERACTION] - (* ; "Dismiss until expected timeout") + (* ; "Dismiss until expected timeout") (if (\SECONDSCLOCKGREATERP \LASTUSERACTION TIMEOUT) then (PROCESS.EVAL PROC '(\IDLE.EXIT.ABORT)) (RETURN]) (\IDLE.EXIT.ABORT - [LAMBDA NIL (* ; "Edited 3-Apr-87 13:37 by bvm:") - - (* ;; "Abort process if still sitting under login reader") + [LAMBDA NIL (* ; "Edited 3-Apr-87 13:37 by bvm:") + + (* ;; "Abort process if still sitting under login reader") (if (RELSTK (STKPOS '\LOGIN.READ)) then (ERROR!]) (\IDLE.PROMPTING.WINDOW - [LAMBDA (TITLE) (* bvm%: " 5-Nov-85 23:10") + [LAMBDA (TITLE) (* bvm%: " 5-Nov-85 23:10") -(* ;;; "Replaces PROVIDE.PROMPTING.WINDOW in \LOGIN.READ while idle is on") +(* ;;; "Replaces PROVIDE.PROMPTING.WINDOW in \LOGIN.READ while idle is on") - (RESETSAVE (INTERRUPTCHAR 5 'ERROR)) (* ; "Allow ^E to abort prompt") + (RESETSAVE (INTERRUPTCHAR 5 'ERROR)) (* ; "Allow ^E to abort prompt") (COND ((NEQ (PROCESSPROP (THIS.PROCESS) 'NAME) @@ -320,7 +549,7 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat '(WAKE.PROCESS IDLE.DISPLAY]) (\IDLE.IS.PREVIOUS - [LAMBDA (NAME PWD NULLOK) (* ; "Edited 26-Jan-89 22:38 by NSato.fx") + [LAMBDA (NAME PWD NULLOK) (* ; "Edited 26-Jan-89 22:38 by NSato.fx") (* ;;; "if the new name is the same as the old name, and the old global password wasn't forgotten, then allow the old password") @@ -332,31 +561,30 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (if (ZEROP (NCHARS OLDPWD)) then (SETQ OLDPWD)) (if (AND (EQ (MACHINETYPE) - 'MAIKO) - (NOT OLDPWD)) + 'MAIKO) + (NOT OLDPWD)) then + (* ;; "when Maiko is first booted the password is empty but we can check w/ UNIX to see if this is the same user s.t. ") - (* ;; "when Maiko is first booted the password is empty but we can check w/ UNIX to see if this is the same user s.t. ") + (* ;; + "UNIX only looks at first 8 chars of username, so ignore any extra chars typed.") - (* ;; - "UNIX only looks at first 8 chars of username, so ignore any extra chars typed.") - - (if (> (NCHARS PREVIOUS.USERNAME) - 8) - then (SETQ PREVIOUS.USERNAME (SUBSTRING PREVIOUS.USERNAME 1 8))) - (if (> (NCHARS NAME) - 8) - then (SETQ NAME (SUBSTRING NAME 1 8))) - (AND (STRING-EQUAL PREVIOUS.USERNAME NAME) - (SUBRCALL CHECKBCPLPASSWORD NAME PWD)) + (if (> (NCHARS PREVIOUS.USERNAME) + 8) + then (SETQ PREVIOUS.USERNAME (SUBSTRING PREVIOUS.USERNAME 1 8))) + (if (> (NCHARS NAME) + 8) + then (SETQ NAME (SUBSTRING NAME 1 8))) + (AND (STRING-EQUAL PREVIOUS.USERNAME NAME) + (SUBRCALL CHECKBCPLPASSWORD NAME PWD)) else (AND (STRING-EQUAL PREVIOUS.USERNAME NAME) - (COND - (OLDPWD (STRING-EQUAL OLDPWD PWD)) - (T (* ; "there was no password") - NULLOK]) + (COND + (OLDPWD (STRING-EQUAL OLDPWD PWD)) + (T (* ; "there was no password") + NULLOK]) (\IDLE.ISMEMBER - [LAMBDA (GROUP NAME PWD) (* ; "Edited 26-Dec-86 20:31 by cutting") + [LAMBDA (GROUP NAME PWD) (* ; "Edited 26-Dec-86 20:31 by cutting") (OR [for X in GROUP thereis (COND ((EQ X T) (STRING-EQUAL NAME (USERNAME))) @@ -399,11 +627,58 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat T]) (\IDLE.AUTHENTICATE -(LAMBDA (NAME PWD TYPE IFALLDOWN OUTPUT) (* ; "Edited 10-Jun-88 02:30 by drc:") (LET ((NS (AND (NEQ TYPE (QUOTE GV)) (NEQ TYPE (QUOTE UNIX)) CH.DEFAULT.DOMAIN)) (GV (AND (NEQ TYPE (QUOTE NS)) (NEQ TYPE (QUOTE UNIX)) DEFAULTREGISTRY)) (UNIX (AND (NEQ TYPE (QUOTE NS)) (NEQ TYPE (QUOTE GV)) (EQ (MACHINETYPE) (QUOTE MAIKO)))) CODE) (printout OUTPUT T "Authenticating " NAME " ... ") (COND ((EQ TYPE T) (* ;; "use heuristics to determine authentication type") (COND ((STRPOS ":" NAME) (* ; "probably wanted NS login") (SETQ GV) (SETQ UNIX) (SETQ NS T)) ((AND (STRPOS "." NAME) DEFAULTREGISTRY) (* ; "probably wanted GV login") (SETQ UNIX) (SETQ NS) (SETQ GV T))))) (OR (AND UNIX (EQ (MACHINETYPE) (QUOTE MAIKO)) (COND ((SUBRCALL CHECKBCPLPASSWORD NAME PWD) (SETQ CODE T)) (T (SETQ CODE (QUOTE Bad% login)) NIL))) (AND NS (EQ T (SETQ CODE (NS.AUTHENTICATE (NS.MAKE.SIMPLE.CREDENTIALS (CONS NAME (\ENCRYPT.PWD (CONCAT PWD)))))))) (AND GV (SETQ CODE (GV.AUTHENTICATE NAME (\ENCRYPT.PWD (CONCAT PWD)))))) (SELECTQ CODE (AllDown (printout OUTPUT "All authentication servers down" T) IFALLDOWN) ((T NIL) (printout OUTPUT "ok.") T) ((SimpleKeyDoesNotExist CredentialsInvalid BadRName BadPassword Bad% login) (printout OUTPUT CODE) NIL) (PROGN (printout OUTPUT T "Odd response from authenticator: " CODE) T)))) -) + [LAMBDA (NAME PWD TYPE IFALLDOWN OUTPUT) (* ; "Edited 10-Jun-88 02:30 by drc:") + (LET ((NS (AND (NEQ TYPE 'GV) + (NEQ TYPE 'UNIX) + CH.DEFAULT.DOMAIN)) + (GV (AND (NEQ TYPE 'NS) + (NEQ TYPE 'UNIX) + DEFAULTREGISTRY)) + [UNIX (AND (NEQ TYPE 'NS) + (NEQ TYPE 'GV) + (EQ (MACHINETYPE) + 'MAIKO] + CODE) + (printout OUTPUT T "Authenticating " NAME " ... ") + [COND + ((EQ TYPE T) + + (* ;; "use heuristics to determine authentication type") + + (COND + ((STRPOS ":" NAME) (* ; "probably wanted NS login") + (SETQ GV) + (SETQ UNIX) + (SETQ NS T)) + ((AND (STRPOS "." NAME) + DEFAULTREGISTRY) (* ; "probably wanted GV login") + (SETQ UNIX) + (SETQ NS) + (SETQ GV T] + [OR (AND UNIX (EQ (MACHINETYPE) + 'MAIKO) + (COND + ((SUBRCALL CHECKBCPLPASSWORD NAME PWD) + (SETQ CODE T)) + (T (SETQ CODE 'Bad% login) + NIL))) + [AND NS (EQ T (SETQ CODE (NS.AUTHENTICATE (NS.MAKE.SIMPLE.CREDENTIALS + (CONS NAME (\ENCRYPT.PWD (CONCAT PWD] + (AND GV (SETQ CODE (GV.AUTHENTICATE NAME (\ENCRYPT.PWD (CONCAT PWD] + (SELECTQ CODE + (AllDown (printout OUTPUT "All authentication servers down" T) + IFALLDOWN) + ((T NIL) + (printout OUTPUT "ok.") + T) + ((SimpleKeyDoesNotExist CredentialsInvalid BadRName BadPassword Bad% login) + (printout OUTPUT CODE) + NIL) + (PROGN (printout OUTPUT T "Odd response from authenticator: " CODE) + T]) (\IDLERKEYACTION - [LAMBDA NIL (* ; "Edited 23-Mar-92 13:20 by jds") + [LAMBDA NIL (* ; "Edited 23-Mar-92 13:20 by jds") (* ;; "Constructs a KEYACTION table for the IDLER process, by taking the (machine-dependent) original table and smashing the mouse buttons so that they transmit characters that cause the idler to wake up, and disabling the interrupts") @@ -435,13 +710,13 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (RPAQ? IDLE.KEYACTIONTABLE ) -(ADDTOVAR SYSTEMINITVARS (IDLE.PROFILE ALLOWED.LOGINS NIL FORGET NIL TIMEOUT 0 DISPLAYFN - IDLE.BOUNCING.BOX SAVEVM 10 AUTHENTICATE T LOGIN.TIMEOUT 30)) +(ADDTOVAR SYSTEMINITVARS (IDLE.PROFILE ALLOWED.LOGINS NIL FORGET NIL TIMEOUT 0 DISPLAYFN IDLE.RANDOM + SAVEVM 5 LOGOUT 5)) (ADDTOVAR IDLE.SUSPEND.PROCESS.NAMES MOUSE) (ADDTOVAR IDLE.RESETVARS (PUPTRACEFLG NIL) - (XIPTRACEFLG NIL)) + (XIPTRACEFLG NIL)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IDLE.PROFILE \IDLING \LASTUSERACTION IDLE.RESETVARS IDLE.SUSPEND.PROCESS.NAMES @@ -533,35 +808,34 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (IDLE.BOUNCING.BOX [LAMBDA (WINDOW BOX WAIT) (* ; "Edited 3-Sep-87 18:55 by jds") - - (* ;; "Bounce a window around the screen.") + + (* ;; "Bounce a window around the screen.") (OR WAIT (SETQ WAIT 1000)) (OR BOX (SETQ BOX IDLE.BOUNCING.BOX)) - (RESETLST (LET ((MAXX (WINDOWPROP WINDOW 'WIDTH)) - (MAXY (WINDOWPROP WINDOW 'HEIGHT)) - ORIGBOX X Y BITMAP) - [for TAIL on [SETQ BOX (COND - ((LISTP BOX) (* ; "don't want to trash user's box") - - (COPY BOX)) - (T (LIST BOX] unless (WINDOWP (CAR TAIL)) - do (* ; "Precompute everything but windows") - - (RPLACA TAIL (IDLE.BITMAP NIL (CAR TAIL] - (SETQ ORIGBOX BOX) - (while T do (SETQ BITMAP (IDLE.BITMAP BITMAP (CAR BOX))) - (SETQ BOX (OR (CDR BOX) - ORIGBOX)) (* ; "rotate it") - - [SETQ X (RAND (IDIFFERENCE MAXX (BITMAPWIDTH BITMAP] - [SETQ Y (RAND (IDIFFERENCE MAXY (BITMAPHEIGHT BITMAP] - (BITBLT BITMAP 0 0 WINDOW X Y NIL NIL NIL 'INVERT) - (BLOCK WAIT) - (BITBLT BITMAP 0 0 WINDOW X Y NIL NIL NIL 'INVERT]) + (RESETLST + [LET ((MAXX (WINDOWPROP WINDOW 'WIDTH)) + (MAXY (WINDOWPROP WINDOW 'HEIGHT)) + ORIGBOX X Y BITMAP) + [for TAIL on [SETQ BOX (COND + ((LISTP BOX) (* ; "don't want to trash user's box") + (COPY BOX)) + (T (LIST BOX] unless (WINDOWP (CAR TAIL)) + do (* ; "Precompute everything but windows") + (RPLACA TAIL (IDLE.BITMAP NIL (CAR TAIL] + (SETQ ORIGBOX BOX) + (while T do (SETQ BITMAP (IDLE.BITMAP BITMAP (CAR BOX))) + (SETQ BOX (OR (CDR BOX) + ORIGBOX)) (* ; "rotate it") + [SETQ X (RAND (IDIFFERENCE MAXX (BITMAPWIDTH BITMAP] + [SETQ Y (RAND (IDIFFERENCE MAXY (BITMAPHEIGHT BITMAP] + (BITBLT BITMAP 0 0 WINDOW X Y NIL NIL NIL 'INVERT) + (BLOCK WAIT) + (BITBLT BITMAP 0 0 WINDOW X Y NIL NIL NIL 'INVERT])]) (IDLE.BITMAP - [LAMBDA (BITMAP BOX) (* lmm "18-Jan-86 03:01") + [LAMBDA (BITMAP BOX) (* ; "Edited 16-Sep-2022 22:33 by larry") + (* lmm "18-Jan-86 03:01") (COND ((BITMAPP BOX) BOX) @@ -585,8 +859,8 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (OR (BITMAPP (CAR BOX)) (CAR (RPLACA BOX (IDLE.BITMAP NIL (CAR BOX] (T (LET ((FONT (OR (FONTCREATE 'TIMESROMAND 36 NIL NIL NIL T) - (PROGN (* ; - "Shouldn't happen unless somebody flushed TIMESROMAND 36 -- don't want to break") + (PROGN (* ; + "Shouldn't happen unless somebody flushed TIMESROMAND 36 -- don't want to break") (FONTCREATE 'HELVETICA 12 NIL NIL NIL T)) DEFAULTFONT)) DSP) @@ -595,7 +869,7 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat (LITATOM BOX)) (NEQ (NCHARS BOX) 0))) - (SETQ BOX "Xerox Lisp"))) + (SETQ BOX "Interlisp.org"))) (SETQ BITMAP (BITMAPCREATE (STRINGWIDTH BOX FONT) (FONTHEIGHT FONT))) (SETQ DSP (DSPCREATE BITMAP)) @@ -605,24 +879,42 @@ Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporat DSP) (PRIN3 BOX DSP) BITMAP]) + +(IDLE.RANDOM + [LAMBDA (W) (* ; "Edited 28-Sep-2022 19:46 by lmm") + (LET ([N (IF (BOUNDP 'LAST.IDLE.FUNCTION) + THEN [IF (IGREATERP (SETQ LAST.IDLE.FUNCTION (SUB1 LAST.IDLE.FUNCTION)) + 0) + THEN LAST.IDLE.FUNCTION + ELSE (SETQ LAST.IDLE.FUNCTION (SUB1 (LENGTH IDLE.FUNCTIONS] + (SETQ LAST.IDLE.FUNCTION) + ELSE (RAND 1 (SUB1 (LENGTH IDLE.FUNCTIONS] + CHOICE) + (for FN in IDLE.FUNCTIONS when (NEQ 'Random (CAR FN)) + do (if (< (SETQ N (SUB1 N)) + 1) + then (PROMPTPRINT "Idle display " (CAR FN)) + (DISMISS 1000) + (RETURN (APPLY* (EVAL (CADR FN)) + W]) ) (RPAQ? IDLE.BOUNCING.BOX (BITMAPCOPY LOGOBITMAP)) -(RPAQ? IDLE.FUNCTIONS '[("Bouncing Box" 'IDLE.BOUNCING.BOX) - ("Bouncing Username" '(LAMBDA (W) - (IDLE.BOUNCING.BOX W (USERNAME NIL NIL T]) +(RPAQ? IDLE.FUNCTIONS '(["Bouncing Box" #'(LAMBDA (W) + (IDLE.BOUNCING.BOX W (USERNAME NIL NIL T] + (Random 'IDLE.RANDOM))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IDLE.FUNCTIONS IDLE.BOUNCING.BOX) ) -(PUTPROPS IDLER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1989 1990 1992)) +(PUTPROPS IDLER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1989 1990 1992 2022)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (7561 30612 (IDLE 7571 . 8016) (IDLE.SET.OPTION 8018 . 11322) (IDLE.SHOW.OPTIONS 11324 - . 11892) (IDLE.SHOW.OPTION 11894 . 13350) (\IDLER 13352 . 18468) (\IDLE.WAIT 18470 . 18573) ( -\OK.TO.IDLE? 18575 . 18747) (\IDLE.TIME 18749 . 19535) (\IDLE.OUT 19537 . 19914) (\IDLE.EXIT? 19916 . -22009) (\IDLE.PROMPT.WATCHER 22011 . 22673) (\IDLE.EXIT.ABORT 22675 . 22959) (\IDLE.PROMPTING.WINDOW -22961 . 23700) (\IDLE.IS.PREVIOUS 23702 . 25594) (\IDLE.ISMEMBER 25596 . 28199) (\IDLE.AUTHENTICATE -28201 . 29526) (\IDLERKEYACTION 29528 . 30610)) (35906 39471 (IDLE.BOUNCING.BOX 35916 . 37472) ( -IDLE.BITMAP 37474 . 39469))))) + (FILEMAP (NIL (7318 37338 (IDLE 7328 . 7776) (IDLE.SET.OPTION 7778 . 11077) (IDLE.SHOW.OPTIONS 11079 + . 11643) (IDLE.SHOW.OPTION 11645 . 13169) (\IDLER 13171 . 22573) (\IDLE.WAIT 22575 . 22678) ( +\OK.TO.IDLE? 22680 . 22858) (\IDLE.TIME 22860 . 23642) (\IDLE.OUT 23644 . 24017) (\IDLE.EXIT? 24019 . +28005) (\IDLE.PROMPT.WATCHER 28007 . 28653) (\IDLE.EXIT.ABORT 28655 . 28923) (\IDLE.PROMPTING.WINDOW +28925 . 29660) (\IDLE.IS.PREVIOUS 29662 . 31521) (\IDLE.ISMEMBER 31523 . 34126) (\IDLE.AUTHENTICATE +34128 . 36248) (\IDLERKEYACTION 36250 . 37336)) (42593 47107 (IDLE.BOUNCING.BOX 42603 . 44066) ( +IDLE.BITMAP 44068 . 46171) (IDLE.RANDOM 46173 . 47105))))) STOP diff --git a/sources/IDLER.LCOM b/sources/IDLER.LCOM index ec449ac1da8753967e7ba3b94b3bc2f02cf3698a..276b58a3cf82cc4798c4757227f13f938d051cbc 100644 GIT binary patch delta 7433 zcmd5>eQaD;R`>X0lT6aYUx}S@VqZ_wWbE3L_ujnuc$3u0^UNE2?D2b(_uhEy#O=hj z-Po~Xr?x{I5KI>dgcg>CT&Z+bq|*LDR{|Bs-Uw(4v%nt+EdutBU8#VUrqC^-&`q>u zg{ZdSckg>M9=loSpNyiLd(S)f+;h%7pVzPcndkMt@chP5(d!MQ(itsbYO1XziC>EK zTXWa@B|(yisKmo^To(K!;GbE!c70)KZkDVp6F>R6q&52UXXjV0%?&I~udd!4xHdPt zGhRcRs;4-4_A z82#ef?BUc&JQ?%S?|S~x5P~DOZ?@A)=&)3A|ucUjJv|KYt141GUo z@dijJM*KlP2}#7?N1$K&<^8Q5@7Bxv|Bw;WAG?Q9IQSgK-#REf=bhpvp$dW^vO(e$ z!6vCWP=nuPHtb_VV@*IIx?!hNlR<4<(`{UxOxX6cJ`^;@H4}iIUG&7T!=Z3!^`ti- z#zarw6uQzsf5KLrZrQ`8lJp;8~NM+Qa zUIqR=z8Z~fzHCa2+JlxP!a`y5ppJK91KXS=CkdkS1yy(9(d-)ZigV3Qab zAJfKymO2i1#9AS}S<^^pTCzW(S{lce1(Gt2F*`k`89BR$H2lknh8oWbQ{Vio&zB$e z%?w{=D-Qa>3jHkLYijzWx#{n^_A>A{>wfWe!y4^uF^defbeRDQ&2@K9U176Xei1%C zpZ79IiIa5jHnJZ6{mvevxpw2*{0IkW6wR{T?bj$X}biHlQOnB|Pzx?S6`^xvG0b1QrUUl&NJ&{;Cb`|rQMw8tPzdp>x# z&|X?J+CMBDD;0btaUJGxOMwsZvNu!hZh#F-rv$3Ry1(pcw?cr zR0x!eUWZsOC*}t+|A&Q>rNW7lancAFCm6Bcy!sL-ym8yJN9Sz3tkcwyY;8V6-)lHh zbm(rAl}iPwWXKL#nUn1U*}e}8La7ie8G<1h!ELfzgS!a~lnQ4{#(+a$fD?#-K;*+h zyi|yljJR>uh*by_?|d7<9xH{*6o^CI10ZXemOIl(&*-!<$E3-`R;O#-}C(28@EO` zzs3i;|h%>`g~hgyK8ydf|QKLO`p-o)K1@N^Vb^(x89=n+FFa) zQ4xK?k@+W{nt&J%Uwb@)CJeP@bSRq+6 zt&0H43J=g)kVPc6mMWj52(dL2h@>dW2-EJCkP<@()2v}cb?gYmqF}+Wv^?e!g&;I$ zRm;j7W)c9Ll(RHbR~hk;6mt$U%gIEH5K&U1#L8J&O;2t!E-3=eL+rGyED?)ROd=U$ z2oV$b5s^&c#Kfq8g^bf(0VVM62q=NuommS2QG^1Rl%_V3O`BTs96(Wt*!JZ1xnelB zONAm%C=RmYh$tvHdQ_Wa;@F0s8ynP2K%uBdKt-J9s83PK`c`5Uohs3?MwN)mt#bzo zSa4LWlrN)56lAB0A{EKK^*m8TWUXDwQv^oY)m;qie~!6m^bvAI!(rmc8I@&%qB4o> zhm;3cKZK8pB2kmuR}`tbh6wJFn_-@W6@@V}l&V2H%`S#?wj7NEjKzBwKjnC1C+PrR^~_>jLDcOq^++$PuB; zi3};GjM1QN1X%%dj>t&#$4<8wV?gJ%AGgYo9NS?6Ayx-e*>DKebVc)0RA3)%Ba8Zg zNVqtSPvAvE+hD1pf0RKCPk_gy%jR8Vjv0$p(GjDOs_kM3H^xrnB^0xFGL=LviaLVT zR4`hY%MO45LAN(Rv(;jwj)KF>%p%6Jc0R3VlLlN>#wit$1Chkt5SZ{zoRAXQ4T%Z# z!BER_csK5t8v&*$wA?Zd3n4TWXhjmDZ4*A_U}l`L{pS1@i_oAxnM=65Dvk`?hsW8?~+v6 ztuO_(>W(cjxU0)`jNRc5rlXNandd0;9Oq-v6$!lrNotvj2BNTW-i{>GRyLzflBggO zZmtpBfC~&F*r_A}Q{t%Lg|&kKh-HkFP9m_a9iPL9VUGC^stNjO=b-}#+Hgw?UK(P) z+kRC>ymGydB@H*a%a9;HY-BVG&Zg-^M!eV|zl^ZNkmbk$Zim#4J4u;r`l^pncgO? z3y2S^k3hbrI}e&}Rv`e#66dYvIl z0{x(yGhP3uF! z;#b^PjXfu=L(UBaSv=rh7f#OMo#Ag!D$Zlbfm27>Nm320GD`_Z}(t1?}{Yd)7S1X@Bo? z12Gmd$I?j6GEB{_+hn0!w}ljxmM%glih6ZhRWQ{U{Z8+Z<6(m4e-MGoF%B&Vd;m}( zqVA=t)>1^ca&ZuFII@Ib?8Hzw9WR+B#A~;pl_CiBRY^gDgN%(@HY)cacmy&Gck69E zIIlBeEVQFggF8C0u>omciqKb|yo9@R3VOFBU>Q(G6|p0nhhiZXWBMT=>j|n*koFZ;DRu;Jh2M+a ztHt7v&ioMLH_k3#Y<}wTqi*~~spjT?Mk@esq}}#mI`h;^osb|*%=FMOOVDI2okUz^ zuAR|R2Yc*#fVwND?J)1Xk8z&huKZIGgKnbY%&YW ziYmmMUY=dKM&P=KAF zoJn?`i4_7qHIg&9wXGz3koIX)7+=s581HHf;!n->dEJT_^=|bAy7f=ETq1>gdPsnN zlnP;6=a5LVLo#L`r8?+qL(Oz^s1K{}4=J>LxF0iZSfVcui67-ud; z-_Ezur^ol<+vW5b`p;u*wYPz=znRcdI>En_`~iIL%Ma4i6MO3U)|>eWEcQ0Q$$|L& z{Nx@~2z)*;aS_OZag=^G`4}xtFfVv7^8_W6Phs}VWD4VJ87A+6i|i%;`lT-VYZuRA z_E#52F&@&{{_B^RrXFNkv2P#!NKaxV7%agyO>|Oy>M{D4Q;hOY45mLd`z*%p3x{dx z=`3cA&qy5FMW-%k?8`H)^qpto^!^3*2a0_rqkYYcAE?$bebXcWzf@?W|77<15}A0} z07xLCjtwSN5`gyvymZX!vq`|UsDP6SsxGUC|43jcV+^VpUV}T%Sf*z=$5uN&+v24g zRv_UGm|6A0xpGwodvex^;b2lrskw|D#9yUQ^;EvNU{f1PBco1&PKVtANuu^-cNJU2 z`v@aKy<$HJ+)r(GIq~7gF+QF1V|*#clmuI$pXT7Q^nCgfAG_$?^bnu5QIcn2bS2M} z|JNhza$*zgO8;M8zTeU01u{52vv_57<;L>t*xd3B!tB=hMCg8#If-g^>~YmjJ#{U# wSZLo{z6N^F4D7G64SLS%6WCw67##v{!0-RE4KF=&dGY|>QX~ntj(y($0W%PRasU7T delta 6986 zcmd^EYiwM{b>@=P!;+RF^&&-4 z{bueixl5`*^SgpDJNL|)Gv}N+&*58t7Wkv@1%7|55)7y8jFoULvtT7jNQw>Jm|Yn% zbRsHoNr}rwh=fCPt1rK@w7f7+R#!-fd^YK&UmIRtT7PA3b#39=`s&8o+`{@bJDIWE z=oK+Sf+1NL%FeD088IRWaaoQFN{D=#QCS|CCrcobU6@~9_zV#%%8D`Um8rMQ(VIo@l-8QaSz9M`($ zIYl>Nc{Lv8SBY#GF^SAo7H3y(Ev%C}tLNh+TryoRNVp&gC+kH>IF<9rGzX-uDKk;9 zom_;xvbONcORF2}oL%e-i7J@+%#a}vQICsSToywl_8xUpJLM{U&!>I-@JwqkEGjf|=xjI`CbCXKxE@&| zp+SPXVBAK%oo)Up-#z@T00`d+eu%Nu_9Di2+k~Z{uRzAS$OegHhf_r0s*H;0nEaRJ#DybrR1x zZr04eaQ5!;(eJhQ($~XhTS=Zs^!x26E{Nn}-gOd|l^jZ#p5wpo;! z{QDrK$Q3XsK1~DSUKL=6K|dTi5m0D*NB=cZ;YzybTF_DoYKP`hV3nj?CtI+ymQyS+ zfcg}ri5k<|(7t1BtxW;0s>S*4?s8A}T+a;C69@fs$8Q`w$i5!7{N`rs`}AKr+zP{Z zG{b-|w7h+l>vWOpcd@&B(I@bTL+3fP+s8P>Haz0w{mu8C0AGK5f3ErdxA9EcZSboMESO1_o}n?+Y*~ zTJjv|v@Z|;fRo_BE89}G2z;HN>2tbxd+7+H^KDMZW@6Sf<#Ty^o)h9**idPzQw1l? zcRqR0#ebJ-^3=4&Q63P!czgGvZ@c$Z|8QSLE1!H~`!f#3XTz>EF38{J3&4>E_5~h< z`D}@AeQ;*ExsPw-^7=R{|2p%7|9qzoVAK4Gp2~OlYPvyk&h(=tU-U0-2K43s;?y4b z3w(Ti@tx%nPHlPL`#-(?S#a2>6A$|xRgVPEMM~m=mNmohPOj}VNKRpi+O(O{>moN)# zE|DY(49t*p^RAr}F;yf#^hH^Oz;{KCZLf(2DOfHr0T=WdSj3qr1ex)Sox=`Mm%xJK zS!K*s#2~AXH$AWHxJdwF3MqP)n==`49K1Wu#)v2w*i`iLRxSy~D~SAzb3xZ|ApbyM z6f~U_3R63R3987W9S?TJT-nayG$DpKo-Lu^fVe_T+S zm$FX!Isk%5DohWqHJP_vD|ww5y3(jpLsQ6T#z~}!0coo0F+j;zsDUiVbEB_M-C$BM zP3yW?n`z>XPIQ%N4;NS_IvDnfm6{@aJ?ILfTvdZ+KqSvBS*7f#nMjYhP7z{jI<%U! z-NIBoP&2A*YN}39SSIsCQ-vA~mux1Py8TmBsCOEdm`DqKM8$@BwWtbI=Ci0u3eER+ z4XMaRNiScpCJRN^BC5bYoxJ6mtUe+!Tpqr1WfIc_wxbe@X{2N)Ehph*p!*nT)_+P8 z$(o6A7*t^@Z;=?vtLiPqa3}uMFOP|0sASYGWX*gH0HgD#WunA{8n23sn{d+6f)llq z2Qt=mqDV4*>%yrDk#UEKaWgk&al4dJSk)Vs3~uVJSQe$73zMKkEEb$R$`B&OV#MMT z*&t&(U}W8@Zc#S@Pc#gYf{ikbS9}A<1?|ugRjqEjsKm%vV$2+aNou%Tt7M}bV)Yk+ z@YBqp{4ajUgj;OPE zP>&;OF*?$B;*2P2)jNR0!`o`rlPC)G%ROf*f+mw`x0uVZk`pAV?yjg$@n_U!Fn1ts zyR1~R2Ij3gTZJ~G4nqc{Qpb!2FGyOMZ7pcH3SQJF(K2PsDWW07 za1+%;jZ}eA#Bh^nut|=JQ(5mwG$B^QNagTVrBqv1abH|nSF=Rb<;J}#f>2eHDpEsj z3R`J7LKRi!%fT1|Hay*fpQ=0_RAPuH4ektX9oI}cMA40!Co9}8c%o1csLSI{#`55} zR*onz_y+YUV)d4ot@|AxnnjJ&%2*jUvcubc$S>B72 z@=4fFn`P53M5q$Fc%<56`i;_G56Se)AriPk|1@-=^I<11y}mFX=m@mjP9JSM-rVx` zM~n2p`Sa8`ceptirloUnJgZbYv?!y>2|cah?cQm4IoY=s+gAb~`DNMt$LJ2lYT887 zWQ1z1a2Q-OrV*d~?yi1lyDQ{Or7U)Yod1 z^@4oWyRd*4f^T0idUv#CP1*%6LETFMZ6EmEK{T}6Ej>(>e$G5hsvxxgUT40G5jvm)aKF zL$J0=C~}G(k&!3(78Wl2$#zzROYsU=g5y^Ua8^0gM|%lDFPruXC=bUFK@>WC>2#0K zP?w2_S=G`Dc^ZcC+^2$J1y0F{x%FCvWLb%C&?UrWrAAmL%7 zyB{UUp77;L_$d! zBCpJ@um8&G+I*ZjyojjK-;039)}g-;9<+S5b33Y;`Ws#Uo0-!}vX!#F z&Rp&~RYxRhjyi7D%Had4)X4_Uciln4lfbuzQ1LH^9EsWE8uB%G1!R|Qz`}&9MN$_h|9%KB2 z;U$b851%{fLsYvAc(LH+A0t~qi@#%LIm%_7s(Y8y0f@I))r=$$^62Lvm48ILRbj06iTJ> zE_$wXj;@Ti;pkV#6+nkD`_cFyJ!~78CG8>Vmb&N{>~4I0%@*mqB?YtRCp+mgXHJMcF zG@oUZm!C~x{L3s;M)z|JGm!73-*gVrH=koCJjtao4m;0ouVgUmcTQ2^*#q>G=_J11 z%bcc;dxS1MKZ39CP4?3KL>qmakK?Q31;*LL%|7~j6KwXk6O5dj$%(~Hv&JVNiz9LCp?f~xvqV9!l4{f9TS;y#+y;jV21nCb8;Y-1= zn>Qz}*Ckv3J24(jS}C)bDMXV_*0giLzg+CZlfA#rkJ$E}f;pP8fH7B`y1w_cU&P{q z^dF0tpq6J!S22#2&S8A16vBA7#FY2{%4~XkZBLNV*}0c)t-%uJvkNO51b+;HvdN4F rg{*jIFy5IFF@AmKvi^(Ol8+B}{>jWmW=*Z!G=^uV4!}g%UtRtOa&P78