graphics/view.lisp

   1 ;;;; Ru*** roLeplay Playground virtual tabletop
   2 ;;;; Copyright (C) 2022  Zull
   3 ;;;;
   4 ;;;; This program is free software: you can redistribute it and/or modify
   5 ;;;; it under the terms of the GNU General Public License as published by
   6 ;;;; the Free Software Foundation, either version 3 of the License, or
   7 ;;;; (at your option) any later version.
   8 ;;;;
   9 ;;;; This program is distributed in the hope that it will be useful,
  10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;;; GNU General Public License for more details.
  13 ;;;;
  14 ;;;; You should have received a copy of the GNU General Public License
  15 ;;;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
  16
  17 (in-package :rulp.graphics)
  18 #| -------------------------------------------
  19  | This file manipulate the window and the
  20  | sdl initialization.
  21  | -------------------------------------------
  22  |#
  23
  24 ;; FIXME: search alternative
  25 (defun create-entities (map-info map-path)
  26   (let ((entities-info (cdr (assoc :entities map-info))))
  27     (loop :for entity-info :in entities-info
  28           :collect
  29           (make-instance 'entity
  30                          ;; :image (merge-pathnames map-path (cdr (assoc :image-path entity-info)))
  31                          :background (merge-pathnames map-path (cdr (assoc :image-path entity-info)))
  32                          :size (if (assoc :size entity-info) (cdr (assoc :size entity-info)) 1)
  33                          :name (assoc :name entity-info)
  34                          ))))
  35
  36 (defun create-plane (map-info map-path &key (number 0))
  37   "convert the map informations into a functioning plane, without number it convert the
  38 first element"
  39   (let ((plane-info (nth number (cdr (assoc :planes map-info)))))
  40     (make-instance 'rulp.layers:plane
  41                    :background (merge-pathnames map-path (cdr (assoc :image-path plane-info)))
  42                    :entities-list (create-entities map-info map-path)
  43                    :grid (make-instance 'squaregrid
  44                                         :span (cdr (assoc :grid-dimension plane-info)))
  45                    )
  46     ;; FIXME: generalize... somehow
  47     )
  48   )
  49
  50 (defun grid-layout (x y &key (size 1))
  51   "converts natural coordinates and size into pixel positions. This function can be replaced to change
  52 the actual grid layout"
  53   (values (cons (* x *plane-grid*)
  54                 (* y *plane-grid*))
  55           (* size *plane-grid*)))
  56
  57 (defun actors-layout (x y)
  58   (cons (floor (/ x *plane-grid*))
  59         (floor (/ y *plane-grid*)))
  60   )
  61
  62 (defmacro with-playground ((window renderer &key (title "RuLP")) &body body)
  63   `(sdl2:with-window (,window :title title :w *window-width* :h *window-height* :flags '(:resizable))
  64      ;; NOTE: here is where you should set the window icon, if there's the method to do that
  65      (sdl2:with-renderer (,renderer ,window :index -1 :flags '(:accelerated :presentvsync)) ;later add delta
  66        (sdl2-image:init '(:png :jpg))
  67        (sdl2-ttf:init)
  68        ,@body
  69        (sdl2-ttf:quit)
  70        (sdl2-image:quit)
  71        )))
  72
  73 ;; FIXME: temporary place
  74 ;; set boundaries so the plane doesn't go away with the panning. fix boundaries to -window width, -window height, plane width, plane height
  75 (defparameter *viewpoint-offset* '(0 . 0))
  76 (defparameter *viewpoint-zoom* 1)
  77 (defparameter *mouse-previous* '(0 . 0))
  78
  79 (defparameter *framerule* 20
  80   "every 20 frames the parameter *changep* is set to t, so it updates informations
  81 even when away from keyboard")
  82
  83 (defparameter *active-entries* nil
  84   "contain the active menu in form of a entry class")
  85
  86 (defparameter *changep* t
  87   "set to t when a change on the plane is made, if nil the viewpoint is not updated")
  88
  89 ;; renderer exists only inside this function, so you cannot create a texture outside
  90 ;; (at least for now), more on this later os
  91 (defun playground (title &optional (fps 60) (debug-info nil))
  92   "initialize and run the game loop. it takes a TITLE to display and FPS for framerate.
  93 DEBUG-INFO can be used to display the content on screen for test and debug purposes."
  94   (declare (ignore fps))
  95   (empty-screen-list)                   ;; NOTE: This clean the screen list,
  96                                         ;; useful for slime/sly sessions where
  97                                         ;; variables are kept after the program
  98                                         ;; ends but textures are closed with sdl.
  99   (sdl2:with-init (:video)
 100     (with-playground (window rulp.render:*renderer* :title title)
 101       (setf *tr-texture* (let* ((font (sdl2-ttf:open-font "media/IBMPlex.ttf" 100)) ;; FIXME: this crashes the program under windows, throws error on linux but works anyway
 102                                 (font-surface (sdl2-ttf:render-utf8-solid font *tr-string* 0 0 0 0))
 103                                 (font-texture (sdl2:create-texture-from-surface rulp.render:*renderer* font-surface)))
 104                            (sdl2:free-surface font-surface)
 105                            font-texture))
 106       (setf *plane* (create-plane *map-info* *map-path*))
 107       (setf *plane-grid* (span (rulp.layers:plane-grid *plane*)))
 108       ;; FIXME: to remove
 109
 110       (setf *entities-list* (entities-list *plane*))
 111       (loop :for i :in *execute-before*
 112             :do (eval `(,i)))
 113       ;; FIXME: to remove
 114       ;; (setf *entities-list* (create-entities *map-info* *map-path*))
 115       (let (;; (mouse-button-previous nil)
 116             (window-texture (sdl2:get-render-target rulp.render:*renderer*))
 117             (viewpoint-texture (sdl2:create-texture rulp.render:*renderer* (sdl2:get-window-pixel-format window)
 118                                                     2 (w *plane*) (h *plane*))) ;camping into the ramhog
 119             (viewpoint-rectangle (sdl2:make-rect 0 0 10 10)))
 120         (sdl2:with-event-loop (:method :poll)
 121           (:quit () t)
 122           (:keydown ()
 123                     ;; FIXME: incorporate into input.lisp. check for input every now and then outside keydown
 124                     (when (sdl2:keyboard-state-p :scancode-up) (setf (cdr *viewpoint-offset*) (+ (cdr *viewpoint-offset*) 10)))
 125                     (when (sdl2:keyboard-state-p :scancode-down) (setf (cdr *viewpoint-offset*) (+ (cdr *viewpoint-offset*) -10)))
 126                     (when (sdl2:keyboard-state-p :scancode-left) (setf (car *viewpoint-offset*) (+ (car *viewpoint-offset*) 10)))
 127                     (when (sdl2:keyboard-state-p :scancode-right) (setf (car *viewpoint-offset*) (+ (car *viewpoint-offset*) -10)))
 128                     (when (sdl2:keyboard-state-p :scancode-p) (setf *viewpoint-zoom* (+ *viewpoint-zoom* 0.2))) ; FIXME: find the scancode for the plus sign
 129                     (when (sdl2:keyboard-state-p :scancode-m) (setf *viewpoint-zoom* (+ *viewpoint-zoom* -0.2)))
 130                     )
 131           (:mousebuttondown ()
 132                             (setf *is-mouse-hold* t)
 133                             ;; this routine seems identical to the one in idle, instead
 134                             ;; of calling the second element of the keybind list it calls
 135                             ;; the third element. If there is something there it would
 136                             ;; execute a special function for when the mouse is released.
 137                             (mouse-event *mouse-position*)
 138                             )
 139           (:mousebuttonup ()
 140                           ;; what about functions that require a single press? just create
 141                           ;; a keybind (+key+ nil (...)) and it will execute just on
 142                           ;; release and not on hold
 143                           ;; (setf mouse-button-previous nil)
 144                           (setf *changep* t)
 145                           (setf *is-mouse-hold* nil)
 146                           )
 147           (:windowevent ()
 148                         ;; bug prevention method. SDL2 can look the :mousebuttonup event
 149                         ;; only when the mouse is on the window. This makes press,
 150                         ;; alt+tab and release a way to keep the value to t. This
 151                         ;; event is a prevention method designed to release the hold
 152                         ;; when alt+tab or other window shortcuts are used.
 153                         (setf *is-mouse-hold* nil))
 154           (:multigesture ()
 155                          ;; same as for windowevent
 156                          (setf *is-mouse-hold* nil))
 157           ;; NOTE: When the user prefear to use only the keyboard or joystick
 158           ;; the *cursor-position* is set default, this is set when a key or
 159           ;; koystick button is pressed, then menues and actions are chosed with
 160           ;; the cursor position. When a mouse motion is detected the
 161           ;; mouse-position is set default. the cursor follows the grid on each
 162           ;; step and it is an alternative to the mouse movement to do
 163           ;; everything.
 164           (:idle ()
 165                  (setf *mouse-previous-position* *mouse-position*)
 166                  (multiple-value-bind (x y) (sdl2:mouse-state)
 167                    (setf *mouse-position* (cons x y)))
 168                  ;; mouse-holding-event
 169                  ;; (unless *active-entries*
 170                  ;;   (when *is-mouse-hold*
 171                  ;;     (loop :for action :in (mouse-actions *mouse-keybinds*)
 172                  ;;           :do (when action (eval (car action))) ; FIXME: replace eval with a more safer DSL eval
 173                  ;;           )
 174                  ;;     ;; (setf mouse-button-previous (mouse-actions *mouse-keybinds*))
 175                  ;;     ))
 176                  (when *is-mouse-hold*
 177                    (mouse-event *mouse-position* :dragp t))
 178
 179                  ;; trick to avoid functions to change the global draw-color
 180                  (sdl2:set-render-draw-color rulp.render:*renderer* 0 0 0 255)
 181
 182                  ;; local viewpoint
 183                  ;; NOTE: generalize
 184                  (when *changep*
 185                    (sdl2:destroy-texture viewpoint-texture)
 186                    (setf viewpoint-texture (sdl2:create-texture rulp.render:*renderer*
 187                                                                 (sdl2:get-window-pixel-format window)
 188                                                                 2
 189                                                                 (w *plane*)
 190                                                                 (h *plane*)))
 191                    (sdl2:set-render-target rulp.render:*renderer* viewpoint-texture)
 192                    (sdl2:render-clear rulp.render:*renderer*)
 193                    (loop :for i :in *execute-in-viewpoint*
 194                          :do (eval `(,i)))
 195                    ;; the chain executes the render-plane-and-entities
 196
 197                    ;; FIXME: grind-render and indexes-render use the renderer
 198                    ;; directly. Update the facade with line methods and update
 199                    ;; the functions into chains
 200                    (when *is-grid*
 201                      (grid-render rulp.render:*renderer* 0 0 (w *plane*) (h *plane*))
 202                      ;; FIXME: change to use the plane directly
 203                      )
 204                    (when *is-indexes*
 205                      (indexes-render rulp.render:*renderer* 0 0 (w *plane*) (h *plane*)))
 206                    ;; FIXME: same as above for grids
 207                    (sdl2:set-render-draw-color rulp.render:*renderer* 0 0 0 255)
 208                    (setf *changep* nil)
 209                    ;; pointer section
 210                    (when *pointer* ;; NOTE: to test this out
 211                      (sdl2:set-render-draw-color rulp.render:*renderer* 128 250 33 255)
 212                      (let* ((object (nth *pointer* (entities-list *plane*)))
 213                             (grid (plane-grid *plane*))
 214                             (obj-position (to-grid grid (coordinates object)))
 215                             (obj-size (to-grid grid (size object))))
 216                        (rulp.render:render-square (car obj-position)
 217                                                   (cdr obj-position)
 218                                                   (car obj-size)
 219                                                   (cdr obj-size)))
 220                      (sdl2:set-render-draw-color rulp.render:*renderer* 0 0 0 255)
 221                      ))
 222
 223
 224
 225                  ;; display viewpoint on window
 226                  (sdl2:set-render-target rulp.render:*renderer* window-texture)
 227                  (sdl2:render-clear rulp.render:*renderer*)
 228                  (setf (sdl2:rect-x viewpoint-rectangle) (car *viewpoint-offset*))
 229                  (setf (sdl2:rect-y viewpoint-rectangle) (cdr *viewpoint-offset*))
 230                  (setf (sdl2:rect-width viewpoint-rectangle) (floor (* (w *plane*) *viewpoint-zoom*)))
 231                  (setf (sdl2:rect-height viewpoint-rectangle) (floor (* (h *plane*) *viewpoint-zoom*)))
 232                  (sdl2:render-copy rulp.render:*renderer* viewpoint-texture
 233                                    :source-rect nil
 234                                    :dest-rect viewpoint-rectangle)
 235
 236                  (loop :for i :in *execute-in-window*
 237                        :do (eval `(,i)))
 238
 239                  ;; entries visualization
 240                  (loop :for entry :in rulp.entries:*entries-list*
 241                        :do (rulp.entries:render-entry rulp.render:*renderer* entry))
 242                  ;; (loop :for entry :in *active-entries*
 243                  ;;       :do (display-entry rulp.render:*renderer* entry))
 244
 245                  ;; debug infos
 246                  (when debug-info
 247                    (tr-write (format nil "~A" debug-info) 0 0 10 15 rulp.render:*renderer*))
 248                  (sdl2:render-present rulp.render:*renderer*)
 249                  ;; updating grids and dimension
 250                  ;;  FIXME: i hate this, find a better way to dinamically change the window dimension
 251                  (multiple-value-bind (new-width new-height) (sdl2:get-window-size window)
 252                    (setf *window-width* new-width)
 253                    (setf *window-height* new-height))
 254                  (1- *framerule*)
 255                  (when (< *framerule* 1)
 256                    (setf *changep* t)
 257                    (setf *framerule* 20))))
 258         (setf *changep* t)   ; useful in the repl where parameters are not reset
 259         ))
 260     ;; sdl2 kills all textures when the session ends. on normal execution this
 261     ;; is not a problem but on emacs because the editor will not delete its
 262     ;; variables. Therefore the flyweight would be filled with screens with no
 263     ;; textures that will fail the second execution.
 264     (empty-screen-list)
 265     (loop :for i :in *execute-after*
 266           :do (eval `(,i)))
 267     ))