camera-system.lisp 3.21 KB
Newer Older
Andrew Kravchuk's avatar
Andrew Kravchuk committed
1 2 3 4 5
(in-package :d2clone-kit)


(defclass camera-system (system)
  ((name :initform 'camera)
Andrew Kravchuk's avatar
Andrew Kravchuk committed
6 7
   (entity :initform nil)
   (target :initform nil))
8
  (:documentation "Handles camera entity."))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
9

10 11
(defhandler camera-system quit (event)
  (setf (slot-value system 'entity) -1))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
12 13 14 15 16 17

(defmethod make-component ((system camera-system) entity &rest parameters)
  (declare (ignore parameters))
  (setf (slot-value system 'entity) entity)
  nil)

Andrew Kravchuk's avatar
Andrew Kravchuk committed
18 19
(declaim (inline camera-entity))
(defun camera-entity ()
20
  "Returns current camera entity."
Andrew Kravchuk's avatar
Andrew Kravchuk committed
21 22
  (slot-value (system-ref 'camera) 'entity))

Andrew Kravchuk's avatar
Andrew Kravchuk committed
23 24 25 26 27 28 29 30 31 32
(declaim (inline camera-target))
(defun camera-target ()
  "Returns current camera target, i.e. the entity camera tracks."
  (slot-value (system-ref 'camera) 'target))

(declaim (inline (setf camera-target)))
(defun (setf camera-target) (target)
  "Sets current camera target, i.e. the entity camera tracks. Set to NIL to stop camera tracking."
  (setf (slot-value (system-ref 'camera) 'target) target))

33 34
(defmacro with-camera (bindings &body body)
  "Executes BODY with current camera position bound to two symbols in BIDNINGS list."
Andrew Kravchuk's avatar
Andrew Kravchuk committed
35
  (with-gensyms (camera-entity)
Andrew Kravchuk's avatar
Andrew Kravchuk committed
36
    `(let ((,camera-entity (camera-entity)))
37
       (with-coordinate ,camera-entity ,bindings
Andrew Kravchuk's avatar
Andrew Kravchuk committed
38 39 40
         ,@body))))

(declaim
41 42 43 44
 (inline absolute->viewport)
 ;; (ftype (function (coordinate coordinate) (values fixnum fixnum)) absolute->viewport)
 )
(defun absolute->viewport (x y)
45 46 47
  "Converts given integer absolute screen coordinates to viewport coordinates.

See VIEWPORT->ABSOLUTE"
48
  (with-system-config-options ((display-width display-height))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
49
    (with-screen-coordinate (camera-entity)
50
        (camera-x camera-y)
Andrew Kravchuk's avatar
Andrew Kravchuk committed
51 52 53 54
      (values
       (+ (- x camera-x) (ceiling display-width 2))
       (+ (- y camera-y) (ceiling display-height 2))))))

55 56 57 58
(declaim
 (inline viewport->absolute)
 )
(defun viewport->absolute (x y)
59 60 61
  "Converts given integer viewport coordinates to absolute screen coordinates.

See ABSOLUTE->VIEWPORT"
62
  (with-system-config-options ((display-width display-height))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
63
    (with-screen-coordinate (camera-entity)
64 65 66 67 68
        (camera-x camera-y)
      (values
       (+ x camera-x (- (ceiling display-width 2)))
       (+ y camera-y (- (ceiling display-height 2)))))))

Andrew Kravchuk's avatar
Andrew Kravchuk committed
69 70
(declaim
 (inline visiblep)
71
 (ftype (function (fixnum fixnum &optional fixnum) boolean) visiblep))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
72
(defun visiblep (x y &optional (delta 0))
73
  "Returns T if point with given viewport coordinates is visible on screeen."
74 75
  (with-system-config-options ((display-width display-height))
    (and
76 77 78 79
     (> x (- delta))
     (< x (+ delta display-width))
     (> y (- delta))
     (< y (+ delta display-height)))))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
80 81 82

(declaim
 (inline range-visible-p)
83
 (ftype (function (fixnum fixnum fixnum fixnum) boolean) range-visible-p))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
84
(defun range-visible-p (x y width height)
85
  "Returns T if any part of rectangular range defined by given viewport coordinates and dimensions is visible on screen."
86 87 88 89 90 91
  (with-system-config-options ((display-width display-height))
    (and
     (> x (- width))
     (< x display-width)
     (> y (- height))
     (< y display-height))))
Andrew Kravchuk's avatar
Andrew Kravchuk committed
92 93 94 95 96 97 98

(defmethod system-update ((system camera-system) dt)
  (when-let (target (slot-value system 'target))
    (with-camera (camera-x camera-y)
      (with-coordinate target ()
        (setf camera-x x
              camera-y y)))))