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-translationdb4
Slava Pestov
parent
eabba96627
commit
f0c61b9499
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 % ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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 } } ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue