basis/ui/render/render.factor

   1 ! Copyright (C) 2005, 2009 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 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 -- )
  22     [
  23         dim>>
  24         [ { 0 1 } v* viewport-translation set ]
  25         [ [ { 0 0 } ] dip gl-viewport ]
  26         [ [ 0 ] dip first2 0 gluOrtho2D ] tri
  27     ]
  28     [ clip set ] bi
  29     do-clip ;
  30
  31 : init-gl ( clip-rect -- )
  32     GL_SMOOTH glShadeModel
  33     GL_SCISSOR_TEST glEnable
  34     GL_BLEND glEnable
  35     GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
  36     GL_VERTEX_ARRAY glEnableClientState
  37     init-matrices
  38     init-clip
  39     ! white gl-clear is broken w.r.t window resizing
  40     ! Linux/PPC Radeon 9200
  41     white gl-color
  42     clip get dim>> gl-fill-rect ;
  43
  44 GENERIC: draw-gadget* ( gadget -- )
  45
  46 M: gadget draw-gadget* drop ;
  47
  48 GENERIC: draw-interior ( gadget interior -- )
  49
  50 GENERIC: draw-boundary ( gadget boundary -- )
  51
  52 SYMBOL: origin
  53
  54 { 0 0 } origin set-global
  55
  56 : visible-children ( gadget -- seq )
  57     clip get origin get vneg offset-rect swap children-on ;
  58
  59 : translate ( rect/point -- ) loc>> origin [ v+ ] change ;
  60
  61 DEFER: draw-gadget
  62
  63 : (draw-gadget) ( gadget -- )
  64     [
  65         dup translate
  66         dup interior>> [
  67             origin get [ dupd draw-interior ] with-translation
  68         ] when*
  69         dup draw-gadget*
  70         dup visible-children [ draw-gadget ] each
  71         dup boundary>> [
  72             origin get [ dupd draw-boundary ] with-translation
  73         ] when*
  74         drop
  75     ] with-scope ;
  76
  77 : >absolute ( rect -- rect )
  78     origin get offset-rect ;
  79
  80 : change-clip ( gadget -- )
  81     >absolute clip [ rect-intersect ] change ;
  82
  83 : with-clipping ( gadget quot -- )
  84     clip get [ over change-clip do-clip call ] dip 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     swap [ over v+ 2array ] curry map
 143     concat concat >float-array ;
 144
 145 : gradient-colors ( colors -- seq )
 146     [ >rgba-components 4array dup 2array ] map concat concat
 147     >float-array ;
 148
 149 M: gradient recompute-pen ( gadget gradient -- )
 150     [ nip ] [ [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi* ] 2bi
 151     [ gradient-vertices >>last-vertices ]
 152     [ gradient-colors >>last-colors ]
 153     bi drop ;
 154
 155 : draw-gradient ( colors -- )
 156     GL_COLOR_ARRAY [
 157         [ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
 158     ] do-enabled-client-state ;
 159
 160 PRIVATE>
 161
 162 M: gradient draw-interior
 163     {
 164         [ compute-pen ]
 165         [ last-vertices>> gl-vertex-pointer ]
 166         [ last-colors>> gl-color-pointer ]
 167         [ colors>> draw-gradient ]
 168     } cleave ;
 169
 170 ! Polygon pen
 171 TUPLE: polygon color
 172 interior-vertices
 173 interior-count
 174 boundary-vertices
 175 boundary-count ;
 176
 177 : <polygon> ( color points -- polygon )
 178     dup close-path [ [ concat >float-array ] [ length ] bi ] bi@
 179     polygon boa ;
 180
 181 M: polygon draw-boundary
 182     nip
 183     [ color>> gl-color ]
 184     [ boundary-vertices>> gl-vertex-pointer ]
 185     [ [ GL_LINE_STRIP 0 ] dip boundary-count>> glDrawArrays ]
 186     tri ;
 187
 188 M: polygon draw-interior
 189     nip
 190     [ color>> gl-color ]
 191     [ interior-vertices>> gl-vertex-pointer ]
 192     [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
 193     tri ;
 194
 195 CONSTANT: arrow-up    { { 3 0 } { 6 6 } { 0 6 } }
 196 CONSTANT: arrow-right { { 0 0 } { 6 3 } { 0 6 } }
 197 CONSTANT: arrow-down  { { 0 0 } { 6 0 } { 3 6 } }
 198 CONSTANT: arrow-left  { { 0 3 } { 6 0 } { 6 6 } }
 199 CONSTANT: close-box   { { 0 0 } { 6 0 } { 6 6 } { 0 6 } }
 200
 201 : <polygon-gadget> ( color points -- gadget )
 202     dup max-dim
 203     [ <polygon> <gadget> ] dip >>dim
 204     swap >>interior ;