carnifex/sdl-test.cl

(ql:quickload "lispbuilder-sdl")
;(asdf:operate 'asdf:load-op :lispbuilder-sdl)

(defvar *grid-width* 100)
(defvar *grid-height* 100)

(defvar *map* nil)

(defvar *new-map* nil)

(defvar *x*)
(defvar *y*)

(defvar *neighbors*)
(defvar *cur-neighbor*)
(defvar *cur-cell*)
(defvar *run* nil)
(defvar *tmp-cell* nil)

(defstruct cell
  alive
  screen-x
  screen-y
  map-x
  map-y)

(defun create-cell (x y)
  (make-cell :screen-x (+ 5 (* x 10)) 
			 :screen-y (+ 5 (* y 10))
			 :map-x x
			 :map-y y))

(defun fill-map ()
  (setf *x* 0)
  (setf *y* 0)
  (dotimes (int *grid-height*)
	(dotimes (int *grid-width*)
	  (if (not *map*)
	   (push (create-cell *x* *y*) *map*)
	   (push (create-cell *x* *y*) (cdr (last *map*))))
	  (setf *x* (incf *x*))
	  (if (= *x* *grid-width*)
		(setf *x* 0)))
	(setf *y* (incf *y*))))

(defun render-map ()
  (loop for cell1 in *map*
		do (if (cell-alive cell1)
			 (sdl:draw-box
			 (sdl:rectangle-from-midpoint-*
			   (cell-screen-x cell1)
			   (cell-screen-y cell1)
			   9
			   9)
			 :color sdl:*white*)
			 (sdl:draw-box
             (sdl:rectangle-from-midpoint-*
               (cell-screen-x cell1)
               (cell-screen-y cell1)
               9
               9)
             :color sdl:*red*))))

(defun mouse-click (mouse-x mouse-y)
  (loop for cell in *map*
		do (if (and (< mouse-x (+ 5 (cell-screen-x cell)))
					(> mouse-x (- 5 (cell-screen-x cell)))
					(< mouse-y (+ 5 (cell-screen-y cell)))
					(> mouse-y (- 5 (cell-screen-y cell))))
			 (progn
			   (setf (cell-alive cell) (not (cell-alive cell)))
			   (return)))))

(defun is-alive (x y tmp-cell)
  (setq tmp-cell (nth (+ (* y *grid-width*) x) *map*))
  (if ((tmp-cell-alive tmp-cell))
	(return-from is-alive t)
	(return-from is-alive nil)))
  

(defun check-top-left-corner (x y)
  (setf *neighbors* 0)
  (if (is-alive 1 0)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive 1 1)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive 0 1)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive 0 *map-height*)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive 1 *map-height*)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive *map-width* 0)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive *map-width* 1)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive *map-width* *map-height*)
	(setf *neighbors* (incf *neighbors*))))

(defun main-check (x y)
  (setf *neighbors* 0)
  (if (is-alive (+ x 1) y *tmp-cell*)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive (+ x 1) (+ y 1) *tmp-cell*)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive x (+ y 1) *tmp-cell*)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive (- x 1) (+ y 1) *tmp-cell*)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive (- x 1) y *tmp-cell*)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive (- x 1) (- y 1) *tmp-cell*)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive x (- y 1) *tmp-cell*)
	(setf *neighbors* (incf *neighbors*)))
  (if (is-alive (+ x 1) (- y 1) *tmp-cell*)
	(setf *neighbors* (incf *neighbors*))))

(defun check-cell (x y)
;  (if (and (= x 0)
;		   (= y 0))
;	(progn
;	  (check-top-left-corner)
;	  (return-from check-cell)))
;  (if (and (= x *map-width*)
;		   (= y 0))
;	(progn
;	  (check-top-right-corner)
;	  (return-from check-cell)))
;  (if (and (= x 0)
;		   (= y *map-height*))
;	(progn
;	  (check-bottom-left-corner)
;	  (return-from check-cell)))
;  (if (and (= x *map-width*)
;		   (= y *map-height*))
;	(progn
;	  (check-bottom-right-corner)
;	  (return-from check-cell)))
;  (if (= x 0)
;	(progn
;	  (check-top)
;	  (return-from check-cell)))
;  (if (= y 0)
;	(progn
;	  (check-left)
;	  (return-from check-cell)))
;  (if (= x *map-width*)
;	(progn
;	  (check-right)
;	  (return-from check-cell)))
;  (if (= y *map-height*)
;	(progn
;	  (check-bottom)
;	  (return-from check-cell)))
  (main-check cell))

(defun set-cell (cell)
  (setf *cur-cell* (nth (+ (* y *map-width*) x) *new-map*))
  (if (and (not (is-alive x y))
		   (= *neighbors* 3))
	(progn
	  (setf (*cur-cell*-alive *cur-cell*) t)
	  (return-from set-cell)))
  (if (and (is-alive x y)
		   (or (= *neighbors* 2)
			   (= *neighbors* 3)))
	(return-from set-cell))
  (if (or (> *neighbors* 3)
		  (< *neighbors* 2))
	(progn
	  (setf (*cur-cell*-alive *cur-cell*) nil)
	  (return-from set-cell))))

;(defun check-map ()
;  (setf *x* 0)
;  (setf *y* 0)
;  (setf *new-map* (copy-list *map*))
;  (dotimes (int *grid-height*)
;	(dotimes (int *grid-widht*)
;	  (check-cell *x* *y*)
;	  (set-cell *x* *y*)
;	  (setf *x* (incf *x*))
;	  (if (= *x* *grid-width*)
;		(setf *x* 0)))
;	(setf *y* (incf *y*)))
;  (setf *map* *new-map*))

(defun check-map ()
  (setf *x* 0)
  (setf *y* 0)
  (setf *new-map* (copy-list *map*))
  (loop for cell in *map*
		do ((check-cell (cell-map-x cell) (cell-map-y cell))
			(set-cell (cell-map-x cell) (cell-map-y cell))))
  (setf *map* *new-map*))


(defun life ()
  (format *query-io* "~%~%~a~%" (first *posix-argv*))
  (fill-map)
  (sdl:with-init ()
	(sdl:window (* *grid-width* 10) (* *grid-height* 10) :title-caption "carnifex")
	(sdl:with-events ()
	  (:quit-event () T)
	  (:key-down-event ()
		(when
		  (sdl:key-down-p :sdl-key-escape)
		  (sdl:push-quit-event))
		(when
		  (sdl:key-down-p :sdl-key-space)
		  (setf *run* (not *run*))))
	  
	  (:idle ()
		(sdl:clear-display sdl:*black*)
		(when (sdl:mouse-left-p)
		  (mouse-click (sdl:mouse-x) (sdl:mouse-y)))
		(render-map)
		(if *run*
		  (check-map))
		(sdl:update-display)))))

(sb-int:with-float-traps-masked 
  (:invalid :inexact :overflow) 
  (life))