core/ui/paint.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays freetype generic hashtables io kernel
   4 math namespaces opengl sequences strings styles
   5 vectors ;
   6 IN: gadgets
   7
   8 SYMBOL: clip
   9
  10 : init-gl ( dim -- )
  11     GL_PROJECTION glMatrixMode
  12     glLoadIdentity
  13     GL_MODELVIEW glMatrixMode
  14     glLoadIdentity
  15     { 0 0 } over <rect> clip set
  16     dup first2 0 0 2swap glViewport
  17     0 over first2 0 gluOrtho2D
  18     first2 0 0 2swap glScissor
  19     GL_SMOOTH glShadeModel
  20     GL_BLEND glEnable
  21     GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
  22     GL_SCISSOR_TEST glEnable
  23     1.0 1.0 1.0 1.0 glClearColor
  24     GL_COLOR_BUFFER_BIT glClear ;
  25
  26 GENERIC: draw-gadget* ( gadget -- )
  27
  28 M: gadget draw-gadget* drop ;
  29
  30 GENERIC: draw-interior ( gadget interior -- )
  31
  32 GENERIC: draw-boundary ( gadget boundary -- )
  33
  34 : visible-children ( gadget -- seq ) clip get swap children-on ;
  35
  36 DEFER: draw-gadget
  37
  38 : (draw-gadget) ( gadget -- )
  39     [
  40         dup translate
  41         dup dup gadget-interior draw-interior
  42         dup draw-gadget*
  43         dup visible-children [ draw-gadget ] each
  44         dup gadget-boundary draw-boundary
  45     ] with-scope ;
  46
  47 : change-clip ( gadget -- )
  48     >absolute clip [ rect-intersect ] change ;
  49
  50 : clip-x/y ( loc dim -- x y )
  51     >r [ first ] keep r> [ second ] 2apply +
  52     world get rect-dim second swap - ;
  53
  54 : gl-set-clip ( loc dim -- )
  55     [ clip-x/y ] keep first2 glScissor ;
  56
  57 : do-clip ( -- ) clip get rect-bounds gl-set-clip ;
  58
  59 : with-clipping ( gadget quot -- )
  60     clip get >r
  61     over change-clip do-clip call
  62     r> clip set do-clip ; inline
  63
  64 : draw-gadget ( gadget -- )
  65     {
  66         { [ dup gadget-visible? not ] [ drop ] }
  67         { [ dup gadget-clipped? not ] [ (draw-gadget) ] }
  68         { [ t ] [ [ (draw-gadget) ] with-clipping ] }
  69     } cond ;
  70
  71 : (draw-world) ( world -- )
  72     dup world-handle [
  73         dup rect-dim init-gl draw-gadget
  74     ] with-gl-context ;
  75
  76 ! Pen paint properties
  77 M: f draw-interior 2drop ;
  78 M: f draw-boundary 2drop ;
  79
  80 ! Solid fill/border
  81 TUPLE: solid color ;
  82
  83 ! Solid pen
  84 : (solid)
  85     solid-color gl-color rect-dim >r origin get dup r> v+ ;
  86
  87 M: solid draw-interior (solid) gl-fill-rect ;
  88
  89 M: solid draw-boundary (solid) gl-rect ;
  90
  91 ! Gradient pen
  92 TUPLE: gradient colors ;
  93
  94 M: gradient draw-interior
  95     origin get [
  96         over gadget-orientation
  97         swap gradient-colors
  98         rot rect-dim
  99         gl-gradient
 100     ] with-translation ;
 101
 102 ! Polygon pen
 103 TUPLE: polygon color points ;
 104
 105 : draw-polygon ( polygon quot -- )
 106     origin get [
 107         >r dup polygon-color gl-color polygon-points r> call
 108     ] with-translation ; inline
 109
 110 M: polygon draw-boundary
 111     [ gl-poly ] draw-polygon drop ;
 112
 113 M: polygon draw-interior
 114     [ gl-fill-poly ] draw-polygon drop ;
 115
 116 : arrow-up    { { 3 0 } { 6 6 } { 0 6 } } ;
 117 : arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
 118 : arrow-down  { { 0 0 } { 6 0 } { 3 6 } } ;
 119 : arrow-left  { { 0 3 } { 6 0 } { 6 6 } } ;
 120 : close-box   { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } ;
 121
 122 : <polygon-gadget> ( color points -- gadget )
 123     dup max-dim
 124     >r <polygon> <gadget> r> over set-rect-dim
 125     [ set-gadget-interior ] keep ;