forked from Shirakumo/trial
-
Notifications
You must be signed in to change notification settings - Fork 0
/
attributes.lisp
130 lines (116 loc) · 4.71 KB
/
attributes.lisp
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
124
125
126
127
128
129
130
#|
This file is a part of trial
(c) 2016 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(in-package #:org.shirakumo.fraf.trial)
(defvar *gl-attributes* #(:blend
:clip-distance0
:clip-distance1
:color-logic-op
:cull-face
:debug-output
:debug-output-synchronous
:depth-clamp
:depth-test
:dither
:framebuffer-srgb
:line-smooth
:multisample
:polygon-offset-fill
:polygon-offset-line
:polygon-offset-point
:polygon-smooth
:primitive-restart
:primitive-restart-fixed-index
:rasterizer-discard
:sample-alpha-to-coverage
:sample-alpha-to-one
:sample-coverage
:sample-shading
:sample-mask
:scissor-test
:stencil-test
:texture-cube-map-seamless
:program-point-size))
(defvar *default-enabled-gl-attributes* #(:dither :multisample))
(defun make-attribute-table (&optional parent)
(let ((table (make-hash-table :test 'eq :size (length *gl-attributes*))))
(if parent
(loop for k being the hash-keys of parent
for v being the hash-values of parent
do (setf (gethash k table) v))
(reset-attributes table))
table))
(defun reset-attributes (&optional (table (attribute-table)))
(loop for k across *gl-attributes*
do (if (find k *default-enabled-gl-attributes*)
(setf (gethash k table) T)
(setf (gethash k table) NIL))))
(defvar *attribute-stack* (list (make-attribute-table)))
(defun attribute-table ()
(first *attribute-stack*))
(defun enable (&rest attributes)
(let ((table (attribute-table)))
(dolist (attrib attributes)
(unless (gethash attrib table)
(gl:enable attrib)
(setf (gethash attrib table) T)))))
(define-compiler-macro enable (&whole whole &environment env &rest attributes)
(let ((constants) (variants) (table (gensym "TABLE")))
(dolist (attribute attributes)
(if (constantp attribute env)
(push attribute constants)
(push attribute variants)))
(cond ((and (null constants) (null variants))
())
((null constants)
whole)
(T
`(let ((,table (attribute-table)))
(enable ,@variants)
,@(loop for constant in constants
for attrib = `(load-time-value ,constant)
collect `(unless (gethash ,attrib ,table)
(gl:enable ,attrib)
(setf (gethash ,attrib ,table) T))))))))
(defun disable (&rest attributes)
(let ((table (attribute-table)))
(dolist (attrib attributes)
(when (gethash attrib table)
(gl:disable attrib)
(setf (gethash attrib table) NIL)))))
(define-compiler-macro disable (&whole whole &environment env &rest attributes)
(let ((constants) (variants) (table (gensym "TABLE")))
(dolist (attribute attributes)
(if (constantp attribute env)
(push attribute constants)
(push attribute variants)))
(cond ((and (null constants) (null variants))
())
((null constants)
whole)
(T
`(let ((,table (attribute-table)))
(disable ,@variants)
,@(loop for constant in constants
for attrib = `(load-time-value ,constant)
collect `(when (gethash ,attrib ,table)
(gl:disable ,attrib)
(setf (gethash ,attrib ,table) NIL))))))))
(defun push-attribs (&optional (table (make-attribute-table (attribute-table))))
(push table *attribute-stack*))
(defun pop-attribs ()
(let ((prev (pop *attribute-stack*))
(cur (attribute-table)))
(loop for k being the hash-keys of prev
for v being the hash-values of prev
do (cond ((and v (not (gethash k cur)))
(gl:disable k))
((and (not v) (gethash k cur))
(gl:enable k))))))
(defmacro with-pushed-attribs (&body body)
`(progn (push-attribs)
(unwind-protect
(progn ,@body)
(pop-attribs))))