Recompile with COMPILE-FIILE (#611)
This commit is contained in:
Larry Masinter
GitHub
227
lispusers/LIFE
227
lispusers/LIFE
@@ -1,119 +1,156 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
|
||||
(filecreated "20-Aug-88 12:18:43" {erinyes}<lispusers>medley>life.\;5 8231
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
|previous| |date:| " 6-Mar-87 19:11:20" {erinyes}<lispusers>medley>life.\;3)
|
||||
(FILECREATED " 6-Dec-2021 15:21:48" |{DSK}<home>medley>medley>lispusers>LIFE.;3| 9875
|
||||
|
||||
|changes| |to:| (VARS LIFECOMS)
|
||||
(FNS EXPAND.BITMAP.VERTICALLY)
|
||||
|
||||
|previous| |date:| "20-Aug-88 12:18:43" |{DSK}<home>medley>medley>lispusers>LIFE.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1987-1988 by Xerox Corporation.
|
||||
|
||||
(prettycomprint lifecoms)
|
||||
(PRETTYCOMPRINT LIFECOMS)
|
||||
|
||||
(rpaqq lifecoms
|
||||
((functions |Life| |LifeIdle|)
|
||||
(fns expand.bitmap.vertically expand.bitmap.horizontally)
|
||||
(addvars (idle.functions ("Life" '|LifeIdle| nil (subitems ("Single bits" '|LifeIdle|)
|
||||
("Double bits" '(lambda (\w)
|
||||
(RPAQQ LIFECOMS
|
||||
((PROP FILETYPE LIFE)
|
||||
(FUNCTIONS |Life| |LifeIdle|)
|
||||
(FNS EXPAND.BITMAP.VERTICALLY EXPAND.BITMAP.HORIZONTALLY)
|
||||
(ADDVARS (IDLE.FUNCTIONS ("Life" '|LifeIdle| NIL (SUBITEMS ("Single bits" '|LifeIdle|)
|
||||
("Double bits" '(LAMBDA (\w)
|
||||
(|LifeIdle|
|
||||
\w 2)))
|
||||
("Quadruple bits"
|
||||
'(lambda (\w)
|
||||
'(LAMBDA (\w)
|
||||
(|LifeIdle| \w 4)))
|
||||
("Eight bits" '(lambda (\w)
|
||||
("Eight bits" '(LAMBDA (\w)
|
||||
(|LifeIdle|
|
||||
\w 8)))))))))
|
||||
|
||||
(cl:defun |Life| (win &optional (n 1))
|
||||
(let* ((w (windowprop win 'width))
|
||||
(w1 (idifference w n))
|
||||
(h (iquotient (windowprop win 'height)
|
||||
n))
|
||||
(h1 (sub1 h))
|
||||
(a (bitmapcreate w h))
|
||||
(b (bitmapcreate w h))
|
||||
(c (bitmapcreate w h))
|
||||
(d (bitmapcreate w h))
|
||||
(e (bitmapcreate w h))
|
||||
pbt temp)
|
||||
(|if| (neq n 1)
|
||||
|then| (setq temp (bitmapcreate (iquotient w n)
|
||||
h))
|
||||
(setq pbt (|create| pilotbbt))
|
||||
(bitblt win 0 0 temp 0 0)
|
||||
(expand.bitmap.horizontally temp n a pbt)
|
||||
(setq temp (bitmapcreate w (windowprop win 'height)))
|
||||
(bitblt a 0 0 temp 0 0 w h)
|
||||
|else| (bitblt win 0 0 a 0 0 w h))
|
||||
(cl:loop (block)
|
||||
(cl:macrolet ((bitbltbitmap (source sourceleft sourcebottom destination
|
||||
destinationleft destinationbottom width height
|
||||
&optional sourcetype operation)
|
||||
`(\\bitblt.bitmap ,source ,sourceleft ,sourcebottom
|
||||
,destination ,destinationleft ,destinationbottom
|
||||
,width
|
||||
,height
|
||||
,sourcetype
|
||||
,operation nil nil ,sourceleft ,sourcebottom))
|
||||
(shuffle (inhi lo horiz?)
|
||||
`(progn ,@(|if| horiz?
|
||||
|then| `((bitbltbitmap ,inhi n 0 ,lo 0 0 w1 h)
|
||||
(bitbltbitmap ,inhi 0 0 ,lo w1 0 n h)
|
||||
(bitbltbitmap ,inhi 0 0 c n 0 w1 h)
|
||||
(bitbltbitmap ,inhi w1 0 c 0 0 n h))
|
||||
|else| `((bitbltbitmap ,inhi 0 1 ,lo 0 0 w h1)
|
||||
(bitbltbitmap ,inhi 0 0 ,lo 0 h1 w 1)
|
||||
(bitbltbitmap ,inhi 0 0 c 0 1 w h1)
|
||||
(bitbltbitmap ,inhi 0 h1 c 0 0 w 1)))
|
||||
(bitbltbitmap c 0 0 ,lo 0 0 w h 'input 'invert)
|
||||
(bitbltbitmap ,lo 0 0 c 0 0 w h 'input 'erase)
|
||||
(bitbltbitmap ,inhi 0 0 ,lo 0 0 w h 'input 'invert)
|
||||
(bitbltbitmap ,lo 0 0 ,inhi 0 0 w h 'input 'erase)
|
||||
(bitbltbitmap c 0 0 ,inhi 0 0 w h 'input 'paint))))
|
||||
(shuffle a b t)
|
||||
(shuffle b d nil)
|
||||
(shuffle a e nil)
|
||||
(bitbltbitmap d 0 0 c 0 0 w h)
|
||||
(bitbltbitmap b 0 0 c 0 0 w h 'input 'invert)
|
||||
(bitbltbitmap e 0 0 c 0 0 w h 'input 'invert)
|
||||
(|if| (eq n 1)
|
||||
|then| (bitblt win 0 0 d 0 0 w h 'input 'paint)
|
||||
|else| (bitbltbitmap temp 0 0 d 0 0 w h 'input 'paint))
|
||||
(|if| (shiftdownp 'ctrl)
|
||||
|then| (bitbltbitmap d 0 0 a 0 0 w h)
|
||||
|else| (bitbltbitmap b 0 0 e 0 0 w h 'input 'paint)
|
||||
(bitbltbitmap e 0 0 a 0 0 w h 'input 'invert)
|
||||
(bitbltbitmap c 0 0 a 0 0 w h 'input 'erase)
|
||||
(bitbltbitmap d 0 0 a 0 0 w h 'invert 'erase))
|
||||
(|if| (eq n 1)
|
||||
|then| (bitblt a 0 0 win 0 0 w h)
|
||||
|else| (expand.bitmap.vertically a n temp pbt)
|
||||
(bitblt temp 0 0 win 0 0)
|
||||
(bitbltbitmap a 0 0 temp 0 0 w h))))))
|
||||
(PUTPROPS LIFE FILETYPE :COMPILE-FILE)
|
||||
|
||||
(cl:defun |LifeIdle| (\w &optional (\n 1))
|
||||
(bitblt (windowprop \w 'imagecovered)
|
||||
(CL:DEFUN |Life| (WIN &OPTIONAL (N 1))
|
||||
(LET* ((W (WINDOWPROP WIN 'WIDTH))
|
||||
(W1 (IDIFFERENCE W N))
|
||||
(H (IQUOTIENT (WINDOWPROP WIN 'HEIGHT)
|
||||
N))
|
||||
(H1 (SUB1 H))
|
||||
(A (BITMAPCREATE W H))
|
||||
(B (BITMAPCREATE W H))
|
||||
(C (BITMAPCREATE W H))
|
||||
(D (BITMAPCREATE W H))
|
||||
(E (BITMAPCREATE W H))
|
||||
PBT TEMP)
|
||||
(|if| (NEQ N 1)
|
||||
|then| (SETQ TEMP (BITMAPCREATE (IQUOTIENT W N)
|
||||
H))
|
||||
(SETQ PBT (|create| PILOTBBT))
|
||||
(BITBLT WIN 0 0 TEMP 0 0)
|
||||
(EXPAND.BITMAP.HORIZONTALLY TEMP N A PBT)
|
||||
(SETQ TEMP (BITMAPCREATE W (WINDOWPROP WIN 'HEIGHT)))
|
||||
(BITBLT A 0 0 TEMP 0 0 W H)
|
||||
|else| (BITBLT WIN 0 0 A 0 0 W H))
|
||||
(CL:LOOP (BLOCK)
|
||||
(CL:MACROLET ((BITBLTBITMAP (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION
|
||||
DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT
|
||||
&OPTIONAL SOURCETYPE OPERATION)
|
||||
`(\\BITBLT.BITMAP ,SOURCE ,SOURCELEFT ,SOURCEBOTTOM
|
||||
,DESTINATION ,DESTINATIONLEFT ,DESTINATIONBOTTOM
|
||||
,WIDTH
|
||||
,HEIGHT
|
||||
,SOURCETYPE
|
||||
,OPERATION NIL NIL ,SOURCELEFT ,SOURCEBOTTOM))
|
||||
(SHUFFLE (INHI LO HORIZ?)
|
||||
`(PROGN ,@(|if| HORIZ?
|
||||
|then| `((BITBLTBITMAP ,INHI N 0 ,LO 0 0 W1 H)
|
||||
(BITBLTBITMAP ,INHI 0 0 ,LO W1 0 N H)
|
||||
(BITBLTBITMAP ,INHI 0 0 C N 0 W1 H)
|
||||
(BITBLTBITMAP ,INHI W1 0 C 0 0 N H))
|
||||
|else| `((BITBLTBITMAP ,INHI 0 1 ,LO 0 0 W H1)
|
||||
(BITBLTBITMAP ,INHI 0 0 ,LO 0 H1 W 1)
|
||||
(BITBLTBITMAP ,INHI 0 0 C 0 1 W H1)
|
||||
(BITBLTBITMAP ,INHI 0 H1 C 0 0 W 1)))
|
||||
(BITBLTBITMAP C 0 0 ,LO 0 0 W H 'INPUT 'INVERT)
|
||||
(BITBLTBITMAP ,LO 0 0 C 0 0 W H 'INPUT 'ERASE)
|
||||
(BITBLTBITMAP ,INHI 0 0 ,LO 0 0 W H 'INPUT 'INVERT)
|
||||
(BITBLTBITMAP ,LO 0 0 ,INHI 0 0 W H 'INPUT 'ERASE)
|
||||
(BITBLTBITMAP C 0 0 ,INHI 0 0 W H 'INPUT 'PAINT))))
|
||||
(SHUFFLE A B T)
|
||||
(SHUFFLE B D NIL)
|
||||
(SHUFFLE A E NIL)
|
||||
(BITBLTBITMAP D 0 0 C 0 0 W H)
|
||||
(BITBLTBITMAP B 0 0 C 0 0 W H 'INPUT 'INVERT)
|
||||
(BITBLTBITMAP E 0 0 C 0 0 W H 'INPUT 'INVERT)
|
||||
(|if| (EQ N 1)
|
||||
|then| (BITBLT WIN 0 0 D 0 0 W H 'INPUT 'PAINT)
|
||||
|else| (BITBLTBITMAP TEMP 0 0 D 0 0 W H 'INPUT 'PAINT))
|
||||
(|if| (SHIFTDOWNP 'CTRL)
|
||||
|then| (BITBLTBITMAP D 0 0 A 0 0 W H)
|
||||
|else| (BITBLTBITMAP B 0 0 E 0 0 W H 'INPUT 'PAINT)
|
||||
(BITBLTBITMAP E 0 0 A 0 0 W H 'INPUT 'INVERT)
|
||||
(BITBLTBITMAP C 0 0 A 0 0 W H 'INPUT 'ERASE)
|
||||
(BITBLTBITMAP D 0 0 A 0 0 W H 'INVERT 'ERASE))
|
||||
(|if| (EQ N 1)
|
||||
|then| (BITBLT A 0 0 WIN 0 0 W H)
|
||||
|else| (EXPAND.BITMAP.VERTICALLY A N TEMP PBT)
|
||||
(BITBLT TEMP 0 0 WIN 0 0)
|
||||
(BITBLTBITMAP A 0 0 TEMP 0 0 W H))))))
|
||||
|
||||
(CL:DEFUN |LifeIdle| (\w &OPTIONAL (\n 1))
|
||||
(BITBLT (WINDOWPROP \w 'IMAGECOVERED)
|
||||
0 0 \w)
|
||||
(|Life| \w \n))
|
||||
(defineq
|
||||
(|Life| \w \n))
|
||||
(DEFINEQ
|
||||
|
||||
(expand.bitmap.vertically
|
||||
(lambda (bitmap m bm2 pbt) (* \; "Edited 6-Mar-87 15:02 by Masinter") (or bm2 (setq bm2 (bitmapcreate (|fetch| bitmapwidth bitmap) (times m (|fetch| bitmapheight bitmap))))) (or pbt (setq pbt (|create| pilotbbt))) (|with| pilotbbt pbt (*) (setq pbtdesthi (|ffetch| |BitMapHiLoc| bm2)) (setq pbtdestlo (|ffetch| |BitMapLoLoc| bm2)) (setq pbtsourcehi (|ffetch| |BitMapHiLoc| bitmap)) (setq pbtsourcelo (|ffetch| |BitMapLoLoc| bitmap)) (setq pbtdestbpl (times 16 m (|ffetch| bitmaprasterwidth bm2))) (setq pbtsourcebpl (times 16 (|ffetch| bitmaprasterwidth bitmap))) (setq pbtsourcebit 0) (setq pbtdestbit 0) (setq pbtflags 16384) (setq pbtheight (|fetch| bitmapheight bitmap)) (setq pbtwidth (|fetch| bitmapwidth bitmap)) (|for| i |from| 0 |while| (lessp i m) |do| (\\pilotbitblt pbt 0) (|add| pbtdestlo (|fetch| bitmaprasterwidth bm2)))) bm2)
|
||||
)
|
||||
(EXPAND.BITMAP.VERTICALLY
|
||||
(LAMBDA (BITMAP M BM2 PBT) (* \;
|
||||
"Edited 6-Dec-2021 15:04 by medley")
|
||||
(* \;
|
||||
"Edited 6-Dec-2021 14:47 by medley")
|
||||
(* \;
|
||||
"Edited 6-Dec-2021 13:54 by medley")
|
||||
(* \;
|
||||
"Edited 6-Dec-2021 13:51 by medley")
|
||||
(* \;
|
||||
"Edited 6-Dec-2021 13:11 by medley")
|
||||
(* \;
|
||||
"Edited 6-Mar-87 15:02 by Masinter")
|
||||
(OR BM2 (SETQ BM2 (BITMAPCREATE (|fetch| BITMAPWIDTH BITMAP)
|
||||
(TIMES M (|fetch| BITMAPHEIGHT BITMAP)))))
|
||||
(OR PBT (SETQ PBT (|create| PILOTBBT)))
|
||||
(|with| PILOTBBT PBT (*)
|
||||
(SETQ PBTDESTHI (|ffetch| |BitMapHiLoc| BM2))
|
||||
(SETQ PBTDESTLO (|ffetch| |BitMapLoLoc| BM2))
|
||||
(SETQ PBTSOURCEHI (|ffetch| |BitMapHiLoc| BITMAP))
|
||||
(SETQ PBTSOURCELO (|ffetch| |BitMapLoLoc| BITMAP))
|
||||
(SETQ PBTDESTBPL (TIMES 16 M (|ffetch| BITMAPRASTERWIDTH BM2)))
|
||||
(SETQ PBTSOURCEBPL (TIMES 16 (|ffetch| BITMAPRASTERWIDTH BITMAP)))
|
||||
(SETQ PBTSOURCEBIT 0)
|
||||
(SETQ PBTDESTBIT 0)
|
||||
(SETQ PBTFLAGS 16384)
|
||||
(SETQ PBTHEIGHT (|fetch| BITMAPHEIGHT BITMAP))
|
||||
(SETQ PBTWIDTH (|fetch| BITMAPWIDTH BITMAP))
|
||||
(|for| I |from| 1 |to| M |do| (\\PILOTBITBLT PBT 0)
|
||||
(|add| PBTDESTLO (|fetch|
|
||||
BITMAPRASTERWIDTH
|
||||
|of| BM2))))
|
||||
BM2))
|
||||
|
||||
(expand.bitmap.horizontally
|
||||
(lambda (bitmap n bm2 pbt) (* \; "Edited 6-Mar-87 17:08 by Masinter") (or bm2 (setq bm2 (bitmapcreate (times n (|fetch| bitmapwidth bitmap)) (|fetch| bitmapheight bitmap)))) (or pbt (setq pbt (|create| pilotbbt))) (let ((sourcebase (|fetch| bitmapbase bitmap)) (destbase (|fetch| bitmapbase bm2))) (|with| pilotbbt pbt (setq pbtdestbpl n) (setq pbtsourcebpl 1) (setq pbtsourcebit 0) (setq pbtflags 16384) (setq pbtwidth 1) (let ((ht (times (|fetch| bitmapwidth bitmap) (|fetch| bitmapheight bitmap)))) (|do| (setq pbtdest destbase) (setq pbtsource sourcebase) (setq pbtheight (min (times 1024 16) ht)) (setq pbtdestbit 0) (|for| i |from| 0 |while| (lessp i n) |do| (\\pilotbitblt pbt 0) (|add| pbtdestbit 1)) (setq ht (- ht (times 1024 16))) (|if| (leq ht 0) |then| (return)) (setq destbase (\\addbase destbase (times n 1024))) (setq sourcebase (\\addbase sourcebase 1024)))))) bm2)
|
||||
)
|
||||
)
|
||||
|
||||
(addtovar idle.functions
|
||||
("Life" '|LifeIdle| nil (subitems ("Single bits" '|LifeIdle|)
|
||||
("Double bits" '(lambda (\w)
|
||||
(ADDTOVAR IDLE.FUNCTIONS
|
||||
("Life" '|LifeIdle| NIL (SUBITEMS ("Single bits" '|LifeIdle|)
|
||||
("Double bits" '(LAMBDA (\w)
|
||||
(|LifeIdle| \w 2)))
|
||||
("Quadruple bits" '(lambda (\w)
|
||||
("Quadruple bits" '(LAMBDA (\w)
|
||||
(|LifeIdle| \w 4)))
|
||||
("Eight bits" '(lambda (\w)
|
||||
("Eight bits" '(LAMBDA (\w)
|
||||
(|LifeIdle| \w 8))))))
|
||||
(putprops life copyright ("Xerox Corporation" 1987 1988))
|
||||
(declare\: dontcopy
|
||||
(filemap (nil (5774 7579 (expand.bitmap.vertically 5784 . 6658) (expand.bitmap.horizontally 6660 .
|
||||
7577)))))
|
||||
stop
|
||||
(PUTPROPS LIFE COPYRIGHT ("Xerox Corporation" 1987 1988))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (1557 5825 (|Life| 1557 . 5825)) (5827 5955 (|LifeIdle| 5827 . 5955)) (5956 9223 (
|
||||
EXPAND.BITMAP.VERTICALLY 5966 . 8302) (EXPAND.BITMAP.HORIZONTALLY 8304 . 9221)))))
|
||||
STOP
|
||||
|
||||
BIN
lispusers/LIFE.DFASL
Normal file
BIN
lispusers/LIFE.DFASL
Normal file
Binary file not shown.
Binary file not shown.
Reference in New Issue
Block a user