basis/ui/render/render.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: math.rectangles math.vectors namespaces kernel accessors
   4 combinators sequences opengl opengl.gl opengl.glu colors
   5 colors.constants ui.gadgets ui.pens ;
   6 IN: ui.render
   7
   8 SYMBOL: clip
   9
  10 SYMBOL: viewport-translation
  11
  12 : flip-rect ( rect -- loc dim )
  13     rect-bounds [
  14         [ { 1 -1 } v* ] dip { 0 -1 } v* v+
  15         viewport-translation get v+
  16     ] keep ;
  17
  18 : do-clip ( -- ) clip get flip-rect gl-set-clip ;
  19
  20 : init-clip ( clip-rect -- )
  21     [
  22         dim>>
  23         [ { 0 1 } v* viewport-translation set ]
  24         [ [ { 0 0 } ] dip gl-viewport ]
  25         [ [ 0 ] dip first2 0 gluOrtho2D ] tri
  26     ]
  27     [ clip set ] bi
  28     do-clip ;
  29
  30 : init-gl ( clip-rect -- )
  31     GL_SMOOTH glShadeModel
  32     GL_SCISSOR_TEST glEnable
  33     GL_BLEND glEnable
  34     GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
  35     GL_VERTEX_ARRAY glEnableClientState
  36     init-matrices
  37     init-clip
  38     ! white gl-clear is broken w.r.t window resizing
  39     ! Linux/PPC Radeon 9200
  40     COLOR: white gl-color
  41     clip get dim>> gl-fill-rect ;
  42
  43 GENERIC: draw-gadget* ( gadget -- )
  44
  45 M: gadget draw-gadget* drop ;
  46
  47 SYMBOL: origin
  48
  49 { 0 0 } origin set-global
  50
  51 : visible-children ( gadget -- seq )
  52     [ clip get origin get vneg offset-rect ] dip children-on ;
  53
  54 : translate ( rect/point -- ) loc>> origin [ v+ ] change ;
  55
  56 GENERIC: draw-children ( gadget -- )
  57
  58 : (draw-gadget) ( gadget -- )
  59     dup loc>> origin get v+ origin [
  60         [
  61             origin get [
  62                 [ dup interior>> dup [ draw-interior ] [ 2drop ] if ]
  63                 [ draw-gadget* ]
  64                 bi
  65             ] with-translation
  66         ]
  67         [ draw-children ]
  68         [
  69             dup boundary>> dup [
  70                 origin get [ draw-boundary ] with-translation
  71             ] [ 2drop ] if
  72         ] tri
  73     ] with-variable ;
  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 ! For text rendering
  92 SYMBOL: background
  93
  94 SYMBOL: foreground
  95
  96 GENERIC: gadget-background ( gadget -- color )
  97
  98 M: gadget gadget-background dup interior>> pen-background ;
  99
 100 GENERIC: gadget-foreground ( gadget -- color )
 101
 102 M: gadget gadget-foreground dup interior>> pen-foreground ;
 103
 104 M: gadget draw-children
 105     [ visible-children ]
 106     [ gadget-background ]
 107     [ gadget-foreground ] tri [
 108         [ foreground set ] when*
 109         [ background set ] when*
 110         [ draw-gadget ] each
 111     ] with-scope ;
 112
 113 CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
 114
 115 CONSTANT: focus-border-color COLOR: dark-gray