extra/processing/shapes/shapes.factor

   1
   2 USING: alien.c-types alien.data arrays colors grouping kernel
   3 locals math math.vectors namespaces opengl opengl.gl opengl.glu
   4 sequences sequences.generalizations shuffle ;
   5 IN: processing.shapes
   6
   7 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   8
   9 : do-state ( mode quot -- ) swap glBegin call glEnd ; inline
  10
  11 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  12
  13 SYMBOL: fill-color
  14 SYMBOL: stroke-color
  15
  16 T{ rgba f 0 0 0 1 } stroke-color set-global
  17 T{ rgba f 1 1 1 1 } fill-color   set-global
  18
  19 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  20
  21 : fill-mode ( -- )
  22   GL_FRONT_AND_BACK GL_FILL glPolygonMode
  23   fill-color get gl-color ;
  24
  25 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  26
  27 : stroke-mode ( -- )
  28   GL_FRONT_AND_BACK GL_LINE glPolygonMode
  29   stroke-color get gl-color ;
  30
  31 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  32
  33 : gl-vertex-2d ( vertex -- ) first2 glVertex2d ;
  34
  35 : gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ;
  36
  37 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  38
  39 : point* ( x y    -- ) stroke-mode GL_POINTS [ glVertex2d     ] do-state ;
  40 : point  ( point  -- ) stroke-mode GL_POINTS [ gl-vertex-2d   ] do-state ;
  41 : points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ;
  42
  43 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  44
  45 : line** ( x y x y -- )
  46   stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
  47
  48 : line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
  49
  50 : lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
  51
  52 : line ( seq -- ) lines ;
  53
  54 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  55
  56 : line-strip ( seq -- ) stroke-mode GL_LINE_STRIP [ gl-vertices-2d ] do-state ;
  57
  58 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  59
  60 : triangles ( seq -- )
  61   [ fill-mode   GL_TRIANGLES [ gl-vertices-2d ] do-state ]
  62   [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;
  63
  64 : triangle ( seq -- ) triangles ;
  65
  66 : triangle* ( a b c -- ) 3array triangles ;
  67
  68 : triangle** ( x y x y x y -- ) 6 narray 2 group triangles ;
  69
  70 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  71
  72 : polygon ( seq -- )
  73   [ fill-mode   GL_POLYGON [ gl-vertices-2d ] do-state ]
  74   [ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ;
  75
  76 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  77
  78 :: rectangle ( loc dim -- )
  79     loc first2 :> ( x y )
  80     dim first2 :> ( dx dy )
  81
  82     x y 2array
  83     x dx + y 2array
  84     x y dy + 2array
  85     x dx + y dy + 2array
  86     4array
  87     polygon ;
  88
  89 : rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ;
  90
  91 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  92
  93 : gl-translate-2d ( pos -- ) first2 0 glTranslated ;
  94
  95 : gl-scale-2d ( xy -- ) first2 1 glScaled ;
  96
  97 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  98
  99 : gl-ellipse ( center dim -- )
 100   glPushMatrix
 101     [ gl-translate-2d ] [ gl-scale-2d ] bi*
 102     gluNewQuadric
 103       dup 0 0.5 20 1 gluDisk
 104     gluDeleteQuadric
 105   glPopMatrix ;
 106
 107 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 108
 109 : gl-get-line-width ( -- width )
 110   GL_LINE_WIDTH 0 double <ref> tuck glGetDoublev double deref ;
 111
 112 : ellipse ( center dim -- )
 113   GL_FRONT_AND_BACK GL_FILL glPolygonMode
 114   [ stroke-color get gl-color                                 gl-ellipse ]
 115   [ fill-color get gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
 116
 117 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 118
 119 : circle ( center size -- ) dup 2array ellipse ;
 120
 121 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 122