;;; -*- Mode:LISP; Package:HACKS; Base:10; Lowercase:T; Readtable:ZL -*-
;;; Created 11/24/81 09:57:32 by CMB
;;; Modified, moved to POINTER, and installed by DLW, 1/9/82

;;; This rotate function was translated from Smalltalk.  It appeared in the August 1981
;;; issue of Byte magazine.  The array must be square and a power of two bits on a side.
;;; The direction of rotation will be clockwise.  To rotate a 512x512 bit array takes
;;; about 5 seconds of solid bitblt time.  Rotate takes 2 + 15*log(N) bitblts.

(defconst .STOR tv:alu-seta)
(defconst .IOR tv:alu-ior)
(defconst .AND tv:alu-and)
(defconst .XOR tv:alu-xor)
(defconst .CLEAR 0)
(defconst .SET 15)
(defconst .NAND 2)

(defmacro copy-all-to (from xoffset yoffset to alu)
  `(bitblt ,alu (- width ,xoffset) (- width ,yoffset) ,from 0 0 ,to ,xoffset ,yoffset))

(defmacro copy-all-from (to xoffset yoffset from alu)
  `(bitblt ,alu (- width ,xoffset) (- width ,yoffset) ,from ,xoffset ,yoffset ,to 0 0))

(defun rotate (myself w)
  (let* ((width (array-dimension myself 0))
	 (mask (make-array (list width width) :element-type 'bit))
	 (temp (make-array (list width width) :element-type 'bit)))
    (copy-all-to mask 0 0 mask .CLEAR)
    (copy-all-from mask (truncate width 2) (truncate width 2) mask .SET)
    (do ((quad (truncate width 2) (truncate quad 2)))
	((< quad 1))
      (copy-all-to mask 0 0 temp .STOR)		; 1
      (copy-all-to mask 0 quad temp .IOR)		; 2
      (copy-all-to myself 0 0 temp .AND)		; 3
      (copy-all-to temp 0 0 myself .XOR)		; 4
      (copy-all-from temp quad 0 myself .XOR)	; 5
      (copy-all-from myself quad 0 myself .IOR)	; 6
      (copy-all-to temp quad 0 myself .XOR)	; 7
      (copy-all-to myself 0 0 temp .STOR)	; 8
      (copy-all-from temp quad quad myself .XOR)	; 9
      (copy-all-to mask 0 0 temp .AND)		; 10
      (copy-all-to temp 0 0 myself .XOR)		; 11
      (copy-all-to temp quad quad myself .XOR)	; 12
      (copy-all-from mask (truncate quad 2) (truncate quad 2) mask .AND)	; 13
      (copy-all-to mask quad 0 mask .IOR)		; 14
      (copy-all-to mask 0 quad mask .IOR)		; 15
      (send w :bitblt tv:alu-seta width width myself 0 0 0 0)))
  myself)

(defvar *rotate-source* nil)
(defvar *rotate-size* 512)

(defun run-rotate ()
  (hof-window)
  (tv:window-call (*hof-window* :deactivate)
    (with-real-time
      (send *hof-window* :set-label "Life Window")
      (if (null *rotate-source*)
	  (setq *rotate-source* (make-array (list *rotate-size* *rotate-size*)
					    :element-type 'bit)))
      (send *hof-window* :clear-window)
      (bitblt tv:alu-xor *rotate-size* *rotate-size* *rotate-source* 0 0 *rotate-source* 0 0) 
      ;; random text
      (princ (documentation 'format 'function) *hof-window*)
      (send *hof-window* :bitblt-from-sheet
			 tv:alu-seta *rotate-size* *rotate-size* 0 0 *rotate-source* 0 0)
      (rotate *rotate-source* *hof-window*)
      (send *hof-window* :tyi))))

(defdemo "Rotate"
	 "A demonstration of an interesting algorithm for rotating a bit array."
  (run-rotate))

;;; 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)
      (send window :inside-size)
    (let* ((h2 (+ h 2))
	   (w2 (+ w 2))
	   (w32 (* (ceiling w2 32) 32))
	   (myself (make-pixel-array w32 h :element-type 'bit))
	   (nbr1   (make-pixel-array w32 h2 :element-type 'bit))
	   (nbr2   (make-pixel-array w32 h2 :element-type 'bit))
	   (nbr4   (make-pixel-array w32 h2 :element-type 'bit))
	   (carry2 (make-pixel-array w32 h2 :element-type 'bit))
	   (carry4 (make-pixel-array w32 h2 :element-type 'bit)))
      (send window :bitblt-from-sheet tv:alu-seta w h 0 0 myself 0 0)
      (dotimes (generation 100000)
	(bitblt .XOR w2 h2 nbr1   0 0 nbr1   0 0)
	(bitblt .XOR w2 h2 nbr2   0 0 nbr2   0 0)
	(bitblt .XOR w2 h2 nbr4   0 0 nbr4   0 0)
	(bitblt .XOR w2 h2 carry2 0 0 carry2 0 0)
	(bitblt .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 .STOR w2 h2 nbr1   0 0 carry2 0       0       )
	  
	  ;; carry2 = nbr1 .AND carry2
	  (bitblt .AND  w  h  myself   0 0 carry2 (car l) (cadr l))
	  
	  ;; nbr1   = nbr1 .XOR myself
	  (bitblt .XOR  w  h  myself   0 0 nbr1   (car l) (cadr l))
	  (bitblt .STOR w2 h2 nbr2   0 0 carry4 0       0       )
	  
	  ;; carry4 = nbr2 .AND carry4
	  (bitblt .AND  w2 h2 carry2 0 0 carry4 0       0       )
	  
	  ;; nbr2   = nbr2 .XOR carry2
	  (bitblt .XOR  w2 h2 carry2 0 0 nbr2   0       0       )
	  
	  ;; nbr4   = nbr4 .XOR carry4
	  (bitblt .XOR  w2 h2 carry4 0 0 nbr4   0       0       ))
	
	;; myself = myself .AND nbr2
	(bitblt .AND    w  h  nbr2 1 1 myself 0 0)
	
	;; nbr1 = nbr1 .AND nbr2
	(bitblt .AND    w2 h2 nbr2 0 0 nbr1 0 0)
	
	;; myself = (myself .AND nbr2) .IOR (nbr1 .AND nbr2)
	(bitblt .IOR     w  h  nbr1 1 1 myself 0 0)
	
	;; myself = (NOT nbr4) .AND ((myself .AND nbr2) .IOR (nbr1 .AND nbr2))
	(bitblt .NAND w  h  nbr4 1 1 myself 0 0)
	(send window :bitblt tv:alu-seta w h myself 0 0 0 0)
	(send window :home-cursor)
	(format window "~D" generation)
	(if (send window :tyi-no-hang) (return-from life t))
	)))
  window)

(defun run-life ()
  (little-hof-window)
  (tv:window-call (*little-hof-window* :deactivate)
    (with-real-time
      (send *little-hof-window* :set-label "Life Window")
      (multiple-value-bind (width height) (send *little-hof-window* :inside-size)
	(send *little-hof-window* :clear-window)
	(send *little-hof-window*
	      :draw-line 100 (truncate height 2)
			 (- width 100) (truncate height 2)))
      (life *little-hof-window*))))

(defdemo "Life"
	 "Conway's game of /"Life/", a cellular automaton demonstration.  By CMB."
  (run-life))