Fix some UI painting bugs
parent
a2a16c1acb
commit
15df9ddddb
|
@ -13,18 +13,14 @@ C: label ( text -- label )
|
||||||
[ set-label-text ] keep
|
[ set-label-text ] keep
|
||||||
dup label-theme ;
|
dup label-theme ;
|
||||||
|
|
||||||
: label-size ( gadget -- dim )
|
M: label pref-dim*
|
||||||
dup label-font lookup-font dup font-height >r
|
dup label-font lookup-font dup font-height >r
|
||||||
swap label-text string-width r> 2array ;
|
swap label-text string-width r> 2array ;
|
||||||
|
|
||||||
M: label pref-dim* label-size ;
|
M: label draw-gadget*
|
||||||
|
|
||||||
: draw-label ( label -- )
|
|
||||||
dup label-color gl-color
|
dup label-color gl-color
|
||||||
dup label-font swap label-text
|
dup label-font swap label-text
|
||||||
origin get draw-string ;
|
origin get draw-string ;
|
||||||
|
|
||||||
M: label draw-gadget* draw-label ;
|
|
||||||
|
|
||||||
: <label-control> ( model -- gadget )
|
: <label-control> ( model -- gadget )
|
||||||
"" <label> [ set-label-text ] <control> ;
|
"" <label> [ set-label-text ] <control> ;
|
||||||
|
|
|
@ -3,18 +3,22 @@
|
||||||
IN: gadgets-outliner
|
IN: gadgets-outliner
|
||||||
USING: arrays gadgets gadgets-borders gadgets-buttons
|
USING: arrays gadgets gadgets-borders gadgets-buttons
|
||||||
gadgets-frames gadgets-grids gadgets-labels gadgets-panes
|
gadgets-frames gadgets-grids gadgets-labels gadgets-panes
|
||||||
gadgets-theme generic io kernel math opengl sequences styles ;
|
gadgets-theme generic io kernel math opengl sequences styles
|
||||||
|
namespaces ;
|
||||||
|
|
||||||
! Vertical line.
|
! Vertical line.
|
||||||
TUPLE: guide color ;
|
TUPLE: guide color ;
|
||||||
|
|
||||||
M: guide draw-interior
|
M: guide draw-interior
|
||||||
guide-color gl-color
|
guide-color gl-color
|
||||||
rect-dim dup { 0.5 0 0 } v* swap { 0.5 1 0 } v* gl-line ;
|
rect-dim dup { 0.5 0 0 } v* origin get v+
|
||||||
|
swap { 0.5 1 0 } v* origin get v+ gl-line ;
|
||||||
|
|
||||||
|
: guide-theme ( gadget -- )
|
||||||
|
T{ guide f { 0.5 0.5 0.5 1.0 } } swap set-gadget-interior ;
|
||||||
|
|
||||||
: <guide-gadget> ( -- gadget )
|
: <guide-gadget> ( -- gadget )
|
||||||
<gadget>
|
<gadget> dup guide-theme ;
|
||||||
T{ guide f { 0.5 0.5 0.5 1.0 } } over set-gadget-interior ;
|
|
||||||
|
|
||||||
! Outliner gadget.
|
! Outliner gadget.
|
||||||
TUPLE: outliner quot ;
|
TUPLE: outliner quot ;
|
||||||
|
|
|
@ -33,7 +33,7 @@ sequences ;
|
||||||
: gl-rect ( loc dim -- )
|
: gl-rect ( loc dim -- )
|
||||||
#! Draws a two-dimensional box.
|
#! Draws a two-dimensional box.
|
||||||
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||||
gl-fill-rect
|
>r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
|
||||||
GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
|
GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
|
||||||
|
|
||||||
: (gl-poly) [ [ gl-vertex ] each ] do-state ;
|
: (gl-poly) [ [ gl-vertex ] each ] do-state ;
|
||||||
|
|
|
@ -38,11 +38,10 @@ DEFER: draw-gadget
|
||||||
: (draw-gadget) ( gadget -- )
|
: (draw-gadget) ( gadget -- )
|
||||||
[
|
[
|
||||||
dup rect-loc translate
|
dup rect-loc translate
|
||||||
! dup dup gadget-interior draw-interior
|
dup dup gadget-interior draw-interior
|
||||||
dup draw-gadget*
|
dup draw-gadget*
|
||||||
dup visible-children [ draw-gadget ] each
|
dup visible-children [ draw-gadget ] each
|
||||||
! dup gadget-boundary draw-boundary
|
dup gadget-boundary draw-boundary
|
||||||
drop
|
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
: change-clip ( gadget -- )
|
: change-clip ( gadget -- )
|
||||||
|
@ -82,7 +81,8 @@ M: f draw-boundary 2drop ;
|
||||||
TUPLE: solid color ;
|
TUPLE: solid color ;
|
||||||
|
|
||||||
! Solid pen
|
! Solid pen
|
||||||
: (solid) solid-color gl-color rect-dim >r origin get r> ;
|
: (solid)
|
||||||
|
solid-color gl-color rect-dim >r origin get dup r> v+ ;
|
||||||
|
|
||||||
M: solid draw-interior (solid) gl-fill-rect ;
|
M: solid draw-interior (solid) gl-fill-rect ;
|
||||||
|
|
||||||
|
@ -103,8 +103,9 @@ M: gradient draw-interior
|
||||||
TUPLE: polygon color points ;
|
TUPLE: polygon color points ;
|
||||||
|
|
||||||
: draw-polygon ( polygon quot -- )
|
: draw-polygon ( polygon quot -- )
|
||||||
>r dup polygon-color gl-color polygon-points r> each ;
|
origin get [
|
||||||
inline
|
>r dup polygon-color gl-color polygon-points r> call
|
||||||
|
] with-translation ; inline
|
||||||
|
|
||||||
M: polygon draw-boundary
|
M: polygon draw-boundary
|
||||||
[ gl-poly ] draw-polygon drop ;
|
[ gl-poly ] draw-polygon drop ;
|
||||||
|
@ -112,12 +113,12 @@ M: polygon draw-boundary
|
||||||
M: polygon draw-interior
|
M: polygon draw-interior
|
||||||
[ gl-fill-poly ] draw-polygon drop ;
|
[ gl-fill-poly ] draw-polygon drop ;
|
||||||
|
|
||||||
: arrow-up { { { 3 0 } { 6 6 } { 0 6 } } } ;
|
: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
|
||||||
: arrow-right { { { 0 0 } { 6 3 } { 0 6 } } } ;
|
: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
|
||||||
: arrow-down { { { 0 0 } { 6 0 } { 3 6 } } } ;
|
: arrow-down { { 0 0 } { 6 0 } { 3 6 } } ;
|
||||||
: arrow-left { { { 0 3 } { 6 0 } { 6 6 } } } ;
|
: arrow-left { { 0 3 } { 6 0 } { 6 6 } } ;
|
||||||
|
|
||||||
: <polygon-gadget> ( color points -- gadget )
|
: <polygon-gadget> ( color points -- gadget )
|
||||||
dup { 0 0 } [ max-dim vmax ] reduce
|
dup max-dim
|
||||||
>r <polygon> <gadget> r> over set-rect-dim
|
>r <polygon> <gadget> r> over set-rect-dim
|
||||||
[ set-gadget-interior ] keep ;
|
[ set-gadget-interior ] keep ;
|
||||||
|
|
|
@ -34,8 +34,10 @@ C: shuffle-gadget ( node -- gadget )
|
||||||
[ 2array ] 2map ;
|
[ 2array ] 2map ;
|
||||||
|
|
||||||
: draw-shuffle ( gadget seq seq -- )
|
: draw-shuffle ( gadget seq seq -- )
|
||||||
|
origin get [
|
||||||
>r >r rect-dim first2 r> r> shuffled-endpoints
|
>r >r rect-dim first2 r> r> shuffled-endpoints
|
||||||
[ first2 gl-line ] each ;
|
[ first2 gl-line ] each
|
||||||
|
] with-translation ;
|
||||||
|
|
||||||
M: shuffle-gadget draw-gadget*
|
M: shuffle-gadget draw-gadget*
|
||||||
{ 0 0 0 1 } gl-color
|
{ 0 0 0 1 } gl-color
|
||||||
|
|
Loading…
Reference in New Issue