Merge branch 'master' of git://factorcode.org/git/factor

extra/bubble-chamber/bubble-chamber-docs.factor

@@ -1,84 +0,0 @@
-
-USING: help.syntax help.markup ;
-
-USING: bubble-chamber.particle.muon
-       bubble-chamber.particle.quark
-       bubble-chamber.particle.hadron
-       bubble-chamber.particle.axion ;
-
-IN: bubble-chamber
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-HELP: muon
-
-  { $class-description
-    "The muon is a colorful particle with an entangled friend."
-    "It draws both itself and its horizontally symmetric partner."
-    "A high range of speed and almost no speed decay allow the"
-    "muon to reach the extents of the window, often forming rings"
-    "where theta has decayed but speed remains stable. The result"
-    "is color almost everywhere in the general direction of collision,"
-    "stabilized into fuzzy rings." } ;
-
-HELP: quark
-
-  { $class-description
-    "The quark draws as a translucent black. Their large numbers"
-    "create fields of blackness overwritten only by the glowing shadows of "
-    "Hadrons. "
-    "quarks are allowed to accelerate away with speed decay values above 1.0. "
-    "Each quark has an entangled friend. Both particles are drawn identically,"
-    "mirrored along the y-axis." } ;
-
-HELP: hadron
-
-  { $class-description
-    "Hadrons collide from totally random directions. "
-    "Those hadrons that do not exit the drawing area, "
-    "tend to stabilize into perfect circular orbits. "
-    "Each hadron draws with a slight glowing emboss. "
-    "The hadron itself is not drawn." } ;
-
-HELP: axion
-
-  { $class-description
-    "The axion particle draws a bold black path. Axions exist "
-    "in a slightly higher dimension and as such are drawn with "
-    "elevated embossed shadows. Axions are quick to stabilize "
-    "and fall into single pixel orbits axions automatically "
-    "recollide themselves after stabilizing." } ;
-
-{ muon quark hadron axion } related-words
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber" "Bubble Chamber"
-
-"The " { $vocab-link "bubble-chamber" } 
-" is a generative painting system of imaginary "
-"colliding particles. A single super-massive collision produces a "
-"discrete universe of four particle types. Particles draw their "
-"positions over time as pixel exposures.\n"
-"\n"
-"Four types of particles exist. The behavior and graphic appearance of "
-"each particle type is unique.\n"
-  { $subsection muon }
-  { $subsection quark }
-  { $subsection hadron }
-  { $subsection axion } 
-"\n"
-"After you run the vocabulary, a window will appear. Click the "
-"mouse in a random area to fire 11 particles of each type. "
-"Another way to fire particles is to press the "
-"spacebar. This fires all the particles.\n"
-"\n"
-"Bubble Chamber was created by Jared Tarbell. "
-"It was originally implemented in Processing. "
-"It was ported to Factor by Eduardo Cavazos. "
-"The original work is on display here: "
-{ $url
-"http://www.complexification.net/gallery/machines/bubblechamber/" } ;
-
-ABOUT: "bubble-chamber"
-

extra/bubble-chamber/bubble-chamber.factor

@@ -1,88 +1,568 @@
 
-USING: kernel namespaces sequences random math math.constants math.libm vars
+USING: kernel syntax accessors sequences
-       ui
+       arrays calendar
-       processing
+       combinators.cleave combinators.short-circuit 
-       processing.gadget
+       locals math math.constants math.functions math.libm
-       bubble-chamber.common
+       math.order math.points math.vectors
-       bubble-chamber.particle
+       namespaces random sequences threads ui ui.gadgets ui.gestures
-       bubble-chamber.particle.muon
+       math.ranges
-       bubble-chamber.particle.quark
+       colors
-       bubble-chamber.particle.hadron
+       colors.gray
-       bubble-chamber.particle.axion ;
+       vars
+       multi-methods
+       multi-method-syntax
+       processing.shapes
+       frame-buffer ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 IN: bubble-chamber
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! processing
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-VARS: particles muons quarks hadrons axions ;
+: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
 
-VAR: boom
+: 1random ( b -- num ) 0 swap 2random ;
+
+: at-fraction ( seq fraction -- val ) over length 1- * swap nth ;
+
+: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
+
+: mouse ( -- point ) hand-loc get ;
+
+: mouse-x ( -- x ) mouse first  ;
+: mouse-y ( -- y ) mouse second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: collide ( particle -- )
+GENERIC: move    ( particle -- )
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: collide-all ( -- )
+TUPLE: particle
-
+  bubble-chamber pos vel speed speed-d theta theta-d theta-dd myc mya ;
-  2 pi * 1random >collision-theta
-
-  particles> [ collide ] each ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: collide-one ( -- )
+: initialize-particle ( particle -- particle )
 
-  dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
+  0 0 {2} >>pos
+  0 0 {2} >>vel
 
