Port the rest of game and engine to lisp

src/engine.lisp

@@ -1,56 +1,169 @@
-#-quicklisp
-(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (ql:quickload '(:cl-raylib :livesupport) :silent t)
-  #+sbcl (sb-int:set-floating-point-modes :traps nil))
-
 (defpackage #:engine
   (:use #:cl)
   (:local-nicknames (#:rl #:raylib)
                     (#:v #:3d-vectors))
-  (:export #:main)
+  (:export #:run-game
-  (:export #:run-game))
+           #:*game-state* #:*game-config*
+           #:read-data #:data-field #:reload-config #:resource-path
+           #:load-texture-once
+           #:make-int-grid
+           #:copy-slots))
 
 (in-package #:engine)
 
 (defvar *game-state* nil)
 (defvar *game-config* nil)
-(defvar *texture-cache* (make-hash-table :test #'equal))
+(defvar *config-path* nil)
-;; (reset! texture-cache {})
-(defvar *buffered-objs* nil)
 
-(defun read-config (b))
+(defvar *texture-cache* (make-hash-table :test #'equal)
-(defun snapshot (b))
+  "Path -> rl:texture. Keyed by string, hence :test equal.")
-(defun restore (b))
 
-(defun run-game (&key (title "Untitled") (width 800) (height 600)
+(defvar *buffers* nil
-                   config-path game-init game-update game-draw unload)
+  "List of (live . backup) int-grid pairs, snapshotted at the top of each frame
+   so a failed frame can be rolled back. See snapshot-state / restore-state.")
+
+(defvar *state-backup* nil
+  "Shallow copy of *game-state*, refreshed every frame alongside *buffers*.")
+
+;;; ------------------------------------------------------------------- assets
+
+(defun resource-path (relative)
+  "Resolve a project-relative path against the system's source directory.
+
+   Everything that touches an asset goes through this. Raylib resolves paths
+   against the *process* working directory, which under SLY is wherever the
+   inferior Lisp happened to start -- and a miss there is silent, LoadTexture
+   just hands back a texture with id 0."
+  (let ((path (asdf:system-relative-pathname :siam-farmer relative)))
+    (unless (probe-file path)
+      (error "Missing resource ~s~%  resolved to: ~a~%  project root: ~a"
+             relative path (asdf:system-source-directory :siam-farmer)))
+    (namestring path)))
+
+(defun read-data (path)
+  "Read one s-expression from PATH, taken relative to the project root. The
+   .data files are plists; *read-eval* is off so a data file can never execute
+   code at load time."
+  (with-open-file (s (resource-path path))
+    (let ((*read-eval* nil))
+      (read s))))
+
+(defun data-field (plist key source)
+  "GETF that refuses to come back empty. A key typo'd in a .data file should
+   fail at the file it was read from, not silently three calls later as an
+   empty palette."
+  (or (getf plist key)
+      (error "Missing ~s in ~a" key source)))
+
+(defun reload-config ()
+  (when *config-path*
+    (setf *game-config* (read-data *config-path*))))
+
+(defun load-texture-once (path)
+  "Load a texture once per path, PATH being relative to the project root."
+  (or (gethash path *texture-cache*)
+      (let ((texture (rl:load-texture (resource-path path))))
+        ;; Raylib only logs a failed load, so check rather than draw nothing.
+        (when (zerop (rl:texture-id texture))
+          (warn "Failed to load texture: ~a" (resource-path path)))
+        (setf (gethash path *texture-cache*) texture))))
+
+;;; ---------------------------------------------------------------- buffering
+
+(defun make-int-grid (n &optional (initial -1))
+  (let ((grid (make-array n :element-type '(signed-byte 32) :initial-element initial)))
+    (push (cons grid (make-array n :element-type '(signed-byte 32) :initial-element initial))
+          *buffers*)
+    grid))
+
+(defun copy-slots (from to)
+  "Shallow-copy every bound slot of FROM onto TO. Walks the class rather than
+   naming slots, so adding a slot to the game class needs no change here."
+  (loop for slot in (sb-mop:class-slots (class-of from))
+        for name = (sb-mop:slot-definition-name slot)
+        when (slot-boundp from name)
+          do (setf (slot-value to name) (slot-value from name)))
+  to)
+
+(defun snapshot-state ()
+  (when *game-state*
+    (unless (and *state-backup*
+                 (eq (class-of *state-backup*) (class-of *game-state*)))
+      (setf *state-backup* (allocate-instance (class-of *game-state*))))
+    (copy-slots *game-state* *state-backup*))
+  (loop for (live . backup) in *buffers*
+        do (replace backup live)))
+
+(defun restore-state ()
+  "Roll the frame back. Copies *into* the existing state object rather than
+   allocating a new one, so any reference held at the REPL stays live."
+  (when (and *game-state* *state-backup*)
+    (copy-slots *state-backup* *game-state*))
+  (loop for (live . backup) in *buffers*
+        do (replace live backup)))
+
+;;; ------------------------------------------------------------------- loop
+
+(defun init-state (init)
+  (setf *buffers*      nil
+        *state-backup* nil
+        *game-state*   (funcall init)))
+
+(defun run-frame (init update draw)
+  "Run one frame. Returns NIL to ask for a re-run, T to move on."
+  (restart-case
+      (progn
+        (funcall update *game-state*)
+        (rl:with-drawing (funcall draw *game-state*))
+        t)
+    (retry-frame ()
+      :report "Roll back this frame and run it again"
+      (restore-state)
+      nil)
+    (skip-frame ()
+      :report "Roll back this frame and continue to the next"
+      (restore-state)
+      t)
+    (reinit ()
+      :report "Throw the state away and re-run the game's init"
+      (init-state init)
+      t)))
+
+(defun cleanup ()
+  (loop for tex being the hash-values of *texture-cache*
+        do (rl:unload-texture tex))
+  (clrhash *texture-cache*)
+  (setf *buffers*      nil
+        *state-backup* nil
+        *game-state*   nil
+        *game-config*  nil
+        *config-path*  nil))
+
+(defun run-game (&key (title "Untitled") (width 1200) (height 900)
+                   config-path init update draw unload)
   (if (rl:is-window-ready)
       (warn "Existing raylib window open, ignoring!")
       (progn
         (rl:set-trace-log-level :log-warning)
+        ;; Decide the REPL backend now, at game start, rather than inheriting
+        ;; whatever was loaded when livesupport itself was.
+        (livesupport:reset-livecoding)
         (rl:with-window (width height title)
+          ;; cleanup has to run inside with-window -- unload-texture needs a
+          ;; live GL context -- and it has to run on an abort out of the
+          ;; debugger too, or the next (main) reuses dead texture ids.
+          (unwind-protect
+               (progn
                  (rl:set-target-fps 30)
-          (setf *game-config* (when config-path (read-config config-path))
+                 (setf *config-path* config-path)
-                *game-state*  (funcall game-init))
+                 (reload-config)
-          (flet ((frame ()
+                 (init-state init)
-                   (livesupport:continuable
+                 (loop until (rl:window-should-close)
-                     (let ((new-state (funcall game-update *game-state*)))
+                       do (snapshot-state)
-                       (rl:with-drawing (funcall game-draw new-state))
+                          (loop until (run-frame init update draw))
-                       (setf *game-state* new-state)))))
+                          ;; Services SLY between frames, so redefining a
-            (loop until (rl:window-should-close) do
+                          ;; function at the REPL takes effect on the next one
-              (dolist (b *buffered-objs*) (snapshot b))
+                          ;; without restarting the game.
-              (restart-case (frame)
+                          (livesupport:update-repl-link))
-                (retry-frame () :report "Restore grid and re-run frame"
-                  (dolist (b *buffered-objs*) (restore b))
-                  (frame))
-                (skip-frame () :report "Restore grid and continue"
-                  (dolist (b *buffered-objs*) (restore b))))))
-          (loop for tex being the hash-values of *texture-cache*
-                do (rl:unload-texture tex))
                  (when unload (funcall unload *game-state*)))
-        (setf *buffered-objs* nil
+            (cleanup))))))
-              *game-state*    nil
-              *game-config*   nil)
-        (clrhash *texture-cache*))))

src/game.lisp

@@ -1,11 +1,3 @@
-#-quicklisp
-(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))
-(load (merge-pathnames "engine.lisp" *load-pathname*))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (ql:quickload :cl-raylib :silent t)
-  #+sbcl (sb-int:set-floating-point-modes :traps nil))
-
 (defpackage #:game
   (:use #:cl)
   (:local-nicknames (#:rl #:raylib)
@@ -15,43 +7,306 @@
 
 (in-package #:game)
 
-(defconstant +screen-width+ 1400)
+(defconstant +screen-width+ 1280)
-(defconstant +screen-height+ 1000)
+(defconstant +screen-height+ 630)
-(defconstant +cell-size+ 5)
+(defconstant +cell-size+ 16)
 (defconstant +rows+ (floor +screen-height+ +cell-size+))
 (defconstant +cols+ (floor +screen-width+ +cell-size+))
+(defconstant +scale+ 4.0)
+(defconstant +num-layers+ 5)
+
+;; A cell is three ints wide: atlas-id, tile-row, tile-col.
+(defconstant +stride+ 3)
+(defconstant +grid-len+ (* +rows+ +cols+ +stride+))
+
+(defparameter *color-ground* '(232 207 166 255))
+(defparameter *color-tint-gray* '(0 0 0 100))
+
+(defparameter *origin* (v:vec 0 0)
+  "Reused rotation origin -- draw-texture-pro takes one on every call.")
+
+(defparameter *num-keys*
+  #(:key-zero :key-one :key-two :key-three :key-four
+    :key-five :key-six :key-seven :key-eight :key-nine))
+
+;;; ------------------------------------------------------------------- state
 
 (defclass game ()
-  ((layers :initarg :layers :accessor layers)
+  ((editor-mode      :initform nil :accessor editor-mode)
-   (tilesets :initarg :tilesets :accessor tilesets)
+   (color-idx        :initform 0   :accessor color-idx)
-   (tilemaps :initarg :tilemaps :accessor tilemaps)
+   (layers           :initform nil :accessor layers)
-   (current-layer :initarg :current-layer :accessor current-layer)
+   (current-layer    :initform 0   :accessor current-layer)
-   (current-tilemap :initarg :current-tilemap :accessor current-tilemap)
+   (current-tilemap  :initform 0   :accessor current-tilemap)
-   (selected-tile :initarg :selected-tile :accessor selected-tile)))
+   (selected-tile    :initform (list -1 -1 -1) :accessor selected-tile)
+   (hovered-tile     :initform nil :accessor hovered-tile)
+   (drag-mode        :initform nil :accessor drag-mode)
+   (last-filled-cell :initform nil :accessor last-filled-cell)
+   (tilesets         :initform #() :accessor tilesets)
+   (tilemaps         :initform #() :accessor tilemaps)))
 
-(defun game-init ()
+;; Plain data, rebuilt wholesale by the reinit restart, so a struct is fine
-  (make-instance 'game
+;; here -- unlike the game object, nothing needs to survive its redefinition.
-                 :layers '()
+(defstruct tileset
-                 :tilesets '()
+  id texture tiles src-rects dst-rects)
-                 :tilemaps '()
-                 :current-layer 0
-                 :current-tilemap 0
-                 :selected-tile '(-1 -1 -1)))
 
-(defun game-update (state)
+;;; -------------------------------------------------------------------- grid
-  state)
 
-(defun game-draw (state)
+(declaim (ftype (function (fixnum fixnum) fixnum) idx)
-  (rl:clear-background :blue))
+         (inline idx))
+(defun idx (row col)
+  (declare (optimize (speed 3) (safety 0)))
+  (* (+ (* row +cols+) col) +stride+))
+
+(declaim (ftype (function (row-index col-index) fixnum) test-idx))
+(defun test-idx (row col bump)
+  (declare (optimize (speed 3) (safety 0)))
+  (let ((i (idx row col)))
+    (+ i bump)))
+
+(defun tile-at (game layer row col)
+  "Returns (values atlas-id tile-row tile-col). atlas-id is -1 when empty."
+  (let ((grid (aref (layers game) layer))
+        (i (idx row col)))
+    (declare (type (simple-array (signed-byte 32) (*)) grid))
+    (values (aref grid i) (aref grid (+ i 1)) (aref grid (+ i 2)))))
+
+(defun tile-at-p (game layer row col)
+  (/= -1 (aref (the (simple-array (signed-byte 32) (*)) (aref (layers game) layer))
+               (idx row col))))
+
+(defun set-tile (game layer atlas-id tile-row tile-col row col)
+  (let ((grid (aref (layers game) layer))
+        (i (idx row col)))
+    (declare (type (simple-array (signed-byte 32) (*)) grid))
+    (setf (aref grid i)       atlas-id
+          (aref grid (+ i 1)) tile-row
+          (aref grid (+ i 2)) tile-col)))
+
+(defun delete-tile (game layer row col)
+  (let ((grid (aref (layers game) layer))
+        (i (idx row col)))
+    (declare (type (simple-array (signed-byte 32) (*)) grid))
+    (setf (aref grid i) -1 (aref grid (+ i 1)) -1 (aref grid (+ i 2)) -1)))
+
+(defun cell-at-mouse-pos ()
+  (let ((pos (rl:get-mouse-position))
+        (size (* +cell-size+ +scale+)))
+    (values (floor (v:vy pos) size)
+            (floor (v:vx pos) size))))
+
+(defun in-bounds-p (row col)
+  (and (< -1 row +rows+) (< -1 col +cols+)))
+
+;;; ------------------------------------------------------------------- setup
+
+(defun compute-tileset-rects (tiles)
+  "Lay the palette out in a padded grid, in the same order as TILES so a
+   dst-rect and its src-rect share an index."
+  (let ((padding 10)
+        (size (* +cell-size+ +scale+)))
+    (map 'vector
+         (lambda (rc)
+           (destructuring-bind (r c) rc
+             (rl:make-rectangle :x (+ (* padding (1+ c)) (* c size))
+                                :y (+ (* padding (1+ r)) (* r size))
+                                :width size :height size)))
+         tiles)))
+
+(defun load-tileset (path)
+  (let* ((data (e:read-data path))
+         (tiles (e:data-field data :selected-cells path)))
+    (make-tileset
+     :id :level-props
+     :texture (e:load-texture-once (e:data-field data :texture-path path))
+     ;; TODO: needs to become a rect once multi-tile sprites land
+     :tiles tiles
+     :src-rects (map 'vector
+                     (lambda (rc)
+                       (destructuring-bind (r c) rc
+                         (rl:make-rectangle :x (* c +cell-size+) :y (* r +cell-size+)
+                                            :width +cell-size+ :height +cell-size+)))
+                     tiles)
+     :dst-rects (compute-tileset-rects tiles))))
+
+(defun init-game ()
+  (let ((tileset-path "source-assets/Sprout Lands Premium/Tilesets/ground tiles/New tiles/")
+        (game (make-instance 'game)))
+    (setf (layers game)
+          (coerce (loop repeat +num-layers+ collect (e:make-int-grid +grid-len+ -1))
+                  'vector)
+          (tilesets game)
+          (vector (load-tileset "assets/Mushrooms, Flowers, Stones.data"))
+          ;; TODO: raylib fails silently when an image is missing
+          (tilemaps game)
+          (map 'vector
+               (lambda (name) (e:load-texture-once (concatenate 'string tileset-path name)))
+               #("Grass_Hill_Tiles_v2.png"
+                 "Darker_Grass_Tiles_v2.png"
+                 "Soil_Ground_Tiles.png"
+                 "Grass_Tile_Layers.png")))
+    game))
+
+;;; ------------------------------------------------------------------- input
+
+(defun handle-game-input (game)
+  (unless (editor-mode game)
+    (when (rl:is-mouse-button-pressed :mouse-button-left)
+      (setf (drag-mode game) :draw))
+    (when (rl:is-mouse-button-pressed :mouse-button-right)
+      (setf (drag-mode game) :erase))
+    (when (or (rl:is-mouse-button-released :mouse-button-left)
+              (rl:is-mouse-button-released :mouse-button-right))
+      (setf (drag-mode game) nil)))
+
+  (when (rl:is-key-pressed :key-space)
+    ;; Drop any drag along with the toggle: its release arrives while the
+    ;; editor is open, where it is not read, and the drag would otherwise
+    ;; go on painting behind the palette.
+    (setf (editor-mode game) (not (editor-mode game))
+          (drag-mode game) nil))
+
+  ;; Deliberate blow-up, for exercising the frame restarts.
+  (when (rl:is-key-pressed :key-e)
+    (dolist (i (append (loop for n below 10 collect n) (list :asdf)))
+      (+ 1 i)))
+
+  ;; 1-5 pick the layer, shift+1-5 the tilemap.
+  (loop for n from 1 to +num-layers+
+        when (rl:is-key-pressed (aref *num-keys* n))
+          do (if (rl:is-key-down :key-left-shift)
+                 (setf (current-tilemap game) (1- n))
+                 (setf (current-layer game) (1- n)))
+             (return)))
+
+;;; ------------------------------------------------------------------ update
+
+(defun update-drag (game)
+  (let ((mode (drag-mode game)))
+    (when mode
+      (multiple-value-bind (row col) (cell-at-mouse-pos)
+        (when (in-bounds-p row col)
+          (when (and (eq mode :erase) (tile-at-p game (current-layer game) row col))
+            (delete-tile game (current-layer game) row col))
+          ;; TODO: single vs auto tiling mode
+          (when (and (eq mode :draw)
+                     (/= -1 (first (selected-tile game)))
+                     (not (equal (list row col) (last-filled-cell game))))
+            (destructuring-bind (atlas-id tile-row tile-col) (selected-tile game)
+              (set-tile game (current-layer game) atlas-id tile-row tile-col row col))
+            (setf (last-filled-cell game) (list row col))))))))
+
+(defun update-palette-pick (game)
+  "Hover or click a tile in the palette overlay."
+  (when (editor-mode game)
+    (let ((tileset (aref (tilesets game) 0))
+          (mouse (rl:get-mouse-position)))
+      ;; Cleared every frame, or the last tile stays highlighted after the
+      ;; cursor has left the palette.
+      (setf (hovered-tile game) nil)
+      (loop for i from 0
+            for rect across (tileset-dst-rects tileset)
+            when (rl:check-collision-point-rec mouse rect)
+              do (if (rl:is-mouse-button-pressed :mouse-button-left)
+                     (let ((src (aref (tileset-src-rects tileset) i)))
+                       (setf (selected-tile game)
+                             (list 0
+                                   (floor (rl:rectangle-y src) +cell-size+)
+                                   (floor (rl:rectangle-x src) +cell-size+))
+                             (editor-mode game) nil
+                             (hovered-tile game) nil))
+                     (setf (hovered-tile game) rect))
+                 (return)))))
+
+(defun update-game (game)
+  (handle-game-input game)
+  (update-drag game)
+  (update-palette-pick game))
+
+;;; -------------------------------------------------------------------- draw
+
+(defun draw-tile (texture tile-row tile-col x y)
+  "Draw one cell of TEXTURE, snapping the destination to the cell grid."
+  (let* ((size (* +cell-size+ +scale+))
+         (dst-x (* (floor x size) size))
+         (dst-y (* (floor y size) size)))
+    (rl:draw-texture-pro
+     texture
+     (rl:make-rectangle :x (* tile-col +cell-size+) :y (* tile-row +cell-size+)
+                        :width +cell-size+ :height +cell-size+)
+     (rl:make-rectangle :x dst-x :y dst-y :width size :height size)
+     *origin* 0.0 :white)))
+
+(defun draw-layers (game)
+  (let ((tilesets (tilesets game)))
+    (dotimes (layer +num-layers+)
+      (dotimes (row +rows+)
+        (dotimes (col +cols+)
+          (multiple-value-bind (atlas-id tile-row tile-col) (tile-at game layer row col)
+            (when (and (/= atlas-id -1) (< atlas-id (length tilesets)))
+              (draw-tile (tileset-texture (aref tilesets atlas-id))
+                         tile-row tile-col
+                         (* col +cell-size+ +scale+)
+                         (* row +cell-size+ +scale+)))))))))
+
+(defun draw-cursor-tile (game)
+  "The tile riding the mouse cursor while painting."
+  (destructuring-bind (atlas-id tile-row tile-col) (selected-tile game)
+    (when (and (/= atlas-id -1)
+               (not (editor-mode game))
+               (not (eq (drag-mode game) :erase)))
+      (let ((pos (rl:get-mouse-position)))
+        (draw-tile (tileset-texture (aref (tilesets game) atlas-id))
+                   tile-row tile-col (v:vx pos) (v:vy pos))))))
+
+(defun draw-palette (game)
+  (rl:draw-rectangle-lines-ex
+   (rl:make-rectangle :x 0 :y 0 :width +screen-width+ :height +screen-height+)
+   5.0 :green)
+  (rl:draw-rectangle 0 0 +screen-width+ +screen-height+ *color-tint-gray*)
+  (let ((tileset (aref (tilesets game) 0)))
+    (loop for src across (tileset-src-rects tileset)
+          for dst across (tileset-dst-rects tileset)
+          do (rl:draw-texture-pro (tileset-texture tileset) src dst *origin* 0.0 :white)
+             (rl:draw-rectangle-lines (floor (rl:rectangle-x dst))
+                                      (floor (rl:rectangle-y dst))
+                                      (floor (rl:rectangle-width dst))
+                                      (floor (rl:rectangle-height dst))
+                                      :white))
+    (let ((hovered (hovered-tile game)))
+      (when hovered
+        (rl:draw-rectangle-lines (floor (rl:rectangle-x hovered))
+                                 (floor (rl:rectangle-y hovered))
+                                 (floor (rl:rectangle-width hovered))
+                                 (floor (rl:rectangle-height hovered))
+                                 :green))))
+  (rl:draw-text "EDIT MODE" (- +screen-width+ 100) 10 16 :green))
+
+(defun draw-game (game)
+  (rl:clear-background *color-ground*)
+  (draw-layers game)
+  (draw-cursor-tile game)
+  (when (editor-mode game)
+    (draw-palette game)))
+
+(defun unload-game (game)
+  (declare (ignore game)))
+
+;;; -------------------------------------------------------------------- main
 
 (defun main ()
-  (e:run-game
+  ;; Symbols, not #'functions -- run-game funcalls them every frame, so
-   :title "Game"
+  ;; redefining one at the REPL takes effect without restarting the game.
-   :width 1200
+  (e:run-game :title "Siam Farmer"
-   :height 1000
+              :width +screen-width+
-   :game-init 'game-init
+              :height +screen-height+
-   :game-update 'game-update
+              :config-path "game-config.data"
-   :game-draw 'game-draw
+              :init 'init-game
-   :unload (lambda (state))))
+              :update 'update-game
+              :draw 'draw-game
+              :unload 'unload-game))
 
+#+(or)
+(progn
   (main)
+  (setf (game::editor-mode engine:*game-state*) t)
+  :-)