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   in-thread ;
  58
  59 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  60
  61 M: trails-gadget pref-dim* ( trails-gadget -- dim ) drop { 500 500 } ;
  62
  63 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  64
  65 : each-percent ( seq quot -- )
  66   [
  67     dup length
  68     [ iota ] [ [ / ] curry ] bi
  69     [ 1 + ] prepose
  70   ] dip compose
  71   2each ;                       inline
  72
  73 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  74
  75 M:: trails-gadget draw-gadget* ( GADGET -- )
  76     T{ rgba f 1 1 1 0.4 } \ fill-color set   ! White, with some transparency
  77     T{ rgba f 0 0 0 0   } \ stroke-color set ! no stroke
  78
  79     COLOR: black gl-clear
  80
  81     GADGET points>> [ dot ] each-percent ;
  82
  83 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  84
  85 : <trails-gadget> ( -- trails-gadget )
  86
  87   trails-gadget new
  88
  89     300 point-list >>points
  90
  91     t >>clipped?
  92
  93   dup start-trails-thread ;
  94
  95 : trails-window ( -- ) [ <trails-gadget> "Trails" open-window ] with-ui ;
  96
  97 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  98
  99 MAIN: trails-window