;;; -*-LISP-*-
;;;
;;; Copyright (C) 2002,2003,2005 Donald Fisk
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
;;; USA

(progn
  (setf BOARD_SIZE 240)
  (setf LIFE_CANVAS _)
  (setf EXPOSED_P FALSE)
  (setf OLD_GEN (makeArray (list BOARD_SIZE BOARD_SIZE) 0))
  (setf NEW_GEN (makeArray (list BOARD_SIZE BOARD_SIZE) 0))
  (setf COLORS (vector WHITE BLACK))
  (setf ALIVE_P #(#(0 0 0 1 0 0 0 0 0) #(0 0 1 1 0 0 0 0 0)))
  '())

(defun calcNextGen ()
  (do ((i 0 (add1 i))
       (deci)
       (inci))
      ((= i BOARD_SIZE))
      (setf deci (mod (sub1 i) BOARD_SIZE))
      (setf inci (mod (add1 i) BOARD_SIZE))
      (do ((j 0 (add1 j))
	   (decj)
	   (incj))
	  ((= j BOARD_SIZE))
	  (setf decj (mod (sub1 j) BOARD_SIZE))
	  (setf incj (mod (add1 j) BOARD_SIZE))
	  (setf (aref NEW_GEN i j)
		(aref ALIVE_P
		      ;; If the old generation's cell = 0, it gets life only
		      ;; if there are exactly 3 neighbors who are alive.  If
		      ;; it's 1, it gets life if 2 or three neighbors are
		      ;; alive.   See the values in ALIVE_P.
		      (aref OLD_GEN i j)
		      ;; Count neighbors who are alive.
		      (+ (aref OLD_GEN i decj)
			 (aref OLD_GEN i incj)
			 (aref OLD_GEN deci j)
			 (aref OLD_GEN inci j)
			 (aref OLD_GEN deci decj)
			 (aref OLD_GEN deci incj)
			 (aref OLD_GEN inci decj)
			 (aref OLD_GEN inci incj)))))))

(defun initLife (pattern)
  (if (null pattern)
      ;; Generate random pattern.
      (do ((i 0 (add1 i)))
	  ((= i BOARD_SIZE))
	  (do ((j 0 (add1 j)))
	      ((= j BOARD_SIZE))
	      (setf (aref NEW_GEN i j) (random 2))))
    (let ((startRow (floor (* 0.5 (- BOARD_SIZE
				     (length pattern)))))
	  (startColumn (floor (* 0.5 (- BOARD_SIZE
					(length (car pattern)))))))
      (do ((i 0 (add1 i)))
	  ((= i BOARD_SIZE))
	  (do ((j 0 (add1 j)))
	      ((= j BOARD_SIZE))
	      (setf (aref NEW_GEN i j) 0)))
      (do ((i startRow (add1 i))
	   (pat pattern (cdr pat)))
	  ((null pat))
	  (do ((j startColumn (add1 j))
	       (row (car pat) (cdr row)))
	      ((null row))
	      (setf (aref NEW_GEN j i)
		    (if (and (not (null pattern))
			     (not (null row))
			     (eq (car row) '*))
			1
		      0))))))
  (setf LIFE_CANVAS
	(new 'Canvas 'title "Life"
	     'width (* 4 BOARD_SIZE) 'height (* 4 BOARD_SIZE)
	     'fillColor WHITE))
  (setBehavior LIFE_CANVAS EXPOSE_EVENT
	       (lambda ((c Canvas) (event Array))
		 (setf EXPOSED_P TRUE))))

(defun redrawBoard ()
  (do ((i 0 (add1 i))
       (win (getWindow LIFE_CANVAS))
       (gc (getGC LIFE_CANVAS)))
      ((= i BOARD_SIZE))
      (do ((j 0 (add1 j))
	   (cell))
	  ((= j BOARD_SIZE))
	  ;; Only redraw the cell if it's changed.
	  (unless (= (aref OLD_GEN i j)
		     ;; Put the cell's value in cell.
		     (setf cell (aref NEW_GEN i j)))
	    (drawRectangle win gc
			   (* i 4) (* j 4) 4 4
			   (aref COLORS cell) ;Get the cell's color.
			   _)))))

(defun drawBoard ()
  (do ((i 0 (add1 i))
       (win (getWindow LIFE_CANVAS))
       (gc (getGC LIFE_CANVAS)))
      ((= i BOARD_SIZE))
      (do ((j 0 (add1 j)))
	  ((= j BOARD_SIZE))
	  ;; Always draw the cell even if it's unchanged.
	  (drawRectangle win gc
			 (* i 4) (* j 4) 4 4
			 (aref COLORS (aref NEW_GEN i j))
			 _))))

(setf CLOCK '((_ * _ _)
	      (_ _ * *)
	      (* * _ _)
	      (_ _ * _)))

(setf GALAXY '((* * * * * * _ * *)
	       (* * * * * * _ * *)
	       (_ _ _ _ _ _ _ * *)
	       (* * _ _ _ _ _ * *)
	       (* * _ _ _ _ _ * *)
	       (* * _ _ _ _ _ * *)
	       (* * _ _ _ _ _ _ _)
	       (* * _ * * * * * *)
	       (* * _ * * * * * *)))

(setf SPACESHIP2 '((_ _ _ _ * _)
		   (_ _ _ _ _ *)
		   (* _ _ _ _ *)
		   (_ * * * * *)))

(setf PENTADECATHLONS
      '((_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ * _ _ * _ _ _ _ * _ _ * _ _)
	(_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ * * * _ _ * * * * * * _ _ * * *)
	(_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ * _ _ * _ _ _ _ * _ _ * _ _)
	(_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
	(_ _ * _ _ * _ _ _ _ * _ _ * _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
	(* * * _ _ * * * * * * _ _ * * * _ _ * _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
	(_ _ * _ _ * _ _ _ _ * _ _ * _ _ _ * _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
	(_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ * * * _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)))

(setf SHUTTLE '((_ _ _ _ _ _ _ _ _ * _ _ _ _ _ _ _ _ _ _ _ _)
		(_ _ _ _ _ _ _ _ _ * * _ _ _ _ _ _ _ _ _ _ _)
		(_ _ _ _ _ _ _ _ _ _ * * _ _ _ _ _ _ _ _ _ _)
		(* * _ _ _ _ _ _ _ _ * * * _ _ _ _ _ _ _ * *)
		(* * _ _ _ _ _ _ _ _ * * _ _ _ _ _ _ _ _ * *)
		(_ _ _ _ _ _ _ _ _ * * _ _ _ _ _ _ _ _ _ _ _)
		(_ _ _ _ _ _ _ _ _ * _ _ _ _ _ _ _ _ _ _ _ _)))

(setf R_PENTOMINO '((_ * *)
		    (* * _)
		    (_ * _)))

(setf PI_HEPTOMINO '((* * *)
		     (* _ *)
		     (* _ *)))

(setf
 GLIDER_GUN
 '((_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ * _ _ _ _ _ _ _ _ _ _)
   (_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ * * * * _ _ _ _ _ _ _ _ _ _)
   (_ _ _ _ _ _ _ _ _ _ _ _ _ * _ _ _ _ _ _ _ * * * * _ _ _ _ _ _ _ _ _ * *)
   (_ _ _ _ _ _ _ _ _ _ _ _ * _ * _ _ _ _ _ _ * _ _ * _ _ _ _ _ _ _ _ _ * *)
   (* * _ _ _ _ _ _ _ _ _ * _ _ _ * * _ _ _ _ * * * * _ _ _ _ _ _ _ _ _ _ _)
   (* * _ _ _ _ _ _ _ _ _ * _ _ _ * * _ _ _ _ _ * * * * _ _ _ _ _ _ _ _ _ _)
   (_ _ _ _ _ _ _ _ _ _ _ * _ _ _ * * _ _ _ _ _ _ _ _ * _ _ _ _ _ _ _ _ _ _)
   (_ _ _ _ _ _ _ _ _ _ _ _ * _ * _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
   (_ _ _ _ _ _ _ _ _ _ _ _ _ * _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)))

(setf ACORN '((_ * _ _ _ _ _)
	      (_ _ _ * _ _ _)
	      (* * _ _ * * *)))

(setf FOO '((* * * _)
	    (_ * _ *)
	    (* * * *)
	    (_ * _ *)))

(defun _line (n)
  (if (zerop n)
      '()
    (cons '* (_line (sub1 n)))))

;;; (life (line 41)) results in 4 pulsars.   Other interesting line lengths
;;; are 33, 68, 71.
;;; 15 ends up blank.
(defun line (n) (list (_line n)))

(defun life (x)
  (initLife x)
  (do ((temp))
      (FALSE)
      (if EXPOSED_P
	  (progn (drawBoard) (setf EXPOSED_P FALSE))
	(redrawBoard))
      (setf temp OLD_GEN)
      (setf OLD_GEN NEW_GEN)
      (setf NEW_GEN temp)
      (calcNextGen)))