Rewrite OpenGL rendering code

- Don't use glPolygonMode to draw outline rectangles
- Use vertex arrays instead of glBegin/glVertex/glEnd
- Remove dead code from opengl vocabulary
- draw-interior and draw-boundary are now called with origin get [ ... ] with-translation

basis/opengl/opengl-docs.factor

@@ -9,14 +9,6 @@ HELP: gl-color
 HELP: gl-error
 { $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ;
 
-HELP: do-state
-  {
-    $values
-      { "mode" { "One of the " { $link "opengl-geometric-primitives" } } }
-      { "quot" quotation }
-  }
-{ $description "Wraps a quotation in " { $link glBegin } "/" { $link glEnd } " calls." } ;
-
 HELP: do-enabled
 { $values { "what" integer } { "quot" quotation } }
 { $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ;
@@ -25,10 +17,6 @@ HELP: do-matrix
 { $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } }
 { $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ;
 
-HELP: gl-vertex
-{ $values { "point" "a pair of integers" } }
-{ $description "Wrapper for " { $link glVertex2d } " taking a point object." } ;
-
 HELP: gl-line
 { $values { "a" "a pair of integers" } { "b" "a pair of integers" } }
 { $description "Draws a line between two points." } ;
@@ -41,22 +29,6 @@ HELP: gl-rect
 { $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
 { $description "Draws the outline of a rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ;
 
-HELP: rect-vertices
-{ $values { "lower-left" "A pair of numbers indicating the lower-left coordinates of the rectangle." } { "upper-right" "The upper-right coordinates of the rectangle." } }
-{ $description "Emits" { $link glVertex2d } " calls outlining the axis-aligned rectangle from " { $snippet "lower-left" } " to " { $snippet "upper-right" } " on the z=0 plane in counterclockwise order." } ;
-
-HELP: gl-fill-poly
-{ $values { "points" "a sequence of pairs of integers" } }
-{ $description "Draws a filled polygon." } ;
-
-HELP: gl-poly
-{ $values { "points" "a sequence of pairs of integers" } }
-{ $description "Draws the outline of a polygon." } ;
-
-HELP: gl-gradient
-{ $values { "direction" "an orientation specifier" } { "colors" "a sequence of color specifiers" } { "dim" "a pair of integers" } }
-{ $description "Draws a rectangle with top-left corner " { $snippet "{ 0 0 }" } " and dimensions " { $snippet "dim" } ", filled with a smoothly shaded transition between the colors in " { $snippet "colors" } "." } ;
-
 HELP: gen-texture
 { $values { "id" integer } }
 { $description "Wrapper for " { $link glGenTextures } " to handle the common case of generating a single texture ID." } ;
@@ -131,12 +103,10 @@ $nl
 { $subsection "opengl-low-level" }
 "Wrappers:"
 { $subsection gl-color }
-{ $subsection gl-vertex }
 { $subsection gl-translate }
 { $subsection gen-texture }
 { $subsection bind-texture-unit }
 "Combinators:"
-{ $subsection do-state }
 { $subsection do-enabled }
 { $subsection do-attribs }
 { $subsection do-matrix }
@@ -146,9 +116,6 @@ $nl
 { $subsection gl-line }
 { $subsection gl-fill-rect }
 { $subsection gl-rect }
-{ $subsection gl-fill-poly }
-{ $subsection gl-poly }
-{ $subsection gl-gradient }
 ;
 
 ABOUT: "gl-utilities"

basis/opengl/opengl.factor

@@ -2,44 +2,31 @@
 ! Portions copyright (C) 2007 Eduardo Cavazos.
 ! Portions copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-
 USING: alien alien.c-types continuations kernel libc math macros
 namespaces math.vectors math.constants math.functions
 math.parser opengl.gl opengl.glu combinators arrays sequences
-       splitting words byte-arrays assocs colors accessors ;
+splitting words byte-arrays assocs colors accessors
-
+generalizations locals memoize ;
 IN: opengl
 
-: coordinates ( point1 point2 -- x1 y2 x2 y2 )
-    [ first2 ] bi@ ;
-
-: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
-    [ first2 [ >fixnum ] bi@ ] bi@ ;
-
 : color>raw ( object -- r g b a )
-    >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
+    >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
 
 : gl-color ( color -- ) color>raw glColor4d ; inline
 
-: gl-clear-color ( color -- )
+: gl-clear-color ( color -- ) color>raw glClearColor ;
-    color>raw glClearColor ;
 
 : gl-clear ( color -- )
     gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
 
-: set-color ( object -- ) color>raw glColor4d ;
-: set-clear-color ( object -- ) color>raw glClearColor ;
-
 : gl-error ( -- )
     glGetError dup zero? [
         "GL error: " over gluErrorString append throw
     ] unless drop ;
 
-: do-state ( mode quot -- )
-    swap glBegin call glEnd ; inline
-
 : do-enabled ( what quot -- )
     over glEnable dip glDisable ; inline
+
 : do-enabled-client-state ( what quot -- )
     over glEnableClientState dip glDisableClientState ; inline
 
@@ -48,6 +35,7 @@ IN: opengl
 
 : (all-enabled) ( seq quot -- )
     over [ glEnable ] each dip [ glDisable ] each ; inline
+
 : (all-enabled-client-state) ( seq quot -- )
     [ dup [ glEnableClientState ] each ] dip
     dip
@@ -55,6 +43,7 @@ IN: opengl
 
 MACRO: all-enabled ( seq quot -- )
     >r words>values r> [ (all-enabled) ] 2curry ;
+
 MACRO: all-enabled-client-state ( seq quot -- )
     >r words>values r> [ (all-enabled-client-state) ] 2curry ;
 
@@ -62,37 +51,46 @@ MACRO: all-enabled-client-state ( seq quot -- )
     swap [ glMatrixMode glPushMatrix call ] keep
     glMatrixMode glPopMatrix ; inline
 
-: gl-vertex ( point -- )
-    dup length {
-        { 2 [ first2 glVertex2d ] }
-        { 3 [ first3 glVertex3d ] }
-        { 4 [ first4 glVertex4d ] }
-    } case ;
-
-: gl-normal ( normal -- ) first3 glNormal3d ;
-
 : gl-material ( face pname params -- )
     >c-float-array glMaterialfv ;
 
+: gl-vertex-pointer ( seq -- )
+    [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
+
+: gl-color-pointer ( seq -- )
+    [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline
+
+: gl-texture-coord-pointer ( seq -- )
+    [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
+
+: line-vertices ( a b -- )
+    append >c-float-array gl-vertex-pointer ;
+
 : gl-line ( a b -- )
-    GL_LINES [ gl-vertex gl-vertex ] do-state ;
+    line-vertices GL_LINES 0 2 glDrawArrays ;
 
-: gl-fill-rect ( loc ext -- )
+: (rectangle-vertices) ( dim -- vertices )
-    coordinates glRectd ;
+    {
+        [ drop 0 0 ]
+        [ first 0 ]
+        [ first2 ]
+        [ second 0 swap ]
+    } cleave 8 narray >c-float-array ;
 
-: gl-rect ( loc ext -- )
+: rectangle-vertices ( dim -- )
-    GL_FRONT_AND_BACK GL_LINE glPolygonMode
+    (rectangle-vertices) gl-vertex-pointer ;
-    >r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
-    GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
 
-: (gl-poly) ( points state -- )
+: (gl-rect) ( -- )
-    [ [ gl-vertex ] each ] do-state ;
+    GL_LINE_LOOP 0 4 glDrawArrays ;
 
-: gl-fill-poly ( points -- )
+: gl-rect ( dim -- )
-    dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
+    rectangle-vertices (gl-rect) ;
 
-: gl-poly ( points -- )
+: (gl-fill-rect) ( -- )
-    GL_LINE_LOOP (gl-poly) ;
+    GL_QUADS 0 4 glDrawArrays ;
+
+: gl-fill-rect ( dim -- )
+    rectangle-vertices (gl-fill-rect) ;
 
 : circle-steps ( steps -- angles )
     dup length v/n 2 pi * v*n ;
@@ -109,35 +107,24 @@ MACRO: all-enabled-client-state ( seq quot -- )
 : circle-points ( loc dim steps -- points )
     circle-steps unit-circle adjust-points scale-points ;
 
-: gl-circle ( loc dim steps -- )
+: circle-vertices ( loc dim steps -- vertices )
-    circle-points gl-poly ;
+    circle-points concat >c-float-array ;
-
-: gl-fill-circle ( loc dim steps -- )
-    circle-points gl-fill-poly ;
-
-: prepare-gradient ( direction dim -- v1 v2 )
-    tuck v* [ v- ] keep ;
-
-: gl-gradient ( direction colors dim -- )
-    GL_QUAD_STRIP [
-        swap >r prepare-gradient r>
-        [ length dup 1- v/n ] keep [
-            >r >r 2dup r> r> set-color v*n
-            dup gl-vertex v+ gl-vertex
-        ] 2each 2drop
-    ] do-state ;
 
 : (gen-gl-object) ( quot -- id )
     >r 1 0 <uint> r> keep *uint ; inline
+
 : gen-texture ( -- id )
     [ glGenTextures ] (gen-gl-object) ;
+
 : gen-gl-buffer ( -- id )
     [ glGenBuffers ] (gen-gl-object) ;
 
 : (delete-gl-object) ( id quot -- )
     >r 1 swap <uint> r> call ; inline
+
 : delete-texture ( id -- )
     [ glDeleteTextures ] (delete-gl-object) ;
+
 : delete-gl-buffer ( id -- )
     [ glDeleteBuffers ] (delete-gl-object) ;
 
@@ -205,35 +192,21 @@ TUPLE: sprite loc dim dim2 dlist texture ;
 
 : gl-translate ( point -- ) first2 0.0 glTranslated ;
 
-<PRIVATE
+MEMO: (rect-texture-coords) ( -- seq )
+    { 0 0 1 0 1 1 0 1 } >c-float-array ;
 
-: top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
+: rect-texture-coords ( -- )
-
+    (rect-texture-coords) gl-texture-coord-pointer ;
-: top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
-
-: bottom-left 0 1 glTexCoord2i second 0.0 swap glVertex2d ; inline
-
-: bottom-right 1 1 glTexCoord2i gl-vertex ; inline
-
-PRIVATE>
-
-: four-sides ( dim -- )
-    dup top-left dup top-right dup bottom-right bottom-left ;
 
 : draw-sprite ( sprite -- )
+    GL_TEXTURE_COORD_ARRAY [
         dup loc>> gl-translate
         GL_TEXTURE_2D over texture>> glBindTexture
-    init-texture
+        init-texture rect-texture-coords
-    GL_QUADS [ dim2>> four-sides ] do-state
+        dim2>> rectangle-vertices
-    GL_TEXTURE_2D 0 glBindTexture ;
+        (gl-fill-rect)
-
+        GL_TEXTURE_2D 0 glBindTexture
-: rect-vertices ( lower-left upper-right -- )
+    ] do-enabled-client-state ;
-    GL_QUADS [
-        over first2 glVertex2d
-        dup first pick second glVertex2d
-        dup first2 glVertex2d
-        swap first swap second glVertex2d
-    ] do-state ;
 
 : make-sprite-dlist ( sprite -- id )
     GL_MODELVIEW [
@@ -256,6 +229,9 @@ PRIVATE>
 : with-translation ( loc quot -- )
     GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline
 
+: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
+    [ first2 [ >fixnum ] bi@ ] bi@ ;
+
 : gl-set-clip ( loc dim -- )
     fix-coordinates glScissor ;
 

basis/ui/gadgets/buttons/buttons.factor

@@ -2,11 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel math models namespaces sequences
 strings quotations assocs combinators classes colors
-       classes.tuple opengl math.vectors
+classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
-       ui.commands ui.gadgets ui.gadgets.borders
+ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
-       ui.gadgets.labels ui.gadgets.theme
 ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
-       ui.render math.geometry.rect ;
+ui.render math.geometry.rect locals alien.c-types ;
 
 IN: ui.gadgets.buttons
 
@@ -62,10 +61,10 @@ C: <button-paint> button-paint
     } cond ;
 
 M: button-paint draw-interior
-    button-paint draw-interior ;
+    button-paint dup [ draw-interior ] [ 2drop ] if ;
 
 M: button-paint draw-boundary
-    button-paint draw-boundary ;
+    button-paint dup [ draw-boundary ] [ 2drop ] if ;
 
 : align-left ( button -- button )
     { 0 1/2 } >>align ; inline
@@ -103,17 +102,34 @@ repeat-button H{
     #! the mouse is held down.
     repeat-button new-button bevel-button-theme ;
 
-TUPLE: checkmark-paint color ;
+TUPLE: checkmark-paint < caching-pen color last-vertices ;
 
-C: <checkmark-paint> checkmark-paint
+: <checkmark-paint> ( color -- paint )
+    checkmark-paint new swap >>color ;
+
+<PRIVATE
+
+: checkmark-points ( dim -- points )
+    {
+        [ { 0 0 } v* ]
+        [ { 1 1 } v* ]
+        [ { 0 1 } v* ]
+        [ { 1 0 } v* ]
+    } cleave 4array ;
+
+: checkmark-vertices ( dim -- vertices )
+    checkmark-points concat >c-float-array ;
+
+PRIVATE>
+
+M: checkmark-paint recompute-pen
+    swap dim>> checkmark-vertices >>last-vertices drop ;
 
 M: checkmark-paint draw-interior
-    color>> set-color
+    [ compute-pen ]
-    origin get [
+    [ color>> gl-color ]
-        rect-dim
+    [ last-vertices>> gl-vertex-pointer ] tri
-        { 0 0 } over gl-line
+    GL_LINES 0 4 glDrawArrays ;
-        dup { 0 1 } v* swap { 1 0 } v* gl-line
-    ] with-translation ;
 
 : checkmark-theme ( gadget -- gadget )
     f
@@ -148,30 +164,47 @@ TUPLE: checkbox < button ;
 M: checkbox model-changed
     swap value>> >>selected? relayout-1 ;
 
-TUPLE: radio-paint color ;
+TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ;
 
-C: <radio-paint> radio-paint
+: <radio-paint> ( color -- paint ) radio-paint new swap >>color ;
+
+<PRIVATE
+
+: circle-steps 12 ;
+
+PRIVATE>
+
+M: radio-paint recompute-pen
+    swap dim>>
+    [ { 4 4 } swap { 8 8 } v- 12 circle-vertices >>interior-vertices ]
+    [ { 1 1 } swap { 2 2 } v- 12 circle-vertices >>boundary-vertices ] bi
+    drop ;
+
+<PRIVATE
+
+: (radio-paint) ( gadget paint -- )
+    [ compute-pen ] [ color>> gl-color ] bi ;
+
+PRIVATE>
 
 M: radio-paint draw-interior
-    color>> set-color
+    [ (radio-paint) ] [ interior-vertices>> gl-vertex-pointer ] bi
-    origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
+    GL_POLYGON 0 circle-steps glDrawArrays ;
 
 M: radio-paint draw-boundary
-    color>> set-color
+    [ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
-    origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
+    GL_LINE_LOOP 0 circle-steps glDrawArrays ;
 
-: radio-knob-theme ( gadget -- gadget )
+:: radio-knob-theme ( gadget -- gadget )
-    f
+    [let | radio-paint [ black <radio-paint> ] |
-    f
+        gadget
-    black <radio-paint>
+        f f radio-paint radio-paint <button-paint> >>interior
-    black <radio-paint>
+        radio-paint >>boundary
-    <button-paint> >>interior
+        { 16 16 } >>dim
-    black <radio-paint> >>boundary ;
+    ] ;
 
 : <radio-knob> ( -- gadget )
-    <gadget>
+    <gadget> radio-knob-theme ;
-    radio-knob-theme
-    { 16 16 } >>dim ;
 
 TUPLE: radio-control < button value ;
 

basis/ui/gadgets/editors/editors.factor

@@ -127,7 +127,7 @@ M: editor ungraft*
 : draw-caret ( -- )
     editor get focused?>> [
         editor get
-        dup caret-color>> set-color
+        dup caret-color>> gl-color
         dup caret-loc origin get v+
         swap caret-dim over v+
         [ { 0.5 -0.5 } v+ ] bi@ gl-line
@@ -171,7 +171,7 @@ M: editor ungraft*
 
 : draw-lines ( -- )
     \ first-visible-line get [
-        editor get dup color>> set-color
+        editor get dup color>> gl-color
         dup visible-lines
         [ draw-line 1 translate-lines ] with each
     ] with-editor-translation ;
@@ -190,7 +190,7 @@ M: editor ungraft*
     (draw-selection) ;
 
 : draw-selection ( -- )
-    editor get selection-color>> set-color
+    editor get selection-color>> gl-color
     editor get selection-start/end
     over first [
         2dup [

basis/ui/gadgets/grid-lines/grid-lines.factor

@@ -23,13 +23,10 @@ SYMBOL: grid-dim
     ] with each ;
 
 M: grid-lines draw-boundary
-    origin get [
+    color>> gl-color [
-        -0.5 -0.5 0.0 glTranslated
-        color>> set-color [
         dup grid set
         dup rect-dim half-gap v- grid-dim set
         compute-grid
         { 0 1 } draw-grid-lines
         { 1 0 } draw-grid-lines
-        ] with-scope
+    ] with-scope ;
-    ] with-translation ;

basis/ui/gadgets/labelled/labelled.factor

@@ -30,10 +30,10 @@ M: labelled-gadget focusable-child* content>> ;
 
 : title-theme ( gadget -- gadget )
     { 1 0 } >>orientation
-    T{ gradient f {
+    {
         T{ rgba f 0.65 0.65 1.0 1.0 }
         T{ rgba f 0.65 0.45 1.0 1.0 }
-    } } >>interior ;
+    } <gradient> >>interior ;
 
 : <title-label> ( text -- label ) <label> title-theme ;
 

basis/ui/gadgets/labels/labels.factor

@@ -34,7 +34,7 @@ M: label pref-dim*
     [ font>> open-font ] [ text>> ] bi text-dim ;
 
 M: label draw-gadget*
-    [ color>> set-color ]
+    [ color>> gl-color ]
     [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
 
 M: label gadget-text* label-string % ;

basis/ui/gadgets/lists/lists.factor

@@ -56,8 +56,12 @@ M: list model-changed
 
 M: list draw-gadget*
     origin get [
-        dup color>> set-color
+        dup color>> gl-color
-        selected-rect [ rect-extent gl-fill-rect ] when*
+        selected-rect [
+            dup loc>> [
+                dim>> gl-fill-rect
+            ] with-translation
+        ] when*
     ] with-translation ;
 
 M: list focusable-child* drop t ;

basis/ui/gadgets/panes/panes.factor

@@ -63,7 +63,11 @@ GENERIC: draw-selection ( loc obj -- )
     >r clip get over intersects? r> [ drop ] if ; inline
 
 M: gadget draw-selection ( loc gadget -- )
-    swap offset-rect [ rect-extent gl-fill-rect ] if-fits ;
+    swap offset-rect [
+        dup loc>> [
+            dim>> gl-fill-rect
+        ] with-translation
+    ] if-fits ;
 
 M: node draw-selection ( loc node -- )
     2dup value>> swap offset-rect [
@@ -74,7 +78,7 @@ M: node draw-selection ( loc node -- )
 
 M: pane draw-gadget*
     dup gadget-selection? [
-        dup selection-color>> set-color
+        dup selection-color>> gl-color
         origin get over rect-loc v- swap selected-children
         [ draw-selection ] with each
     ] [

basis/ui/gadgets/theme/theme.factor

@@ -17,44 +17,44 @@ IN: ui.gadgets.theme
 
 : selection-color ( -- color ) light-purple ;
 
-: plain-gradient
+: plain-gradient ( -- gradient )
-    T{ gradient f {
+    {
         T{ gray f 0.94 1.0 }
         T{ gray f 0.83 1.0 }
         T{ gray f 0.83 1.0 }
         T{ gray f 0.62 1.0 }
-    } } ;
+    } <gradient> ;
 
-: rollover-gradient
+: rollover-gradient ( -- gradient )
-    T{ gradient f {
+    {
         T{ gray f 1.0  1.0 }
         T{ gray f 0.9  1.0 }
         T{ gray f 0.9  1.0 }
         T{ gray f 0.75 1.0 }
-    } } ;
+    } <gradient> ;
 
-: pressed-gradient
+: pressed-gradient ( -- gradient )
-    T{ gradient f {
+    {
         T{ gray f 0.75 1.0 }
         T{ gray f 0.9  1.0 }
         T{ gray f 0.9  1.0 }
         T{ gray f 1.0  1.0 }
-    } } ;
+    } <gradient> ;
 
-: selected-gradient
+: selected-gradient ( -- gradient )
-    T{ gradient f {
+    {
         T{ gray f 0.65 1.0 }
         T{ gray f 0.8  1.0 }
         T{ gray f 0.8  1.0 }
         T{ gray f 1.0  1.0 }
-    } } ;
+    } <gradient> ;
 
-: lowered-gradient
+: lowered-gradient ( -- gradient )
-    T{ gradient f {
+    {
         T{ gray f 0.37 1.0 }
         T{ gray f 0.43 1.0 }
         T{ gray f 0.5  1.0 }
-    } } ;
+    } <gradient> ;
 
 : sans-serif-font { "sans-serif" plain 12 } ;
 

basis/ui/gadgets/worlds/worlds.factor

@@ -83,6 +83,7 @@ SYMBOL: ui-error-hook
 [ rethrow ] ui-error-hook set-global
 
 : draw-world ( world -- )
+    [
     dup draw-world? [
         dup world [
             [
@@ -94,7 +95,8 @@ SYMBOL: ui-error-hook
         ] with-variable
     ] [
         drop
-    ] if ;
+    ] if USE: prettyprint
+    ] USE: tools.time benchmark global [ "timings" get-global push ] bind ;
 
 world H{
     { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }

basis/ui/render/render.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien arrays hashtables io kernel math namespaces opengl
+USING: accessors alien alien.c-types arrays hashtables io kernel
-opengl.gl opengl.glu sequences strings io.styles vectors
+math namespaces opengl opengl.gl opengl.glu sequences strings
-combinators math.vectors ui.gadgets colors
+io.styles vectors combinators math.vectors ui.gadgets colors
-math.order math.geometry.rect ;
+math.order math.geometry.rect locals ;
 IN: ui.render
 
 SYMBOL: clip
@@ -21,7 +21,7 @@ SYMBOL: viewport-translation
 : init-clip ( clip-rect rect -- )
     GL_SCISSOR_TEST glEnable
     [ rect-intersect ] keep
-    rect-dim dup { 0 1 } v* viewport-translation set
+    dim>> dup { 0 1 } v* viewport-translation set
     { 0 0 } over gl-viewport
     0 swap first2 0 gluOrtho2D
     clip set
@@ -31,12 +31,13 @@ SYMBOL: viewport-translation
     GL_SMOOTH glShadeModel
     GL_BLEND glEnable
     GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
+    GL_VERTEX_ARRAY glEnableClientState
     init-matrices
     init-clip
     ! white gl-clear is broken w.r.t window resizing
     ! Linux/PPC Radeon 9200
-    white set-color
+    white gl-color
-    clip get rect-extent gl-fill-rect ;
+    clip get dim>> gl-fill-rect ;
 
 GENERIC: draw-gadget* ( gadget -- )
 
@@ -60,10 +61,15 @@ DEFER: draw-gadget
 : (draw-gadget) ( gadget -- )
     [
         dup translate
-        dup dup interior>> draw-interior
+        dup interior>> [
+            origin get [ dupd draw-interior ] with-translation
+        ] when*
         dup draw-gadget*
         dup visible-children [ draw-gadget ] each
-        dup boundary>> draw-boundary
+        dup boundary>> [
+            origin get [ dupd draw-boundary ] with-translation
+        ] when*
+        drop
     ] with-scope ;
 
 : >absolute ( rect -- rect )
@@ -84,51 +90,97 @@ DEFER: draw-gadget
         [ [ (draw-gadget) ] with-clipping ]
     } cond ;
 
-! Pen paint properties
+! A pen that caches vertex arrays, etc
-M: f draw-interior 2drop ;
+TUPLE: caching-pen last-dim ;
-M: f draw-boundary 2drop ;
+
+GENERIC: recompute-pen ( gadget pen -- )
+
+: compute-pen ( gadget pen -- )
+    2dup [ dim>> ] [ last-dim>> ] bi* = [
+        2drop
+    ] [
+        [ swap dim>> >>last-dim drop ] [ recompute-pen ] 2bi
+    ] if ;
 
 ! Solid fill/border
-TUPLE: solid color ;
+TUPLE: solid < caching-pen color last-vertices ;
 
-C: <solid> solid
+: <solid> ( color -- solid ) solid new swap >>color ;
+
+M: solid recompute-pen
+    swap dim>> (rectangle-vertices) >>last-vertices drop ;
+
+<PRIVATE
 
 ! Solid pen
-: (solid) ( gadget paint -- loc dim )
+: (solid) ( gadget pen -- )
-    color>> set-color rect-dim >r origin get dup r> v+ ;
+    [ compute-pen ]
+    [ color>> gl-color ]
+    [ last-vertices>> gl-vertex-pointer ] tri ;
 
-M: solid draw-interior (solid) gl-fill-rect ;
+PRIVATE>
 
-M: solid draw-boundary (solid) gl-rect ;
+M: solid draw-interior (solid) (gl-fill-rect) ;
+
+M: solid draw-boundary (solid) (gl-rect) ;
 
 ! Gradient pen
-TUPLE: gradient colors ;
+TUPLE: gradient < caching-pen colors last-vertices last-colors ;
 
-C: <gradient> gradient
+: <gradient> ( colors -- gradient ) gradient new swap >>colors ;
+
+<PRIVATE
+
+:: gradient-vertices ( direction dim colors -- seq )
+    direction dim v* dim over v- swap
+    colors length dup 1- v/n [ v*n ] with map
+    [ dup rot v+ 2array ] with map
+    concat concat >c-float-array ;
+
+: gradient-colors ( colors -- seq )
+    [ color>raw 4array dup 2array ] map concat concat >c-float-array ;
+
+M: gradient recompute-pen ( gadget gradient -- )
+    tuck
+    [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi*
+    [ gradient-vertices >>last-vertices ]
+    [ gradient-colors >>last-colors ] bi
+    drop ;
+
+: draw-gradient ( colors -- )
+    GL_COLOR_ARRAY [
+        [ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
+    ] do-enabled-client-state ;
+
+PRIVATE>
 
 M: gradient draw-interior
-    origin get [
+    {
-        over orientation>>
+        [ compute-pen ]
-        swap colors>>
+        [ last-vertices>> gl-vertex-pointer ]
-        rot rect-dim
+        [ last-colors>> gl-color-pointer ]
-        gl-gradient
+        [ colors>> draw-gradient ]
-    ] with-translation ;
+    } cleave ;
 
 ! Polygon pen
-TUPLE: polygon color points ;
+TUPLE: polygon color vertex-array count ;
 
-C: <polygon> polygon
+: <polygon> ( color points -- polygon )
+    [ concat >c-float-array ] [ length ] bi polygon boa ;
 
-: draw-polygon ( polygon quot -- )
+: draw-polygon ( polygon mode -- )
-    origin get [
+    swap
-        >r dup color>> set-color points>> r> call
+    [ color>> gl-color ]
-    ] with-translation ; inline
+    [ vertex-array>> gl-vertex-pointer ]
+    [ 0 swap count>> glDrawArrays ]
+    tri ;
 
 M: polygon draw-boundary
-    [ gl-poly ] draw-polygon drop ;
+    GL_LINE_LOOP draw-polygon drop ;
 
 M: polygon draw-interior
-    [ gl-fill-poly ] draw-polygon drop ;
+    dup count>> 2 > GL_POLYGON GL_LINES ?
+    draw-polygon drop ;
 
 : arrow-up    { { 3 0 } { 6 6 } { 0 6 } } ;
 : arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;