examples/canvas.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 ! This example only runs in the UI listener.
   5
   6 ! Pass with-canvas a quotation calling these words:
   7 ! - turn-by
   8 ! - move-by
   9 ! - plot-point
  10 ! - line-to
  11 ! - new-pen
  12
  13 ! plot-string doesn't yet work.
  14
  15 ! other GL calls can be made, but be careful.
  16
  17 IN: gadgets-canvas
  18 USING: arrays errors freetype gadgets gadgets-labels
  19 gadgets-layouts gadgets-panes gadgets-theme generic kernel math
  20 namespaces opengl sequences styles ;
  21
  22 SYMBOL: canvas-font
  23
  24 { "monospaced" plain 12 } canvas-font set-global
  25
  26 : turn-by ( angle -- ) 0 0 1 glRotated ;
  27
  28 : move-by ( distance -- ) 0 0 glTranslated ;
  29
  30 : plot-point ( -- )
  31     GL_POINTS [ 0 0 0 glVertex3d ] do-state ;
  32
  33 : line-to ( distance -- )
  34     dup
  35     GL_LINES [ 0 0 0 glVertex3d 0 0 glVertex3d ] do-state
  36     move-by ;
  37
  38 : plot-string ( string -- )
  39     canvas-font get open-font swap draw-string ;
  40
  41 : new-pen ( quot -- ) GL_MODELVIEW swap do-matrix ; inline
  42
  43 TUPLE: canvas quot id ;
  44
  45 C: canvas ( quot -- )
  46     dup delegate>gadget [ set-canvas-quot ] keep ;
  47
  48 M: canvas add-notify* ( gadget -- )
  49     dup canvas-quot GL_COMPILE [ with-scope ] make-dlist
  50     swap set-canvas-id ;
  51
  52 M: canvas draw-gadget* ( gadget -- )
  53     GL_MODELVIEW [
  54         dup rect-dim 2 v/n gl-translate
  55         canvas-id glCallList
  56     ] do-matrix ;
  57
  58 : with-canvas ( size quot -- )
  59     <canvas> dup solid-boundary [ set-gadget-dim ] keep gadget. ;
  60
  61 : random-walk ( n -- )
  62     [ 2 random-int 1/2 - 180 * turn-by 10 line-to ] times ;
  63
  64 : regular-polygon ( sides n -- )
  65     [ 360 swap / ] keep [ over line-to dup turn-by ] times 2drop ;
  66
  67 : random-color
  68     4 [ drop 255 random-int 255 /f ] map gl-color ;
  69
  70 : turtle-test
  71     { 400 400 0 } [
  72         36 [
  73             ! random-color
  74             10 line-to
  75             10 turn-by [ 60 10 regular-polygon ] new-pen
  76         ] times
  77     ] with-canvas ;