Add viewport

NOTES.org

@@ -18,6 +18,7 @@ CLOSED: [2016-01-01 Fri 22:52]
 *** TODO Figure out an interesting way to integrate "Darkness"
 *** TODO Figure out how to get messages in exact center.
 ** Medium priority
-*** TODO Create map -> graphics layer so that isn't manual. (consider generalizing this)
+*** DONE Create map -> graphics layer so that isn't manual. (consider generalizing this)
+CLOSED: [2016-01-02 Sat 01:32]
 *** TODO Create generalized input command dispatch. (consider generalizing this)
 *** TODO Create configuration system that can control display and keybindings.

crypts-and-corpses.lisp

@@ -7,9 +7,16 @@
   (height 40 :type fixnum :read-only t)
   (mobiles (make-hash-table) :type hash-table :read-only t))
 
-(defclass tile-entity ()
-  ((codepoint :initarg :codepoint :initform #x3f :type fixnum)
-   (location :initarg :location :initform 0 :type fixnum)))
+(defclass entity ()
+  ((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)
@@ -50,7 +57,14 @@
 (defgeneric move-up (object map))
 (defgeneric move-down (object map))
 
-(defun update-location (object map old-location new-location)
+(defgeneric update-location (object map old-locaiton new-location))
+
+(defmethod update-location ((object entity) map old-location new-location)
+  (declare (ignore old-location))
+  (unless (out-of-bounds-p new-location 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)
@@ -58,30 +72,28 @@
 
 (defun out-of-bounds-p (new-location map)
   (multiple-value-bind (x y) (calc-coord new-location map)
-    (format t "~S~%" x)
-    (format t "~S~%" y)
     (or (> 0 x)
         (> 0 y)
         (>= x (game-map-width map))
         (>= y (game-map-height map)))))
 
-(defmethod move-left ((object mobile) 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 mobile) map)
+(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 mobile) map)
+(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 mobile) map)
+(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))
@@ -95,8 +107,8 @@
     (terminal-refresh)
         until (= key bearlibterminal-ffi:+tk-enter+)))
 
-(defun write-map-to-terminal (map)
-  (labels ((write-cell (key tile) (multiple-value-bind (x y) (calc-coord key map)
+(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))))
 
@@ -104,12 +116,20 @@
   (setf (gethash (slot-value player 'location) (game-map-mobiles map)) player)
   map)
 
-(defun handle-input (key map player)
+(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-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))))
+
+(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
@@ -117,10 +137,11 @@
                  :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 player)
+            (handle-input key map viewport player)
             (terminal-clear)
-            (write-map-to-terminal map)
+            (write-map-to-terminal map viewport)
             (terminal-refresh)
           until (or (= key bearlibterminal-ffi:+tk-close+)
                     (= key bearlibterminal-ffi:+tk-escape+)))))