basis/ui/render/render.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types arrays hashtables io kernel
   4 math namespaces opengl opengl.gl opengl.glu sequences strings
   5 io.styles vectors combinators math.vectors ui.gadgets colors
   6 math.order math.geometry.rect locals specialized-arrays.float ;
   7 IN: ui.render
   8
   9 SYMBOL: clip
  10
  11 SYMBOL: viewport-translation
  12
  13 : flip-rect ( rect -- loc dim )
  14     rect-bounds [
  15         [ { 1 -1 } v* ] dip { 0 -1 } v* v+
  16         viewport-translation get v+
  17     ] keep ;
  18
  19 : do-clip ( -- ) clip get flip-rect gl-set-clip ;
  20
  21 : init-clip ( clip-rect rect -- )
  22     GL_SCISSOR_TEST glEnable
  23     [ rect-intersect ] keep
  24     dim>> dup { 0 1 } v* viewport-translation set
  25     { 0 0 } over gl-viewport
  26     0 swap first2 0 gluOrtho2D
  27     clip set
  28     do-clip ;
  29
  30 : init-gl ( clip-rect rect -- )
  31     GL_SMOOTH glShadeModel
  32     GL_BLEND glEnable
  33     GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
  34     GL_VERTEX_ARRAY glEnableClientState
  35     init-matrices
  36     init-clip
  37     ! white gl-clear is broken w.r.t window resizing
  38     ! Linux/PPC Radeon 9200
  39     white gl-color
  40     clip get dim>> gl-fill-rect ;
  41
  42 GENERIC: draw-gadget* ( gadget -- )
  43
  44 M: gadget draw-gadget* drop ;
  45
  46 GENERIC: draw-interior ( gadget interior -- )
  47
  48 GENERIC: draw-boundary ( gadget boundary -- )
  49
  50 SYMBOL: origin
  51
  52 { 0 0 } origin set-global
  53
  54 : visible-children ( gadget -- seq )
  55     clip get origin get vneg offset-rect swap children-on ;
  56
  57 : translate ( rect/point -- ) rect-loc origin [ v+ ] change ;
  58
  59 DEFER: draw-gadget
  60
  61 : (draw-gadget) ( gadget -- )
  62     [
  63         dup translate
  64         dup interior>> [
  65             origin get [ dupd draw-interior ] with-translation
  66         ] when*
  67         dup draw-gadget*
  68         dup visible-children [ draw-gadget ] each
  69         dup boundary>> [
  70             origin get [ dupd draw-boundary ] with-translation
  71         ] when*
  72         drop
  73     ] with-scope ;
  74
  75 : >absolute ( rect -- rect )
  76     origin get offset-rect ;
  77
  78 : change-clip ( gadget -- )
  79     >absolute clip [ rect-intersect ] change ;
  80
  81 : with-clipping ( gadget quot -- )
  82     clip get [ over change-clip do-clip call ] dip clip set do-clip ; inline
  83
  84 : draw-gadget ( gadget -- )
  85     {
  86         { [ dup visible?>> not ] [ drop ] }
  87         { [ dup clipped?>> not ] [ (draw-gadget) ] }
  88         [ [ (draw-gadget) ] with-clipping ]
  89     } cond ;
  90
  91 ! A pen that caches vertex arrays, etc
  92 TUPLE: caching-pen last-dim ;
  93
  94 GENERIC: recompute-pen ( gadget pen -- )
  95
  96 : compute-pen ( gadget pen -- )
  97     2dup [ dim>> ] [ last-dim>> ] bi* = [
  98         2drop
  99     ] [
 100         [ swap dim>> >>last-dim drop ] [ recompute-pen ] 2bi
 101     ] if ;
 102
 103 ! Solid fill/border
 104 TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
 105
 106 : <solid> ( color -- solid ) solid new swap >>color ;
 107
 108 M: solid recompute-pen
 109     swap dim>>
 110     [ (fill-rect-vertices) >>interior-vertices ]
 111     [ (rect-vertices) >>boundary-vertices ]
 112     bi drop ;
 113
 114 <PRIVATE
 115
 116 ! Solid pen
 117 : (solid) ( gadget pen -- )
 118     [ compute-pen ] [ color>> gl-color ] bi ;
 119
 120 PRIVATE>
 121
 122 M: solid draw-interior
 123     [ (solid) ] [ interior-vertices>> gl-vertex-pointer ] bi
 124     (gl-fill-rect) ;
 125
 126 M: solid draw-boundary
 127     [ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
 128     (gl-rect) ;
 129
 130 ! Gradient pen
 131 TUPLE: gradient < caching-pen colors last-vertices last-colors ;
 132
 133 : <gradient> ( colors -- gradient ) gradient new swap >>colors ;
 134
 135 <PRIVATE
 136
 137 :: gradient-vertices ( direction dim colors -- seq )
 138     direction dim v* dim over v- swap
 139     colors length dup 1- v/n [ v*n ] with map
 140     [ dup rot v+ 2array ] with map
 141     concat concat >float-array ;
 142
 143 : gradient-colors ( colors -- seq )
 144     [ color>raw 4array dup 2array ] map concat concat
 145     >float-array ;
 146
 147 M: gradient recompute-pen ( gadget gradient -- )
 148     tuck
 149     [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi*
 150     [ gradient-vertices >>last-vertices ]
 151     [ gradient-colors >>last-colors ] bi
 152     drop ;
 153
 154 : draw-gradient ( colors -- )
 155     GL_COLOR_ARRAY [
 156         [ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
 157     ] do-enabled-client-state ;
 158
 159 PRIVATE>
 160
 161 M: gradient draw-interior
 162     {
 163         [ compute-pen ]
 164         [ last-vertices>> gl-vertex-pointer ]
 165         [ last-colors>> gl-color-pointer ]
 166         [ colors>> draw-gradient ]
 167     } cleave ;
 168
 169 ! Polygon pen
 170 TUPLE: polygon color
 171 interior-vertices
 172 interior-count
 173 boundary-vertices
 174 boundary-count ;
 175
 176 : <polygon> ( color points -- polygon )
 177     dup close-path [ [ concat >float-array ] [ length ] bi ] bi@
 178     polygon boa ;
 179
 180 M: polygon draw-boundary
 181     nip
 182     [ color>> gl-color ]
 183     [ boundary-vertices>> gl-vertex-pointer ]
 184     [ [ GL_LINE_STRIP 0 ] dip boundary-count>> glDrawArrays ]
 185     tri ;
 186
 187 M: polygon draw-interior
 188     nip
 189     [ color>> gl-color ]
 190     [ interior-vertices>> gl-vertex-pointer ]
 191     [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
 192     tri ;
 193
 194 CONSTANT: arrow-up { { 3 0 } { 6 6 } { 0 6 } }
 195 CONSTANT: arrow-right { { 0 0 } { 6 3 } { 0 6 } }
 196 CONSTANT: arrow-down { { 0 0 } { 6 0 } { 3 6 } }
 197 CONSTANT: arrow-left { { 0 3 } { 6 0 } { 6 6 } }
 198 CONSTANT: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } }
 199
 200 : <polygon-gadget> ( color points -- gadget )
 201     dup max-dim
 202     [ <polygon> <gadget> ] dip >>dim
 203     swap >>interior ;
 204
 205 ! Font rendering
 206 SYMBOL: font-renderer
 207
 208 HOOK: open-font font-renderer ( font -- open-font )
 209
 210 HOOK: string-width font-renderer ( open-font string -- w )
 211
 212 HOOK: string-height font-renderer ( open-font string -- h )
 213
 214 HOOK: draw-string font-renderer ( font string loc -- )
 215
 216 HOOK: x>offset font-renderer ( x open-font string -- n )
 217
 218 HOOK: free-fonts font-renderer ( world -- )
 219
 220 : text-height ( open-font text -- n )
 221     dup string? [
 222         string-height
 223     ] [
 224         [ string-height ] with map sum
 225     ] if ;
 226
 227 : text-width ( open-font text -- n )
 228     dup string? [
 229         string-width
 230     ] [
 231         [ 0 ] 2dip [ string-width max ] with each
 232     ] if ;
 233
 234 : text-dim ( open-font text -- dim )
 235     [ text-width ] 2keep text-height 2array ;
 236
 237 : draw-text ( font text loc -- )
 238     over string? [
 239         draw-string
 240     ] [
 241         [
 242             [
 243                 2dup { 0 0 } draw-string
 244                 [ open-font ] dip string-height
 245                 0.0 swap 0.0 glTranslated
 246             ] with each
 247         ] with-translation
 248     ] if ;