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

processing: Update to use 'processing.shapes'

db4
Eduardo Cavazos 2008-07-28 12:54:21 -05:00
parent 4f10ed4aaf
commit ac23f41198
1 changed files with 128 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

274
extra/processing/processing.factor
View File

@ -10,7 +10,8 @@ USING: kernel namespaces threads combinators sequences arrays
combinators.cleave combinators.cleave
rewrite-closures fry accessors newfx rewrite-closures fry accessors newfx
processing.color processing.color
processing.gadget math.geometry.rect ; processing.gadget math.geometry.rect
processing.shapes ;
IN: processing IN: processing
@ -36,53 +37,34 @@ IN: processing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: fill-color ! VAR: fill-color
VAR: stroke-color ! VAR: stroke-color
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: set-color ( value -- ) GENERIC: canonical-color-value ( obj -- color )
METHOD: set-color { number } dup dup glColor3d ; METHOD: canonical-color-value { number } dup dup 1 4array ;
METHOD: set-color { array } METHOD: canonical-color-value { array }
dup length dup length
{ {
{ 2 [ first2 >r dup dup r> glColor4d ] } { 2 [ first2 >r dup dup r> 4array ] }
{ 3 [ first3 glColor3d ] } { 3 [ 1 suffix ] }
{ 4 [ first4 glColor4d ] } { 4 [ ] }
} }
case ; case ;
METHOD: set-color { rgba } METHOD: canonical-color-value { rgba }
{ [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ; { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fill ( value -- ) >fill-color ; : fill ( value -- ) canonical-color-value >fill-color ;
: stroke ( value -- ) >stroke-color ; : stroke ( value -- ) canonical-color-value >stroke-color ;
: no-fill ( -- ) : no-fill ( -- ) 0 fill-color> set-fourth ;
fill-color> : no-stroke ( -- ) 0 stroke-color> set-fourth ;
{
{ [ dup number? ] [ 0 2array fill ] }
{ [ t ]
[
[ drop 0 ] [ length 1- ] [ ] tri set-nth
] }
}
cond ;
: no-stroke ( -- )
stroke-color>
{
{ [ dup number? ] [ 0 2array stroke ] }
{ [ t ]
[
[ drop 0 ] [ length 1- ] [ ] tri set-nth
] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -90,163 +72,163 @@ METHOD: set-color { rgba }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: point* ( x y -- ) ! : point* ( x y -- )
stroke-color> set-color ! stroke-color> set-color
GL_POINTS glBegin ! GL_POINTS glBegin
glVertex2d ! glVertex2d
glEnd ; ! glEnd ;
: point ( seq -- ) first2 point* ; ! : point ( seq -- ) first2 point* ;
: line ( x1 y1 x2 y2 -- ) ! : line ( x1 y1 x2 y2 -- )
stroke-color> set-color ! stroke-color> set-color
GL_LINES glBegin ! GL_LINES glBegin
glVertex2d ! glVertex2d
glVertex2d ! glVertex2d
glEnd ; ! glEnd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: triangle ( x1 y1 x2 y2 x3 y3 -- ) ! : triangle ( x1 y1 x2 y2 x3 y3 -- )
GL_FRONT_AND_BACK GL_FILL glPolygonMode ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
fill-color> set-color ! fill-color> set-color
6 ndup ! 6 ndup
GL_TRIANGLES glBegin ! GL_TRIANGLES glBegin
glVertex2d ! glVertex2d
glVertex2d ! glVertex2d
glVertex2d ! glVertex2d
glEnd ! glEnd
GL_FRONT_AND_BACK GL_LINE glPolygonMode ! GL_FRONT_AND_BACK GL_LINE glPolygonMode
stroke-color> set-color ! stroke-color> set-color
GL_TRIANGLES glBegin ! GL_TRIANGLES glBegin
glVertex2d ! glVertex2d
glVertex2d ! glVertex2d
glVertex2d ! glVertex2d
glEnd ; ! glEnd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) ! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
GL_POLYGON glBegin ! GL_POLYGON glBegin
glVertex2d ! glVertex2d
glVertex2d ! glVertex2d
glVertex2d ! glVertex2d
glVertex2d ! glVertex2d
glEnd ; ! glEnd ;
: quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) ! : quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
8 ndup ! 8 ndup
GL_FRONT_AND_BACK GL_FILL glPolygonMode ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
fill-color> set-color ! fill-color> set-color
quad-vertices ! quad-vertices
GL_FRONT_AND_BACK GL_LINE glPolygonMode ! GL_FRONT_AND_BACK GL_LINE glPolygonMode
stroke-color> set-color ! stroke-color> set-color
quad-vertices ; ! quad-vertices ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rect-vertices ( x y width height -- ) ! : rect-vertices ( x y width height -- )
GL_POLYGON glBegin ! GL_POLYGON glBegin
[ 2drop glVertex2d ] 4keep ! [ 2drop glVertex2d ] 4keep
[ drop swap >r + 1- r> glVertex2d ] 4keep ! [ drop swap >r + 1- r> glVertex2d ] 4keep
[ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep ! [ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep
[ nip + 1- glVertex2d ] 4keep ! [ nip + 1- glVertex2d ] 4keep
4drop ! 4drop
glEnd ; ! glEnd ;
: rect ( x y width height -- ) ! : rect ( x y width height -- )
4dup ! 4dup
GL_FRONT_AND_BACK GL_FILL glPolygonMode ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
fill-color> set-color ! fill-color> set-color
rect-vertices ! rect-vertices
GL_FRONT_AND_BACK GL_LINE glPolygonMode ! GL_FRONT_AND_BACK GL_LINE glPolygonMode
stroke-color> set-color ! stroke-color> set-color
rect-vertices ; ! rect-vertices ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ellipse-disk ( x y width height -- ) ! : ellipse-disk ( x y width height -- )
glPushMatrix ! glPushMatrix
>r >r ! >r >r
0 glTranslated ! 0 glTranslated
r> r> 1 glScaled ! r> r> 1 glScaled
gluNewQuadric ! gluNewQuadric
dup 0 0.5 20 1 gluDisk ! dup 0 0.5 20 1 gluDisk
gluDeleteQuadric ! gluDeleteQuadric
glPopMatrix ; ! glPopMatrix ;
: ellipse-center ( x y width height -- ) ! : ellipse-center ( x y width height -- )
4dup ! 4dup
GL_FRONT_AND_BACK GL_FILL glPolygonMode ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
stroke-color> set-color ! stroke-color> set-color
ellipse-disk ! ellipse-disk
GL_FRONT_AND_BACK GL_FILL glPolygonMode ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
fill-color> set-color ! fill-color> set-color
[ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@ ! [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
ellipse-disk ; ! ellipse-disk ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: CENTER ! SYMBOL: CENTER
SYMBOL: RADIUS ! SYMBOL: RADIUS
SYMBOL: CORNER ! SYMBOL: CORNER
SYMBOL: CORNERS ! SYMBOL: CORNERS
SYMBOL: ellipse-mode-value ! SYMBOL: ellipse-mode-value
: ellipse-mode ( val -- ) ellipse-mode-value set ; ! : ellipse-mode ( val -- ) ellipse-mode-value set ;
: ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ; ! : ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
: ellipse-corner ( x y width height -- ) ! : ellipse-corner ( x y width height -- )
[ drop nip 2 / + ] 4keep ! [ drop nip 2 / + ] 4keep
[ nip rot drop 2 / + ] 4keep ! [ nip rot drop 2 / + ] 4keep
[ >r >r 2drop r> r> ] 4keep ! [ >r >r 2drop r> r> ] 4keep
4drop ! 4drop
ellipse-center ; ! ellipse-center ;
: ellipse-corners ( x1 y1 x2 y2 -- ) ! : ellipse-corners ( x1 y1 x2 y2 -- )
[ drop nip + 2 / ] 4keep ! [ drop nip + 2 / ] 4keep
[ nip rot drop + 2 / ] 4keep ! [ nip rot drop + 2 / ] 4keep
[ drop nip - abs 1+ ] 4keep ! [ drop nip - abs 1+ ] 4keep
[ nip rot drop - abs 1+ ] 4keep ! [ nip rot drop - abs 1+ ] 4keep
4drop ! 4drop
ellipse-center ; ! ellipse-center ;
: ellipse ( a b c d -- ) ! : ellipse ( a b c d -- )
ellipse-mode-value get ! ellipse-mode-value get
{ ! {
{ CENTER [ ellipse-center ] } ! { CENTER [ ellipse-center ] }
{ RADIUS [ ellipse-radius ] } ! { RADIUS [ ellipse-radius ] }
{ CORNER [ ellipse-corner ] } ! { CORNER [ ellipse-corner ] }
{ CORNERS [ ellipse-corners ] } ! { CORNERS [ ellipse-corners ] }
} ! }
case ; ! case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ; ! : circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -279,8 +261,8 @@ METHOD: background { array }
: mouse ( -- point ) hand-loc get ; : mouse ( -- point ) hand-loc get ;
: mouse-x mouse first ; : mouse-x ( -- x ) mouse first ;
: mouse-y mouse second ; : mouse-y ( -- y ) mouse second ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -296,9 +278,9 @@ VAR: loop-flag
: defaults ( -- ) : defaults ( -- )
0.8 background 0.8 background
0 >stroke-color ! 0 >stroke-color
1 >fill-color ! 1 >fill-color
CENTER ellipse-mode ! CENTER ellipse-mode
60 frame-rate ; 60 frame-rate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!