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
db4
Slava Pestov 2008-11-11 00:28:37 -06:00
parent eabba96627
commit f0c61b9499
12 changed files with 256 additions and 221 deletions

View File

@ -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"

View File

@ -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 -- )
color>raw glClearColor ;
: gl-clear-color ( color -- ) 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 -- )
coordinates glRectd ;
: (rectangle-vertices) ( dim -- vertices )
{
[ drop 0 0 ]
[ first 0 ]
[ first2 ]
[ second 0 swap ]
} cleave 8 narray >c-float-array ;
: gl-rect ( loc ext -- )
GL_FRONT_AND_BACK GL_LINE glPolygonMode
>r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
: rectangle-vertices ( dim -- )
(rectangle-vertices) gl-vertex-pointer ;
: (gl-poly) ( points state -- )
[ [ gl-vertex ] each ] do-state ;
: (gl-rect) ( -- )
GL_LINE_LOOP 0 4 glDrawArrays ;
: gl-fill-poly ( points -- )
dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
: gl-rect ( dim -- )
rectangle-vertices (gl-rect) ;
: gl-poly ( points -- )
GL_LINE_LOOP (gl-poly) ;
: (gl-fill-rect) ( -- )
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-points gl-poly ;
: 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 ;
: circle-vertices ( loc dim steps -- vertices )
circle-points concat >c-float-array ;
: (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
: 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 ;
: rect-texture-coords ( -- )
(rect-texture-coords) gl-texture-coord-pointer ;
: draw-sprite ( sprite -- )
GL_TEXTURE_COORD_ARRAY [
dup loc>> gl-translate
GL_TEXTURE_2D over texture>> glBindTexture
init-texture
GL_QUADS [ dim2>> four-sides ] do-state
GL_TEXTURE_2D 0 glBindTexture ;
: rect-vertices ( lower-left upper-right -- )
GL_QUADS [
over first2 glVertex2d
dup first pick second glVertex2d
dup first2 glVertex2d
swap first swap second glVertex2d
] do-state ;
init-texture rect-texture-coords
dim2>> rectangle-vertices
(gl-fill-rect)
GL_TEXTURE_2D 0 glBindTexture
] do-enabled-client-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 ;

View File

@ -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
ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme
classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
ui.gadgets.borders 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
origin get [
rect-dim
{ 0 0 } over gl-line
dup { 0 1 } v* swap { 1 0 } v* gl-line
] with-translation ;
[ compute-pen ]
[ color>> gl-color ]
[ last-vertices>> gl-vertex-pointer ] tri
GL_LINES 0 4 glDrawArrays ;
: 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
origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
[ (radio-paint) ] [ interior-vertices>> gl-vertex-pointer ] bi
GL_POLYGON 0 circle-steps glDrawArrays ;
M: radio-paint draw-boundary
color>> set-color
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
[ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
GL_LINE_LOOP 0 circle-steps glDrawArrays ;
: radio-knob-theme ( gadget -- gadget )
f
f
black <radio-paint>
black <radio-paint>
<button-paint> >>interior
black <radio-paint> >>boundary ;
:: radio-knob-theme ( gadget -- gadget )
[let | radio-paint [ black <radio-paint> ] |
gadget
f f radio-paint radio-paint <button-paint> >>interior
radio-paint >>boundary
{ 16 16 } >>dim
] ;
: <radio-knob> ( -- gadget )
<gadget>
radio-knob-theme
{ 16 16 } >>dim ;
<gadget> radio-knob-theme ;
TUPLE: radio-control < button value ;

View File

@ -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 [

View File

@ -23,13 +23,10 @@ SYMBOL: grid-dim
] with each ;
M: grid-lines draw-boundary
origin get [
-0.5 -0.5 0.0 glTranslated
color>> set-color [
color>> gl-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-translation ;
] with-scope ;

View File

@ -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 ;

View File

@ -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 % ;

View File

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

View File

@ -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
] [

View File

@ -17,44 +17,44 @@ IN: ui.gadgets.theme
: selection-color ( -- color ) light-purple ;
: plain-gradient
T{ gradient f {
: plain-gradient ( -- gradient )
{
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
T{ gradient f {
: rollover-gradient ( -- gradient )
{
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
T{ gradient f {
: pressed-gradient ( -- gradient )
{
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
T{ gradient f {
: selected-gradient ( -- gradient )
{
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
T{ gradient f {
: lowered-gradient ( -- gradient )
{
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 } ;

View File

@ -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 ] }

View File

@ -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
opengl.gl opengl.glu sequences strings io.styles vectors
combinators math.vectors ui.gadgets colors
math.order math.geometry.rect ;
USING: accessors alien alien.c-types arrays hashtables io kernel
math namespaces opengl opengl.gl opengl.glu sequences strings
io.styles vectors combinators math.vectors ui.gadgets colors
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
clip get rect-extent gl-fill-rect ;
white gl-color
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
M: f draw-interior 2drop ;
M: f draw-boundary 2drop ;
! A pen that caches vertex arrays, etc
TUPLE: caching-pen last-dim ;
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 )
color>> set-color rect-dim >r origin get dup r> v+ ;
: (solid) ( gadget pen -- )
[ 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>>
swap colors>>
rot rect-dim
gl-gradient
] with-translation ;
{
[ compute-pen ]
[ last-vertices>> gl-vertex-pointer ]
[ last-colors>> gl-color-pointer ]
[ colors>> draw-gradient ]
} 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 -- )
origin get [
>r dup color>> set-color points>> r> call
] with-translation ; inline
: draw-polygon ( polygon mode -- )
swap
[ color>> gl-color ]
[ 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 } } ;