(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "26-Jun-2022 18:34:22"  |{DSK}kaplan>Local>medley3.5>working-medley>lispusers>LIFE.;3| 10394 :CHANGES-TO (FNS EXPAND.BITMAP.VERTICALLY EXPAND.BITMAP.HORIZONTALLY) :PREVIOUS-DATE " 6-Dec-2021 15:21:48" |{DSK}kaplan>Local>medley3.5>working-medley>lispusers>LIFE.;2|) ; Copyright (c) 1987-1988 by Xerox Corporation. (PRETTYCOMPRINT LIFECOMS) (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) (|LifeIdle| \w 4))) ("Eight bits" '(LAMBDA (\w) (|LifeIdle| \w 8))))))))) (PUTPROPS LIFE FILETYPE :COMPILE-FILE) (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 (EXPAND.BITMAP.VERTICALLY (LAMBDA (BITMAP M BM2 PBT) (* |;;| "Edited 26-Jun-2022 18:29 by rmk: Change (add ... to (SETQ xx (PLUS xxx ..)) because \"with\" gets confused") (* |;;| "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) (* \;  "RMK: Can't use add here, expansion setf expansion gets confused") (SETQ PBTDESTLO (PLUS PBTDESTLO (|fetch| BITMAPRASTERWIDTH |of| BM2))) \n)) BM2)) (EXPAND.BITMAP.HORIZONTALLY (LAMBDA (BITMAP N BM2 PBT) (* |;;| "Edited 26-Jun-2022 18:34 by rmk: ADD doesn't expand properly under WITH, at least masterscope complains. So expanded it here") (* |;;| "Edited 26-Jun-2022 18:30 by rmk") (* |;;| "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) (SETQ PBTDESTBIT (PLUS 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) (|LifeIdle| \w 2))) ("Quadruple bits" '(LAMBDA (\w) (|LifeIdle| \w 4))) ("Eight bits" '(LAMBDA (\w) (|LifeIdle| \w 8)))))) (PUTPROPS LIFE COPYRIGHT ("Xerox Corporation" 1987 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1590 5830 (|Life| 1590 . 5830)) (5832 5960 (|LifeIdle| 5832 . 5960)) (5961 9742 ( EXPAND.BITMAP.VERTICALLY 5971 . 7898) (EXPAND.BITMAP.HORIZONTALLY 7900 . 9740))))) STOP