ECS Sample with sdl2 implementation

main.lisp

;; https://awkravchuk.itch.io/cl-fast-ecs/devlog/622054/gamedev-in-lisp-part-1-ecs-and-metalinguistic-abstraction
(in-package #:ecs_tutorial_sdl)

(define-constant +window-width+ 800)
(define-constant +window-height+ 600)

(define-constant +repl-update-interval+ 0.3d0)

(define-constant +font-path+ (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/inconsolata.ttf"))
  :test #'string=)

(define-constant +config-path+
    (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "config.cfg"))
  :test #'string=)

(define-constant +font-size+ 24)

(define-constant asteroid-images
    (list (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10000.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10001.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10002.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10003.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10004.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10005.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10006.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10007.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10008.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10009.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10010.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10011.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10012.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10013.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10014.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/a10015.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10000.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10001.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10002.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10003.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10004.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10005.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10006.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10007.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10008.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10009.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10010.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10011.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10012.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10013.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10014.png"))
          (namestring (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/b10015.png")))
  :test #'equalp)

(defvar *planet-x* nil)
(defvar *planet-y* nil)
(defvar *planet-width* nil)
(defvar *planet-height* nil)
(defvar *planet-mass* 500000.0)

(ecs:define-component position
  "Determines the location of the object, in pixels."
  (x 0.0 :type single-float :documentation "X coordinate")
  (y 0.0 :type single-float :documentation "Y coordinate"))

(ecs:define-component speed
  "Determines the speed of the object, in pixels/second."
  (x 0.0 :type single-float :documentation "X coordinate")
  (y 0.0 :type single-float :documentation "Y coordinate"))

(ecs:define-component image
  "Stores ALLEGRO_BITMAP structure pointer, size and scaling information."
  (bitmap nil ) ;; :type (or null 'sdl2-ffi:sdl-surface))
  (width 0 :type integer)
  (height 0 :type integer)
  (scale 1.0 :type single-float))

(ecs:define-component planet
  "Tag component to indicate that entity is a planet.")

(ecs:define-component acceleration
  "Determines the acceleration of the object, in pixels/second^2."
  (x 0.0 :type single-float :documentation "X coordinate")
  (y 0.0 :type single-float :documentation "Y coordinate"))

(ecs:define-system draw-images
    (:arguments ((:renderer sdl2-ffi:sdl-renderer))
     :components-ro (position image))
  (let ((scaled-width (floor (* image-scale image-width)))
        (scaled-height (floor (* image-scale image-height))))
    (sdl2:with-rects ((rect (floor position-x) (floor position-y) scaled-width scaled-height))
      (let* ((texture (sdl2:create-texture-from-surface renderer image-bitmap)))
        (sdl2:render-copy renderer texture :dest-rect rect)
        (sdl2:destroy-texture texture)))))

(ecs:define-system move
    (:components-ro (speed)
     :components-rw (position)
     :arguments ((:dt single-float)))
  (incf position-x (* dt speed-x))
  (incf position-y (* dt speed-y)))

(ecs:define-system crash-asteroids
    (:components-ro (position)
     :components-no (planet)
     :with ((planet-half-width planet-half-height)
            :of-type (single-float single-float)
            := (values (/ *planet-width* 2.0)
                       (/ *planet-height* 2.0))))
  (when (<= (+
             (expt
              (/ (- position-x *planet-x*) planet-half-width)
              2)
             (expt
              (/ (- position-y *planet-y*) planet-half-height)
              2))
            1.0)
    (ecs:delete-entity entity)))

(ecs:define-system accelerate
    (:components-ro (acceleration)
     :components-rw (speed)
     :arguments ((:dt single-float)))
  (incf speed-x (* dt acceleration-x))
  (incf speed-y (* dt acceleration-y)))

(ecs:define-system pull
    (:components-ro (position)
     :components-rw (acceleration))
  (let* ((distance-x (- *planet-x* position-x))
         (distance-y (- *planet-y* position-y))
         (angle (atan distance-y distance-x))
         (distance-squared (+ (expt distance-x 2)
                              (expt distance-y 2)))
         (acceleration (/ *planet-mass* distance-squared)))
    (setf acceleration-x (* acceleration (cos angle))
          acceleration-y (* acceleration (sin angle)))))


;;(al:draw-scaled-bitmap image-bitmap 0 0
;;                     image-width image-height
;;                   (- position-x (* 0.5 scaled-width))
;;                 (- position-y (* 0.5 scaled-height))
;;               scaled-width scaled-height 0)))

(defun %render-text (renderer font x y text)
  (let* ((surface (sdl2-ttf:render-text-blended font text 255 255 255 0))
         (texture (sdl2:create-texture-from-surface renderer surface)))
    (sdl2:with-rects ((dest-rect x y
                                 (sdl2:texture-width texture)
                                 (sdl2:texture-height texture)))
      (sdl2:render-copy renderer texture :source-rect (cffi:null-pointer)
                                         :dest-rect dest-rect)
      (sdl2:destroy-texture texture)))
  t)

(defun init ()
  ;; TODO : put your initialization logic here
  (ecs:bind-storage)

  (let ((planet-bitmap
          (sdl2-image:load-image
           (namestring
            (asdf:system-relative-pathname :ecs_tutorial_sdl "Resources/parallax-space-big-planet.png")))))
    (setf *planet-width* (floor (sdl2:surface-width planet-bitmap))
          *planet-height* (floor (sdl2:surface-height planet-bitmap))
          *planet-x* (float (/ +window-width+ 2.0))
          *planet-y* (float (/ +window-height+ 2.0)))
    (ecs:make-object `((:planet)
                       (:position :x ,*planet-x*
                                  :y ,*planet-y*)
                       (:image :bitmap ,planet-bitmap
                               :width ,*planet-width*
                               :height ,*planet-height*))))



  (let ((asteroid-bitmaps (map 'list #'(lambda (filename)
                                         (sdl2-image:load-image filename))
                               asteroid-images)))
    (dotimes (_ 5000)
      (let ((r (random 20.0))
            (angle (float (random (* 2 pi)) 0.0)))
        (ecs:make-object
         `((:position :x ,(+ 200.0 (* r (cos angle)))
                      :y ,(+ *planet-y* (* r (sin angle))))
           (:speed :x ,(+ -5.0 (random 15.0))
                   :y ,(+ 30.0 (random 30.0)))
           (:acceleration)
           (:image
            :bitmap ,(alexandria:random-elt asteroid-bitmaps)
            :scale ,(+ 0.1 (random 0.9))
            :width 64 :height 64 )))))))



(declaim (type fixnum *fps*))
(defvar *fps* 0)

(defun update (dt)
  (unless (zerop dt)
    (setf *fps* (round 1 dt)))

  ;; TODO : put your game logic here
  )

(defvar *font*)

(defun render (renderer dt)

  (%render-text renderer *font* 0 0 (format nil "~6d FPS" *fps*))

  ;; TODO : put your drawing code here
  (ecs:run-systems :renderer renderer :dt (float dt 0.0))
  )

(defun main ()
  (sdl2:with-init (:everything)
    (handler-bind
        ((error #'(lambda (e)
                    (unless *debugger-hook*
                      (sdl2-ffi.functions::sdl-show-simple-message-box
                       sdl2-ffi:+sdl-messagebox-error+
                       "Hey guys"
                       (with-output-to-string (s)
                         (format s "We got a big error here :(~%~%")
                         (uiop:print-condition-backtrace e :stream s))
                       (cffi:null-pointer))
                      (sdl2:quit)
                      (uiop:quit)))))
      (sdl2-image:init '(:png :jpg))
      (sdl2-mixer:init)
      (sdl2-ttf:init)
      (sdl2:with-window (win :w +window-width+ :h +window-height+
                             :title "ecs_tutorial_sdl"
                             :flags '(:shown))
        (sdl2:with-renderer (ren win :flags '(:accelerated))
          (init)
          (let ((*font* (sdl2-ttf:open-font +font-path+ +font-size+))
                (ticks (sdl2:get-ticks))
                (dt 0.0))
            (declare (type fixnum ticks)
                     (type single-float dt))
            (sdl2:with-event-loop (:method :poll)
              (:idle
               ()
               (let ((new-ticks (sdl2:get-ticks)))
                 (setf dt (* (- new-ticks ticks) 0.001)
                       ticks new-ticks))
               (sdl2:render-clear ren)
               (update dt)
               (render ren dt)
               (sdl2:render-present ren)
               (sdl2:delay 1))
              (:quit
               ()
               (sdl2-ttf:close-font *font*)
               (sdl2-ttf:quit)
               (sdl2-image:quit)
               t))))))))