graphics/menu.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 (defpackage :rulp.entries
  18   (:use :cl)
  19   (:export *entries-list* push pop entry x y width height rectangle click-event
  20            render-entry make-plist))
  21
  22 (in-package :rulp.entries)
  23
  24 (defparameter *entries-list* nil
  25   "List of entries, menues who are generated into the window with options")
  26
  27 (defgeneric x (entry))
  28 (defgeneric y (entry))
  29 (defgeneric width (entry))
  30 (defgeneric height (entry))
  31 (defgeneric rectangle (entry))
  32
  33 (defclass entry ()
  34     ((coordinates :accessor coordinates
  35                   :initarg :coordinates
  36                   :initform '(0 . 0)
  37                   :documentation "the starting position of the entry generation"
  38                   :type list)
  39      (title :accessor title
  40             :initarg :title
  41             :initform "custom"
  42             :documentation "title for the entry")
  43      (margin :accessor margin
  44              :initarg :margin
  45              :initform 5
  46              :type number
  47              :documentation "the margin between the content and the borders of the rectangle")
  48      (padding :accessor padding
  49               :initarg :padding
  50               :initform 0
  51               :type number
  52               :documentation "the padding between the coordinates and the borders")
  53      (action :accessor action
  54              :initarg :action
  55              :initform nil
  56              :documentation "action when pressed")
  57      (contents :accessor contents
  58                 :initarg :contents
  59                 :initform nil
  60                 :type list
  61                 :documentation "a list of other entries")
  62      (text-size :accessor size
  63                 :initarg :size
  64                 :initform 20
  65                 :type number)
  66      (content-orientation :accessor orientation
  67                           :initarg :orientation
  68                           :initform :v
  69                           :documentation "when :v the contents and title
  70 are displaced vertically, when :h the contents are horizontally displayed")))
  71
  72 (defmethod x ((entry entry))
  73   (car (coordinates entry)))
  74
  75 (defmethod y ((entry entry))
  76   (cdr (coordinates entry)))
  77
  78 ;; (defmethod width ((entry entry))
  79 ;;   200)
  80
  81 ;; (defmethod height ((entry entry))
  82 ;;   200)
  83
  84 (defun width-vertical (plist)
  85   (let* ((i 0))
  86     (labels ((operation (element)
  87                (setf i (max i (length (getf element :title)))) ; FIXME: add padding
  88                (loop :for x :in (getf element :contents)
  89                      :do (operation x))
  90                ))
  91       (operation plist))
  92     i
  93     ))
  94
  95 (defun width-horizontal (plist)
  96   (let* ((i 0))
  97     (labels ((operation (element)
  98                (incf i (length (getf element :title)))
  99                (loop :for x :in (getf element :contents)
 100                      :do (operation x))
 101                ))
 102       (operation plist))
 103     i
 104     ))
 105
 106 (defun height-vertical (plist)
 107   (let* ((i 0))
 108     (labels ((operation (element)
 109                (1+ i)
 110                (loop :for x :in (getf element :contents)
 111                      :do (operation x))
 112                ))
 113       (operation plist))
 114     i
 115     ))
 116
 117 (defun height-horizontal (plist) 1)
 118
 119 ;; (defmethod width ((entry entry))
 120 ;;   "give the length of the longest menu entry, useful for creating a box containing them all"
 121 ;;   (reduce #'max (loop :for content :in (contents entry))))
 122
 123 ;; (defmethod height ((entry entry))
 124 ;;   "give the number of entries, useful for creating a box containing them all"
 125 ;;   (length (contents entry)))
 126
 127 (defmethod rectangle ((entry entry))
 128   (flet ((on-size (a) (* a (text-size y))))
 129     (sdl2:make-rect (x entry)
 130                     (y entry)
 131                     (on-size (entry-width y))
 132                     )))
 133
 134 ;; NOTE: this method makes the entry class totally useless. It is possible
 135 ;; to replace entries with these plists and use them directly with the macro
 136 (defmethod make-plist ((entry entry))
 137   (list ':entry 'entry
 138         ':title (title entry)
 139         ':coordinates (coordinates entry)
 140         ':padding (padding entry)
 141         ':margin (margin entry)
 142         ':text-size (size entry)
 143         ':action (action entry)
 144         ':contents (contents entry)
 145         ':orientation (orientation entry))
 146   )
 147 ;; NOTE: The idea of replacing the whole class idea with the plist system makes
 148 ;; room for special functions that can create rectangles out of the correct size,
 149 ;; can adjust the text and aid the macro in the rendering process.
 150
 151 (defun n-letter-content (pair)
 152   "given a list of two elements, one a string and the other a generic symbol, it returns the
 153 length of the string. This is used in display-entry, where it is used to find
 154 the maximum size of a list of options to make the correct dimension for the entry"
 155   (length (car pair)))
 156
 157 (defun keep-inside (position size limit)
 158   (if (> position (- limit size))
 159       (- position size)
 160       position
 161     ))
 162
 163 (defmacro render-entry (renderer plist)
 164   `(let* ((entry-margin (if (numberp (getf ,plist :margin)) (getf ,plist :margin) 0))
 165           (entry-padding (if (numberp (getf ,plist :padding)) (getf ,plist :padding) 0))
 166           (entry-size (getf ,plist :text-size)) ; NOTE: make error checking instead of redefinition
 167           (entry-x (+ entry-margin (car (getf ,plist :coordinates))))
 168           (entry-y (+ entry-margin (cdr (getf ,plist :coordinates))))
 169           (entry-w (if (eq (getf ,plist :orientation) 'v)
 170                        (width-vertical ,plist)
 171                        (width-horizontal ,plist)))
 172           (entry-h (if (eq (getf ,plist :orientation) 'v)
 173                        (height-vertical ,plist)
 174                        (height-horizontal ,plist))))
 175      (setf entry-x (keep-inside entry-x entry-w rulp.graphics:*window-width*))
 176      (setf entry-y (keep-inside entry-y entry-h rulp.graphics:*window-height*)) ; BUG: doesn't seems to work
 177      ;; (when (> entry-x (- rulp.graphics:*window-width* entry-w))
 178      ;;   (setf entry-x (- entry-x entry-w)))
 179      ;; (when (> entry-y (- rulp.graphics:*window-height* entry-h))
 180      ;;   (setf entry-y (- entry-y entry-h)))
 181      (sdl2:set-render-draw-color ,renderer 255 255 255 255)
 182      (sdl2:render-fill-rect ,renderer (rulp.graphics:arrange-rect
 183                                        entry-x
 184                                        entry-y
 185                                        (+ (* 2 entry-padding) (* entry-w entry-size))
 186                                        (+ (* 2 entry-padding) (* entry-h entry-size)))) ; FIXME: fixed size font
 187      ;; NOTE: temporary solution, to be extended with the content-rendering
 188      ;; function into a rendering engine for nested schemas
 189      (sdl2:set-render-draw-color ,renderer 0 0 0 255)
 190      (rulp.graphics:tr-write (getf ,plist :title)
 191                              (+ entry-x entry-padding)
 192                              (+ entry-y entry-padding)
 193                              entry-size
 194                              entry-size
 195                              ,renderer)
 196      ;; FIXME: continue with contents
 197      ))
 198
 199 (defmacro display-entry (renderer entry)
 200   "macro for creating the actual menu given the renderer and the entry"
 201   `(let* ((entry-x (+ (car (coordinate ,entry)) (padding ,entry)))
 202           (entry-y (+ (cdr (coordinate ,entry)) (padding ,entry)))
 203           (maximum-letters (apply #'max (cons (length (title ,entry)) (mapcar #'n-letter-content (contents ,entry)))))
 204           (number-of-elements (1+ (length (contents ,entry))))
 205           (entry-h (+ (* number-of-elements (text-size ,entry)) (* 2 (margin ,entry))))
 206           (entry-w (+ (* maximum-letters (text-size ,entry)) (* (margin ,entry))))
 207           )
 208      (when (> entry-x (- *window-width* entry-w))
 209        (setf entry-x (- entry-x entry-w)))
 210      (when (> entry-y (- *window-height* entry-h))
 211        (setf entry-y (- entry-y entry-h)))
 212      (sdl2:set-render-draw-color ,renderer 255 255 255 255)
 213      (sdl2:render-fill-rect ,renderer (arrange-rect entry-x entry-y entry-w entry-h))
 214      (tr-write (title ,entry)
 215                (+ entry-x (margin ,entry))
 216                (+ entry-y (margin ,entry))
 217                (text-size ,entry)
 218                (text-size ,entry)
 219                ,renderer
 220                )
 221      ;; FIXME: to complete with the actual menu
 222      )
 223   )
 224
 225 (defun select-entry (renderer entry)
 226   "given the renderer and an entry, returns the option pressed or return nil if
 227 nothing was pressed"
 228   nil)
 229
 230 (defgeneric click-event (entry coordinates)
 231   (:documentation "this function is activated when the
 232 mouse/cursor is pressed with a entry active. From here the method can execute
 233 command and destroy itself by returning nil. The destruction has to be handled
 234 by whatever call the entry event"))
 235
 236 ;; NOTE: test if the mouse-state-p is enought, to get to this method is a long
 237 ;; run and it could be that mouse-state-p has changed from when was triggered
 238 (defmethod click-event ((entry entry) coordinates)
 239   "event for mouse/cursor action. This function applies events on an element of a
 240 list"
 241   'destroy
 242   )