;;;; Ru*** roLeplay Playground virtual tabletop ;;;; Copyright (C) 2022 Zull ;;;; ;;;; This program is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation, either version 3 of the License, or ;;;; (at your option) any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program. If not, see . (in-package :rulp.graphics) #| ------------------------------------------- | This file manipulate the window and the | sdl initialization. | ------------------------------------------- |# ;; FIXME: search alternative (defun create-entities (map-info map-path) (let ((entities-info (cdr (assoc :entities map-info)))) (loop :for entity-info :in entities-info :collect (make-instance 'entity ;; :image (merge-pathnames map-path (cdr (assoc :image-path entity-info))) :background (merge-pathnames map-path (cdr (assoc :image-path entity-info))) :size (if (assoc :size entity-info) (cdr (assoc :size entity-info)) 1) :name (assoc :name entity-info) )))) (defun create-plane (map-info map-path &key (number 0)) "convert the map informations into a functioning plane, without number it convert the first element" (let ((plane-info (nth number (cdr (assoc :planes map-info))))) (make-instance 'rulp.layers:plane :background (merge-pathnames map-path (cdr (assoc :image-path plane-info))) :entities-list (create-entities map-info map-path) :grid (make-instance 'squaregrid :span (cdr (assoc :grid-dimension plane-info))) ) ;; FIXME: generalize... somehow ) ) (defun grid-layout (x y &key (size 1)) "converts natural coordinates and size into pixel positions. This function can be replaced to change the actual grid layout" (values (cons (* x *plane-grid*) (* y *plane-grid*)) (* size *plane-grid*))) (defun actors-layout (x y) (cons (floor (/ x *plane-grid*)) (floor (/ y *plane-grid*))) ) (defmacro with-playground ((window renderer &key (title "RuLP")) &body body) `(sdl2:with-window (,window :title title :w *window-width* :h *window-height* :flags '(:resizable)) ;; NOTE: here is where you should set the window icon, if there's the method to do that (sdl2:with-renderer (,renderer ,window :index -1 :flags '(:accelerated :presentvsync)) ;later add delta (sdl2-image:init '(:png :jpg)) (sdl2-ttf:init) ,@body (sdl2-ttf:quit) (sdl2-image:quit) ))) ;; FIXME: temporary place ;; set boundaries so the plane doesn't go away with the panning. fix boundaries to -window width, -window height, plane width, plane height (defparameter *viewpoint-offset* '(0 . 0)) (defparameter *viewpoint-zoom* 1) (defparameter *mouse-previous* '(0 . 0)) (defparameter *framerule* 20 "every 20 frames the parameter *changep* is set to t, so it updates informations even when away from keyboard") (defparameter *active-entries* nil "contain the active menu in form of a entry class") (defparameter *changep* t "set to t when a change on the plane is made, if nil the viewpoint is not updated") ;; renderer exists only inside this function, so you cannot create a texture outside ;; (at least for now), more on this later os (defun playground (title &optional (fps 60) (debug-info nil)) "initialize and run the game loop. it takes a TITLE to display and FPS for framerate. DEBUG-INFO can be used to display the content on screen for test and debug purposes." (declare (ignore fps)) (empty-screen-list) ;; NOTE: This clean the screen list, ;; useful for slime/sly sessions where ;; variables are kept after the program ;; ends but textures are closed with sdl. (sdl2:with-init (:video) (with-playground (window rulp.render:*renderer* :title title) (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 (font-surface (sdl2-ttf:render-utf8-solid font *tr-string* 0 0 0 0)) (font-texture (sdl2:create-texture-from-surface rulp.render:*renderer* font-surface))) (sdl2:free-surface font-surface) font-texture)) (setf *plane* (create-plane *map-info* *map-path*)) (setf *plane-grid* (span (rulp.layers:plane-grid *plane*))) ;; FIXME: to remove (setf *entities-list* (entities-list *plane*)) (loop :for i :in *execute-before* :do (eval `(,i))) ;; FIXME: to remove ;; (setf *entities-list* (create-entities *map-info* *map-path*)) (let (;; (mouse-button-previous nil) (window-texture (sdl2:get-render-target rulp.render:*renderer*)) (viewpoint-texture (sdl2:create-texture rulp.render:*renderer* (sdl2:get-window-pixel-format window) 2 (w *plane*) (h *plane*))) ;camping into the ramhog (viewpoint-rectangle (sdl2:make-rect 0 0 10 10))) (sdl2:with-event-loop (:method :poll) (:quit () t) (:keydown () ;; FIXME: incorporate into input.lisp. check for input every now and then outside keydown (when (sdl2:keyboard-state-p :scancode-up) (setf (cdr *viewpoint-offset*) (+ (cdr *viewpoint-offset*) 10))) (when (sdl2:keyboard-state-p :scancode-down) (setf (cdr *viewpoint-offset*) (+ (cdr *viewpoint-offset*) -10))) (when (sdl2:keyboard-state-p :scancode-left) (setf (car *viewpoint-offset*) (+ (car *viewpoint-offset*) 10))) (when (sdl2:keyboard-state-p :scancode-right) (setf (car *viewpoint-offset*) (+ (car *viewpoint-offset*) -10))) (when (sdl2:keyboard-state-p :scancode-p) (setf *viewpoint-zoom* (+ *viewpoint-zoom* 0.2))) ; FIXME: find the scancode for the plus sign (when (sdl2:keyboard-state-p :scancode-m) (setf *viewpoint-zoom* (+ *viewpoint-zoom* -0.2))) ) (:mousebuttondown () (setf *is-mouse-hold* t) ;; this routine seems identical to the one in idle, instead ;; of calling the second element of the keybind list it calls ;; the third element. If there is something there it would ;; execute a special function for when the mouse is released. (mouse-event *mouse-position*) ) (:mousebuttonup () ;; what about functions that require a single press? just create ;; a keybind (+key+ nil (...)) and it will execute just on ;; release and not on hold ;; (setf mouse-button-previous nil) (setf *changep* t) (setf *is-mouse-hold* nil) ) (:windowevent () ;; bug prevention method. SDL2 can look the :mousebuttonup event ;; only when the mouse is on the window. This makes press, ;; alt+tab and release a way to keep the value to t. This ;; event is a prevention method designed to release the hold ;; when alt+tab or other window shortcuts are used. (setf *is-mouse-hold* nil)) (:multigesture () ;; same as for windowevent (setf *is-mouse-hold* nil)) ;; NOTE: When the user prefear to use only the keyboard or joystick ;; the *cursor-position* is set default, this is set when a key or ;; koystick button is pressed, then menues and actions are chosed with ;; the cursor position. When a mouse motion is detected the ;; mouse-position is set default. the cursor follows the grid on each ;; step and it is an alternative to the mouse movement to do ;; everything. (:idle () (setf *mouse-previous-position* *mouse-position*) (multiple-value-bind (x y) (sdl2:mouse-state) (setf *mouse-position* (cons x y))) ;; mouse-holding-event ;; (unless *active-entries* ;; (when *is-mouse-hold* ;; (loop :for action :in (mouse-actions *mouse-keybinds*) ;; :do (when action (eval (car action))) ; FIXME: replace eval with a more safer DSL eval ;; ) ;; ;; (setf mouse-button-previous (mouse-actions *mouse-keybinds*)) ;; )) (when *is-mouse-hold* (mouse-event *mouse-position* :dragp t)) ;; trick to avoid functions to change the global draw-color (sdl2:set-render-draw-color rulp.render:*renderer* 0 0 0 255) ;; local viewpoint ;; NOTE: generalize (when *changep* (sdl2:destroy-texture viewpoint-texture) (setf viewpoint-texture (sdl2:create-texture rulp.render:*renderer* (sdl2:get-window-pixel-format window) 2 (w *plane*) (h *plane*))) (sdl2:set-render-target rulp.render:*renderer* viewpoint-texture) (sdl2:render-clear rulp.render:*renderer*) (loop :for i :in *execute-in-viewpoint* :do (eval `(,i))) ;; the chain executes the render-plane-and-entities ;; FIXME: grind-render and indexes-render use the renderer ;; directly. Update the facade with line methods and update ;; the functions into chains (when *is-grid* (grid-render rulp.render:*renderer* 0 0 (w *plane*) (h *plane*)) ;; FIXME: change to use the plane directly ) (when *is-indexes* (indexes-render rulp.render:*renderer* 0 0 (w *plane*) (h *plane*))) ;; FIXME: same as above for grids (sdl2:set-render-draw-color rulp.render:*renderer* 0 0 0 255) (setf *changep* nil) ;; pointer section (when *pointer* ;; NOTE: to test this out (sdl2:set-render-draw-color rulp.render:*renderer* 128 250 33 255) (let* ((object (nth *pointer* (entities-list *plane*))) (grid (plane-grid *plane*)) (obj-position (to-grid grid (coordinates object))) (obj-size (to-grid grid (size object)))) (rulp.render:render-square (car obj-position) (cdr obj-position) (car obj-size) (cdr obj-size))) (sdl2:set-render-draw-color rulp.render:*renderer* 0 0 0 255) )) ;; display viewpoint on window (sdl2:set-render-target rulp.render:*renderer* window-texture) (sdl2:render-clear rulp.render:*renderer*) (setf (sdl2:rect-x viewpoint-rectangle) (car *viewpoint-offset*)) (setf (sdl2:rect-y viewpoint-rectangle) (cdr *viewpoint-offset*)) (setf (sdl2:rect-width viewpoint-rectangle) (floor (* (w *plane*) *viewpoint-zoom*))) (setf (sdl2:rect-height viewpoint-rectangle) (floor (* (h *plane*) *viewpoint-zoom*))) (sdl2:render-copy rulp.render:*renderer* viewpoint-texture :source-rect nil :dest-rect viewpoint-rectangle) (loop :for i :in *execute-in-window* :do (eval `(,i))) ;; entries visualization (loop :for entry :in rulp.entries:*entries-list* :do (rulp.entries:render-entry rulp.render:*renderer* entry)) ;; (loop :for entry :in *active-entries* ;; :do (display-entry rulp.render:*renderer* entry)) ;; debug infos (when debug-info (tr-write (format nil "~A" debug-info) 0 0 10 15 rulp.render:*renderer*)) (sdl2:render-present rulp.render:*renderer*) ;; updating grids and dimension ;; FIXME: i hate this, find a better way to dinamically change the window dimension (multiple-value-bind (new-width new-height) (sdl2:get-window-size window) (setf *window-width* new-width) (setf *window-height* new-height)) (1- *framerule*) (when (< *framerule* 1) (setf *changep* t) (setf *framerule* 20)))) (setf *changep* t) ; useful in the repl where parameters are not reset )) ;; sdl2 kills all textures when the session ends. on normal execution this ;; is not a problem but on emacs because the editor will not delete its ;; variables. Therefore the flyweight would be filled with screens with no ;; textures that will fail the second execution. (empty-screen-list) (loop :for i :in *execute-after* :do (eval `(,i))) ))