processing: Update to use 'processing.shapes'

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