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

;;;; crypts-and-corpses.lisp

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

(defclass tile-entity ()
  ((codepoint :initarg :codepoint :initform #x3f)
   (location :initarg :location :initform 0)))

(defclass mobile (tile-entity)
  ((health :initarg :health)
   (mana :initarg :mana)))

(defclass player-character (mobile) ())

(defclass enemy (mobile) ())

(defclass minion (mobile) ())

(defun calc-location (x y)
  (+ (* 100 (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 move-left (object map))
(defgeneric move-right (object map))
(defgeneric move-up (object map))
(defgeneric move-down (object map))

(defun update-location (object map old-location new-location)
  (setf (slot-value object 'location) new-location)
  (setf (gethash new-location map) object)
  (remhash old-location map))

(defmethod move-left ((object mobile) map)
  (let ((old-location (slot-value object 'location))
        (new-location (1- (slot-value object 'location))))
    (update-location object map old-location new-location)))

(defmethod move-up ((object mobile) map)
  (let ((old-location (slot-value object 'location))
        (new-location (- (slot-value object 'location) 100)))
    (update-location object map old-location new-location)))

(defmethod move-down ((object mobile) map)
  (let ((old-location (slot-value object 'location))
        (new-location (+ (slot-value object 'location) 100)))
    (update-location object map old-location new-location)))

(defmethod move-right ((object mobile) map)
  (let ((old-location (slot-value object 'location))
        (new-location (1+ (slot-value object 'location))))
    (update-location object map old-location new-location)))

(defun intro-message ()
  (loop as key = (terminal-read) do
    (terminal-print 40 21  "Crypts and Corpses")
    (terminal-print 39 22 "Press enter to start")
    (terminal-refresh)
        until (= key bearlibterminal-ffi:+tk-enter+)))

(defun write-cell (key tile)
  (terminal-put (mod key 100) (floor (/ key 100)) (slot-value tile 'codepoint)))

(defun write-map-to-terminal (map)
  (maphash #'write-cell map))

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

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

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

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