WIP commit

src/crypts-and-corpses.lisp

@@ -18,40 +18,54 @@
 (in-package #:crypts-and-corpses)
 
 (defstruct game-map
-  (width 100 :type fixnum :read-only t)
-  (height 40 :type fixnum :read-only t)
+  (width  99 :type fixnum :read-only t)
+  (height 39 :type fixnum :read-only t)
   (mobiles (make-hash-table) :type hash-table :read-only t))
 
 (defclass entity ()
   ((width :initarg :width :type fixnum :initform 1)
    (height :initarg :height :type fixnum :initform 1)
-   (location :initarg :location :initform 0 :type fixnum)))
+   (location :initarg :location :initform 0 :type fixnum)
+   (color :initarg :color :initform (color-from-name "white"))))
 
 (defclass tile-entity (entity)
   ((codepoint :initarg :codepoint :initform #x3f :type fixnum)))
 
 (defclass wall (tile-entity)
-  ((codepoint :initarg :codepoint :initform #x23 :type fixnum)))
+  ((codepoint :initarg :codepoint :initform #x23 :type fixnum)
+   (color :initarg :color :initform (color-from-name "grey"))))
 
 (defclass viewport (entity)
-  ((width :initarg :width :type fixnum :initform 100)
+  ((width :initarg :width :type fixnum :initform 99)
    (height :initarg :height :type fixnum :initform 40)
    (location :initarg :location :type fixnum :initform 0)))
 
 (defclass mobile (tile-entity)
-  ((health :initarg :health :type fixnum)
-   (mana :initarg :mana :type fixnum)
+  ((health :initarg :health :type fixnum :initform 10)
+   (mana :initarg :mana :type fixnum :initform 0)
+   (max-health :initarg :health :type fixnum :initform 10)
+   (max-mana :initarg :mana :type fixnum :initform 10)
    (health-regen :initarg :health-regen :initform 0 :type fixnum)
    (mana-regen :initarg :mana-regen :initform 0 :type fixnum)))
 
 (defclass player-character (mobile)
-  ((codepoint :initform #x263a)
+  ((health :initarg :health :type fixnum :initform 100)
+   (mana :initarg :mana :type fixnum :initform 10)
+   (codepoint :initform #x263a)
    (ranged-attack-damage :initarg :ranged-attack-damage :initform 5 :type fixnum)
-   (ranged-attack-cost :initarg :ranged-attack-cost :initform 5 :type fixnum)))
+   (melee-attack-damage :initarg :ranged-attack-damage :initform 2 :type fixnum)
+   (ranged-attack-cost :initarg :ranged-attack-cost :initform 5 :type fixnum)
+   (mana-regen :initarg :mana-regen :initform 3 :type fixnum)
+   (color :initarg :color :initform (color-from-name "green"))))
 
-(defclass enemy (mobile) ())
+(defclass enemy (mobile)
+  ((codepoint :initform #x263a)
+   (melee-attack-damage :initarg :ranged-attack-damage :initform 1 :type fixnum)
+   (health-regen :initarg :health-regen :initform 1 :type fixnum)
+   (color :initarg :color :initform (color-from-name "red"))))
 
-(defclass minion (mobile) ())
+(defclass minion (mobile)
+  ((color :initarg :color :initform (color-from-name "yellow"))))
 
 (defun calc-coord (location map)
   (values (mod location (game-map-width map)) (floor (/ location (game-map-width map)))))
@@ -66,12 +80,15 @@
 (defmethod set-location ((object tile-entity) x y map)
   (setf (slot-value object 'location) (calc-location x y map)))
 
-
 (defgeneric end-of-turn (object))
 
 (defmethod end-of-turn ((object mobile))
   (incf (slot-value object 'health) (slot-value object 'health-regen))
-  (incf (slot-value object 'mana) (slot-value object 'mana-regen)))
+  (incf (slot-value object 'mana) (slot-value object 'mana-regen))
+  (when (> (slot-value object 'health) (slot-value object 'max-health))
+    (setf (slot-value object 'health) (slot-value object 'max-health)))
+  (when (> (slot-value object 'mana) (slot-value object 'max-mana))
+    (setf (slot-value object 'mana) (slot-value object 'max-mana))))
 
 (defgeneric move-left (object map))
 (defgeneric move-right (object map))
@@ -99,11 +116,14 @@
    (1- (slot-value object 'width))
    (* (1- (slot-value object 'height)) (game-map-width map))))
 
+(defun collision-p (new-location map)
+  (gethash new-location (game-map-mobiles map)))
+
 (defun bad-move-p (object map old-location new-location)
   (let ((old-effective-location (calculate-effective-location object map old-location))
         (new-effective-location (calculate-effective-location object map new-location)))
     (or (out-of-bounds-p new-effective-location map)
-        (out-of-bounds-p new-location map)
+        (collision-p new-effective-location map)
         (overrun-p old-effective-location new-effective-location map))))
 
 (defmethod update-location ((object entity) map old-location new-location)
@@ -136,21 +156,130 @@
         (new-location (1+ (slot-value object 'location))))
     (update-location object map old-location new-location)))
 
+(defun find-mobile-left (location map)
+  (let ((found-object nil))
+    (loop for i from (1- location) downto 0 do
+      (setf found-object (gethash i (game-map-mobiles map)))
+      (when (not (typep found-object 'mobile))
+        (setf found-object nil))
+          until found-object)
+    found-object))
+
+(defun find-mobile-right (location map)
+  (let ((found-object nil))
+    (loop for i from (1+ location) to (* (game-map-width map) (game-map-height map)) do
+      (setf found-object (gethash i (game-map-mobiles map)))
+      (when (not (typep found-object 'mobile))
+        (setf found-object nil))
+          until found-object)
+    found-object))
+
+(defun find-mobile-up (location map)
+  (let ((found-object nil))
+    (loop for i from (- location (game-map-width map)) downto 0 by (game-map-width map) do
+      (setf found-object (gethash i (game-map-mobiles map)))
+      (when (not (typep found-object 'mobile))
+        (setf found-object nil))
+          until found-object)
+    found-object))
+
+(defun find-mobile-down (location map)
+  (let ((found-object nil))
+    (loop for i from (+ location (game-map-width map)) to (* (game-map-width map) (game-map-height map)) by (game-map-width map) do
+      (setf found-object (gethash i (game-map-mobiles map)))
+      (when (not (typep found-object 'mobile))
+        (setf found-object nil))
+          until found-object)
+    found-object))
+
+(defgeneric shoot-left (object map))
+(defgeneric shoot-right (object map))
+(defgeneric shoot-up (object map))
+(defgeneric shoot-down (object map))
+
+(defmethod shoot-left ((object player-character) map)
+  (let ((target (find-mobile-left (slot-value object 'location) map)))
+    (when target
+      (decf (slot-value target 'health) (slot-value object 'ranged-attack-damage))
+      (decf (slot-value object 'mana) (slot-value object 'ranged-attack-cost)))))
+
+(defmethod shoot-right ((object player-character) map)
+  (let ((target (find-mobile-right (slot-value object 'location) map)))
+    (when target
+      (decf (slot-value target 'health) (slot-value object 'ranged-attack-damage))
+      (decf (slot-value object 'mana) (slot-value object 'ranged-attack-cost)))))
+
+(defmethod shoot-up ((object player-character) map)
+  (let ((target (find-mobile-up (slot-value object 'location) map)))
+    (when target
+      (decf (slot-value target 'health) (slot-value object 'ranged-attack-damage))
+      (decf (slot-value object 'mana) (slot-value object 'ranged-attack-cost)))))
+
+(defmethod shoot-down ((object player-character) map)
+  (let ((target (find-mobile-down (slot-value object 'location) map)))
+    (when target
+      (decf (slot-value target 'health) (slot-value object 'ranged-attack-damage))
+      (decf (slot-value object 'mana) (slot-value object 'ranged-attack-cost)))))
+
+(defgeneric bash-left (object map))
+(defgeneric bash-right (object map))
+(defgeneric bash-up (object map))
+(defgeneric bash-down (object map))
+
+(defmethod bash-left ((object player-character) map)
+  (let* ((location (1- (slot-value object 'location)))
+         (potential-target (gethash location (game-map-mobiles map)))
+         (target (and potential-target (typep potential-target 'mobile))))
+    (when target
+      (decf (slot-value target 'health) (slot-value object 'melee-attack-damage)))))
+
+(defmethod bash-right ((object player-character) map)
+  (let* ((location (1+ (slot-value object 'location)))
+         (potential-target (gethash location (game-map-mobiles map)))
+         (target (and potential-target (typep potential-target 'mobile))))
+    (when target
+      (decf (slot-value target 'health) (slot-value object 'melee-attack-damage)))))
+
+(defmethod bash-up ((object player-character) map)
+  (let* ((location (- (slot-value object 'location) (game-map-width map)))
+         (potential-target (gethash location (game-map-mobiles map)))
+         (target (and potential-target (typep potential-target 'mobile))))
+    (when target
+      (decf (slot-value target 'health) (slot-value object 'melee-attack-damage)))))
+
+(defmethod bash-down ((object player-character) map)
+  (let* ((location (+ (slot-value object 'location) (game-map-width map)))
+         (potential-target (gethash location (game-map-mobiles map)))
+         (target (and potential-target (typep potential-target 'mobile))))
+    (when target
+      (decf (slot-value target 'health) (slot-value object 'melee-attack-damage)))))
+
 (defun intro-message ()
-  (loop as key = (terminal-read) do
-    (multiple-value-bind (win-width win-height) (get-window-size)
-      (terminal-print (floor (- (/ win-width 2) 10)) (floor (1- (/ win-height 2))) "Crypts and Corpses")
-      (terminal-print (floor (- (/ win-width 2) 11)) (floor (1+ (/ win-height 2))) "Press enter to start"))
-    (terminal-refresh)
-        until (= key bearlibterminal-ffi:+tk-enter+)))
+  (multiple-value-bind (win-width win-height) (get-window-size)
+    (terminal-print (floor (- (/ win-width 2) 10)) (floor (1- (/ win-height 2))) "Crypts and Corpses")
+    (terminal-print (floor (- (/ win-width 2) 11)) (floor (1+ (/ win-height 2))) "Press enter to start"))
+  (terminal-refresh))
 
 (defun write-map-to-terminal (map viewport)
   (labels ((write-cell (key tile)
              (multiple-value-bind (x y) (calc-coord (- key (slot-value viewport 'location)) map)
+               (terminal-color (slot-value tile 'color))
                (terminal-put x y (slot-value tile 'codepoint)))))
     (maphash #'write-cell (game-map-mobiles map))))
 
-(defun fill-map-from-crawler (dungeon map)
+(defun nearest-open-tile (location map)
+  (let ((left (1- location))
+        (right (1+ location))
+        (up (- (game-map-width map) location))
+        (down (+ (game-map-width map) location))
+        (mobiles (game-map-mobiles map)))
+    (cond
+      ((eq :not-found (gethash left mobiles :not-found)) left)
+      ((eq :not-found (gethash up mobiles :not-found)) up)
+      ((eq :not-found (gethash right mobiles :not-found)) right)
+      ((eq :not-found (gethash down mobiles :not-found)) down))))
+
+(defun fill-map-from-crawler (dungeon map player)
   (with-slots ((width crawler:width) (height crawler:height)) dungeon
     (dotimes (x width)
       (dotimes (y height)
@@ -158,24 +287,52 @@
           (unless (crawler:walkablep tile)
             (let ((wall (make-instance 'wall)))
               (set-location wall x y map)
-              (setf (gethash (calc-location x y map) (game-map-mobiles map)) wall))))))))
+              (setf (gethash (calc-location x y map) (game-map-mobiles map)) wall)))
+          (when (eq (crawler:map-feature tile) :stairs-up)
+            (set-location player x y map)
+            (setf (gethash (calc-location x y map) (game-map-mobiles map)) player)
+            (let* ((location (nearest-open-tile (calc-location x y map) map))
+                   (enemy (make-instance 'enemy :location location)))
+              (setf (gethash location (game-map-mobiles map)) enemy))))))))
 
 (defun initialize-map (map player)
   (setf (gethash (slot-value player 'location) (game-map-mobiles map)) player)
-  (fill-map-from-crawler (crawler:make-dungeon (1- (game-map-width map)) (1- (game-map-height map))) map)
+  (fill-map-from-crawler (crawler:make-dungeon (game-map-width map) (game-map-height map)) map player)
   map)
 
-(defun handle-input (key map viewport player)
+(defun handle-input (key map viewport player prev-key)
   (cond
-    ((= key bearlibterminal-ffi:+tk-up+) (move-up player map))
-    ((= key bearlibterminal-ffi:+tk-down+) (move-down player map))
-    ((= key bearlibterminal-ffi:+tk-right+) (move-right player map))
-    ((= key bearlibterminal-ffi:+tk-left+) (move-left player map))
-    ((= key bearlibterminal-ffi:+tk-w+) (move-up viewport map))
-    ((= key bearlibterminal-ffi:+tk-a+) (move-left viewport map))
-    ((= key bearlibterminal-ffi:+tk-d+) (move-right viewport map))
-    ((= key bearlibterminal-ffi:+tk-s+) (move-down viewport map))
-    ((= key bearlibterminal-ffi:+tk-space+) (update-location viewport map (slot-value viewport 'location) (slot-value player 'location)))))
+    ;; Ranged attack
+    ((equal prev-key bearlibterminal-ffi:+tk-r+)
+     (cond
+       ((= key bearlibterminal-ffi:+tk-up+) (shoot-up player map))
+       ((= key bearlibterminal-ffi:+tk-down+) (shoot-down player map))
+       ((= key bearlibterminal-ffi:+tk-right+) (shoot-right player map))
+       ((= key bearlibterminal-ffi:+tk-left+) (shoot-left player map))
+       ((= key bearlibterminal-ffi:+tk-enter+) t))) ; cancel
+    ;; Melee attack
+    ((equal prev-key bearlibterminal-ffi:+tk-m+)
+     (cond
+       ((= key bearlibterminal-ffi:+tk-up+) (bash-up player map))
+       ((= key bearlibterminal-ffi:+tk-down+) (bash-down player map))
+       ((= key bearlibterminal-ffi:+tk-right+) (bash-right player map))
+       ((= key bearlibterminal-ffi:+tk-left+) (bash-left player map))
+       ((= key bearlibterminal-ffi:+tk-enter+) t))) ; cancel
+    ;; Not a stateful command
+    (:otherwise
+     (cond
+       ((= key bearlibterminal-ffi:+tk-r+) t) ; Prepare for ranged
+       ((= key bearlibterminal-ffi:+tk-m+) t) ; Prepare for melee
+       ((= key bearlibterminal-ffi:+tk-enter+) t) ; idle
+       ((= key bearlibterminal-ffi:+tk-up+) (move-up player map))
+       ((= key bearlibterminal-ffi:+tk-down+) (move-down player map))
+       ((= key bearlibterminal-ffi:+tk-right+) (move-right player map))
+       ((= key bearlibterminal-ffi:+tk-left+) (move-left player map))
+       ((= key bearlibterminal-ffi:+tk-w+) (move-up viewport map))
+       ((= key bearlibterminal-ffi:+tk-a+) (move-left viewport map))
+       ((= key bearlibterminal-ffi:+tk-d+) (move-right viewport map))
+       ((= key bearlibterminal-ffi:+tk-s+) (move-down viewport map))
+       ((= key bearlibterminal-ffi:+tk-space+) (update-location viewport map (slot-value viewport 'location) (slot-value player 'location)))))))
 
 (defun create-viewport (map)
   (multiple-value-bind (width height) (get-window-size)
@@ -185,23 +342,48 @@
       (setf height (game-map-height map)))
     (make-instance 'viewport :width width :height height)))
 
+(defun end-of-turn-tasks (player map)
+  (declare (ignore player))
+  (maphash (lambda (location object)
+             (when (typep object 'mobile)
+               (if (>= 0 (slot-value object 'health))
+                   (progn
+                     (format t "~S~%" (slot-value object 'health))
+                     (setf (slot-value object 'location) nil)
+                     (remhash location (game-map-mobiles map)))
+                   (end-of-turn object)))) (game-map-mobiles map)))
+
+(defun write-status-to-terminal (player prev-key)
+  (declare (ignore prev-key))
+  (multiple-value-bind (width height) (get-window-size)
+    (declare (ignore width))
+    (terminal-color (color-from-name "white"))
+    (terminal-print 0 (1- height) (format nil "H: ~d M: ~d"
+                                          (slot-value player 'health)
+                                          (slot-value player 'mana)))))
+
 (defun main-loop ()
-  (let ((player (make-instance
-                 'player-character
-                 :location 0)))
-    (loop with map = (initialize-map (make-instance 'game-map) player)
-          with viewport = (create-viewport map)
-          as key = (terminal-read) do
-            (handle-input key map viewport player)
+  (loop with player = (make-instance 'player-character)
+        with map = (initialize-map (make-instance 'game-map) player)
+        with viewport = (create-viewport map)
+        with prev-key = nil
+        as key = (terminal-read) do
+          (when (handle-input key map viewport player prev-key)
+            (setf prev-key key)
             (terminal-clear)
+            (unless (or (= key bearlibterminal-ffi:+tk-r+)
+                        (= key bearlibterminal-ffi:+tk-m+))
+              (end-of-turn-tasks player map))
             (write-map-to-terminal map viewport)
-            (terminal-refresh)
-          until (or (= key bearlibterminal-ffi:+tk-close+)
-                    (= key bearlibterminal-ffi:+tk-escape+)))))
+            (write-status-to-terminal player prev-key)
+            (terminal-refresh))
+        until (or (= key bearlibterminal-ffi:+tk-close+)
+                  (= key bearlibterminal-ffi:+tk-escape+)
+                  (eq (slot-value player 'location) nil))))
 
 (defun start ()
   (terminal-open)
-  (terminal-set "window: size=100x40, title='Crypts and Corpses'")
+  (terminal-set "window: size=99x40, title='Crypts and Corpses'")
   (terminal-set "font: ./fonts/DejaVuSansMono.ttf, size=16")
   (intro-message)
   (main-loop)