crypts-and-corpses/crypts-and-corpses.lisp

;;;; crypts-and-corpses.lisp

(in-package #:crypts-and-corpses)

(defstruct game-map
  (width 250 :type fixnum :read-only t)
  (height 250 :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)))

(defclass tile-entity (entity)
  ((codepoint :initarg :codepoint :initform #x3f :type fixnum)))

(defclass viewport (entity)
  ((width :initarg :width :type fixnum :initform 100)
   (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-regen :initarg :health-regen :initform 0 :type fixnum)
   (mana-regen :initarg :mana-regen :initform 0 :type fixnum)))

(defclass player-character (mobile)
  ((ranged-attack-damage :initarg :ranged-attack-damage :initform 5 :type fixnum)
   (ranged-attack-cost :initarg :ranged-attack-cost :initform 5 :type fixnum)))

(defclass enemy (mobile) ())

(defclass minion (mobile) ())

(defun calc-coord (location map)
  (values (mod location (game-map-width map)) (floor (/ location (game-map-width map)))))

(defun get-window-size ()
  (apply 'values (mapcar #'parse-integer (split-sequence #\x (terminal-get "window.size" "0x0")))))

;; DEPRECATED until I find a use for it
;; (defun calc-location (x y map)
;;   (+ (* (game-map-width map) (cdr y)) (car x)))
;; (defgeneric set-location (object x y))
;; (defmethod set-location ((object tile-entity) x y)
;;   (setf (slot-value object 'location) (calc-location x y)))


(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)))

(defgeneric move-left (object map))
(defgeneric move-right (object map))
(defgeneric move-up (object map))
(defgeneric move-down (object map))

(defgeneric update-location (object map old-location new-location))

(defun overrun-p (old-location new-location map)
  (multiple-value-bind (old-x old-y) (calc-coord old-location map)
    (multiple-value-bind (new-x new-y) (calc-coord new-location map)
      (and (< old-y new-y)
           (> old-x new-x)))))

(defmethod update-location ((object entity) map old-location new-location)
  (unless (or (out-of-bounds-p new-location map)
              (overrun-p old-location (+ new-location (slot-value object 'width)) map)
              (out-of-bounds-p (+ new-location (* (slot-value object 'height) (game-map-width map))) map))
    (setf (slot-value object 'location) new-location)))

(defmethod update-location ((object mobile) map old-location new-location)
  (unless (out-of-bounds-p new-location map)
    (setf (slot-value object 'location) new-location)
    (setf (gethash new-location (game-map-mobiles map)) object)
    (remhash old-location (game-map-mobiles map))))

(defun out-of-bounds-p (new-location map)
  (multiple-value-bind (x y) (calc-coord new-location map)
    (or (> 0 x)
        (> 0 y)
        (>= x (game-map-width map))
        (>= y (game-map-height map)))))

(defmethod move-left ((object entity) map)
  (let ((old-location (slot-value object 'location))
        (new-location (1- (slot-value object 'location))))
    (unless (= 0 (calc-coord old-location map))
      (update-location object map old-location new-location))))

(defmethod move-up ((object entity) map)
  (let ((old-location (slot-value object 'location))
        (new-location (- (slot-value object 'location) (game-map-width map))))
    (update-location object map old-location new-location)))

(defmethod move-down ((object entity) map)
  (let ((old-location (slot-value object 'location))
        (new-location (+ (slot-value object 'location) (game-map-width map))))
    (update-location object map old-location new-location)))

(defmethod move-right ((object entity) map)
  (let ((old-location (slot-value object 'location))
        (new-location (1+ (slot-value object 'location))))
    (unless (= 0 (calc-coord new-location map))
      (update-location object map old-location new-location))))

(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+)))

(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-put x y (slot-value tile 'codepoint)))))
    (maphash #'write-cell (game-map-mobiles map))))

(defun initialize-map (map player)
  (setf (gethash (slot-value player 'location) (game-map-mobiles map)) player)
  map)

(defun handle-input (key map viewport player)
  (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)))))

(defun create-viewport ()
  (multiple-value-bind (width height) (get-window-size)
    (make-instance 'viewport :width width :height height)))

(defun main-loop ()
  (let ((player (make-instance
                 'player-character
                 :codepoint #x263a
                 :location 0)))
    (loop with map = (initialize-map (make-instance 'game-map) player)
          with viewport = (create-viewport)
          as key = (terminal-read) do
            (handle-input key map viewport player)
            (terminal-clear)
            (write-map-to-terminal map viewport)
            (terminal-refresh)
          until (or (= key bearlibterminal-ffi:+tk-close+)
                    (= key bearlibterminal-ffi:+tk-escape+)))))

(defun start ()
  (terminal-open)
  (terminal-set "window: size=100x40, title='Crypts and Corpses'")
  (terminal-set "font: ./fonts/DejaVuSansMono.ttf, size=16")
  (intro-message)
  (main-loop)
  (terminal-close))