aboutsummaryrefslogtreecommitdiffhomepage
path: root/src/application.lisp
blob: 3b531c94e71051d94e54942006bf33640293f058 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
;;;; application

(in-package #:wheelwork)

(defclass/std application (region interactive)
  ((title :with :ri :std "Wheelwork App")
   (asset-root :ri :std #P"./" :doc "Directory under which assets are stored.")
   (asset-classifiers
    :std '(("png" png) ("ttf" font))
    :doc "ALIST of (EXT CLASS). EXT is a string, file estension. CLASS is a symbol, class name.")
   (assets :with :a :std (make-hash-table :test 'equal)
           :doc "maps asset names to asset instances.")
   (scale :with :std 1.0
                :doc "Scale factor applied before all
                rendering. Affects sizes of all object as well as the
                coordinates of mouse events.")
   (width height :with :std 800 :doc "Window dimensions in real pixels.")
   (projection :with :a :doc "The projection matrix for the scene. Orthographic by default.")
   (window :with :a)
   (refocus-on-mousedown-p
    :std t
    :doc "When T, clicking on a visible object will set the
    application focus to that object.")
   (mouse-button-events-bubble-p
    mouse-motion-events-bubble-p
    :std nil
    :doc "determines whether the search for event handlers stops at
    the first visible unit under the xy position of the mouse or
    not. ")
   (scene focus last-motion-target :with :a)
   (fps :std 30 :doc "Frames Per Second")
   (frame-wait :r))
  (:documentation "The application contains the information and data
  structures necessary for creating a window, adding display units to
  it, handling events, and loading resources.  You should sublcass
  this and write your own BOOT method."))

(defun can-set-projection-p (app)
  (and (slot-boundp app 'width)
       (slot-boundp app 'height)
       (slot-boundp app 'scale)))

(defun set-projection (app)
  (when (can-set-projection-p app)
    (with-slots (projection scale width height) app 
      ;; set projection matrix
      (setf projection (mat:mortho 0.0 (/ width scale) 0 (/ height scale) -1.0 1.0)))))

(defmethod initialize-instance :after ((app application) &key)
  (set-projection app)
  (with-slots (listener left right top bottom scale width height) app
  (setf listener (make-instance 'listener)
        left 0
        bottom 0
        top (/ height scale)
        right (/ width scale))))

(defun fire-blur-event-on (thing)
  (when-let (blur-handlers (and thing (get-handlers-for thing 'blur)))
    (dolist (handler blur-handlers) 
      (funcall handler thing))))

(defun fire-focus-event-on (thing)
  (when-let (focus-handlers (and thing (get-handlers-for thing 'focus)))
    (dolist (handler focus-handlers)
      (funcall handler thing))))

(defmethod (setf closer-mop:slot-value-using-class ) :before
    (new-value class (app application) slot)
  (case (closer-mop:slot-definition-name slot)
    (focus
     (when (slot-boundp app 'focus) 
       (unless (eq new-value (slot-value app 'focus)) 
         (fire-blur-event-on (slot-value app 'focus))
         (fire-focus-event-on new-value))))))

(defmethod (setf closer-mop:slot-value-using-class) :after
    (new-value class (app application) slot)
  (case (closer-mop:slot-definition-name slot)
    ((scale width height)
     (set-projection app))
    (fps
     (setf (slot-value app 'frame-wait) (/ 1.0 new-value)))))

(defparameter +listener-table-slot-names+
  '(keydown-table keyup-table mousedown-table  mouseup-table  mousemotion-table
    focus-table blur-table perframe-table))

(defmethod cleanup ((app application))
  (loop for asset being the hash-value of (application-assets app)
        do (cleanup asset))
  ;; drop all current handlers
  (let ((listener (listener app))) 
    (dolist (table +listener-table-slot-names+)
      (setf (slot-value listener table) (make-hash-table :synchronized t))))
  (dolist (unit (application-scene app))
    (drop-unit unit)
    (cleanup unit))
  (pre-exit-hooks))

(defun run-perframe (app)
  "Runs all of the handlers objects listening for perframe events, if
those objects are currently part of the scene tree."
  (let ((table (perframe-table (listener app)))
        (time (sdl2:get-ticks)))
    (loop for target being the hash-key of table
          for handlers = (slot-value (listener target) 'perframe)
          ;; only fire perframe when target is in scene
          when (or (eq app target) (unit-in-scene-p target)) 
            do (loop for handler in handlers do (funcall handler target time)))))

(defmethod render ((app application))
  (run-perframe app)
  (gl:clear-color 0.0 0.0 0.0 1.0)
  ;(gl:clear :depth-buffer-bit :color-buffer-bit)
  (gl:clear :color-buffer-bit)
  (gl:enable :blend)
  (gl:blend-func :src-alpha :one-minus-src-alpha )
  (dolist (unit (reverse (application-scene app)))
    (render unit))
  (sdl2:gl-swap-window (application-window app))
  (sleep (frame-wait app)))