LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032646. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "LIFE" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "GRAPHICS-DEMO") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2753213705. :AUTHOR "REL3" :LENGTH-IN-BYTES 3563. :LENGTH-IN-BLOCKS 4. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     ;;; -*- Mode:Common-Lisp; Package:DEMO; Base:10 -*-;;; This life function was translated from Smalltalk.  It appeared in the;;; August 1981 issue of Byte magazine.  The array may be any size at all,;;; as long as it fits on the screen.  Each generation of life takes 65;;; bitblts.  If the loop was unrolled, some of the initial bitblts could;;; be deleted since it is unnecessary to calculate the carrys and high order;;; sums.(defun life (window)  (multiple-value-bind (w h) (funcall window ':inside-size)    (let* ((h2 (+ h 2))   (w2 (+ w 2))   (w32 (* (truncate (+ w2 31) 32) 32))   (myself (make-array (list h w32) ':type 'art-1b))   (nbr1   (make-array (list h2 w32) ':type 'art-1b))   (nbr2   (make-array (list h2 w32) ':type 'art-1b))   (nbr4   (make-array (list h2 w32) ':type 'art-1b))   (carry2 (make-array (list h2 w32) ':type 'art-1b))   (carry4 (make-array (list h2 w32) ':type 'art-1b)))      (funcall window ':bitblt-from-sheet tv:alu-seta w h 0 0 myself 0 0)      (unwind-protect  (loop for generation below 100000 doing    (bitblt TV:ALU-XOR w2 h2 nbr1   0 0 nbr1   0 0)    (bitblt TV:ALU-XOR w2 h2 nbr2   0 0 nbr2   0 0)    (bitblt TV:ALU-XOR w2 h2 nbr4   0 0 nbr4   0 0)    (bitblt TV:ALU-XOR w2 h2 carry2 0 0 carry2 0 0)    (bitblt TV:ALU-XOR w2 h2 carry4 0 0 carry4 0 0)    (dolist (l '((0 0) (0 1) (0 2) (1 0) (1 2) (2 0) (2 1) (2 2)))      (bitblt TV:ALU-SETA w2 h2 nbr1   0 0 carry2 0       0       )            ;; carry2 = nbr1 AND carry2      (bitblt TV:ALU-AND  w  h  myself   0 0 carry2 (car l) (cadr l))            ;; nbr1   = nbr1 TV:ALU-XOR myself      (bitblt TV:ALU-XOR  w  h  myself   0 0 nbr1   (car l) (cadr l))      (bitblt TV:ALU-SETA w2 h2 nbr2   0 0 carry4 0       0       )            ;; carry4 = nbr2 AND carry4      (bitblt TV:ALU-AND  w2 h2 carry2 0 0 carry4 0       0       )            ;; nbr2   = nbr2 TV:ALU-XOR carry2      (bitblt TV:ALU-XOR  w2 h2 carry2 0 0 nbr2   0       0       )            ;; nbr4   = nbr4 TV:ALU-XOR carry4      (bitblt TV:ALU-XOR  w2 h2 carry4 0 0 nbr4   0       0       ))        ;; myself = myself AND nbr2    (bitblt TV:ALU-AND    w  h  nbr2 1 1 myself 0 0)        ;; nbr1 = nbr1 AND nbr2    (bitblt TV:ALU-AND    w2 h2 nbr2 0 0 nbr1 0 0)        ;; myself = (myself AND nbr2) OR (nbr1 AND nbr2)    (bitblt TV:ALU-IOR     w  h  nbr1 1 1 myself 0 0)        ;; myself = (NOT nbr4) AND ((myself AND nbr2) OR (nbr1 AND nbr2))    (bitblt TV:ALU-ANDCA w  h  nbr4 1 1 myself 0 0)    (funcall window ':bitblt tv:alu-seta w h myself 0 0 0 0)    (funcall window ':home-cursor)    (format window "~D" generation)    until (funcall window ':tyi-no-hang)      )(return-array (prog1 carry4 (setq carry4 nil)))(return-array (prog1 carry2 (setq carry2 nil)))(return-array (prog1 nbr4 (setq nbr4 nil)))(return-array (prog1 nbr2 (setq nbr2 nil)))(return-array (prog1 nbr1 (setq nbr1 nil)))(return-array (prog1 myself (setq myself nil))))))  window)(defun run-life ()  (tv:window-call (*little-hof-window* :deactivate)    (with-real-time      (funcall *little-hof-window* ':set-label "Life Window")      (multiple-value-bind (width height) (funcall *little-hof-window* ':inside-size)(funcall *little-hof-window* ':clear-screen)(funcall *little-hof-window* ':draw-line 100 (floor height 2) (- width 100) (floor height 2)))      (life *little-hof-window*))))(defdemo "Life" "Conway's game of \"Life\", a cellular automaton demonstration.  By CMB."  (run-life))L "Attempt to punch ~C" CHAR))    (DO ((BITS BITS (LSH BITS -1)) (Y (+ CARD-TOP CARD-TOP-HEIGHT CARD-NUMBER-TOP-HEIGHT (* CARD-NUMBER-HEIGHT 9))    (- Y CARD-NUMBER-HEIGHT)))((ZEROP BITS))      (AND (zlc:BIT-TEST 1 BITS)   (SYS:%DRAW-RECTANGLE 6 (- CARD-NUMBER-HEIGHT 3) X YTV:ALU-IOR CARD-WINDOW)))))(DEFUN ERASE-CARD-CHAR (CHAR CHAR-X &AUX X BITS)  (TV:PREPARE-SHEET (CARD-WINDOW)    (SETQ X (+ CARD-MARGIN 2 (* CHAR-X 9)))    (SYS:%DRAW-RECTANGLE 5 10. X (+ CARD-TOP CARD-LETTER-TOP) TV:ALU-ANDCA CARD-WIND