diff --git a/src/engine.lisp b/src/engine.lisp index b27a285..ad4a58b 100644 --- a/src/engine.lisp +++ b/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)) -;; (reset! texture-cache {}) -(defvar *buffered-objs* nil) +(defvar *config-path* nil) -(defun read-config (b)) -(defun snapshot (b)) -(defun restore (b)) +(defvar *texture-cache* (make-hash-table :test #'equal) + "Path -> rl:texture. Keyed by string, hence :test equal.") -(defun run-game (&key (title "Untitled") (width 800) (height 600) - config-path game-init game-update game-draw unload) +(defvar *buffers* nil + "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) - (rl:set-target-fps 30) - (setf *game-config* (when config-path (read-config config-path)) - *game-state* (funcall game-init)) - (flet ((frame () - (livesupport:continuable - (let ((new-state (funcall game-update *game-state*))) - (rl:with-drawing (funcall game-draw new-state)) - (setf *game-state* new-state))))) - (loop until (rl:window-should-close) do - (dolist (b *buffered-objs*) (snapshot b)) - (restart-case (frame) - (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 - *game-state* nil - *game-config* nil) - (clrhash *texture-cache*)))) + ;; 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 *config-path* config-path) + (reload-config) + (init-state init) + (loop until (rl:window-should-close) + do (snapshot-state) + (loop until (run-frame init update draw)) + ;; Services SLY between frames, so redefining a + ;; function at the REPL takes effect on the next one + ;; without restarting the game. + (livesupport:update-repl-link)) + (when unload (funcall unload *game-state*))) + (cleanup)))))) diff --git a/src/game.lisp b/src/game.lisp index 0b6df85..82b2858 100644 --- a/src/game.lisp +++ b/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-height+ 1000) -(defconstant +cell-size+ 5) +(defconstant +screen-width+ 1280) +(defconstant +screen-height+ 630) +(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) - (tilesets :initarg :tilesets :accessor tilesets) - (tilemaps :initarg :tilemaps :accessor tilemaps) - (current-layer :initarg :current-layer :accessor current-layer) - (current-tilemap :initarg :current-tilemap :accessor current-tilemap) - (selected-tile :initarg :selected-tile :accessor selected-tile))) + ((editor-mode :initform nil :accessor editor-mode) + (color-idx :initform 0 :accessor color-idx) + (layers :initform nil :accessor layers) + (current-layer :initform 0 :accessor current-layer) + (current-tilemap :initform 0 :accessor current-tilemap) + (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 () - (make-instance 'game - :layers '() - :tilesets '() - :tilemaps '() - :current-layer 0 - :current-tilemap 0 - :selected-tile '(-1 -1 -1))) +;; Plain data, rebuilt wholesale by the reinit restart, so a struct is fine +;; here -- unlike the game object, nothing needs to survive its redefinition. +(defstruct tileset + id texture tiles src-rects dst-rects) -(defun game-update (state) - state) +;;; -------------------------------------------------------------------- grid -(defun game-draw (state) - (rl:clear-background :blue)) +(declaim (ftype (function (fixnum fixnum) fixnum) idx) + (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 - :title "Game" - :width 1200 - :height 1000 - :game-init 'game-init - :game-update 'game-update - :game-draw 'game-draw - :unload (lambda (state)))) + ;; Symbols, not #'functions -- run-game funcalls them every frame, so + ;; redefining one at the REPL takes effect without restarting the game. + (e:run-game :title "Siam Farmer" + :width +screen-width+ + :height +screen-height+ + :config-path "game-config.data" + :init 'init-game + :update 'update-game + :draw 'draw-game + :unload 'unload-game)) -(main) +#+(or) +(progn + (main) + (setf (game::editor-mode engine:*game-state*) t) + :-)