steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

33
basis/opengl/opengl-docs.factor
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"

146
basis/opengl/opengl.factor
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 ;
namespaces math.vectors math.constants math.functions
math.parser opengl.gl opengl.glu combinators arrays sequences
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 -- )
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 ;
GL_TEXTURE_COORD_ARRAY [
dup loc>> gl-translate
GL_TEXTURE_2D over texture>> glBindTexture
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 ;

97
basis/ui/gadgets/buttons/buttons.factor
View File

@ -1,12 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! 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
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render math.geometry.rect ;
strings quotations assocs combinators classes colors
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 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 ;

6
basis/ui/gadgets/editors/editors.factor
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 [

17
basis/ui/gadgets/grid-lines/grid-lines.factor
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 [
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 ;
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 ;

4
basis/ui/gadgets/labelled/labelled.factor
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 ;

2
basis/ui/gadgets/labels/labels.factor
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 % ;

8
basis/ui/gadgets/lists/lists.factor
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 ;

8
basis/ui/gadgets/panes/panes.factor
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
] [

30
basis/ui/gadgets/theme/theme.factor
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 } ;

4
basis/ui/gadgets/worlds/worlds.factor
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 ] }

122
basis/ui/render/render.factor
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 } } ;