/prog/ - Lisp A I Now.

Name: Anonymous 2009-09-20 19:53



;;; ****************************************************************

;;; Conway's Game of Life ******************************************

;;; ****************************************************************



;;; Don't know where/when got this. --mk



(defstruct (world (:print-function 

                   (lambda (s d o)

                     (declare (ignore d))

                     (format s "#<WORLD: ~D>" (world-numdots world)))))

  size

  current

  numdots

  next

  (xmin 1000000)    ; Initialize the region to ridiculous numbers.

  (xmax -1)

  (ymin 1000000)

  (ymax -1))



(defun setnext (world i j)

  (let* ((current (world-current world))

         (next (world-next world))

         (neighbors (count-neighbors current i j)))

    ;; set the next bit pattern

    (if (zerop (bit current i j))

        (cond ((not (= neighbors 3))

               ;; current = 0, surrounding cells != 3

               (setf (bit next i j) 0)) 

              (t (setf (bit next i j) 1)

                 ;; current = 0, surrounding cells = 3

                 (incf (world-numdots world)))) 

      (cond ((or (= neighbors 2) 

                 (= neighbors 3))

             ;; current = 1, surrounding cells = 2,3

             (setf (bit next i j) 1))   

            (t (setf (bit next i j) 0)

               (decf (world-numdots world)))))

    ;; reset the bounds, if necessary

    (unless (zerop (bit next i j))

      (when (< i (world-xmin world)) (setf (world-xmin world) i))

      (when (> i (world-xmax world)) (setf (world-xmax world) i))

      (when (< j (world-ymin world)) (setf (world-ymin world) j))

      (when (> j (world-ymax world)) (setf (world-ymax world) j)))))



(defun count-neighbors (array i j)

  (+ (bit array (1- i) (1- j))

     (bit array i      (1- j))

     (bit array (1+ i) (1- j))

     (bit array (1- i) j)

     (bit array (1+ i) j)

     (bit array (1- i) (1+ j))

     (bit array i      (1+ j))

     (bit array (1+ i) (1+ j))))



(defun next-cycle (world)

  (let* ((lim (world-size world))

         (current (world-current world))

         (next (world-next world))

         (xlb (max 1 (1- (world-xmin world))))

         (xub (min (- lim 2) (1+ (world-xmax world))))

         (ylb (max 1 (1- (world-ymin world))))

         (yub (min (- lim 2) (1+ (world-ymax world)))))

    (dotimes (i (1+ (- xub xlb)))

      (dotimes (j (1+ (- yub ylb)))

        (setnext world (+ i xlb) (+ j ylb))))

    (dotimes (y lim)

      (dotimes (x lim)

        (setf (bit current x y) (bit next x y))))))



(defun print-world (world generations)

  (let ((lim (world-size world))

        (current (world-current world)))

    (dotimes (y lim)

      (dotimes (x lim)

        (if (zerop (bit current y x))

          (princ " ")

          (princ "*")))

      (terpri))

    (format t "~&~d Generations, ~d Organisms." 

            generations (world-numdots world))))



(defun propagate (world cycles)

  (print-world world cycles)

  (do ()

      ((zerop (world-numdots world))

       (format t "~2&POPULATION 0 ... ~d generations" cycles))

    (next-cycle world)

    (incf cycles)

    (print-world world cycles)))







(defun life (source)

  (let* ((size (length (car source)))

         (life (make-world

                :size size

                :current (make-array (list size size) :element-type 'bit

                                     :initial-contents source)

                :next (make-array (list size size) :element-type 'bit

                                  :initial-element 0)

                :numdots 0)))

    (dotimes (i size)

      (dotimes (j size)

        (unless (zerop (bit (world-current life) i j))

          (incf (world-numdots life))

          (when (< i (world-xmin life)) (setf (world-xmin life) i))

          (when (> i (world-xmax life)) (setf (world-xmax life) i))

          (when (< j (world-ymin life)) (setf (world-ymin life) j))

          (when (> j (world-ymax life)) (setf (world-ymax life) j)))))

    (propagate life 0)))



#|

;;; Example:

(setq test 

      '((0 0 0 0 0 0 0 0)

       (0 0 0 1 1 0 1 0)

       (0 0 1 0 1 0 1 0)

       (0 0 1 1 1 0 0 0)

       (0 1 0 0 1 1 1 0)

       (0 1 1 1 0 0 0 0)

       (0 0 0 1 1 0 1 0)

       (0 0 0 0 0 0 0 0)))



(life test)

|#



;;; *EOF*
Lisp A I Now.

1 Name: Anonymous 2009-09-20 19:53

24 Name: Anonymous 2009-09-23 23:33

Name: Anonymous 2009-09-20 19:53

Name: Anonymous 2009-09-23 23:33