-  hadrons> random collide
+  0 >>speed
-  quarks>  random collide
+  0 >>speed-d
-  muons>   random collide ;
+  0 >>theta
+  0 >>theta-d
+  0 >>theta-dd
+
+  0 0 0 1 rgba boa >>myc
+  0 0 0 1 rgba boa >>mya ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: mouse-pressed ( -- )
+: center ( particle -- point ) bubble-chamber>> size>> 2 v/n ;
-  boom on
+
-  1 background ! kludge
+DEFER: collision-theta
-  11 [ drop collide-one ] each ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: key-released ( -- )
+: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
-  key " " =
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
+
+: random-theta-dd  ( par a b -- par ) 2random >>theta-dd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: turn ( particle -- particle )
+  dup
+    [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+  >>vel ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: step-theta     ( p -- p ) [ ] [ theta>>   ] [ theta-d>>  ] tri + >>theta   ;
+: step-theta-d   ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
+: step-speed-sub ( p -- p ) [ ] [ speed>>   ] [ speed-d>>  ] tri - >>speed   ;
+: step-speed-mul ( p -- p ) [ ] [ speed>>   ] [ speed-d>>  ] tri * >>speed   ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: out-of-bounds? ( PARTICLE -- ? )
+  [let | X      [ PARTICLE pos>> first                    ]
+         Y      [ PARTICLE pos>> second                   ]
+         WIDTH  [ PARTICLE bubble-chamber>> size>> first  ]
+         HEIGHT [ PARTICLE bubble-chamber>> size>> second ] |
+
+    [let | LEFT   [ WIDTH  neg ]
+           RIGHT  [ WIDTH  2 * ]
+           BOTTOM [ HEIGHT neg ]
+           TOP    [ HEIGHT 2 * ] |
+
+      { [ X LEFT < ] [ X RIGHT > ] [ Y BOTTOM < ] [ Y TOP > ] } 0|| ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.axion
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <axion> < particle ;
+
+: axion ( -- <axion> ) <axion> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <axion> -- )
+
+  dup center          >>pos
+  2 pi *      1random >>theta
+  1.0   6.0   2random >>speed
+  0.998 1.000 2random >>speed-d
+  0                   >>theta-d
+  0                   >>theta-dd
+
+  [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
+
+! : axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} \ stroke-color set ;
+! : axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} \ stroke-color set ;
+
+: axion-white ( dy -- dy ) dup 1 swap dy>alpha gray boa \ stroke-color set ;
+: axion-black ( dy -- dy ) dup 0 swap dy>alpha gray boa \ stroke-color set ;
+
+: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
+: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <axion> -- )
+
+  T{ gray f 0.06 0.59 } \ stroke-color set
+  dup pos>>  point
+
+  1 4 [a,b] [ axion-white axion-point- ] each
+  1 4 [a,b] [ axion-black axion-point+ ] each
+
+  dup vel>> move-by
+
+  turn
+
+  step-theta
+  step-theta-d
+  step-speed-mul
+
+  [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
+
+  1000 random 996 >
     [
-      boom on
+      dup speed>>   neg     >>speed
-      1 background
+      dup speed-d>> neg 2 + >>speed-d
-      collide-all
+
+      100 random 30 > [ collide ] [ drop ] if
     ]
-  when ;
+    [ drop ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.hadron
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <hadron> < particle ;
+
+: hadron ( -- <hadron> ) <hadron> new initialize-particle ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: bubble-chamber ( -- )
+METHOD: collide ( <hadron> -- )
 
-  1000 1000 size*
+  dup center          >>pos
+  2 pi *      1random >>theta
+  0.5   3.5   2random >>speed
+  0.996 1.001 2random >>speed-d
+  0                   >>theta-d
+  0                   >>theta-dd
 
+  [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+  0 1 0 1 rgba boa >>myc
+
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <hadron> -- )
+
+  T{ gray f 1 0.11 } \ stroke-color set  dup pos>> 1 v-y point
+  T{ gray f 0 0.11 } \ stroke-color set  dup pos>> 1 v+y point
+
+  dup vel>> move-by
+
+  turn
+
+  step-theta
+  step-theta-d
+  step-speed-mul
+
+  1000 random 997 >
     [
-    1 background
+      1.0     >>speed-d
-    no-stroke
+      0.00001 >>theta-dd
 
-    1789 [ drop <muon>   ] map >muons
+      100 random 70 > [ dup collide ] when
-    1300 [ drop <quark>  ] map >quarks
+    ]
-    1000 [ drop <hadron> ] map >hadrons
-    111  [ drop <axion>  ] map >axions
-
-    muons> quarks> hadrons> axions> 3append append >particles
-
-    collide-one
-  ] setup
-
-  [
-    boom>
-      [ particles> [ move ] each ]
   when
-  ] draw
 
-  [ mouse-pressed ] button-down
+  dup out-of-bounds? [ collide ] [ drop ] if ;
-  [ key-released  ] key-up ;
 
-: go ( -- ) [ bubble-chamber run ] with-ui ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.muon.colors
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: good-colors ( -- seq )
+  {
+    T{ rgba f 0.23 0.14 0.17 1 }
+    T{ rgba f 0.23 0.14 0.15 1 }
+    T{ rgba f 0.21 0.14 0.15 1 }
+    T{ rgba f 0.51 0.39 0.33 1 }
+    T{ rgba f 0.49 0.33 0.20 1 }
+    T{ rgba f 0.55 0.45 0.32 1 }
+    T{ rgba f 0.69 0.63 0.51 1 }
+    T{ rgba f 0.64 0.39 0.18 1 }
+    T{ rgba f 0.73 0.42 0.20 1 }
+    T{ rgba f 0.71 0.45 0.29 1 }
+    T{ rgba f 0.79 0.45 0.22 1 }
+    T{ rgba f 0.82 0.56 0.34 1 }
+    T{ rgba f 0.88 0.72 0.49 1 }
+    T{ rgba f 0.85 0.69 0.40 1 }
+    T{ rgba f 0.96 0.92 0.75 1 }
+    T{ rgba f 0.99 0.98 0.87 1 }
+    T{ rgba f 0.85 0.82 0.69 1 }
+    T{ rgba f 0.99 0.98 0.87 1 }
+    T{ rgba f 0.82 0.82 0.79 1 }
+    T{ rgba f 0.65 0.69 0.67 1 }
+    T{ rgba f 0.53 0.60 0.55 1 }
+    T{ rgba f 0.57 0.53 0.68 1 }
+    T{ rgba f 0.47 0.42 0.56 1 }
+  } ;
+
+: anti-colors ( -- seq ) good-colors <reversed> ; 
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
+
+: set-good-color ( particle -- particle )
+  color-fraction dup 0 1 between?
+    [ good-colors at-fraction-of >>myc ]
+    [ drop ]
+  if ;
+
+: set-anti-color ( particle -- particle )
+  color-fraction dup 0 1 between?
+    [ anti-colors at-fraction-of >>mya ]
+    [ drop ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.muon
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <muon> < particle ;
+
+: muon ( -- <muon> ) <muon> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <muon> -- )
+
+  dup center           >>pos
+  2 32 [a,b] random    >>speed
+  0.0001 0.001 2random >>speed-d
+
+  dup collision-theta  -0.1 0.1 2random + >>theta
+  0                                    >>theta-d
+  0                                    >>theta-dd
+
+  [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
+
+  set-good-color
+  set-anti-color
+
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <muon> -- )
+
+  [let | MUON [ ] |
+
+    [let | WIDTH [ MUON bubble-chamber>> size>> first ] |
+
+      MUON
+
+      dup myc>> 0.16 >>alpha \ stroke-color set
+      dup pos>> point
+
+      dup mya>> 0.16 >>alpha \ stroke-color set
+      dup pos>> first2 [ WIDTH swap - ] dip 2array point
+
+      dup
+      [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+      move-by
+
+      step-theta
+      step-theta-d
+      step-speed-sub
+
+      dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.quark
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <quark> < particle ;
+
+: quark ( -- <quark> ) <quark> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <quark> -- )
+
+  dup center                             >>pos
+  dup collision-theta -0.11 0.11 2random +  >>theta
+  0.5 3.0 2random                        >>speed
+
+  0.996 1.001 2random                    >>speed-d
+  0                                      >>theta-d
+  0                                      >>theta-dd
+
+  [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <quark> -- )
+
+  [let | QUARK [ ] |
+
+    [let | WIDTH [ QUARK bubble-chamber>> size>> first ] |
+
+      QUARK
+    
+      dup myc>> 0.13 >>alpha \ stroke-color set
+      dup pos>>              point
+
+      dup pos>> first2 [ WIDTH swap - ] dip 2array point
+
+      [ ] [ vel>> ] bi move-by
+
+      turn
+
+      step-theta
+      step-theta-d
+      step-speed-mul
+
+      1000 random 997 >
+      [
+      dup speed>> neg    >>speed
+      2 over speed-d>> - >>speed-d
+      ]
+      when
+
+      dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
+
+TUPLE: <bubble-chamber> < <frame-buffer>
+  paused particles collision-theta size ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : randomize-collision-theta ( bubble-chamber -- bubble-chamber )
+!   0  2 pi *  0.001  <range>  random >>collision-theta ;
+
+: randomize-collision-theta ( bubble-chamber -- bubble-chamber )
+  pi neg  pi  0.001 <range> random >>collision-theta ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collision-theta ( particle -- theta ) bubble-chamber>> collision-theta>> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: <bubble-chamber> pref-dim* ( gadget -- dim ) size>> ;
+
+M: <bubble-chamber> ungraft* ( <bubble-chamber> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: iterate-particle ( particle -- ) move ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <bubble-chamber> update-frame-buffer ( BUBBLE-CHAMBER -- )
+
+  BUBBLE-CHAMBER particles>> [ iterate-particle ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: iterate-system ( <bubble-chamber> -- ) drop ;
+
+:: start-bubble-chamber-thread ( GADGET -- )
+  GADGET f >>paused drop
+  [
+    [
+      GADGET paused>>
+        [ f ]
+        [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
+      if
+    ]
+    loop
+  ]
+  in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber ( -- <bubble-chamber> )
+  <bubble-chamber> new-gadget
+    { 1000 1000 } >>size
+    randomize-collision-theta ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber-window ( -- <bubble-chamber> )
+  bubble-chamber
+    dup start-bubble-chamber-thread
+    dup "Bubble Chamber" open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: add-particle ( BUBBLE-CHAMBER PARTICLE -- bubble-chamber )
+  
+  PARTICLE BUBBLE-CHAMBER >>bubble-chamber drop
+
+  BUBBLE-CHAMBER  BUBBLE-CHAMBER particles>> PARTICLE suffix  >>particles ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: mouse->collision-theta ( BUBBLE-CHAMBER -- BUBBLE-CHAMBER )
+  mouse
+  BUBBLE-CHAMBER size>> 2 v/n
+  v-
+  first2
+  fatan2
+  BUBBLE-CHAMBER (>>collision-theta)
+  BUBBLE-CHAMBER ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: mouse-pressed ( BUBBLE-CHAMBER -- )
+
+  BUBBLE-CHAMBER mouse->collision-theta drop
+
+  11
+  [
+    BUBBLE-CHAMBER particles>> [ <hadron>? ] filter random [ collide ] when*
+    BUBBLE-CHAMBER particles>> [ <quark>?  ] filter random [ collide ] when*
+    BUBBLE-CHAMBER particles>> [ <muon>?   ] filter random [ collide ] when*
+  ]
+  times ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<bubble-chamber> H{ { T{ button-down } [ mouse-pressed ] } } set-gestures
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-random-particle ( bubble-chamber -- bubble-chamber )
+  dup particles>> random collide ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: big-bang ( bubble-chamber -- bubble-chamber )
+  dup particles>> [ collide ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Some initial configurations
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ten-hadrons ( -- )
+  bubble-chamber-window
+  10 [ drop hadron add-particle ] each
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original ( -- )
+  
+  bubble-chamber-window
+  
+    1789 [ muon   add-particle ] times
+    1300 [ quark  add-particle ] times
+    1000 [ hadron add-particle ] times
+     111 [ axion  add-particle ] times
+
+    particles>>
+    [ [ <muon>?   ] filter random collide ]
+    [ [ <quark>?  ] filter random collide ]
+    [ [ <hadron>? ] filter random collide ]
+    tri ;
+    
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original-big-bang ( -- )
+  bubble-chamber
+    { 1000 1000 } >>size
+    dup start-bubble-chamber-thread
+    dup "Bubble Chamber" open-window
+
+  1789 [ muon   add-particle ] times
+  1300 [ quark  add-particle ] times
+  1000 [ hadron add-particle ] times
+   111 [ axion  add-particle ] times
+
+  big-bang
+
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hadron-chamber ( -- )
+  bubble-chamber-window
+  1000 [ hadron add-particle ] times
+  big-bang
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: muon-chamber ( -- )
+  bubble-chamber-window
+  1000 [ muon add-particle ] times
+  dup particles>> [ collide randomize-collision-theta ] each
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original-big-bang-variant ( -- )
+  bubble-chamber-window
+  1789 [ muon   add-particle ] times
+  1300 [ quark  add-particle ] times
+  1000 [ hadron add-particle ] times
+   111 [ axion  add-particle ] times
+  dup particles>> [ collide randomize-collision-theta ] each
+  drop ;
 
-MAIN: go

extra/bubble-chamber/common/common.factor

@@ -1,12 +0,0 @@
-
-USING: kernel math accessors combinators.cleave vars ;
-
-IN: bubble-chamber.common
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: collision-theta
-
-: dim ( -- dim ) 1000 ;
-
-: center ( -- point ) dim 2 / dup {2} ; foldable

extra/bubble-chamber/particle/axion/axion.factor

@@ -1,68 +0,0 @@
-
-USING: kernel sequences random accessors multi-methods
-       math math.constants math.ranges math.points combinators.cleave
-       processing processing.shapes
-       bubble-chamber.common bubble-chamber.particle ;
-
-IN: bubble-chamber.particle.axion
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: axion < particle ;
-
-: <axion> ( -- axion ) axion new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { axion }
-
-  center              >>pos
-  2 pi *      1random >>theta
-  1.0   6.0   2random >>speed
-  0.998 1.000 2random >>speed-d
-  0                   >>theta-d
-  0                   >>theta-dd
-
-  [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
-  drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
-
-: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ;
-: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
-
-: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
-: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { axion }
-
-  { 0.06 0.59 } stroke
-  dup pos>>  point
-
-  1 4 [a,b] [ axion-white axion-point- ] each
-  1 4 [a,b] [ axion-black axion-point+ ] each
-
-  dup vel>> move-by
-
-  turn
-
-  step-theta
-  step-theta-d
-  step-speed-mul
-
-  [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
-
-  1000 random 996 >
-    [
-      dup speed>>   neg     >>speed
-      dup speed-d>> neg 2 + >>speed-d
-
-      100 random 30 > [ collide ] [ drop ] if
-    ]
-    [ drop ]
-  if ;

extra/bubble-chamber/particle/hadron/hadron.factor

@@ -1,59 +0,0 @@
-
-USING: kernel random math math.constants math.points accessors multi-methods
-       processing processing.shapes
-       bubble-chamber.common
-       bubble-chamber.particle colors ;
-
-IN: bubble-chamber.particle.hadron
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: hadron < particle ;
-
-: <hadron> ( -- hadron ) hadron new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { hadron }
-
-  center              >>pos
-  2 pi *      1random >>theta
-  0.5   3.5   2random >>speed
-  0.996 1.001 2random >>speed-d
-  0                   >>theta-d
-  0                   >>theta-dd
-
-  [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
-  0 1 0 1 rgba boa >>myc
-
-  drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { hadron }
-
-  { 1 0.11 } stroke
-  dup pos>> 1 v-y point
-  
-  { 0 0.11 } stroke
-  dup pos>> 1 v+y point
-
-  dup vel>> move-by
-
-  turn
-
-  step-theta
-  step-theta-d
-  step-speed-mul
-
-  1000 random 997 >
-    [
-      1.0     >>speed-d
-      0.00001 >>theta-dd
-
-      100 random 70 > [ dup collide ] when
-    ]
-  when
-
-  out-of-bounds? [ collide ] [ drop ] if ;

extra/bubble-chamber/particle/muon/colors/colors.factor

@@ -1,53 +0,0 @@
-
-USING: kernel sequences math math.constants math.order accessors
-       processing
-       colors ;
-
-IN: bubble-chamber.particle.muon.colors
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: good-colors ( -- seq )
-  {
-    T{ rgba f 0.23 0.14 0.17 1 }
-    T{ rgba f 0.23 0.14 0.15 1 }
-    T{ rgba f 0.21 0.14 0.15 1 }
-    T{ rgba f 0.51 0.39 0.33 1 }
-    T{ rgba f 0.49 0.33 0.20 1 }
-    T{ rgba f 0.55 0.45 0.32 1 }
-    T{ rgba f 0.69 0.63 0.51 1 }
-    T{ rgba f 0.64 0.39 0.18 1 }
-    T{ rgba f 0.73 0.42 0.20 1 }
-    T{ rgba f 0.71 0.45 0.29 1 }
-    T{ rgba f 0.79 0.45 0.22 1 }
-    T{ rgba f 0.82 0.56 0.34 1 }
-    T{ rgba f 0.88 0.72 0.49 1 }
-    T{ rgba f 0.85 0.69 0.40 1 }
-    T{ rgba f 0.96 0.92 0.75 1 }
-    T{ rgba f 0.99 0.98 0.87 1 }
-    T{ rgba f 0.85 0.82 0.69 1 }
-    T{ rgba f 0.99 0.98 0.87 1 }
-    T{ rgba f 0.82 0.82 0.79 1 }
-    T{ rgba f 0.65 0.69 0.67 1 }
-    T{ rgba f 0.53 0.60 0.55 1 }
-    T{ rgba f 0.57 0.53 0.68 1 }
-    T{ rgba f 0.47 0.42 0.56 1 }
-  } ;
-
-: anti-colors ( -- seq ) good-colors <reversed> ; 
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
-
-: set-good-color ( particle -- particle )
-  color-fraction dup 0 1 between?
-    [ good-colors at-fraction-of >>myc ]
-    [ drop ]
-  if ;
-
-: set-anti-color ( particle -- particle )
-  color-fraction dup 0 1 between?
-    [ anti-colors at-fraction-of >>mya ]
-    [ drop ]
-  if ;

extra/bubble-chamber/particle/muon/muon.factor

@@ -1,63 +0,0 @@
-
-USING: kernel arrays sequences random
-       math
-       math.ranges
-       math.functions
-       math.vectors
-       multi-methods accessors
-       combinators.cleave
-       processing
-       processing.shapes
-       bubble-chamber.common
-       bubble-chamber.particle
-       bubble-chamber.particle.muon.colors ;
-
-IN: bubble-chamber.particle.muon
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: muon < particle ;
-
-: <muon> ( -- muon ) muon new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { muon }
-
-  center               >>pos
-  2 32 [a,b] random    >>speed
-  0.0001 0.001 2random >>speed-d
-
-  collision-theta>  -0.1 0.1 2random + >>theta
-  0                                    >>theta-d
-  0                                    >>theta-dd
-
-  [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
-
-  set-good-color
-  set-anti-color
-
-  drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { muon }
-
-  dup myc>> 0.16 >>alpha stroke
-  dup pos>> point
-
-  dup mya>> 0.16 >>alpha stroke
-  dup pos>> first2 >r dim swap - r> 2array point
-
-  dup
-    [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
-  move-by
-
-  step-theta
-  step-theta-d
-  step-speed-sub
-
-  out-of-bounds? [ collide ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-

extra/bubble-chamber/particle/particle.factor

@@ -1,68 +0,0 @@
-
-USING: kernel sequences combinators
-       math math.vectors math.functions multi-methods
-       accessors combinators.cleave processing
-       bubble-chamber.common colors ;
-
-IN: bubble-chamber.particle
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: collide ( particle -- )
-GENERIC: move    ( particle -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: initialize-particle ( particle -- particle )
-
-  0 0 {2} >>pos
-  0 0 {2} >>vel
-
-  0 >>speed
-  0 >>speed-d
-  0 >>theta
-  0 >>theta-d
-  0 >>theta-dd
-
-  0 0 0 1 rgba boa >>myc
-  0 0 0 1 rgba boa >>mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
-
-: random-theta-dd  ( par a b -- par ) 2random >>theta-dd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: turn ( particle -- particle )
-  dup
-    [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
-  >>vel ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: step-theta     ( p -- p ) [ ] [ theta>>   ] [ theta-d>>  ] tri + >>theta   ;
-: step-theta-d   ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
-: step-speed-sub ( p -- p ) [ ] [ speed>>   ] [ speed-d>>  ] tri - >>speed   ;
-: step-speed-mul ( p -- p ) [ ] [ speed>>   ] [ speed-d>>  ] tri * >>speed   ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x ( particle -- x ) pos>> first  ;
-: y ( particle -- x ) pos>> second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: out-of-bounds? ( particle -- particle ? )
-  dup
-  { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
-  or or or ;

extra/bubble-chamber/particle/quark/quark.factor

@@ -1,53 +0,0 @@
-
-USING: kernel arrays sequences random math accessors multi-methods
-       processing processing.shapes
-       bubble-chamber.common
-       bubble-chamber.particle ;
-
-IN: bubble-chamber.particle.quark
-
-TUPLE: quark < particle ;
-
-: <quark> ( -- quark ) quark new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { quark }
-
-  center                     >>pos
-  collision-theta> -0.11 0.11 2random +  >>theta
-  0.5 3.0 2random                        >>speed
-
-  0.996 1.001 2random                    >>speed-d
-  0                                      >>theta-d
-  0                                      >>theta-dd
-
-  [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
-  drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { quark }
-
-  dup myc>> 0.13 >>alpha stroke
-  dup pos>>              point
-
-  dup pos>> first2 >r dim swap - r> 2array point
-
-  [ ] [ vel>> ] bi move-by
-
-  turn
-
-  step-theta
-  step-theta-d
-  step-speed-mul
-
-  1000 random 997 >
-    [
-      dup speed>> neg    >>speed
-      2 over speed-d>> - >>speed-d
-    ]
-  when
-
-  out-of-bounds? [ collide ] [ drop ] if ;

extra/bubble-chamber/tags.txt

@@ -1 +0,0 @@
-demos

extra/frame-buffer/frame-buffer.factor

@@ -0,0 +1,112 @@
+
+USING: accessors alien.c-types combinators grouping kernel
+       locals math math.geometry.rect math.vectors opengl.gl sequences
+       ui.gadgets ui.render ;
+
+IN: frame-buffer
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <frame-buffer> < gadget pixels last-dim ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: update-frame-buffer ( <frame-buffer> -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-frame-buffer-pixels ( frame-buffer -- )
+  dup
+    rect-dim product "uint[4]" <c-array>
+  >>pixels
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: frame-buffer ( -- <frame-buffer> ) <frame-buffer> new-gadget ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: draw-pixels ( FRAME-BUFFER -- )
+
+  FRAME-BUFFER rect-dim first2
+  GL_RGBA
+  GL_UNSIGNED_INT
+  FRAME-BUFFER pixels>>
+  glDrawPixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: read-pixels ( FRAME-BUFFER -- )
+
+  0
+  0
+  FRAME-BUFFER rect-dim first2
+  GL_RGBA
+  GL_UNSIGNED_INT
+  FRAME-BUFFER pixels>>
+  glReadPixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: copy-row ( OLD NEW -- )
+  
+  [let | LEN [ OLD NEW min-length ] |
+
+    OLD LEN head-slice 0 NEW copy ] ;
+
+: copy-pixels ( old-pixels old-width new-pixels new-width -- )
+  [ 16 * <sliced-groups> ] 2bi@
+  [ copy-row ] 2each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update-last-dim ( frame-buffer -- ) dup rect-dim >>last-dim drop ;
+
+M:: <frame-buffer> layout* ( FRAME-BUFFER -- )
+
+  {
+    {
+      [ FRAME-BUFFER last-dim>> f = ]
+      [
+        FRAME-BUFFER init-frame-buffer-pixels
+
+        FRAME-BUFFER update-last-dim
+      ]
+    }
+    {
+      [ FRAME-BUFFER [ rect-dim ] [ last-dim>> ] bi = not ]
+      [
+        [let | OLD-PIXELS [ FRAME-BUFFER pixels>>         ]
+               OLD-WIDTH  [ FRAME-BUFFER last-dim>> first ] |
+
+          FRAME-BUFFER init-frame-buffer-pixels
+
+          FRAME-BUFFER update-last-dim
+
+          [let | NEW-PIXELS [ FRAME-BUFFER pixels>>         ]
+                 NEW-WIDTH  [ FRAME-BUFFER last-dim>> first ] |
+
+            OLD-PIXELS OLD-WIDTH NEW-PIXELS NEW-WIDTH copy-pixels ] ]
+      ]
+    }
+    { [ t ] [ ] }
+  }
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <frame-buffer> draw-gadget* ( FRAME-BUFFER -- )
+
+  FRAME-BUFFER rect-dim { 0 1 } v* first2 glRasterPos2i
+
+  FRAME-BUFFER draw-pixels
+
+  FRAME-BUFFER update-frame-buffer
+
+  glFlush
+
+  FRAME-BUFFER read-pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

extra/fuel/fuel.factor

@@ -1,12 +1,13 @@
 ! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: accessors arrays classes classes.tuple compiler.units
+USING: accessors arrays assocs classes classes.tuple
-combinators continuations debugger definitions eval help io
+combinators compiler.units continuations debugger definitions
-io.files io.pathnames io.streams.string kernel lexer listener
+eval help io io.files io.pathnames io.streams.string kernel
-listener.private make math namespaces parser prettyprint
+lexer listener listener.private make math memoize namespaces
-prettyprint.config quotations sequences strings source-files
+parser prettyprint prettyprint.config quotations sequences sets
-tools.vocabs vectors vocabs vocabs.loader ;
+sorting source-files strings tools.vocabs vectors vocabs
+vocabs.loader ;
 
 IN: fuel
 
@@ -88,6 +89,14 @@ SYMBOL: :restarts
 M: condition fuel-pprint
     [ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
 
+M: lexer-error fuel-pprint
+    {
+        [ line>> ]
+        [ column>> ]
+        [ line-text>> ]
+        [ fuel-restarts ]
+    } cleave 4array lexer-error prefix fuel-pprint ;
+
 M: source-file-error fuel-pprint
     [ file>> ] [ error>> ] bi 2array source-file-error prefix
     fuel-pprint ;
@@ -159,8 +168,24 @@ M: source-file fuel-pprint path>> fuel-pprint ;
 : fuel-get-vocab-location ( vocab -- )
     >vocab-link fuel-get-edit-location ;
 
+: (fuel-get-vocabs) ( -- seq )
+    all-vocabs-seq [ vocab-name ] map ; inline
+
 : fuel-get-vocabs ( -- )
-    all-vocabs-seq [ vocab-name ] map fuel-eval-set-result ; inline
+    (fuel-get-vocabs) fuel-eval-set-result ;
+
+MEMO: (fuel-vocab-words) ( name -- seq )
+    >vocab-link words [ name>> ] map ;
+
+: fuel-vocabs-words ( names/f -- seq )
+    [ (fuel-get-vocabs) ] unless* prune
+    [ (fuel-vocab-words) ] map concat natural-sort ;
+
+: (fuel-get-words) ( prefix names/f -- seq )
+    fuel-vocabs-words swap [ drop-prefix nip length 0 = ] curry filter ;
+
+: fuel-get-words ( prefix names -- )
+    (fuel-get-words) fuel-eval-set-result ; inline
 
 : fuel-run-file ( path -- ) run-file ; inline
 

extra/processing/gadget/gadget.factor

@@ -1,69 +0,0 @@
-
-USING: kernel namespaces combinators
-       ui.gestures accessors ui.gadgets.frame-buffer ;
-
-IN: processing.gadget
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;
-
-: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: mouse-pressed-value
-SYMBOL: key-pressed-value
-
-SYMBOL: button-value
-SYMBOL: key-value
-
-: key-pressed?   ( -- ? ) key-pressed-value   get ;
-: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
-
-: key    ( -- key ) key-value    get ;
-: button ( -- val ) button-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: processing-gadget handle-gesture ( gesture gadget -- ? )
-   swap
-   {
-     {
-       [ dup key-down? ]
-       [
-         sym>> key-value set
-         key-pressed-value on
-         key-down>> dup [ call ] [ drop ] if
-         t
-       ]
-     }
-     {
-       [ dup key-up?   ]
-       [
-         key-pressed-value off
-         drop
-         key-up>> dup [ call ] [ drop ] if
-         t
-       ] }
-     {
-       [ dup button-down? ]
-       [
-         #>> button-value set
-         mouse-pressed-value on
-         button-down>> dup [ call ] [ drop ] if
-         t
-       ]
-     }
-     {
-       [ dup button-up? ]
-       [
-         mouse-pressed-value off
-         drop
-         button-up>> dup [ call ] [ drop ] if
-         t
-       ]
-     }
-     { [ t ] [ 2drop t ] }
-   }
-   cond ;

extra/processing/processing.factor

@@ -1,313 +0,0 @@
-
-USING: kernel namespaces threads combinators sequences arrays
-       math math.functions math.ranges random
-       opengl.gl opengl.glu vars multi-methods generalizations shuffle
-       ui
-       ui.gestures
-       ui.gadgets
-       combinators
-       combinators.lib
-       combinators.cleave
-       rewrite-closures bake bake.fry accessors newfx
-       processing.gadget math.geometry.rect
-       processing.shapes
-       colors ;
-       
-IN: processing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
-
-: 1random ( b -- num ) 0 swap 2random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chance ( fraction -- ? ) 0 1 2random > ;
-
-: percent-chance ( percent -- ? ) 100 / chance ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
-
-: at-fraction ( seq fraction -- val ) over length 1- * at ;
-
-: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: canonical-color-value ( obj -- color )
-
-METHOD: canonical-color-value { number } dup dup 1 rgba boa ;
-
-METHOD: canonical-color-value { array }
-   dup length
-   {
-     { 2 [ first2 >r dup dup r> rgba boa ] }
-     { 3 [ first3 1             rgba boa ] }
-     { 4 [ first4               rgba boa ] }
-   }
-   case ;
-
-! METHOD: canonical-color-value { rgba }
-!   { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
-
-METHOD: canonical-color-value { color } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fill   ( value -- ) canonical-color-value >fill-color   ;
-: stroke ( value -- ) canonical-color-value >stroke-color ;
-
-! : no-fill   ( -- ) 0 fill-color>   set-fourth ;
-! : no-stroke ( -- ) 0 stroke-color> set-fourth ;
-
-: no-fill   ( -- ) fill-color>   0 >>alpha drop ;
-: no-stroke ( -- ) stroke-color> 0 >>alpha drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: stroke-weight ( w -- ) glLineWidth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : 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 -- )
-
-!   8 ndup
-
-!   GL_FRONT_AND_BACK GL_FILL glPolygonMode
-!   fill-color> set-color
-
-!   quad-vertices
-  
-!   GL_FRONT_AND_BACK GL_LINE glPolygonMode
-!   stroke-color> set-color
-
-!   quad-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-center ( x y width height -- )
-
-!   4dup
-
-!   GL_FRONT_AND_BACK GL_FILL glPolygonMode
-!   stroke-color> set-color
-
-!   ellipse-disk
-
-!   GL_FRONT_AND_BACK GL_FILL glPolygonMode
-!   fill-color> set-color
-
-!   [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
-
-!   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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: background ( value -- )
-
-METHOD: background { number }
-   dup dup 1 glClearColor
-   GL_COLOR_BUFFER_BIT glClear ;
-
-METHOD: background { array }
-   dup length
-   {
-     { 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] }
-     { 3 [ first3 1             glClearColor GL_COLOR_BUFFER_BIT glClear ] }
-     { 4 [ first4               glClearColor GL_COLOR_BUFFER_BIT glClear ] }
-   }
-   case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: translate ( x y -- ) 0 glTranslated ;
-
-: rotate ( angle -- ) 0 0 1 glRotated ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mouse ( -- point ) hand-loc get ;
-
-: mouse-x ( -- x ) mouse first  ;
-: mouse-y ( -- y ) mouse second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: frame-rate-value
-
-: frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! VAR: slate
-
-VAR: loop-flag
-
-: defaults ( -- )
-  0.8    background
-  ! CENTER ellipse-mode
-  60 frame-rate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: size-val
-
-: size ( seq -- ) size-val set ;
-
-: size* ( width height -- ) 2array size-val set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: setup-action
-SYMBOL: draw-action
-
-! : setup ( quot -- ) closed-quot setup-action set ;
-! : draw  ( quot -- ) closed-quot draw-action  set ;
-
-: setup ( quot -- ) setup-action set ;
-: draw  ( quot -- ) draw-action  set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: key-down-action
-SYMBOL: key-up-action
-
-: key-down ( quot -- ) closed-quot key-down-action set ;
-: key-up   ( quot -- ) closed-quot key-up-action   set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: button-down-action
-SYMBOL: button-up-action
-
-: button-down ( quot -- ) closed-quot button-down-action set ;
-: button-up   ( quot -- ) closed-quot button-up-action   set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-processing-thread ( -- )
-  loop-flag get not
-    [
-      loop-flag on
-      [
-        [ loop-flag get ]
-        processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
-        [ ]
-        while
-      ]
-      in-thread
-    ]
-  when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-size ( -- size ) processing-gadget get rect-dim ;
-
-: width  ( -- width  ) get-size first ;
-: height ( -- height ) get-size second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: setup-called
-
-: setup-called? ( -- ? ) setup-called get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run ( -- )
-
-  loop-flag off
-
-  500 sleep
-
-  <processing-gadget>
-    size-val get >>pdim
-    dup "Processing" open-window
-
-    500 sleep
-
-    defaults
-
-    setup-called off
-
-    [
-      setup-called? not
-        [
-          setup-action get call
-          setup-called on
-        ]
-        [
-          draw-action get call
-        ]
-      if
-    ]
-      closed-quot >>action
-    
-    key-down-action get >>key-down
-    key-up-action   get >>key-up
-
-    button-down-action get >>button-down
-    button-up-action   get >>button-up
-    
-  processing-gadget set
-
-  start-processing-thread ;

extra/ui/gadgets/frame-buffer/frame-buffer.factor

@@ -1,115 +0,0 @@
-
-USING: kernel alien.c-types combinators sequences splitting grouping
-       opengl.gl ui.gadgets ui.render
-       math math.vectors accessors math.geometry.rect ;
-
-IN: ui.gadgets.frame-buffer
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-frame-buffer-pixels ( frame-buffer -- frame-buffer )
-  dup
-    rect-dim product "uint[4]" <c-array>
-  >>pixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: new-frame-buffer ( class -- gadget )
-  new-gadget
-    [ ]         >>action
-    { 100 100 } >>pdim
-    [ ]         >>graft
-    [ ]         >>ungraft ;
-
-: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-pixels ( fb -- fb )
-  dup >r
-  dup >r
-  rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels
-  r> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: read-pixels ( fb -- fb )
-  dup >r
-  dup >r
-      >r
-  0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels
-  r> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer pref-dim* pdim>> ;
-M: frame-buffer graft*    graft>>   call ;
-M: frame-buffer ungraft*  ungraft>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: copy-row ( old new -- )
-  2dup min-length swap >r head-slice 0 r> copy ;
-
-! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
-!   [ group ] 2bi@
-!   [ copy-row ] 2each ;
-
-! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
-!   [ 16 * group ] 2bi@
-!   [ copy-row ] 2each ;
-
-: copy-pixels ( old-pixels old-width new-pixels new-width -- )
-  [ 16 * <sliced-groups> ] 2bi@
-  [ copy-row ] 2each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer layout* ( fb -- )
-   {
-     {
-       [ dup last-dim>> f = ]
-       [
-         init-frame-buffer-pixels
-         dup
-           rect-dim >>last-dim
-         drop
-       ]
-     }
-     {
-       [ dup [ rect-dim ] [ last-dim>> ] bi = not ]
-       [
-         dup [ pixels>> ] [ last-dim>> first ] bi
-
-         rot init-frame-buffer-pixels
-         dup rect-dim >>last-dim
-
-         [ pixels>> ] [ rect-dim first ] bi
-
-         copy-pixels
-       ]
-     }
-     { [ t ] [ drop ] }
-   }
-   cond ;
-   
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer draw-gadget* ( fb -- )
-
-   dup rect-dim { 0 1 } v* first2 glRasterPos2i
-
-   draw-pixels
-
-   dup action>> call
-
-   glFlush
-
-   read-pixels
-
-   drop ;
-

misc/fuel/README

@@ -56,6 +56,7 @@ the same as C-cz)).
  - C-co : cycle between code, tests and docs factor files
 
  - M-. : edit word at point in Emacs (also in listener)
+ - M-TAB : complete word at point
  - C-cC-ev : edit vocabulary
 
  - C-cr, C-cC-er : eval region

misc/fuel/factor-mode.el

@@ -84,8 +84,7 @@ code in the buffer."
   (set (make-local-variable 'beginning-of-defun-function)
        'fuel-syntax--beginning-of-defun)
   (set (make-local-variable 'end-of-defun-function) 'fuel-syntax--end-of-defun)
-  (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil)
+  (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil))
-  (fuel-syntax--enable-usings))
 
 
 ;;; Indentation:

misc/fuel/fuel-base.el

@@ -61,5 +61,12 @@
 
 (defsubst empty-string-p (str) (equal str ""))
 
+(defun fuel--respecting-message (format &rest format-args)
+  "Display TEXT as a message, without hiding any minibuffer contents."
+  (let ((text (format " [%s]" (apply #'format format format-args))))
+    (if (minibuffer-window-active-p (minibuffer-window))
+        (minibuffer-message text)
+      (message "%s" text))))
+
 (provide 'fuel-base)
 ;;; fuel-base.el ends here

misc/fuel/fuel-completion.el

@@ -0,0 +1,173 @@
+;;; fuel-completion.el -- completion utilities
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Sun Dec 14, 2008 21:17
+
+;;; Comentary:
+
+;; Code completion utilities.
+
+;;; Code:
+
+(require 'fuel-base)
+(require 'fuel-syntax)
+(require 'fuel-eval)
+(require 'fuel-log)
+
+
+;;; Vocabs dictionary:
+
+(defvar fuel-completion--vocabs nil)
+
+(defun fuel-completion--vocabs (&optional reload)
+  (when (or reload (not fuel-completion--vocabs))
+    (fuel--respecting-message "Retrieving vocabs list")
+    (let ((fuel-log--inhibit-p t))
+      (setq fuel-completion--vocabs
+            (fuel-eval--retort-result
+             (fuel-eval--send/wait '(:fuel* (fuel-get-vocabs) "fuel" (:array)))))))
+  fuel-completion--vocabs)
+
+(defsubst fuel-completion--words (prefix vocabs)
+  (fuel-eval--retort-result
+   (fuel-eval--send/wait `(:fuel* (,prefix V{ ,@vocabs } fuel-get-words) t ,vocabs))))
+
+
+;;; Completions window handling, heavily inspired in slime's:
+
+(defvar fuel-completion--comp-buffer "*Completions*")
+
+(make-variable-buffer-local
+ (defvar fuel-completion--window-cfg nil
+   "Window configuration before we show the *Completions* buffer.
+This is buffer local in the buffer where the completion is
+performed."))
+
+(make-variable-buffer-local
+ (defvar fuel-completion--completions-window nil
+   "The window displaying *Completions* after saving window configuration.
+If this window is no longer active or displaying the completions
+buffer then we can ignore `fuel-completion--window-cfg'."))
+
+(defun fuel-completion--maybe-save-window-configuration ()
+  "Maybe save the current window configuration.
+Return true if the configuration was saved."
+  (unless (or fuel-completion--window-cfg
+              (get-buffer-window fuel-completion--comp-buffer))
+    (setq fuel-completion--window-cfg
+          (current-window-configuration))
+    t))
+
+(defun fuel-completion--delay-restoration ()
+  (add-hook 'pre-command-hook
+            'fuel-completion--maybe-restore-window-configuration
+            nil t))
+
+(defun fuel-completion--forget-window-configuration ()
+  (setq fuel-completion--window-cfg nil)
+  (setq fuel-completion--completions-window nil))
+
+(defun fuel-completion--restore-window-configuration ()
+  "Restore the window config if available."
+  (remove-hook 'pre-command-hook
+               'fuel-completion--maybe-restore-window-configuration)
+  (when (and fuel-completion--window-cfg
+             (fuel-completion--window-active-p))
+    (save-excursion
+      (set-window-configuration fuel-completion--window-cfg))
+    (setq fuel-completion--window-cfg nil)
+    (when (buffer-live-p fuel-completion--comp-buffer)
+      (kill-buffer fuel-completion--comp-buffer))))
+
+(defun fuel-completion--maybe-restore-window-configuration ()
+  "Restore the window configuration, if the following command
+terminates a current completion."
+  (remove-hook 'pre-command-hook
+               'fuel-completion--maybe-restore-window-configuration)
+  (condition-case err
+      (cond ((find last-command-char "()\"'`,# \r\n:")
+             (fuel-completion--restore-window-configuration))
+            ((not (fuel-completion--window-active-p))
+             (fuel-completion--forget-window-configuration))
+            (t (fuel-completion--delay-restoration)))
+    (error
+     ;; Because this is called on the pre-command-hook, we mustn't let
+     ;; errors propagate.
+     (message "Error in fuel-completion--restore-window-configuration: %S" err))))
+
+(defun fuel-completion--window-active-p ()
+  "Is the completion window currently active?"
+  (and (window-live-p fuel-completion--completions-window)
+       (equal (buffer-name (window-buffer fuel-completion--completions-window))
+              fuel-completion--comp-buffer)))
+
+(defun fuel-completion--display-comp-list (completions base)
+  (let ((savedp (fuel-completion--maybe-save-window-configuration)))
+    (with-output-to-temp-buffer fuel-completion--comp-buffer
+      (display-completion-list completions)
+      (let ((offset (- (point) 1 (length base))))
+        (with-current-buffer standard-output
+          (setq completion-base-size offset)
+          (set-syntax-table fuel-syntax--syntax-table))))
+    (when savedp
+      (setq fuel-completion--completions-window
+            (get-buffer-window fuel-completion--comp-buffer)))))
+
+(defun fuel-completion--display-or-scroll (completions base)
+  (cond ((and (eq last-command this-command) (fuel-completion--window-active-p))
+         (fuel-completion--scroll-completions))
+        (t (fuel-completion--display-comp-list completions base)))
+  (fuel-completion--delay-restoration))
+
+(defun fuel-completion--scroll-completions ()
+  (let ((window fuel-completion--completions-window))
+    (with-current-buffer (window-buffer window)
+      (if (pos-visible-in-window-p (point-max) window)
+          (set-window-start window (point-min))
+        (save-selected-window
+          (select-window window)
+          (scroll-up))))))
+
+
+;;; Completion functionality:
+
+(defsubst fuel-completion--word-list (prefix)
+  (let ((fuel-log--inhibit-p t))
+    (fuel-completion--words
+     prefix `("syntax" ,(fuel-syntax--current-vocab) ,@(fuel-syntax--usings)))))
+
+(defun fuel-completion--complete (prefix)
+  (let* ((words (fuel-completion--word-list prefix))
+         (completions (all-completions prefix words))
+         (partial (try-completion prefix words))
+         (partial (if (eq partial t) prefix partial)))
+    (cons completions partial)))
+
+(defun fuel-completion--complete-symbol ()
+  "Complete the symbol at point.
+Perform completion similar to Emacs' complete-symbol."
+  (interactive)
+  (let* ((end (point))
+         (beg (fuel-syntax--symbol-start))
+         (prefix (buffer-substring-no-properties beg end))
+         (result (fuel-completion--complete prefix))
+         (completions (car result))
+         (partial (cdr result)))
+    (cond ((null completions)
+           (fuel--respecting-message "Can't find completion for %S" prefix)
+           (fuel-completion--restore-window-configuration))
+          (t (insert-and-inherit (substring partial (length prefix)))
+             (cond ((= (length completions) 1)
+                    (fuel--respecting-message "Sole completion")
+                    (fuel-completion--restore-window-configuration))
+                   (t (fuel--respecting-message "Complete but not unique")
+                      (fuel-completion--display-or-scroll completions
+                                                          partial)))))))
+
+
+(provide 'fuel-completion)
+;;; fuel-completion.el ends here

misc/fuel/fuel-connection.el

@@ -74,10 +74,11 @@
 
 (defsubst fuel-con--make-connection (buffer)
   (list :fuel-connection
-        (list :requests)
+        (cons :requests (list))
-        (list :current)
+        (cons :current nil)
         (cons :completed (make-hash-table :weakness 'value))
-        (cons :buffer buffer)))
+        (cons :buffer buffer)
+        (cons :timer nil)))
 
 (defsubst fuel-con--connection-p (c)
   (and (listp c) (eq (car c) :fuel-connection)))
@@ -110,6 +111,15 @@
         (fuel-con--connection-pop-request c)
       (cdr current))))
 
+(defun fuel-con--connection-start-timer (c)
+  (let ((cell (assoc :timer c)))
+    (when (cdr cell) (cancel-timer (cdr cell)))
+    (setcdr cell (run-at-time t 0.5 'fuel-con--process-next c))))
+
+(defun fuel-con--connection-cancel-timer (c)
+  (let ((cell (assoc :timer c)))
+    (when (cdr cell) (cancel-timer (cdr cell)))))
+
 
 ;;; Connection setup:
 
@@ -117,7 +127,9 @@
   (set-buffer buffer)
   (let ((conn (fuel-con--make-connection buffer)))
     (fuel-con--setup-comint)
-    (setq fuel-con--connection conn)))
+    (prog1
+        (setq fuel-con--connection conn)
+      (fuel-con--connection-start-timer conn))))
 
 (defun fuel-con--setup-comint ()
   (add-hook 'comint-redirect-filter-functions
@@ -133,13 +145,13 @@
     (let* ((buffer (fuel-con--connection-buffer con))
            (req (fuel-con--connection-pop-request con))
            (str (and req (fuel-con--request-string req))))
+      (if (not (buffer-live-p buffer))
+          (fuel-con--connection-cancel-timer con)
         (when (and buffer req str)
           (set-buffer buffer)
-        (when fuel-log--verbose-p
+          (fuel-log--info "<%s>: %s" (fuel-con--request-id req) str)
-          (with-current-buffer (fuel-log--buffer)
+          (comint-redirect-send-command (format "%s" str)
-            (let ((inhibit-read-only t))
+                                        (fuel-log--buffer) nil t))))))
-              (fuel-log--info "<%s>: %s" (fuel-con--request-id req) str))))
-        (comint-redirect-send-command str (fuel-log--buffer) nil t)))))
 
 (defun fuel-con--process-completed-request (req)
   (let ((str (fuel-con--request-output req))
@@ -164,7 +176,7 @@
       (if (not req) (fuel-log--error "No current request (%s)" str)
         (fuel-con--request-output req str)
         (fuel-log--info "<%s>: in progress" (fuel-con--request-id req)))))
-  ".")
+  (fuel--shorten-str str 70))
 
 (defun fuel-con--comint-redirect-hook ()
   (if (not fuel-con--connection)
@@ -196,12 +208,15 @@
            (req (fuel-con--send-string buffer/proc str cont sbuf))
            (id (and req (fuel-con--request-id req)))
            (time (or timeout fuel-connection-timeout))
-         (step 2))
+           (step 100)
+           (waitsecs (/ step 1000.0)))
       (when id
+        (condition-case nil
             (while (and (> time 0)
                         (not (fuel-con--connection-completed-p con id)))
-          (sleep-for 0 step)
+              (accept-process-output nil waitsecs)
               (setq time (- time step)))
+          (error (setq time 1)))
         (or (> time 0)
             (fuel-con--request-deactivate req)
             nil)))))

misc/fuel/fuel-debug.el

@@ -119,6 +119,7 @@
       (setq fuel-debug--last-ret ret)
       (setq fuel-debug--file file)
       (goto-char (point-max))
+      (font-lock-fontify-buffer)
       (when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer))
       (not err))))
 
@@ -130,7 +131,7 @@
          (trail (and last (substring-no-properties last (/ llen 2))))
          (err (fuel-eval--retort-error ret))
          (p (point)))
-    (save-excursion (insert current))
+    (when current (save-excursion (insert current)))
     (when (and (> clen llen) (> llen 0) (search-forward trail nil t))
       (delete-region p (point)))
     (goto-char (point-max))

misc/fuel/fuel-eval.el

@@ -17,6 +17,8 @@
 (require 'fuel-syntax)
 (require 'fuel-connection)
 
+(eval-when-compile (require 'cl))
+
 
 ;;; Simple sexp-based representation of factor code
 
@@ -39,7 +41,7 @@
                    (:rs 'fuel-eval-restartable)
                    (:nrs 'fuel-eval-non-restartable)
                    (:in (fuel-syntax--current-vocab))
-                   (:usings `(:array ,@(fuel-syntax--usings-update)))
+                   (:usings `(:array ,@(fuel-syntax--usings)))
                    (:get 'fuel-eval-set-result)
                    (t `(:factor ,(symbol-name sexp))))))
         ((symbolp sexp) (symbol-name sexp))))

misc/fuel/fuel-help.el

@@ -73,7 +73,7 @@
 
 (defun fuel-help--word-synopsis (&optional word)
   (let ((word (or word (fuel-syntax-symbol-at-point)))
-        (fuel-eval--log t))
+        (fuel-log--inhibit-p t))
     (when word
       (let* ((cmd `(:fuel* (((:quote ,word) synopsis :get)) t))
              (ret (fuel-eval--send/wait cmd 20)))
@@ -157,7 +157,7 @@ displayed in the minibuffer."
 (defun fuel-help--show-help-cont (def ret)
   (let ((out (fuel-eval--retort-output ret)))
     (if (or (fuel-eval--retort-error ret) (empty-string-p out))
-        (message "No help for '%s'" def)
+        (message "No help for '%s'" ret)
       (fuel-help--insert-contents def out))))
 
 (defun fuel-help--insert-contents (def str &optional nopush)
@@ -225,6 +225,8 @@ buffer."
     (define-key map "q" 'bury-buffer)
     (define-key map "b" 'fuel-help-previous)
     (define-key map "f" 'fuel-help-next)
+    (define-key map "l" 'fuel-help-previous)
+    (define-key map "n" 'fuel-help-next)
     (define-key map (kbd "SPC")  'scroll-up)
     (define-key map (kbd "S-SPC") 'scroll-down)
     map))

misc/fuel/fuel-listener.el

@@ -49,9 +49,16 @@ buffer."
 
 ;;; Fuel listener buffer/process:
 
-(defvar fuel-listener-buffer nil
+(defvar fuel-listener--buffer nil
   "The buffer in which the Factor listener is running.")
 
+(defun fuel-listener--buffer ()
+  (if (buffer-live-p fuel-listener--buffer)
+      fuel-listener--buffer
+    (with-current-buffer (get-buffer-create "*fuel listener*")
+      (fuel-listener-mode)
+      (setq fuel-listener--buffer (current-buffer)))))
+
 (defun fuel-listener--start-process ()
   (let ((factor (expand-file-name fuel-listener-factor-binary))
         (image (expand-file-name fuel-listener-factor-image)))
@@ -59,19 +66,18 @@ buffer."
       (error "Could not run factor: %s is not executable" factor))
     (unless (file-readable-p image)
       (error "Could not run factor: image file %s not readable" image))
-    (setq fuel-listener-buffer (get-buffer-create "*fuel listener*"))
-    (with-current-buffer fuel-listener-buffer
-      (fuel-listener-mode)
     (message "Starting FUEL listener ...")
-      (comint-exec fuel-listener-buffer "factor"
+    (comint-exec (fuel-listener--buffer) "factor"
                  factor nil `("-run=fuel" ,(format "-i=%s" image)))
-      (fuel-listener--wait-for-prompt 20)
+    (pop-to-buffer (fuel-listener--buffer))
-      (fuel-eval--send/wait "USE: fuel")
+    (goto-char (point-max))
-      (message "FUEL listener up and running!"))))
+    (comint-send-string nil "USE: fuel \"\\nFUEL loaded\\n\" write\n")
+    (fuel-listener--wait-for-prompt 30)
+    (message "FUEL listener up and running!")))
 
 (defun fuel-listener--process (&optional start)
-  (or (and (buffer-live-p fuel-listener-buffer)
+  (or (and (buffer-live-p (fuel-listener--buffer))
-           (get-buffer-process fuel-listener-buffer))
+           (get-buffer-process (fuel-listener--buffer)))
       (if (not start)
           (error "No running factor listener (try M-x run-factor)")
         (fuel-listener--start-process)
@@ -83,18 +89,17 @@ buffer."
 ;;; Prompt chasing
 
 (defun fuel-listener--wait-for-prompt (&optional timeout)
-  (let ((proc (get-buffer-process fuel-listener-buffer)))
+  (let ((proc (get-buffer-process (fuel-listener--buffer)))
-    (with-current-buffer fuel-listener-buffer
+        (seen))
-      (goto-char (or comint-last-input-end (point-min)))
+    (with-current-buffer (fuel-listener--buffer)
-      (let ((seen (re-search-forward comint-prompt-regexp nil t)))
+      (goto-char (or comint-last-input-end (point-max)))
       (while (and (not seen)
                   (accept-process-output proc (or timeout 10) nil t))
         (sleep-for 0 1)
         (goto-char comint-last-input-end)
         (setq seen (re-search-forward comint-prompt-regexp nil t)))
-        (pop-to-buffer fuel-listener-buffer)
       (goto-char (point-max))
-        (unless seen (error "No prompt found!"))))))
+      (unless seen (error "No prompt found!")))))
 
 
 ;;; Interface: starting fuel listener
@@ -114,13 +119,12 @@ buffer."
 
 ;;; Fuel listener mode:
 
-(defconst fuel-listener--prompt-regex "( [^)]* ) ")
+(defconst fuel-listener--prompt-regex ".* ) ")
 
 (define-derived-mode fuel-listener-mode comint-mode "Fuel Listener"
   "Major mode for interacting with an inferior Factor listener process.
 \\{fuel-listener-mode-map}"
-  (set (make-local-variable 'comint-prompt-regexp)
+  (set (make-local-variable 'comint-prompt-regexp) fuel-listener--prompt-regex)
-       fuel-listener--prompt-regex)
   (set (make-local-variable 'comint-prompt-read-only) t)
   (setq fuel-listener--compilation-begin nil))
 

misc/fuel/fuel-log.el

@@ -31,6 +31,9 @@
 (defvar fuel-log--verbose-p t
   "Log level for Factor messages")
 
+(defvar fuel-log--inhibit-p nil
+  "Set this to t to inhibit all log messages")
+
 (define-derived-mode factor-messages-mode fundamental-mode "FUEL Messages"
   "Simple mode to log interactions with the factor listener"
   (kill-all-local-variables)
@@ -52,11 +55,12 @@
         (current-buffer))))
 
 (defun fuel-log--msg (type &rest args)
+  (unless fuel-log--inhibit-p
     (with-current-buffer (fuel-log--buffer)
       (let ((inhibit-read-only t))
         (insert
          (fuel--shorten-str (format "\n%s: %s\n" type (apply 'format args))
-                          fuel-log--max-message-size)))))
+                            fuel-log--max-message-size))))))
 
 (defsubst fuel-log--warn (&rest args)
   (apply 'fuel-log--msg 'WARNING args))
@@ -65,7 +69,8 @@
   (apply 'fuel-log--msg 'ERROR args))
 
 (defsubst fuel-log--info (&rest args)
-  (if fuel-log--verbose-p (apply 'fuel-log--msg 'INFO args) ""))
+  (when fuel-log--verbose-p
+    (apply 'fuel-log--msg 'INFO args) ""))
 
 
 (provide 'fuel-log)

misc/fuel/fuel-mode.el

@@ -21,6 +21,7 @@
 (require 'fuel-debug)
 (require 'fuel-help)
 (require 'fuel-eval)
+(require 'fuel-completion)
 (require 'fuel-listener)
 
 
@@ -67,13 +68,12 @@ buffer in case of errors."
   (interactive "r\nP")
   (let* ((lines (split-string (buffer-substring-no-properties begin end)
                               "[\f\n\r\v]+" t))
-         (cmd `(:fuel (,(mapcar (lambda (l) `(:factor ,l)) lines)))))
+         (cmd `(:fuel (,(mapcar (lambda (l) `(:factor ,l)) lines))))
+         (cv (fuel-syntax--current-vocab)))
     (fuel-debug--display-retort
      (fuel-eval--send/wait cmd 10000)
      (format "%s%s"
-             (if fuel-syntax--current-vocab
+             (if cv (format "IN: %s " cv) "")
-                 (format "IN: %s " fuel-syntax--current-vocab)
-               "")
              (fuel--shorten-region begin end 70))
      arg
      (buffer-file-name))))
@@ -125,23 +125,24 @@ With prefix, asks for the word to edit."
     (let ((cmd `(:fuel ((:quote ,word) fuel-get-edit-location))))
       (condition-case nil
           (fuel--try-edit (fuel-eval--send/wait cmd))
-        (error (fuel-edit-vocabulary word))))))
+        (error (fuel-edit-vocabulary nil word))))))
 
 (defvar fuel--vocabs-prompt-history nil)
 
-(defun fuel--read-vocabulary-name ()
+(defun fuel--read-vocabulary-name (refresh)
-  (let* ((cmd '(:fuel* (fuel-get-vocabs) "fuel" t))
+  (let* ((vocabs (fuel-completion--vocabs refresh))
-         (vocabs (fuel-eval--retort-result (fuel-eval--send/wait cmd)))
          (prompt "Vocabulary name: "))
     (if vocabs
         (completing-read prompt vocabs nil t nil fuel--vocabs-prompt-history)
       (read-string prompt nil fuel--vocabs-prompt-history))))
 
-(defun fuel-edit-vocabulary (vocab)
+(defun fuel-edit-vocabulary (&optional refresh vocab)
   "Visits vocabulary file in Emacs.
-When called interactively, asks for vocabulary with completion."
+When called interactively, asks for vocabulary with completion.
-  (interactive (list (fuel--read-vocabulary-name)))
+With prefix argument, refreshes cached vocabulary list."
-  (let* ((cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t)))
+  (interactive "P")
+  (let* ((vocab (or vocab (fuel--read-vocabulary-name refresh)))
+         (cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t)))
     (fuel--try-edit (fuel-eval--send/wait cmd))))
 
 
@@ -183,22 +184,19 @@ interacting with a factor listener is at your disposal.
   (define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c))
 
 (fuel-mode--key-1 ?z 'run-factor)
-
 (fuel-mode--key-1 ?k 'fuel-run-file)
-(fuel-mode--key ?e ?k 'fuel-run-file)
+(fuel-mode--key-1 ?r 'fuel-eval-region)
 
 (define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
-(fuel-mode--key ?e ?x 'fuel-eval-definition)
-
-(fuel-mode--key-1 ?r 'fuel-eval-region)
-(fuel-mode--key ?e ?r 'fuel-eval-region)
-
 (define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
-(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
-
-(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
-
 (define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point)
+(define-key fuel-mode-map (kbd "M-TAB") 'fuel-completion--complete-symbol)
+
+(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
+(fuel-mode--key ?e ?r 'fuel-eval-region)
+(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
+(fuel-mode--key ?e ?w 'fuel-edit-word-at-point)
+(fuel-mode--key ?e ?x 'fuel-eval-definition)
 
 (fuel-mode--key ?d ?a 'fuel-autodoc-mode)
 (fuel-mode--key ?d ?d 'fuel-help)

misc/fuel/fuel-syntax.el

@@ -22,11 +22,17 @@
   (while (eq (char-before) ?:) (backward-char))
   (skip-syntax-backward "w_"))
 
+(defsubst fuel-syntax--symbol-start ()
+  (save-excursion (fuel-syntax--beginning-of-symbol) (point)))
+
 (defun fuel-syntax--end-of-symbol ()
   "Move point to the end of the current symbol."
   (skip-syntax-forward "w_")
   (while (looking-at ":") (forward-char)))
 
+(defsubst fuel-syntax--symbol-end ()
+  (save-excursion (fuel-syntax--end-of-symbol) (point)))
+
 (put 'factor-symbol 'end-op 'fuel-syntax--end-of-symbol)
 (put 'factor-symbol 'beginning-op 'fuel-syntax--beginning-of-symbol)
 
@@ -34,6 +40,7 @@
   (let ((s (substring-no-properties (thing-at-point 'factor-symbol))))
     (and (> (length s) 0) s)))
 
+
 
 ;;; Regexps galore:
 
@@ -43,7 +50,7 @@
     "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
     "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
     "IN:" "INSTANCE:" "INTERSECTION:"
-    "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:"
+    "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "METHOD:" "MIXIN:"
     "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
     "REQUIRE:"  "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
     "TUPLE:" "T{" "t\\??" "TYPEDEF:"
@@ -91,7 +98,7 @@
 (defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
 
 (defconst fuel-syntax--definition-starters-regex
-  (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" "")))
+  (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" "MEMO" "METHOD" ":" "")))
 
 (defconst fuel-syntax--definition-start-regex
   (format "^\\(%s:\\) " fuel-syntax--definition-starters-regex))
@@ -234,17 +241,12 @@
 
 ;;; USING/IN:
 
-(make-variable-buffer-local
- (defvar fuel-syntax--current-vocab nil))
-
-(make-variable-buffer-local
- (defvar fuel-syntax--usings nil))
-
 (defun fuel-syntax--current-vocab ()
-  (let ((ip
+  (let* ((vocab)
+         (ip
           (save-excursion
             (when (re-search-backward fuel-syntax--current-vocab-regex nil t)
-             (setq fuel-syntax--current-vocab (match-string-no-properties 1))
+              (setq vocab (match-string-no-properties 1))
               (point)))))
     (when ip
       (let ((pp (save-excursion
@@ -253,29 +255,19 @@
         (when (and pp (> pp ip))
           (let ((sub (match-string-no-properties 1)))
             (unless (save-excursion (search-backward (format "%s>" sub) pp t))
-              (setq fuel-syntax--current-vocab
+              (setq vocab (format "%s.%s" vocab (downcase sub))))))))
-                    (format "%s.%s" fuel-syntax--current-vocab (downcase sub)))))))))
+    vocab))
-  fuel-syntax--current-vocab)
 
-(defun fuel-syntax--usings-update ()
+(defun fuel-syntax--usings ()
   (save-excursion
-    (let ((in (fuel-syntax--current-vocab)))
+    (let ((usings)
-      (setq fuel-syntax--usings (and in (list in))))
+          (in (fuel-syntax--current-vocab)))
+      (when in (setq usings (list in)))
+      (goto-char (point-max))
       (while (re-search-backward fuel-syntax--using-lines-regex nil t)
         (dolist (u (split-string (match-string-no-properties 1) nil t))
-        (push u fuel-syntax--usings)))
+          (push u usings)))
-    fuel-syntax--usings))
+      usings)))
-
-(defsubst fuel-syntax--usings-update-hook ()
-  (fuel-syntax--usings-update)
-  nil)
-
-(defun fuel-syntax--enable-usings ()
-  (add-hook 'before-save-hook 'fuel-syntax--usings-update-hook nil t)
-  (fuel-syntax--usings-update))
-
-(defsubst fuel-syntax--usings ()
-  (or fuel-syntax--usings (fuel-syntax--usings-update)))
 
 
 (provide 'fuel-syntax)