4 (defclass viewport
(widget)
5 ((render :type function
:initarg
:render
:accessor render-of
6 :documentation
"Callback for this class for drawing the scene inside the viewport."))
7 (:documentation
"Widget that contains a miniature viewport,
8 use the render attribute, or draw-viewport-scene method for derived classes."))
10 (defgeneric draw-viewport-scene
(viewport)
11 (:documentation
"Override this method in sub-classes of viewport to
12 define the render function of the viewport."))
14 (defmethod draw ((viewport viewport
))
15 (destructuring-bind (display-width display-height
)
16 (let ((viewport (list 0 0 0 0)))
17 (gl:get-integerv gl
:+viewport
+ viewport
)
19 (gl:with-push-attrib
(gl:+depth-buffer-bit
+)
20 (gl:enable gl
:+depth-test
+)
21 (gl:depth-func gl
:+always
+)
22 (gl:color-4f
0.5 0.5 0.5 0)
23 (gl:translate-f
0 0 -
1)
24 (gl:rect-f
0 (current-size-of (y viewport
))
25 (current-size-of (x viewport
)) 0))
26 (destructuring-bind (x y
) (cumulative-offset-of viewport
)
27 (gl:with-push-attrib
(gl:+viewport-bit
+)
28 (let ((height (round (current-size-of (y viewport
)))))
29 (gl:viewport
(round x
)
30 (- display-height
(round y
) height
)
31 (round (current-size-of (x viewport
)))
33 (draw-viewport-scene viewport
)))))
35 (defmethod draw-viewport-scene ((viewport viewport
))
36 (funcall (render-of viewport
)))
38 (defmacro make-viewport
((&rest make-instance-keyargs
) &body render-forms
)
39 "Convenience macro that takes the keywords and a render function body."
40 `(make-instance 'viewport
,@make-instance-keyargs
41 :render
#'(lambda () ,@render-forms
)))
44 ;; (defclass model-viewer (viewport)
45 ;; ((model-uri :type model-uri :initarg :model-uri :initform nil :accessor model-uri-of
46 ;; :documentation "Unique identifier of the model to be drawn.")
47 ;; (x-rotation :type single-float :initform -45.0 :initarg :x-rotation :accessor x-rotation-of
48 ;; :documentation "Angle from straight-down this model is rotated by.")
49 ;; (z-rotation :type single-float :initform 0.0 :initarg :z-rotation :accessor z-rotation-of
50 ;; :documentation "Current state of the z-rotation."))
51 ;; (:documentation "Viewport widget that renders a centred, rotating model."))
53 ;; (defmethod draw-viewport-scene ((model-viewer model-viewer))
54 ;; (with-slots (model-uri distance x-rotation z-rotation) model-viewer
56 ;; (let* ((width (current-size-of (x model-viewer)))
57 ;; (height (current-size-of (y model-viewer)))
58 ;; (model (get-model model-uri))
59 ;; (distance (/ (maths:modulus (mapcar #'-
60 ;; (first (extents-of model))
61 ;; (second (extents-of model))))
62 ;; (tan (/ *fov* 2)))))
63 ;; (setf z-rotation (* (glfw:get-time) 10.0))
64 ;; (gl:with-projection-matrix
65 ;; ((glu:perspective *fov*
66 ;; (coerce (/ width height) 'single-float)
67 ;; (coerce (/ distance 16) 'single-float)
68 ;; (coerce (* distance 2) 'single-float)))
70 ;; (gl:with-push-attrib (gl:+texture-bit+)
71 ;; (gl:disable gl:+texture-2d+)
72 ;; (gl:translate-f 0 0 (- distance))
73 ;; (gl:rotate-f x-rotation 1 0 0)
74 ;; (gl:rotate-f z-rotation 0 0 1)
75 ;; ;; translate down by half of the model's z extents
76 ;; (gl:translate-f 0 0 (/ (apply #'+ (mapcar #'third (extents-of model)))
78 ;; (gl:color-4f 1 1 1 1)