extra/trails/trails.factor

   1 USING: accessors calendar circular colors colors.constants
   2 kernel locals math math.order math.vectors namespaces opengl
   3 processing.shapes sequences threads ui ui.gadgets ui.gestures
   4 ui.render ;
   5
   6 IN: trails
   7
   8 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   9
  10 ! Example 33-15 from the Processing book
  11
  12 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  13
  14 ! Return the mouse location relative to the current gadget
  15
  16 : mouse ( -- point ) hand-loc get  hand-gadget get screen-loc  v- ;
  17
  18 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  19
  20 : point-list ( n -- seq ) [ { 0 0 } ] replicate <circular> ;
  21
  22 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  23
  24 : percent->radius ( percent -- radius ) neg 1 + 25 * 5 max ;
  25
  26 : dot ( pos percent -- ) percent->radius circle ;
  27
  28 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  29
  30 TUPLE: trails-gadget < gadget paused points ;
  31
  32 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  33
  34 :: iterate-system ( GADGET -- )
  35
  36   ! Add a valid point if the mouse is in the gadget
  37   ! Otherwise, add an "invisible" point
  38
  39   hand-gadget get GADGET =
  40     [ mouse       GADGET points>> circular-push ]
  41     [ { -10 -10 } GADGET points>> circular-push ]
  42   if ;
  43
  44 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  45
  46 :: start-trails-thread ( GADGET -- )
  47   GADGET f >>paused drop
  48   [
  49     [
  50       GADGET paused>>
  51         [ f ]
  52         [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
  53       if
  54     ]
  55     loop
  56   ]
  57   "trails" spawn drop ;
  58
  59 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  60
  61 M: trails-gadget ungraft* ( trails-gadget -- ) t >>paused drop ;
  62
  63 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  64
  65 M: trails-gadget pref-dim* ( trails-gadget -- dim ) drop { 500 500 } ;
  66
  67 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  68
  69 : each-percent ( seq quot -- )
  70   [
  71     dup length
  72     [ iota ] [ [ / ] curry ] bi
  73     [ 1 + ] prepose
  74   ] dip compose
  75   2each ;                       inline
  76
  77 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  78
  79 M:: trails-gadget draw-gadget* ( GADGET -- )
  80     T{ rgba f 1 1 1 0.4 } \ fill-color set   ! White, with some transparency
  81     T{ rgba f 0 0 0 0   } \ stroke-color set ! no stroke
  82
  83     COLOR: black gl-clear
  84
  85     GADGET points>> [ dot ] each-percent ;
  86
  87 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  88
  89 : <trails-gadget> ( -- trails-gadget )
  90
  91   trails-gadget new
  92
  93     300 point-list >>points
  94
  95     t >>clipped?
  96
  97   dup start-trails-thread ;
  98
  99 MAIN-WINDOW: trails-window
 100     { { title "Trails" } }
 101     <trails-gadget> >>gadgets ;