2006-03-15 01:20:59 -05:00
|
|
|
! Copyright (C) 2005, 2006 Slava Pestov.
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2006-05-31 18:45:11 -04:00
|
|
|
USING: alien arrays freetype generic hashtables
|
2006-05-15 01:01:47 -04:00
|
|
|
io kernel math namespaces opengl sequences strings
|
2005-10-14 04:05:02 -04:00
|
|
|
styles vectors ;
|
2005-10-13 00:23:17 -04:00
|
|
|
IN: gadgets
|
2005-02-27 03:48:27 -05:00
|
|
|
|
2006-03-15 15:06:36 -05:00
|
|
|
SYMBOL: clip
|
|
|
|
|
2006-03-15 01:20:59 -05:00
|
|
|
: init-gl ( dim -- )
|
|
|
|
GL_PROJECTION glMatrixMode
|
|
|
|
glLoadIdentity
|
|
|
|
GL_MODELVIEW glMatrixMode
|
|
|
|
glLoadIdentity
|
2006-06-23 00:06:53 -04:00
|
|
|
{ 0 0 } over <rect> clip set
|
2006-03-15 01:20:59 -05:00
|
|
|
dup first2 0 0 2swap glViewport
|
2006-03-18 02:37:40 -05:00
|
|
|
0 over first2 0 gluOrtho2D
|
|
|
|
first2 0 0 2swap glScissor
|
2006-03-15 01:20:59 -05:00
|
|
|
GL_SMOOTH glShadeModel
|
|
|
|
GL_BLEND glEnable
|
|
|
|
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
|
2006-06-23 02:25:08 -04:00
|
|
|
GL_SCISSOR_TEST glEnable
|
2006-03-17 19:47:35 -05:00
|
|
|
1.0 1.0 1.0 1.0 glClearColor
|
|
|
|
GL_COLOR_BUFFER_BIT glClear ;
|
2006-03-15 01:20:59 -05:00
|
|
|
|
2005-10-25 21:52:26 -04:00
|
|
|
GENERIC: draw-gadget* ( gadget -- )
|
|
|
|
|
|
|
|
M: gadget draw-gadget* ( gadget -- ) drop ;
|
|
|
|
|
|
|
|
GENERIC: draw-interior ( gadget interior -- )
|
2005-10-27 16:17:50 -04:00
|
|
|
|
2005-10-25 21:52:26 -04:00
|
|
|
GENERIC: draw-boundary ( gadget boundary -- )
|
|
|
|
|
2005-08-24 19:25:12 -04:00
|
|
|
: visible-children ( gadget -- seq ) clip get swap children-on ;
|
2005-02-27 03:48:27 -05:00
|
|
|
|
2005-10-25 21:52:26 -04:00
|
|
|
DEFER: draw-gadget
|
|
|
|
|
2006-06-23 00:06:53 -04:00
|
|
|
: with-translation ( loc quot -- )
|
|
|
|
over translate over gl-translate
|
|
|
|
swap slip
|
|
|
|
vneg dup translate gl-translate ; inline
|
|
|
|
|
2005-10-25 21:52:26 -04:00
|
|
|
: (draw-gadget) ( gadget -- )
|
2006-06-23 00:06:53 -04:00
|
|
|
dup rect-loc [
|
2005-10-28 15:37:28 -04:00
|
|
|
dup dup gadget-interior draw-interior
|
2006-06-23 00:06:53 -04:00
|
|
|
dup draw-gadget*
|
2006-06-29 01:54:11 -04:00
|
|
|
dup visible-children [ draw-gadget ] each
|
|
|
|
dup gadget-boundary draw-boundary
|
2006-06-23 00:06:53 -04:00
|
|
|
] with-translation ;
|
2005-07-13 21:03:34 -04:00
|
|
|
|
2006-06-23 02:25:08 -04:00
|
|
|
: change-clip ( gadget -- )
|
|
|
|
>absolute clip [ rect-intersect ] change ;
|
|
|
|
|
|
|
|
: clip-x/y ( loc dim -- x y )
|
|
|
|
>r [ first ] keep r>
|
|
|
|
[ second ] 2apply + world get rect-dim second swap - ;
|
|
|
|
|
2006-03-14 01:22:33 -05:00
|
|
|
: gl-set-clip ( loc dim -- )
|
2006-06-29 01:54:11 -04:00
|
|
|
[ clip-x/y ] keep first2 glScissor ;
|
2006-06-23 02:25:08 -04:00
|
|
|
|
|
|
|
: do-clip ( -- ) clip get rect-bounds gl-set-clip ;
|
2006-03-14 01:22:33 -05:00
|
|
|
|
2006-06-23 02:25:08 -04:00
|
|
|
: with-clipping ( gadget quot -- )
|
|
|
|
clip get >r
|
|
|
|
over change-clip do-clip call
|
|
|
|
r> clip set do-clip ; inline
|
2005-10-13 00:23:17 -04:00
|
|
|
|
2005-02-27 03:48:27 -05:00
|
|
|
: draw-gadget ( gadget -- )
|
2006-06-25 18:21:18 -04:00
|
|
|
{
|
|
|
|
{ [ dup gadget-visible? not ] [ drop ] }
|
|
|
|
{ [ dup gadget-clipped? not ] [ (draw-gadget) ] }
|
|
|
|
{ [ t ] [ [ (draw-gadget) ] with-clipping ] }
|
|
|
|
} cond ;
|
2005-07-13 21:03:34 -04:00
|
|
|
|
2006-03-18 01:57:57 -05:00
|
|
|
: draw-world ( world -- )
|
|
|
|
[
|
2006-06-23 02:25:08 -04:00
|
|
|
dup world-handle [
|
|
|
|
dup rect-dim init-gl
|
|
|
|
dup world set
|
|
|
|
draw-gadget
|
|
|
|
] with-gl-context
|
|
|
|
] with-scope ;
|
2006-03-18 01:57:57 -05:00
|
|
|
|
2005-07-18 18:14:13 -04:00
|
|
|
! Pen paint properties
|
2005-07-17 02:49:07 -04:00
|
|
|
M: f draw-interior 2drop ;
|
|
|
|
M: f draw-boundary 2drop ;
|
|
|
|
|
2005-08-26 00:55:56 -04:00
|
|
|
! Solid fill/border
|
2005-10-27 16:17:50 -04:00
|
|
|
TUPLE: solid color ;
|
2005-07-17 03:47:14 -04:00
|
|
|
|
2005-07-18 18:14:13 -04:00
|
|
|
! Solid pen
|
2005-07-17 02:49:07 -04:00
|
|
|
M: solid draw-interior
|
2005-10-27 16:17:50 -04:00
|
|
|
solid-color gl-color rect-dim gl-fill-rect ;
|
2005-07-17 02:49:07 -04:00
|
|
|
|
|
|
|
M: solid draw-boundary
|
2005-10-27 16:17:50 -04:00
|
|
|
solid-color gl-color rect-dim gl-rect ;
|
2005-08-26 00:55:56 -04:00
|
|
|
|
2005-07-18 18:14:13 -04:00
|
|
|
! Gradient pen
|
2005-10-24 00:08:09 -04:00
|
|
|
TUPLE: gradient colors ;
|
2005-07-17 03:47:14 -04:00
|
|
|
|
|
|
|
M: gradient draw-interior ( gadget gradient -- )
|
2005-10-24 00:08:09 -04:00
|
|
|
over gadget-orientation swap gradient-colors rot rect-dim
|
2005-10-13 00:23:17 -04:00
|
|
|
gl-gradient ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
2005-09-27 00:24:42 -04:00
|
|
|
! Polygon pen
|
2005-10-27 16:17:50 -04:00
|
|
|
TUPLE: polygon color points ;
|
|
|
|
|
|
|
|
: draw-polygon ( polygon quot -- )
|
|
|
|
>r dup polygon-color gl-color polygon-points r> each ; inline
|
2005-09-27 00:24:42 -04:00
|
|
|
|
|
|
|
M: polygon draw-boundary ( gadget polygon -- )
|
2005-10-27 16:17:50 -04:00
|
|
|
[ gl-poly ] draw-polygon drop ;
|
2005-09-27 00:24:42 -04:00
|
|
|
|
|
|
|
M: polygon draw-interior ( gadget polygon -- )
|
2005-10-27 16:17:50 -04:00
|
|
|
[ gl-fill-poly ] draw-polygon drop ;
|
2005-09-27 00:24:42 -04:00
|
|
|
|
2006-06-23 00:06:53 -04:00
|
|
|
: arrow-up { { { 3 0 } { 6 6 } { 0 6 } } } ;
|
|
|
|
: arrow-right { { { 0 0 } { 6 3 } { 0 6 } } } ;
|
|
|
|
: arrow-down { { { 0 0 } { 6 0 } { 3 6 } } } ;
|
|
|
|
: arrow-left { { { 0 3 } { 6 0 } { 6 6 } } } ;
|
2006-05-20 16:42:33 -04:00
|
|
|
: close-box
|
|
|
|
{
|
2006-06-23 00:06:53 -04:00
|
|
|
{ { 0 0 } { 6 6 } }
|
|
|
|
{ { 0 6 } { 6 0 } }
|
2006-05-20 16:42:33 -04:00
|
|
|
} ;
|
2005-09-27 00:24:42 -04:00
|
|
|
|
2005-10-27 16:17:50 -04:00
|
|
|
: <polygon-gadget> ( color points -- gadget )
|
2006-06-23 00:06:53 -04:00
|
|
|
dup { 0 0 } [ max-dim vmax ] reduce
|
2005-09-28 23:29:00 -04:00
|
|
|
>r <polygon> <gadget> r> over set-rect-dim
|
2005-10-27 16:17:50 -04:00
|
|
|
[ set-gadget-interior ] keep ;
|