Commits (5)
......@@ -6,66 +6,86 @@
;;;; global state --------------------------------------------------------------
(defparameter *running* nil)
(defparameter *width* nil)
(defparameter *height* nil)
;;;; scenes ---------------------------------------------------------------------
(defclass <scene> () ())
(defclass scene () ())
(defgeneric display-scene (scene window))
(defgeneric handle-input (scene key))
(defclass <start-scene> (<scene>) ())
(defclass start-scene (scene) ())
(defmethod display-scene ((s <start-scene>) window)
(defmethod display-scene ((s start-scene) window)
(draw-string window 0 2 " CORYS ROGUELIKE")
(draw-string window 0 4 " Press [Space] to start")
(draw-string window 0 5 " Press [Q] to quit"))
(defmethod handle-input ((s <start-scene>) key)
(defmethod handle-input ((s start-scene) key)
(case key
(#\Space (make-instance '<play-scene>))
(#\Space (make-instance 'play-scene :world (random-world 250 250)))
(#\Q (progn
(setf *running* nil)
(otherwise s)))
(defclass play-scene (scene)
:initarg :world
:initform (error "`world` is required")
:accessor world)
(defclass <play-scene> (<scene>) ())
:initform '(0 0)
:accessor location)))
(defmethod display-scene ((s <play-scene>) window)
(draw-string window 0 0 " You are having fun.")
(draw-string window 0 1 "-- press [Esc] to lose or [Enter] to win --"))
(defmethod display-scene ((s play-scene) window)
(draw-world window (world s) (location s))
(draw-string window 0 (1- *height*) "-- [~S] press [Esc] to lose, [Enter] to win, [S] to smooth -- " (location s)))
(defmethod handle-input ((s <play-scene>) key)
(defmethod handle-input ((s play-scene) key)
(case key
(#\Escape (make-instance '<lose-scene>))
(#\Newline (make-instance '<win-scene>))
(#\Escape (make-instance 'lose-scene))
(#\Newline (make-instance 'win-scene))
(#\S (progn
(setf (world s) (smooth (world s)))
(#\l (update-position s :dx 1))
(#\h (update-position s :dx -1))
(#\j (update-position s :dy 1))
(#\k (update-position s :dy -1))
(otherwise s)))
(defun update-position (scene &key (dy 0) (dx 0))
(destructuring-bind (x y) (location scene)
(setf (location scene) (list (+ dx x) (+ dy y))))
(defclass <win-scene> (<scene>) ())
(defclass win-scene (scene) ())
(defmethod display-scene ((s <win-scene>) window)
(defmethod display-scene ((s win-scene) window)
(draw-string window 0 0 " !! YOU WIN !!")
(draw-string window 0 1 "-- press [Enter] to restart --"))
(defmethod handle-input ((s <win-scene>) key)
(defmethod handle-input ((s win-scene) key)
(case key
(#\Newline (make-instance '<start-scene>))
(#\Newline (make-instance 'start-scene))
(otherwise s)))
(defclass <lose-scene> (<scene>) ())
(defclass lose-scene (scene) ())
(defmethod display-scene ((s <lose-scene>) window)
(defmethod display-scene ((s lose-scene) window)
(draw-string window 0 0 " You lose.")
(draw-string window 0 1 "-- press [Enter] to restart --"))
(defmethod handle-input ((s <lose-scene>) key)
(defmethod handle-input ((s lose-scene) key)
(case key
(#\Newline (make-instance '<start-scene>))
(#\Newline (make-instance 'start-scene))
(otherwise s)))
......@@ -77,15 +97,69 @@
;;;; world generation -----------------------------------------------------------
(defstruct tile name glyph color)
(defparameter *tiles* (make-hash-table))
(setf (gethash 'floor *tiles*) (make-tile :name "floor" :glyph "." :color :white))
(setf (gethash 'wall *tiles*) (make-tile :name "wall" :glyph "#" :color :white))
(setf (gethash 'bound *tiles*) (make-tile :name "bound" :glyph "X" :color :black))
(defun random-world (width height)
(make-array (list height width)
(loop for row upto (1- height) collect
(loop for column upto (1- width) collect (random-tile)))))
(defun smooth (world)
(destructuring-bind (world-height world-width) (array-dimensions world)
(let ((r (make-array (list world-height world-width))))
(loop for row upto (1- world-height) do
(loop for col upto (1- world-width) do
(let ((wall-count (length
(remove-if-not (lambda (tile) (equal "wall" (tile-name tile)))
(neighbors world col row)))))
(setf (aref r row col)
(if (> wall-count 4)
(gethash 'wall *tiles* )
(gethash 'floor *tiles*))))))
(defun neighbors (world x y)
(loop for xd from (1- x) upto (1+ x) append
(loop for yd from (1- y) upto (1+ y)
when (not (and (eq x xd) (eq y yd)))
collect (get-tile world xd yd))))
(defun random-tile ()
(let ((tiles '(floor wall)))
(gethash (nth (random (length tiles)) tiles) *tiles*)))
(defun get-tile (world x y)
(handler-case (aref world y x)
(sb-int:invalid-array-index-error () (gethash 'bound *tiles*))))
(defun draw-world (window world location)
(destructuring-bind (viewport-x viewport-y) location
(loop for y upto (1- *height*) do
(loop for x upto (1- (1- *width*)) do
(draw-string window x y (tile-glyph (get-tile world (+ viewport-x x) (+ viewport-y y))))))))
;;;; main -----------------------------------------------------------------------
(defun initialize ()
(defun initialize (window)
(setf *running* t)
(make-instance '<start-scene>))
(multiple-value-bind (width height) (charms:window-dimensions window)
(setf *width* width)
(setf *height* height))
(make-instance 'start-scene))
(defun gameloop ()
(let* ((window charms:*standard-window*)
(scene (initialize)))
(scene (initialize window)))
(loop named :game-loop
while *running*
do (progn
......@@ -98,3 +172,4 @@
(charms:enable-raw-input :interpret-control-characters t)