(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated "20-Aug-88 12:18:43" {erinyes}medley>life.\;5 8231 |previous| |date:| " 6-Mar-87 19:11:20" {erinyes}medley>life.\;3) ; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. (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) (|LifeIdle| \w 2))) ("Quadruple bits" '(lambda (\w) (|LifeIdle| \w 4))) ("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)))))) (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 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.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) (|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 (5774 7579 (expand.bitmap.vertically 5784 . 6658) (expand.bitmap.horizontally 6660 . 7577))))) stop