carnifex/sdl-test.cl
Gregory Tertyshny 1a7d554165 some logic
2017-05-31 21:02:44 +03:00

423 lines
11 KiB
Common Lisp

(ql:quickload "lispbuilder-sdl")
;(asdf:operate 'asdf:load-op :lispbuilder-sdl)
(defvar *grid-width* 3)
(defvar *grid-height* 3)
(defvar *map* nil)
(defvar *map-copy* nil)
(defvar *next-generation* nil)
(defvar *run* nil)
(defun create-cell (x y)
(list :screen-x (+ 5 (* x 10))
:screen-y (+ 5 (* y 10))
:map-x x
:map-y y
:was-alive nil
:alive nil))
(defun fill-map ()
(let ((x 0)
(y 0))
(dotimes (int (* *grid-height* *grid-width*))
(push (create-cell x y) *map*)
(setf x (incf x))
(if (= x *grid-width*)
(progn
(setf x 0)
(setf y (incf y)))))))
(defun print-map ()
(let ((x 0))
(dolist (cell *map*)
(format t
"x:~a y:~a; "
(getf cell :map-x)
(getf cell :map-y))
(setf x (incf x))
(if (= x *grid-width*)
(progn
(setf x 0)
(format t "~%"))))))
(defun render-cell (cell color)
(sdl:draw-box
(sdl:rectangle-from-midpoint-*
(getf cell :screen-x)
(getf cell :screen-y)
9
9)
:color color))
(defun render-map ()
(dolist (cell *map*)
(cond
((getf cell :alive)
(render-cell cell sdl:*green*))
((getf cell :was-alive)
(render-cell cell sdl:*white*))
(t
(render-cell cell sdl:*red*)))))
(defun kill (cell)
(setf (getf cell :alive) nil)
(setf (getf cell :was-alive) t))
(defun reanimate (cell)
(setf (getf cell :alive) t))
(defun mouse-intersect (mouse-x mouse-y cell)
(and (<= mouse-x (+ (getf cell :screen-x) 5))
(>= mouse-x (- (getf cell :screen-x) 5))
(<= mouse-y (+ (getf cell :screen-y) 5))
(>= mouse-y (- (getf cell :screen-y) 5))))
(defun mouse-set-cell (mouse-x mouse-y)
(dolist (cell *map*)
(if (mouse-intersect mouse-x mouse-y cell)
(progn
(setf (getf cell :alive) (not (getf cell :alive)))
(return)))))
(defun get-cell (x y)
(copy-list (nth (+ (* y *grid-width*) x) *map-copy*)))
(defun is-alive (cell)
(getf cell :alive))
(defun get-cell-x (cell)
(getf cell :map-x))
(defun get-cell-y (cell)
(getf cell :map-y))
(defun main-check (cell)
(let ((x (get-cell-x cell))
(y (get-cell-y cell))
(new-cell (copy-list cell))
(neighbors 0))
(if (is-alive (get-cell (+ x 1) y))
(progn
(setf neighbors (incf neighbors))
(format t
"right cell:~%x:~ay:~a~%~%"
(getf (get-cell (+ x 1) y) :map-x)
(getf (get-cell (+ x 1) y) :map-y))))
(if (is-alive (get-cell (+ x 1) (+ y 1)))
(progn
(setf neighbors (incf neighbors))
(format t
"right bottom cell:~%x:~ay:~a~%~%"
(getf (get-cell (+ x 1) (+ y 1)) :map-x)
(getf (get-cell (+ x 1) (+ y 1)) :map-y))))
(if (is-alive (get-cell x (+ y 1)))
(progn
(setf neighbors (incf neighbors))
(format t
"right bottom cell:~%x:~ay:~a~%~%"
(getf (get-cell x (+ y 1)) :map-x)
(getf (get-cell x (+ y 1)) :map-y))))
(if (is-alive (get-cell (- x 1) (+ y 1)))
(progn
(setf neighbors (incf neighbors))
(format t
"middle bottom cell:~%x:~ay:~a~%~%"
(getf (get-cell (- x 1) (+ y 1)) :map-x)
(getf (get-cell (- x 1) (+ y 1)) :map-y))))
(if (is-alive (get-cell (- x 1) y))
(progn
(setf neighbors (incf neighbors))
(format t
"left cell:~%x:~ay:~a~%~%"
(getf (get-cell (- x 1) y) :map-x)
(getf (get-cell (- x 1) y) :map-y))))
(if (is-alive (get-cell (- x 1) (- y 1)))
(progn
(setf neighbors (incf neighbors))
(format t
"left bottom cell:~%x:~ay:~a~%~%"
(getf (get-cell (- x 1) (- y 1)) :map-x)
(getf (get-cell (- x 1) (- y 1)) :map-y))))
(if (is-alive (get-cell x (- y 1)))
(setf neighbors (incf neighbors)))
(if (is-alive (get-cell (+ x 1) (- y 1)))
(setf neighbors (incf neighbors)))
;(cond
; ((getf new-cell :alive)
; (if (or (<= neighbors 1)
; (>= neighbors 4))
; (kill new-cell))
; (format t
; "x:~a y:~a~%~%"
; (get-cell-x new-cell)
; (get-cell-y new-cell)))
; (t
; (if (= neighbors 3)
; (reanimate new-cell))))
(if (is-alive new-cell)
(format t "neighbors:~a~%" neighbors))
(push new-cell *next-generation*)))
(defun check-top-left-corner (cell)
(push (copy-list cell) *next-generation*))
(defun check-top-right-corner (cell)
(push (copy-list cell) *next-generation*))
(defun check-bottom-left-corner (cell)
(push (copy-list cell) *next-generation*))
(defun check-bottom-right-corner (cell)
(push (copy-list cell) *next-generation*))
(defun check-top (cell)
(push (copy-list cell) *next-generation*))
(defun check-bottom (cell)
(push (copy-list cell) *next-generation*))
(defun check-left (cell)
(push (copy-list cell) *next-generation*))
(defun check-right (cell)
(push (copy-list cell) *next-generation*))
(defun check-cell (cell)
(cond
((and
(= (get-cell-x cell) 0)
(= (get-cell-y cell) 0))
(check-top-left-corner cell))
((and
(= (get-cell-x cell) (- *grid-width* 1))
(= (get-cell-y cell) 0))
(check-top-right-corner cell))
((and
(= (get-cell-x cell) 0)
(= (get-cell-y cell) (- *grid-height* 1)))
(check-bottom-left-corner cell))
((and
(= (get-cell-x cell) (- *grid-width* 1))
(= (get-cell-y cell) (- *grid-height* 1)))
(check-bottom-right-corner cell))
((= (get-cell-y cell) 0)
(check-top cell))
((= (get-cell-y cell) (- *grid-height* 1))
(check-bottom cell))
((= (get-cell-x cell) 0)
(check-left cell))
((= (get-cell-x cell) (- *grid-width* 1))
(check-right cell))
(t
(main-check cell))))
(defun next-generation ()
(setf *map-copy* *map*)
(dolist (cell *map*)
(check-cell cell))
(setf *map* *next-generation*)
(setf *next-generation* nil)
(setf *map-copy* nil))
;(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 ()
(fill-map)
; (print-map)
(sdl:with-init ()
(sdl:window
(+ (* *grid-width* 10) 1)
(+ (* *grid-height* 10) 1)
:title-caption "the Game of Life")
(setf (sdl:frame-rate) 60)
(sdl:DISABLE-KEY-REPEAT)
(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-enter)
; (setf *run* (not *run*)))
(when
(sdl:key-down-p :sdl-key-space)
(next-generation)))
(:idle ()
(sdl:clear-display sdl:*black*)
(when (sdl:mouse-left-p)
(mouse-set-cell (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))