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         >r { 1 -1 } v* r> { 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 >r
  83     over change-clip do-clip call
  84     r> clip set do-clip ; inline
  85
  86 : draw-gadget ( gadget -- )
  87     {
  88         { [ dup visible?>> not ] [ drop ] }
  89         { [ dup clipped?>> not ] [ (draw-gadget) ] }
  90         [ [ (draw-gadget) ] with-clipping ]
  91     } cond ;
  92
  93 ! A pen that caches vertex arrays, etc
  94 TUPLE: caching-pen last-dim ;
  95
  96 GENERIC: recompute-pen ( gadget pen -- )
  97
  98 : compute-pen ( gadget pen -- )
  99     2dup [ dim>> ] [ last-dim>> ] bi* = [
 100         2drop
 101     ] [
 102         [ swap dim>> >>last-dim drop ] [ recompute-pen ] 2bi
 103     ] if ;
 104
 105 ! Solid fill/border
 106 TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
 107
 108 : <solid> ( color -- solid ) solid new swap >>color ;
 109
 110 M: solid recompute-pen
 111     swap dim>>
 112     [ (fill-rect-vertices) >>interior-vertices ]
 113     [ (rect-vertices) >>boundary-vertices ]
 114     bi drop ;
 115
 116 <PRIVATE
 117
 118 ! Solid pen
 119 : (solid) ( gadget pen -- )
 120     [ compute-pen ] [ color>> gl-color ] bi ;
 121
 122 PRIVATE>
 123
 124 M: solid draw-interior
 125     [ (solid) ] [ interior-vertices>> gl-vertex-pointer ] bi
 126     (gl-fill-rect) ;
 127
 128 M: solid draw-boundary
 129     [ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
 130     (gl-rect) ;
 131
 132 ! Gradient pen
 133 TUPLE: gradient < caching-pen colors last-vertices last-colors ;
 134
 135 : <gradient> ( colors -- gradient ) gradient new swap >>colors ;
 136
 137 <PRIVATE
 138
 139 :: gradient-vertices ( direction dim colors -- seq )
 140     direction dim v* dim over v- swap
 141     colors length dup 1- v/n [ v*n ] with map
 142     [ dup rot v+ 2array ] with map
 143     concat concat >float-array underlying>> ;
 144
 145 : gradient-colors ( colors -- seq )
 146     [ color>raw 4array dup 2array ] map concat concat
 147     >float-array underlying>> ;
 148
 149 M: gradient recompute-pen ( gadget gradient -- )
 150     tuck
 151     [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi*
 152     [ gradient-vertices >>last-vertices ]
 153     [ gradient-colors >>last-colors ] bi
 154     drop ;
 155
 156 : draw-gradient ( colors -- )
 157     GL_COLOR_ARRAY [
 158         [ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
 159     ] do-enabled-client-state ;
 160
 161 PRIVATE>
 162
 163 M: gradient draw-interior
 164     {
 165         [ compute-pen ]
 166         [ last-vertices>> gl-vertex-pointer ]
 167         [ last-colors>> gl-color-pointer ]
 168         [ colors>> draw-gradient ]
 169     } cleave ;
 170
 171 ! Polygon pen
 172 TUPLE: polygon color vertex-array count ;
 173
 174 : <polygon> ( color points -- polygon )
 175     [ concat >float-array underlying>> ] [ length ] bi polygon boa ;
 176
 177 : draw-polygon ( polygon mode -- )
 178     swap
 179     [ color>> gl-color ]
 180     [ vertex-array>> gl-vertex-pointer ]
 181     [ 0 swap count>> glDrawArrays ]
 182     tri ;
 183
 184 M: polygon draw-boundary
 185     GL_LINE_LOOP draw-polygon drop ;
 186
 187 M: polygon draw-interior
 188     dup count>> 2 > GL_POLYGON GL_LINES ?
 189     draw-polygon drop ;
 190
 191 : arrow-up    { { 3 0 } { 6 6 } { 0 6 } } ;
 192 : arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
 193 : arrow-down  { { 0 0 } { 6 0 } { 3 6 } } ;
 194 : arrow-left  { { 0 3 } { 6 0 } { 6 6 } } ;
 195 : close-box   { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } ;
 196
 197 : <polygon-gadget> ( color points -- gadget )
 198     dup max-dim
 199     >r <polygon> <gadget> r> >>dim
 200     swap >>interior ;
 201
 202 ! Font rendering
 203 SYMBOL: font-renderer
 204
 205 HOOK: open-font font-renderer ( font -- open-font )
 206
 207 HOOK: string-width font-renderer ( open-font string -- w )
 208
 209 HOOK: string-height font-renderer ( open-font string -- h )
 210
 211 HOOK: draw-string font-renderer ( font string loc -- )
 212
 213 HOOK: x>offset font-renderer ( x open-font string -- n )
 214
 215 HOOK: free-fonts font-renderer ( world -- )
 216
 217 : text-height ( open-font text -- n )
 218     dup string? [
 219         string-height
 220     ] [
 221         [ string-height ] with map sum
 222     ] if ;
 223
 224 : text-width ( open-font text -- n )
 225     dup string? [
 226         string-width
 227     ] [
 228         0 -rot [ string-width max ] with each
 229     ] if ;
 230
 231 : text-dim ( open-font text -- dim )
 232     [ text-width ] 2keep text-height 2array ;
 233
 234 : draw-text ( font text loc -- )
 235     over string? [
 236         draw-string
 237     ] [
 238         [
 239             [
 240                 2dup { 0 0 } draw-string
 241                 >r open-font r> string-height
 242                 0.0 swap 0.0 glTranslated
 243             ] with each
 244         ] with-translation
 245     ] if ;