blob: 70d7758a7bf42c534d0465be80819c3a7c55b616 (
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
|
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
USING: locals math.functions math namespaces
opengl.gl opengl.demo-support accessors kernel opengl ui.gadgets
fry assocs
destructors sequences ui.render colors ;
IN: opengl.gadgets
TUPLE: texture-gadget < gadget ;
GENERIC: render* ( gadget -- texture dims )
GENERIC: cache-key* ( gadget -- key )
M: texture-gadget cache-key* ;
SYMBOL: textures
SYMBOL: refcounts
: init-cache ( symbol -- )
dup get [ drop ] [ H{ } clone swap set-global ] if ;
textures init-cache
refcounts init-cache
: refcount-change ( gadget quot -- )
[ cache-key* refcounts get [ [ 0 ] unless* ] ] dip compose change-at ;
TUPLE: cache-entry tex dims ;
C: <entry> cache-entry
: make-entry ( gadget -- entry )
dup render* <entry>
[ swap cache-key* textures get set-at ] keep ;
: get-entry ( gadget -- {texture,dims} )
dup cache-key* textures get at
[ ] [ make-entry ] ?if ;
: get-dims ( gadget -- dims )
get-entry dims>> ;
: get-texture ( gadget -- texture )
get-entry tex>> ;
: release-texture ( gadget -- )
cache-key* textures get delete-at*
[ tex>> delete-texture ] [ drop ] if ;
: clear-textures ( -- )
textures get values [ tex>> delete-texture ] each
H{ } clone textures set-global
H{ } clone refcounts set-global ;
M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
M: texture-gadget ungraft* ( gadget -- )
dup [ 1- ] refcount-change
dup cache-key* refcounts get at
zero? [ release-texture ] [ drop ] if ;
: 2^-ceil ( x -- y )
dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
: 2^-bounds ( dim -- dim' )
[ 2^-ceil ] map ; foldable flushable
:: (render-bytes) ( dims bytes format texture -- )
GL_ENABLE_BIT [
GL_TEXTURE_2D glEnable
GL_TEXTURE_2D texture glBindTexture
GL_TEXTURE_2D
0
GL_RGBA
dims 2^-bounds first2
0
format
GL_UNSIGNED_BYTE
bytes
glTexImage2D
init-texture
GL_TEXTURE_2D 0 glBindTexture
] do-attribs ;
: render-bytes ( dims bytes format -- texture )
gen-texture [ (render-bytes) ] keep ;
: render-bytes* ( dims bytes format -- texture dims )
pick [ render-bytes ] dip ;
:: four-corners ( dim -- )
[let* | w [ dim first ]
h [ dim second ]
dim' [ dim dup 2^-bounds [ /f ] 2map ]
w' [ dim' first ]
h' [ dim' second ] |
0 0 glTexCoord2d 0 0 glVertex2d
0 h' glTexCoord2d 0 h glVertex2d
w' h' glTexCoord2d w h glVertex2d
w' 0 glTexCoord2d w 0 glVertex2d
] ;
M: texture-gadget draw-gadget* ( gadget -- )
origin get [
GL_ENABLE_BIT [
white gl-color
1.0 -1.0 glPixelZoom
GL_TEXTURE_2D glEnable
GL_TEXTURE_2D over get-texture glBindTexture
GL_QUADS [
get-dims four-corners
] do-state
GL_TEXTURE_2D 0 glBindTexture
] do-attribs
] with-translation ;
M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ;
|
