Fixed window resize problem, added ability to set cells

gol-gl.lisp

@@ -1,61 +1,130 @@
 (defpackage :gol-gl-frontend
-  (:use #:cl #:cl-opengl #:cl-glu #:cl-glut)
+  (:use #:cl #:cl-opengl #:cl-glu #:cl-glut #:gol)
   (:export #:run)
   (:shadow #:get-string #:close #:get #:special))
 
 (in-package :gol-gl-frontend)
+(defvar *cells* nil)
+(defvar *new-cells nil)
+(defvar *chooser-coords* (list 0 0))
+(defvar *generation-timer* (get-universal-time))
+(defvar *paused* nil)
+(defvar *pause-status-coords* nil)
 
 (defun display-cells()
-  (let ((cells '((t nil nil)(nil nil nil))))
-    (dotimes (y (length cells))
-      (dotimes (x (length (nth y cells)))
-                (with-pushed-matrix 
-                  (let ((value (nth y (nth x cells))))
-                  (gl:translate x (- y) 0)
-                  (if value
-                      (glut:solid-cube 1)
-                      (glut:wire-cube 1))))))))
+  (do-cells *cells*
+            (let ((x gol::x)(y gol::y)(cell gol::cell))
+            (with-pushed-matrix 
+              (gl:translate x (- y) 0)
+              (glut:wire-cube 1)
+              (if cell
+                  (glut:solid-sphere 0.5 50 50)))))
+  (if (and (>= (- (get-universal-time) *generation-timer*) 1) (not *paused*))
+    (progn
+      (update-generation-timer)
+      (setf *cells* (gol:next-generation *cells*)))))
+
+(defun display-chooser()
+  (with-pushed-matrix
+    (gl:color 0.5 0 0)
+    (gl:translate (first *chooser-coords*) (- (second *chooser-coords*)) 1)
+  (glut:solid-torus 0.1 0.3 4 20)))
+
+(defun update-generation-timer()
+  (setf *generation-timer* (get-universal-time)))
+
+(defun toggle-pause()
+  (if *paused* (update-generation-timer))
+  (setf *paused* (not *paused*)))
+
+(defun display-pause-status()
+  (with-pushed-matrix
+    (let ((coords (multiple-value-list (glu:un-project (first *pause-status-coords*) (second *pause-status-coords*) 0))))
+            (gl:color 1.0 0 0)
+          (setf (nth 2 coords) 0)
+          (apply #'gl:translate coords)
+          (glut:solid-cube 1))))
+
+(defun move-chooser(way)
+  (case way
+    (:down (incf (second *chooser-coords*)))
+    (:up (decf (second *chooser-coords*)))
+    (:right (incf (first *chooser-coords*)))
+    (:left (decf (first *chooser-coords*)))))
 
 ;;;;;;;;;;;;;;;;;;; OPENGL DEFS ;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defclass cube-window (glut:window)
   ()
   (:default-initargs :width 500 :height 500 :title "cube.lisp"
-                     :mode '(:single :rgb)))
+                     :mode '(:double :rgb :depth)))
 
 (defmethod glut:display-window :before ((w cube-window))
+  (gl:light :light0 :position #(5.0 5.0 10.0 0.0))
+  (gl:enable :cull-face :lighting :light0 :depth-test)
   (gl:clear-color 0 0 0 0)
-  (gl:shade-model :flat))
+  #+l(gl:shade-model :flat))
 
 (defmethod glut:display ((w cube-window))
-  (gl:clear :color-buffer)
-  (gl:color 1 1 1)
+  (gl:clear :color-buffer :depth-buffer)
   (gl:load-identity) ; clear the matrix
   ;; viewing transformation
   (glu:look-at 0 0 10 0 0 0 0 1 0)
   ;; modeling transformation
   (gl:scale 1 1 1)
-  (glut:wire-cube 1)
+  (display-chooser)
   (display-cells)
-  (gl:flush))
+  (display-pause-status)
+  (gl:flush)
+  (glut:swap-buffers))
+
+#+l(defmethod glut:idle ((window cube-window))
+  (glut:post-redisplay))
 
 (defmethod glut:reshape ((w cube-window) width height)
+  (setf *pause-status-coords* (list width height))
   (gl:viewport 0 0 width height)
-  (gl:matrix-mode :projection)
+  (gl:matrix-mode :projection)    ; select the projection matrix
+  (gl:load-identity)              ; reset the matrix
+  (glu:perspective 45 (/ width (max height 1)) 1/10 100)
+  (gl:matrix-mode :modelview)
   (gl:load-identity)
-  (gl:frustum -1 1 -1 1 1.5 20)
-  (gl:matrix-mode :modelview))
+  (glut:post-redisplay))
 
 (defmethod glut:keyboard ((w cube-window) key x y)
   (declare (ignore x y))
-  (when (eql key #\Esc)
-    (glut:destroy-current-window)))
+  (move-chooser (case key 
+                  (#\w :up)
+                  (#\s :down)
+                  (#\d :right)
+                  (#\a :left)))
+  (if (equal key #\Esc)
+    (glut:destroy-current-window)
+    (progn
+      (case key
+        (#\Space (toggle-pause))
+        (#\Return (setxycell (first *chooser-coords*) (second *chooser-coords*) *cells* t))
+        (#\Esc )
+        (t (print key)))
+      (glut:post-redisplay))))
+
+(defmethod glut:special ((window cube-window) special-key x y)
+  (declare (ignore x y))
+    (move-chooser (case special-key
+      (:key-up :up)
+      (:key-down :down)
+      (:key-left :left)
+      (:key-right :right)))
+    (glut:post-redisplay))
+
+#+l(defmethod glut:mouse ((w cube-window) button state x y)
+  (format t "~A~%" (list w button state x y)))
 
 (defun rb-cube ()
   (glut:display-window (make-instance 'cube-window)))
 
 (defun run ()
   "Run application"
-  (let ((glut:*run-main-loop-after-display* nil))
+  (let ((glut:*run-main-loop-after-display* nil)(*cells* '((nil nil nil t)(t t t nil)(t nil nil nil)(nil t nil t))))
       (rb-cube)
     (glut:main-loop)))

gol-tests.lisp

@@ -104,6 +104,22 @@ DESCRIBE-ing them."
              (t t t)))
          5)
 
+(deftest live-neighbours-count-4
+         (gol:live-neighbours-count 
+           1 0
+           '((nil nil nil)
+             (t   t   t)
+             (nil nil nil)))
+         3)
+
+(deftest live-neighbours-count-5
+         (gol:live-neighbours-count 
+           0 0
+           '((nil nil nil)
+             (t   t   t)
+             (nil nil nil)))
+         2)
+
 (deftest cell-value-must-alive
          (gol:cell-value 
            0 0
@@ -145,11 +161,20 @@ DESCRIBE-ing them."
              (nil nil nil)
              (nil nil nil)))))
 
-(addtest 'next-generation-1
+(addtest 'next-generation-2
          (ensure (equal (gol:next-generation 
            '((t   t   t)
              (t   t   t)
              (t   t   t)))
            '((t   nil t)
              (nil nil nil)
              (t   nil t)))))
+
+(addtest 'next-generation-3
+         (ensure (equal (gol:next-generation 
+           '((nil   t   nil)
+             (nil   t   nil)
+             (nil   t   nil)))
+           '((nil   nil nil)
+             (t     t   t)
+             (nil   nil nil)))))

gol.lisp

@@ -19,16 +19,12 @@
 ;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;(asdf:operate 'asdf:load-op :cl-opengl)
-;(require :cl-opengl)
-;(require :cl-glut)
-
 (defpackage :gol
   (:use #:cl))
 
 (in-package :gol)
 
-(export '(xycell cell live-neighbours-count cell-value next-generation))
+(export '(xycell cell live-neighbours-count cell-value next-generation do-cells setxycell))
 
 (defparameter *can-out-of-bounds* nil)
 
@@ -40,6 +36,10 @@
   (xcell x 
          (xcell y cells)))
 
+(defmacro setxycell(x y cells value)
+  `(setf (nth ,y 
+             (nth ,x ,cells)) ,value))
+
 (defun neighbours-values(x y c)
   (list 
     (xycell (1+ x)  y c)
@@ -63,6 +63,13 @@
       (t (xycell x y cells)))))
 
 (defun next-generation(cells)
-  (loop for x from 0 to (1- (length cells))
-        collect (loop for y from 0 to (1- (length (nth x cells)))
+  (loop for y from 0 to (1- (length cells))
+        collect (loop for x from 0 to (1- (length (nth y cells)))
                       collect (cell-value x y cells))))
+
+(defmacro do-cells(cells &body body)
+    `(dotimes (y (length ,cells))
+        (dotimes (x (length (nth y ,cells)))
+           (let ((cell (nth y (nth x ,cells))))
+              (funcall (lambda (x y cell)
+                         ,@body) x y cell)))))