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

.gitignore

@@ -21,3 +21,4 @@ logs
 work
 build-support/wordsize
 *.bak
+.#*

basis/compiler/utilities/utilities.factor

@@ -21,11 +21,3 @@ IN: compiler.utilities
 : map-flat ( seq quot -- seq' ) [ each ] flattening ; inline
 
 : 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
-
-: (3each) ( seq1 seq2 seq3 quot -- n quot' )
-    [ [ [ length ] tri@ min min ] 3keep ] dip
-    '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline
-
-: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
-
-: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline

basis/farkup/farkup-tests.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: farkup kernel peg peg.ebnf tools.test namespaces ;
+USING: farkup kernel peg peg.ebnf tools.test namespaces xml
+urls.encoding assocs xml.utilities ;
 IN: farkup.tests
 
 relative-link-prefix off
@@ -157,3 +158,12 @@ link-no-follow? off
 
 [ "<p>hello_world how are you today?\n<ul><li> hello_world how are you today?</li></ul></p>" ]
 [ "hello_world how are you today?\n- hello_world how are you today?" convert-farkup ] unit-test
+
+: check-link-escaping ( string -- link )
+    convert-farkup string>xml-chunk
+    "a" deep-tag-named "href" swap at url-decode ;
+
+[ "Trader Joe's" ] [ "[[Trader Joe's]]" check-link-escaping ] unit-test
+[ "<foo>" ] [ "[[<foo>]]" check-link-escaping ] unit-test
+[ "&blah;" ] [ "[[&blah;]]" check-link-escaping ] unit-test
+[ "C++" ] [ "[[C++]]" check-link-escaping ] unit-test

basis/farkup/farkup.factor

@@ -167,7 +167,7 @@ stand-alone
     } cond ;
 
 : escape-link ( href text -- href-esc text-esc )
-    [ check-url escape-quoted-string ] dip escape-string ;
+    [ check-url ] dip escape-string ;
 
 : write-link ( href text -- )
     escape-link

basis/grouping/grouping-docs.factor

@@ -29,8 +29,7 @@ ABOUT: "grouping"
 HELP: groups
 { $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
 $nl
-"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
+"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." } ;
-{ $see-also group } ;
 
 HELP: group
 { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
@@ -48,11 +47,16 @@ HELP: <groups>
         "USING: arrays kernel prettyprint sequences grouping ;"
         "9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
     }
+    { $example
+        "USING: kernel prettyprint sequences grouping ;"
+        "{ 1 2 3 4 5 6 } 3 <groups> 0 swap nth ."
+        "{ 1 2 3 }"
+    }
 } ;
 
 HELP: <sliced-groups>
 { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are slices of disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
 { $examples
     { $example
         "USING: arrays kernel prettyprint sequences grouping ;"
@@ -60,6 +64,11 @@ HELP: <sliced-groups>
         "dup [ reverse-here ] each concat >array ."
         "{ 2 1 0 5 4 3 8 7 6 }"
     }
+    { $example
+        "USING: kernel prettyprint sequences grouping ;"
+        "{ 1 2 3 4 5 6 } 3 <sliced-groups> 1 swap nth ."
+        "T{ slice { from 3 } { to 6 } { seq { 1 2 3 4 5 6 } } }"
+    }
 } ;
 
 HELP: clumps
@@ -89,11 +98,23 @@ HELP: <clumps>
         "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
         "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
     }
+    { $example
+        "USING: kernel sequences grouping prettyprint ;"
+        "{ 1 2 3 4 5 6 } 3 <clumps> 1 swap nth ."
+        "{ 2 3 4 }"
+    }
 } ;
 
 HELP: <sliced-clumps>
 { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
-{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+    { $example
+        "USING: kernel sequences grouping prettyprint ;"
+        "{ 1 2 3 4 5 6 } 3 <sliced-clumps> 1 swap nth ."
+        "T{ slice { from 1 } { to 4 } { seq { 1 2 3 4 5 6 } } }"
+    }
+} ;
 
 { clumps groups } related-words
 

basis/math/miller-rabin/miller-rabin.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators io locals kernel math math.functions
+USING: combinators kernel locals math math.functions math.ranges
-math.ranges namespaces random sequences hashtables sets ;
+random sequences sets ;
 IN: math.miller-rabin
 
 <PRIVATE
@@ -37,7 +37,7 @@ PRIVATE>
         { [ dup 1 <= ] [ 3drop f ] }
         { [ dup 2 = ] [ 3drop t ] }
         { [ dup even? ] [ 3drop f ] }
-        [ [ drop (miller-rabin) ] with-scope ]
+        [ drop (miller-rabin) ]
     } cond ;
 
 : miller-rabin ( n -- ? ) 10 miller-rabin* ;

core/kernel/kernel-docs.factor

@@ -359,6 +359,17 @@ HELP: 2bi*
     }
 } ;
 
+HELP: 2tri*
+{ $values { "u" object } { "v" object } { "w" object } { "x" object } { "y" object } { "z" object } { "p" { $quotation "( u v -- ... )" } } { "q" { $quotation "( w x -- ... )" } } { "r" { $quotation "( y z -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to " { $snippet "u" } " and " { $snippet "v" } ", then applies " { $snippet "q" } " to " { $snippet "w" } " and " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "y" } " and " { $snippet "z" } "." }
+{ $examples
+    "The following two lines are equivalent:"
+    { $code
+        "[ p ] [ q ] [ r ] 2tri*"
+        "[ [ p ] 2dip q ] 2dip r"
+    }
+} ;
+
 HELP: tri*
 { $values { "x" object } { "y" object } { "z" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( y -- ... )" } } { "r" { $quotation "( z -- ... )" } } }
 { $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } ", and finally applies " { $snippet "r" } " to " { $snippet "z" } "." }
@@ -418,6 +429,22 @@ HELP: tri@
     }
 } ;
 
+HELP: 2tri@
+{ $values { "u" object } { "v" object } { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- ... )" } } }
+{ $description "Applies the quotation to " { $snippet "u" } " and " { $snippet "v" } ", then to " { $snippet "w" } " and " { $snippet "x" } ", and then to " { $snippet "y" } " and " { $snippet "z" } "." }
+{ $examples
+    "The following two lines are equivalent:"
+    { $code
+        "[ p ] 2tri@"
+        "[ [ p ] 2dip p ] 2dip p"
+    }
+    "The following two lines are also equivalent:"
+    { $code
+        "[ p ] 2tri@"
+        "[ p ] [ p ] [ p ] 2tri*"
+    }
+} ;
+
 HELP: if
 { $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } }
 { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation."
@@ -595,12 +622,20 @@ HELP: 2dip
 
 HELP: 3dip
 { $values { "x" object } { "y" object } { "z" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." }
+{ $description "Calls " { $snippet "quot" } " with " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." }
 { $notes "The following are equivalent:"
     { $code "[ [ [ foo bar ] dip ] dip ] dip" }
     { $code "[ foo bar ] 3dip" }
 } ;
 
+HELP: 4dip
+{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" quotation } }
+{ $description "Calls " { $snippet "quot" } " with " { $snippet "w" } ", " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." }
+{ $notes "The following are equivalent:"
+    { $code "[ [ [ [ foo bar ] dip ] dip ] dip ] dip" }
+    { $code "[ foo bar ] 4dip" }
+} ;
+
 HELP: while
 { $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
 { $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ;
@@ -735,7 +770,7 @@ $nl
 { $subsection "cleave-shuffle-equivalence" } ;
 
 ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
-"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
+"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "."
 $nl
 "Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
 { $code
@@ -775,6 +810,7 @@ $nl
 { $subsection 2bi* }
 "Three quotations:"
 { $subsection tri* }
+{ $subsection 2tri* }
 "Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
 { $code
     "! First alternative; uses dip"
@@ -793,6 +829,7 @@ $nl
 { $subsection 2bi@ }
 "Three quotations:"
 { $subsection tri@ }
+{ $subsection 2tri@ }
 "A pair of utility words built from " { $link bi@ } ":"
 { $subsection both? }
 { $subsection either? } ;
@@ -804,6 +841,7 @@ $nl
 { $subsection dip }
 { $subsection 2dip }
 { $subsection 3dip }
+{ $subsection 4dip }
 "The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
 { $subsection slip }
 { $subsection 2slip }

core/kernel/kernel-tests.factor

@@ -163,3 +163,9 @@ IN: kernel.tests
     [ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors
     last-frame
 ] unit-test
+
+[ 10 2 3 4 5 ] [ 1 2 3 4 5 [ 10 * ] 4dip ] unit-test
+
+[ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test
+
+[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test

core/kernel/kernel.factor

@@ -79,6 +79,8 @@ DEFER: if
 
 : 3dip ( x y z quot -- x y z ) -roll 3slip ;
 
+: 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline
+
 ! Keepers
 : keep ( x quot -- x ) over slip ; inline
 
@@ -118,6 +120,9 @@ DEFER: if
 : 2bi* ( w x y z p q -- )
     [ 2dip ] dip call ; inline
 
+: 2tri* ( u v w x y z p q r -- )
+    [ 4dip ] 2dip 2bi* ; inline
+
 ! Appliers
 : bi@ ( x y quot -- )
     dup bi* ; inline
@@ -129,6 +134,9 @@ DEFER: if
 : 2bi@ ( w x y z quot -- )
     dup 2bi* ; inline
 
+: 2tri@ ( u v w y x z quot -- )
+    dup dup 2tri* ; inline
+
 ! Object protocol
 GENERIC: hashcode* ( depth obj -- code )
 

core/sequences/sequences-docs.factor

@@ -1112,15 +1112,6 @@ HELP: virtual@
      { "n'" integer } { "seq'" sequence } }
 { $description "Part of the sequence protocol, this word translates the input index " { $snippet "n" } " into an index into the underlying storage returned by " { $link virtual-seq } "." } ;
 
-HELP: 2change-each
-{ $values
-     { "seq1" sequence } { "seq2" sequence } { "quot" quotation } }
-{ $description "Calls the quotation on subsequent pairs of objects from the two input sequences. The resulting computation replaces the element in the first sequence." }
-{ $examples { $example "USING: kernel math sequences prettyprint ;"
-    "{ 10 20 30 } dup { 60 70 80 } [ + ] 2change-each ."
-    "{ 70 90 110 }"
-} } ;
-
 HELP: 2map-reduce
 { $values
      { "seq1" sequence } { "seq2" sequence } { "map-quot" quotation } { "reduce-quot" quotation }

core/sequences/sequences-tests.factor

@@ -55,6 +55,11 @@ IN: sequences.tests
 
 [ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry filter ] unit-test
 
+[ V{ 1 2 3 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 4 < ] filter-here ] keep ] unit-test
+[ V{ 4 2 6 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 2 mod 0 = ] filter-here ] keep ] unit-test
+
+[ V{ 3 } ] [ V{ 1 2 3 } clone [ 2 [ swap < ] curry filter-here ] keep ] unit-test
+
 [ "hello world how are you" ]
 [ { "hello" "world" "how" "are" "you" } " " join ]
 unit-test
@@ -261,3 +266,14 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
 
 [ "a,b" ] [ "a" "b" "," glue ] unit-test
 [ "(abc)" ] [ "abc" "(" ")" surround ] unit-test
+
+[ "HELLO" ] [
+    "HELLO" { -1 -1 -1 -1 -1 } { 2 2 2 2 2 2 }
+    [ * 2 + + ] 3map
+] unit-test
+
+{ 3 1 } [ [ 3array ] 3map ] must-infer-as
+
+{ 3 0 } [ [ 3drop ] 3each ] must-infer-as
+
+[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test

core/sequences/sequences.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2005, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel kernel.private slots.private math
 math.private math.order ;
@@ -117,9 +117,9 @@ INSTANCE: integer immutable-sequence
     [ tuck [ nth-unsafe ] 2bi@ ]
     [ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline
 
-: (head) ( seq n -- from to seq ) 0 spin ; inline
+: (head) ( seq n -- from to seq ) [ 0 ] 2dip swap ; inline
 
-: (tail) ( seq n -- from to seq ) over length rot ; inline
+: (tail) ( seq n -- from to seq ) swap [ length ] keep ; inline
 
 : from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline
 
@@ -346,11 +346,19 @@ PRIVATE>
     [ over ] dip [ nth-unsafe ] 2bi@ ; inline
 
 : (2each) ( seq1 seq2 quot -- n quot' )
-    [ [ min-length ] 2keep ] dip
+    [
-    [ [ 2nth-unsafe ] dip call ] 3curry ; inline
+        [ min-length ] 2keep
+        [ 2nth-unsafe ] 2curry
+    ] dip compose ; inline
 
-: 2map-into ( seq1 seq2 quot into -- newseq )
+: 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 )
-    [ (2each) ] dip collect ; inline
+    [ over ] 2dip [ over ] dip [ nth-unsafe ] 2tri@ ; inline
+
+: (3each) ( seq1 seq2 seq3 quot -- n quot' )
+    [
+        [ [ length ] tri@ min min ] 3keep
+        [ 3nth-unsafe ] 3curry
+    ] dip compose ; inline
 
 : finish-find ( i seq -- i elt )
     over [ dupd nth-unsafe ] [ drop f ] if ; inline
@@ -407,18 +415,23 @@ PRIVATE>
     [ -rot ] dip 2each ; inline
 
 : 2map-as ( seq1 seq2 quot exemplar -- newseq )
-    [ 2over min-length ] dip
+    [ (2each) ] dip map-as ; inline
-    [ [ 2map-into ] keep ] new-like ; inline
 
 : 2map ( seq1 seq2 quot -- newseq )
     pick 2map-as ; inline
 
-: 2change-each ( seq1 seq2 quot -- )
-    pick 2map-into ; inline
-
 : 2all? ( seq1 seq2 quot -- ? )
     (2each) all-integers? ; inline
 
+: 3each ( seq1 seq2 seq3 quot -- )
+    (3each) each ; inline
+
+: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq )
+    [ (3each) ] dip map-as ; inline
+
+: 3map ( seq1 seq2 seq3 quot -- newseq )
+    [ pick ] dip swap 3map-as ; inline
+
 : find-from ( n seq quot -- i elt )
     [ (find-integer) ] (find-from) ; inline
 
@@ -494,10 +507,12 @@ PRIVATE>
 : last-index-from ( obj i seq -- n )
     rot [ = ] curry find-last-from drop ;
 
+: (indices) ( elt i obj accum -- )
+    [ swap [ = ] dip ] dip [ push ] 2curry when ; inline
+
 : indices ( obj seq -- indices )
-    V{ } clone spin
+    swap V{ } clone
-    [ rot = [ over push ] [ drop ] if ]
+    [ [ (indices) ] 2curry each-index ] keep ;
-    curry each-index ;
 
 : nths ( indices seq -- seq' )
     [ nth ] curry map ;
@@ -566,7 +581,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
 PRIVATE>
 
 : filter-here ( seq quot -- )
-    0 0 roll (filter-here) ; inline
+    swap [ 0 0 ] dip (filter-here) ; inline
 
 : delete ( elt seq -- )
     [ = not ] with filter-here ;
@@ -828,7 +843,7 @@ PRIVATE>
 
 : supremum ( seq -- n ) dup first [ max ] reduce ;
 
-: sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline
+: sigma ( seq quot -- n ) [ 0 ] 2dip [ rot slip + ] curry each ; inline
 
 : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
 

extra/L-system/L-system.factor

@@ -0,0 +1,448 @@
+
+USING: accessors arrays assocs colors combinators.short-circuit
+kernel locals math math.functions math.matrices math.order
+math.parser math.trig math.vectors opengl opengl.demo-support
+opengl.gl sbufs sequences strings ui.gadgets ui.gadgets.worlds
+ui.gestures ui.render ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: L-system
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <turtle> pos ori angle length thickness color vertices saved ;
+
+DEFER: default-L-parser-values
+
+: reset-turtle ( turtle -- turtle )
+  { 0 0 0 } clone   >>pos
+  3 identity-matrix >>ori
+  V{ } clone >>vertices
+  V{ } clone >>saved
+
+  default-L-parser-values ;
+
+: turtle ( -- turtle ) <turtle> new reset-turtle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: step-turtle ( TURTLE LENGTH -- turtle )
+
+  TURTLE
+    TURTLE pos>>   TURTLE ori>> { 0 0 LENGTH } m.v   v+
+  >>pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: Rx ( ANGLE -- Rx )
+  
+  [let | ANGLE [ ANGLE deg>rad ] |
+
+    [let | A [ ANGLE cos     ]
+           B [ ANGLE sin neg ]
+           C [ ANGLE sin     ]
+           D [ ANGLE cos     ] |
+
+      { { 1 0 0 }
+        { 0 A B }
+        { 0 C D } }
+
+    ] ] ;
+
+:: Ry ( ANGLE -- Ry )
+  
+  [let | ANGLE [ ANGLE deg>rad ] |
+
+    [let | A [ ANGLE cos     ]
+           B [ ANGLE sin     ]
+           C [ ANGLE sin neg ]
+           D [ ANGLE cos     ] |
+
+      { { A 0 B }
+        { 0 1 0 }
+        { C 0 D } }
+
+    ] ] ;
+
+:: Rz ( ANGLE -- Rz )
+  
+  [let | ANGLE [ ANGLE deg>rad ] |
+
+    [let | A [ ANGLE cos     ]
+           B [ ANGLE sin neg ]
+           C [ ANGLE sin     ]
+           D [ ANGLE cos     ] |
+
+      { { A B 0 }
+        { C D 0 }
+        { 0 0 1 } }
+
+    ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: apply-rotation ( TURTLE ROTATION -- turtle )
+  
+  TURTLE  TURTLE ori>> ROTATION m.  >>ori ;
+
+: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
+: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
+: rotate-z ( turtle angle -- turtle ) Rz apply-rotation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pitch-up   ( turtle angle -- turtle ) neg rotate-x ;
+: pitch-down ( turtle angle -- turtle )     rotate-x ;
+
+: turn-left  ( turtle angle -- turtle )     rotate-y ;
+: turn-right ( turtle angle -- turtle ) neg rotate-y ;
+
+: roll-left  ( turtle angle -- turtle ) neg rotate-z ;
+: roll-right ( turtle angle -- turtle )     rotate-z ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: V ( -- V ) { 0 1 0 } ;
+
+: X ( turtle -- 3array ) ori>> [ first  ] map ;
+: Y ( turtle -- 3array ) ori>> [ second ] map ;
+: Z ( turtle -- 3array ) ori>> [ third  ] map ;
+
+: set-X ( turtle seq -- turtle ) over ori>> [ set-first  ] 2each ;
+: set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ;
+: set-Z ( turtle seq -- turtle ) over ori>> [ set-third  ] 2each ;
+
+:: roll-until-horizontal ( TURTLE -- turtle )
+
+  TURTLE
+  
+    V         TURTLE Z  cross normalize  set-X
+
+    TURTLE Z  TURTLE X  cross normalize  set-Y ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: strafe-up ( TURTLE LENGTH -- turtle )
+  TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
+
+:: strafe-down ( TURTLE LENGTH -- turtle )
+  TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
+
+:: strafe-left ( TURTLE LENGTH -- turtle )
+  TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
+
+:: strafe-right ( TURTLE LENGTH -- turtle )
+  TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
+
+: start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
+
+: finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
+
+: polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
+
+: draw-forward ( turtle length -- turtle )
+  GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
+
+: move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
+
+: sneak-forward ( turtle length -- turtle ) step-turtle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: scale-length ( turtle m -- turtle ) over length>> * >>length ;
+: scale-angle  ( turtle m -- turtle ) over angle>>  * >>angle  ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
+
+: scale-thickness ( turtle m -- turtle )
+  over thickness>> * 0.5 max set-thickness ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-table ( -- colors )
+  {
+    T{ rgba f 0    0    0    1 } ! black
+    T{ rgba f 0.5  0.5  0.5  1 } ! grey
+    T{ rgba f 1    0    0    1 } ! red
+    T{ rgba f 1    1    0    1 } ! yellow
+    T{ rgba f 0    1    0    1 } ! green
+    T{ rgba f 0.25 0.88 0.82 1 } ! turquoise
+    T{ rgba f 0    0    1    1 } ! blue
+    T{ rgba f 0.63 0.13 0.94 1 } ! purple
+    T{ rgba f 0.00 0.50 0.00 1 } ! dark green
+    T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise
+    T{ rgba f 0.00 0.00 0.50 1 } ! dark blue
+    T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
+    T{ rgba f 0.50 0.00 0.00 1 } ! dark red
+    T{ rgba f 0.25 0.25 0.25 1 } ! dark grey
+    T{ rgba f 0.75 0.75 0.75 1 } ! medium grey
+    T{ rgba f 1    1    1    1 } ! white
+  } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : material-color ( color -- )
+!   GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
+
+: material-color ( color -- )
+  GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ;
+
+: set-color ( turtle i -- turtle )
+  dup color-table nth dup gl-color material-color >>color ;
+
+: inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: save-turtle    ( turtle -- turtle ) dup clone over saved>> push ;
+: restore-turtle ( turtle -- turtle )                saved>> pop  ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-L-parser-values ( turtle -- turtle )
+  1 >>length 45 >>angle 1 >>thickness 2 >>color ;
+
+: L-parser-dialect ( -- commands )
+
+  {
+      { "+" [ dup angle>> turn-left  ] }
+      { "-" [ dup angle>> turn-right ] }
+      { "&" [ dup angle>> pitch-down ] }
+      { "^" [ dup angle>> pitch-up   ] }
+      { "<" [ dup angle>> roll-left  ] }
+      { ">" [ dup angle>> roll-right ] }
+
+      { "|" [ 180.0         rotate-y ] }
+      { "%" [ 180.0         rotate-z ] }
+      { "$" [ roll-until-horizontal  ]  }
+
+      { "F" [ dup length>>     draw-forward  ] }
+      { "Z" [ dup length>> 2 / draw-forward  ] }
+      { "f" [ dup length>>     move-forward  ] }
+      { "z" [ dup length>> 2 / move-forward  ] }
+      { "g" [ dup length>>     sneak-forward ] }
+      { "." [ polygon-vertex                 ] }
+
+      { "[" [ save-turtle      ] }
+      { "]" [ restore-turtle   ] }
+      
+      { "{" [ start-polygon    ] }
+      { "}" [ finish-polygon   ] }
+
+      { "/" [ 1.1 scale-length    ] } ! double quote command in lparser
+      { "'" [ 0.9 scale-length    ] }
+      { ";" [ 1.1 scale-angle     ] }
+      { ":" [ 0.9 scale-angle     ] }
+      { "?" [ 1.4 scale-thickness ] }
+      { "!" [ 0.7 scale-thickness ] }
+
+      { "c" [ dup color>> 1 + color-table length mod set-color ] }
+
+    }
+    ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <L-system> < gadget
+  camera display-list
+  commands axiom rules string ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: open-paren  ( -- ch ) CHAR: ( ;
+: close-paren ( -- ch ) CHAR: ) ;
+
+: open-paren?  ( obj -- ? ) open-paren  = ;
+: close-paren? ( obj -- ? ) close-paren = ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: read-instruction ( STRING -- next rest )
+  
+  { [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
+    [ STRING  close-paren STRING index 1 + cut ]
+    [ STRING  1                            cut ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-string-loop ( STRING RULES ACCUM -- )
+  STRING empty? not
+    [
+      STRING read-instruction
+    
+      [let | REST [ ] NEXT [ ] |
+
+        NEXT 1 head RULES at  NEXT  or  ACCUM push-all
+
+        REST RULES ACCUM iterate-string-loop ]
+    ]
+  when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-string ( STRING RULES -- string )
+
+  [let | ACCUM [ STRING length  10 *  <sbuf> ] |
+
+    STRING RULES ACCUM iterate-string-loop
+
+    ACCUM >string ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: interpret-string ( STRING COMMANDS -- )
+
+  STRING empty? not
+    [
+      STRING read-instruction
+
+      [let | REST [ ] NEXT [ ] |
+
+        [let | COMMAND [ NEXT 1 head COMMANDS at ] |
+
+          COMMAND
+            [
+              NEXT length 1 =
+                [ COMMAND call ]
+                [
+                  NEXT 2 tail 1 head* string>number
+                  COMMAND 1 tail*
+                  call
+                ]
+              if
+            ]
+          when ]
+
+        REST COMMANDS interpret-string ]
+    ]
+  when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-L-system-string ( L-SYSTEM -- )
+  L-SYSTEM string>>
+  L-SYSTEM rules>>
+  iterate-string
+  L-SYSTEM (>>string) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: do-camera-look-at ( CAMERA -- )
+
+  [let | EYE   [ CAMERA pos>> ]
+         FOCUS [ CAMERA clone 1 step-turtle pos>> ]
+         UP    [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ]
+       |
+
+    EYE FOCUS UP gl-look-at ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: generate-display-list ( L-SYSTEM -- )
+
+  L-SYSTEM find-gl-context
+
+  L-SYSTEM display-list>> GL_COMPILE glNewList
+
+    turtle
+    L-SYSTEM string>>
+    L-SYSTEM commands>>
+    interpret-string
+    drop
+
+  glEndList ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> draw-gadget* ( L-SYSTEM -- )
+
+  black gl-clear
+
+  GL_FLAT glShadeModel
+
+  GL_PROJECTION glMatrixMode
+  glLoadIdentity
+  -1 1 -1 1 1.5 200 glFrustum
+
+  GL_MODELVIEW glMatrixMode
+
+  glLoadIdentity
+
+  L-SYSTEM camera>> do-camera-look-at
+
+  GL_FRONT_AND_BACK GL_LINE glPolygonMode
+
+  ! draw axis
+  white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
+
+  L-SYSTEM display-list>> glCallList ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> graft* ( L-SYSTEM -- )
+
+  L-SYSTEM find-gl-context
+
+  1 glGenLists L-SYSTEM (>>display-list) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: camera-left ( L-SYSTEM -- )
+  L-SYSTEM camera>> 5 turn-left drop
+  L-SYSTEM relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: with-camera ( L-SYSTEM QUOT -- )
+  L-SYSTEM camera>> QUOT call drop
+  L-SYSTEM relayout-1 ;
+
+<L-system>
+H{
+  { T{ key-down f f "LEFT"  } [ [  5 turn-left   ] with-camera ] }
+  { T{ key-down f f "RIGHT" } [ [  5 turn-right  ] with-camera ] }
+  { T{ key-down f f "UP"    } [ [  5 pitch-down  ] with-camera ] }
+  { T{ key-down f f "DOWN"  } [ [  5 pitch-up    ] with-camera ] }
+  
+  { T{ key-down f f "a"     } [ [  1 step-turtle ] with-camera ] }
+  { T{ key-down f f "z"     } [ [ -1 step-turtle ] with-camera ] }
+
+  {
+    T{ key-down f f "x" }
+    [
+      dup iterate-L-system-string
+      dup generate-display-list
+      dup relayout-1
+      drop
+    ]
+  }
+    
+}
+set-gestures
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: L-system ( -- L-system )
+
+  <L-system> new-gadget
+  
+    turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

extra/L-system/models/abop-1/abop-1.factor

@@ -0,0 +1,29 @@
+
+USING: accessors kernel ui L-system ;
+
+IN: L-system.models.abop-1
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-1 ( <L-system> -- <L-system> )
+  
+  L-parser-dialect >>commands
+
+  "c(12)FFAL" >>axiom
+
+  {
+    { "A" "F[&'(.8)!BL]>(137)'!(.9)A"   }
+    { "B" "F[-'(.8)!(.9)$CL]'!(.9)C"    }
+    { "C" "F[+'(.8)!(.9)$BL]'!(.9)B"    }
+    
+    { "L" "~c(8){+(30)f-(120)f-(120)f}" }
+  }
+  >>rules
+
+  dup axiom>> >>string ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-1 "L-system" open-window ] with-ui ;
+
+MAIN: main

extra/benchmark/binary-search/binary-search.factor

@@ -1,10 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: binary-search math.primes.list math.ranges sequences
+USING: binary-search kernel math.primes.list math.ranges sequences
 prettyprint ;
 IN: benchmark.binary-search
 
 : binary-search-benchmark ( -- )
     1 1000000 [a,b] [ primes-under-million sorted-member? ] map length . ;
 
+! Force computation of the primes list before benchmarking the binary search
+primes-under-million drop
+
 MAIN: binary-search-benchmark

extra/faq/authors.txt

@@ -1 +0,0 @@
-Daniel Ehrenberg

extra/faq/faq.factor

@@ -1,113 +0,0 @@
-! Copyright (C) 2007 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: xml kernel sequences xml.utilities math xml.data
-arrays assocs xml.generator xml.writer namespaces
-make math.parser io accessors ;
-IN: faq
-
-: find-after ( seq quot -- elem after )
-    over [ find ] dip rot 1+ tail ; inline
-
-: tag-named*? ( tag name -- ? )
-    assure-name swap tag-named? ;
-
-! Questions
-TUPLE: q/a question answer ;
-C: <q/a> q/a
-
-: li>q/a ( li -- q/a )
-    [ "br" tag-named*? not ] filter
-    [ "strong" tag-named*? ] find-after
-    [ children>> ] dip <q/a> ;
-
-: q/a>li ( q/a -- li )
-    [ question>> "strong" build-tag* f "br" build-tag* 2array ] keep
-    answer>> append "li" build-tag* ;
-
-: xml>q/a ( xml -- q/a )
-    [ "question" tag-named children>> ] keep
-    "answer" tag-named children>> <q/a> ;
-
-: q/a>xml ( q/a -- xml )
-    [ question>> "question" build-tag* ] keep
-    answer>> "answer" build-tag*
-    "\n" swap 3array "qa" build-tag* ;
-
-! Lists of questions
-TUPLE: question-list title seq ;
-C: <question-list> question-list
-
-: xml>question-list ( list -- question-list )
-    [ "title" swap at ] keep
-    children>> [ tag? ] filter [ xml>q/a ] map
-    <question-list> ;
-
-: question-list>xml ( question-list -- list )
-    [ seq>> [ q/a>xml "\n" swap 2array ]
-      map concat "list" build-tag* ] keep
-    title>> [ "title" pick set-at ] when* ;
-
-: html>question-list ( h3 ol -- question-list )
-    [ [ children>string ] [ f ] if* ] dip
-    children-tags [ li>q/a ] map <question-list> ;
-
-: question-list>h3 ( id question-list -- h3 )
-    title>> [
-        "h3" build-tag
-        swap number>string "id" pick set-at
-    ] [ drop f ] if* ;
-
-: question-list>html ( question-list start id -- h3/f ol )
-    -rot [ [ question-list>h3 ] keep seq>> [ q/a>li ] map "ol" build-tag* ] dip
-    number>string "start" pick set-at
-    "margin-left: 5em" "style" pick set-at ;
-
-! Overall everything
-TUPLE: faq header lists ;
-C: <faq> faq
-
-: html>faq ( div -- faq )
-    unclip swap { "h3" "ol" } [ tags-named ] with map
-    first2 [ f prefix ] dip [ html>question-list ] 2map <faq> ;
-
-: header, ( faq -- )
-    dup header>> ,
-    lists>> first 1 -1 question-list>html nip , ;
-
-: br, ( -- )
-    "br" contained, nl, ;
-
-: toc-link, ( question-list number -- )
-    number>string "#" prepend "href" swap 2array 1array
-    "a" swap [ title>> , ] tag*, br, ;
-
-: toc, ( faq -- )
-    "div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [
-        "strong" [ "The big questions" , ] tag, br,
-        lists>> rest dup length [ toc-link, ] 2each
-    ] tag*, ;
-
-: faq-sections, ( question-lists -- )
-    unclip seq>> length 1+ dupd
-    [ seq>> length + ] accumulate nip
-    0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ;
-
-: faq>html ( faq -- div )
-    "div" [
-        dup header,
-        dup toc,
-        lists>> faq-sections,
-    ] make-xml ;
-
-: xml>faq ( xml -- faq )
-    [ "header" tag-named children>string ] keep
-    "list" tags-named [ xml>question-list ] map <faq> ;
-
-: faq>xml ( faq -- xml )
-    "faq" [
-        "header" [ dup header>> , ] tag,
-        lists>> [ question-list>xml , nl, ] each
-    ] make-xml ;
-
-: read-write-faq ( xml-stream -- )
-    read-xml xml>faq faq>html write-xml ;

extra/faq/summary.txt

@@ -1 +0,0 @@
-The Factor FAQ

extra/fuel/fuel.factor

@@ -1,11 +1,12 @@
-! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
+! Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz.
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: accessors arrays assocs classes.tuple combinators
-compiler.units continuations debugger definitions io io.pathnames
+compiler.units continuations debugger definitions help help.crossref
-io.streams.string kernel lexer math math.order memoize namespaces
+help.markup help.topics io io.pathnames io.streams.string kernel lexer
-parser prettyprint sequences sets sorting source-files strings summary
+make math math.order memoize namespaces parser quotations prettyprint
-tools.vocabs vectors vocabs vocabs.parser words ;
+sequences sets sorting source-files strings summary tools.crossref
+tools.vocabs tools.vocabs.browser vectors vocabs vocabs.parser words ;
 
 IN: fuel
 
@@ -17,13 +18,13 @@ SYMBOL: fuel-status-stack
 V{ } clone fuel-status-stack set-global
 
 SYMBOL: fuel-eval-result
-f clone fuel-eval-result set-global
+f fuel-eval-result set-global
 
 SYMBOL: fuel-eval-output
-f clone fuel-eval-result set-global
+f fuel-eval-result set-global
 
 SYMBOL: fuel-eval-res-flag
-t clone fuel-eval-res-flag set-global
+t fuel-eval-res-flag set-global
 
 : fuel-eval-restartable? ( -- ? )
     fuel-eval-res-flag get-global ; inline
@@ -56,6 +57,12 @@ GENERIC: fuel-pprint ( obj -- )
 
 M: object fuel-pprint pprint ; inline
 
+: fuel-maybe-scape ( ch -- seq )
+    dup "\\\"?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ;
+
+M: word fuel-pprint
+    name>> V{ } clone [ fuel-maybe-scape append ] reduce >string write ;
+
 M: f fuel-pprint drop "nil" write ; inline
 
 M: integer fuel-pprint pprint ; inline
@@ -67,6 +74,8 @@ M: sequence fuel-pprint
 
 M: tuple fuel-pprint tuple>array fuel-pprint ; inline
 
+M: quotation fuel-pprint pprint ; inline
+
 M: continuation fuel-pprint drop ":continuation" write ; inline
 
 M: restart fuel-pprint name>> fuel-pprint ; inline
@@ -99,20 +108,17 @@ M: source-file fuel-pprint path>> fuel-pprint ;
     clone fuel-eval-result set-global ; inline
 
 : fuel-retort ( -- )
-    error get
+    error get fuel-eval-result get-global fuel-eval-output get-global
-    fuel-eval-result get-global
-    fuel-eval-output get-global
     3array fuel-pprint flush nl "<~FUEL~>" write nl flush ;
 
 : fuel-forget-error ( -- ) f error set-global ; inline
 : fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
 : fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
+: fuel-forget-status ( -- )
+    fuel-forget-error fuel-forget-result fuel-forget-output ; inline
 
 : (fuel-begin-eval) ( -- )
-    fuel-push-status
+    fuel-push-status fuel-forget-status ; inline
-    fuel-forget-error
-    fuel-forget-result
-    fuel-forget-output ;
 
 : (fuel-end-eval) ( output -- )
     fuel-eval-output set-global fuel-retort fuel-pop-status ; inline
@@ -138,14 +144,17 @@ M: source-file fuel-pprint path>> fuel-pprint ;
 
 ! Loading files
 
-: fuel-run-file ( path -- ) run-file ; inline
+SYMBOL: :uses
 
-: fuel-with-autouse ( quot -- )
+: fuel-set-use-hook ( -- )
-    [
+    [ amended-use get clone :uses prefix fuel-eval-set-result ]
-        auto-use? on
+    print-use-hook set ;
-        [ amended-use get clone fuel-eval-set-result ] print-use-hook set
+
-        call
+: fuel-run-file ( path -- )
-    ] curry with-scope ;
+    [ fuel-set-use-hook run-file ] curry with-scope ; inline
+
+: fuel-with-autouse ( ... quot: ( ... -- ... ) -- ... )
+    [ auto-use? on fuel-set-use-hook call ] curry with-scope ; inline
 
 : (fuel-get-uses) ( lines -- )
     [ parse-fresh drop ] curry with-compilation-unit ; inline
@@ -156,18 +165,22 @@ M: source-file fuel-pprint path>> fuel-pprint ;
 ! Edit locations
 
 : fuel-normalize-loc ( seq -- path line )
-    dup length 1 > [ first2 [ (normalize-path) ] dip ] [ f ] if ; inline
+    [ dup length 0 > [ first (normalize-path) ] [ drop f ] if ]
+    [ dup length 1 > [ second ] [ drop 1 ] if ] bi ;
 
-: fuel-get-edit-location ( defspec -- )
+: fuel-get-edit-location ( word -- )
     where fuel-normalize-loc 2array fuel-eval-set-result ; inline
 
 : fuel-get-vocab-location ( vocab -- )
     >vocab-link fuel-get-edit-location ; inline
 
-: fuel-get-doc-location ( defspec -- )
+: fuel-get-doc-location ( word -- )
     props>> "help-loc" swap at
     fuel-normalize-loc 2array fuel-eval-set-result ;
 
+: fuel-get-article-location ( name -- )
+    article loc>> fuel-normalize-loc 2array fuel-eval-set-result ;
+
 ! Cross-references
 
 : fuel-word>xref ( word -- xref )
@@ -177,13 +190,16 @@ M: source-file fuel-pprint path>> fuel-pprint ;
     [ [ first ] dip first <=> ] sort ; inline
 
 : fuel-format-xrefs ( seq -- seq' )
-    [ word? ] filter [ fuel-word>xref ] map fuel-sort-xrefs ;
+    [ word? ] filter [ fuel-word>xref ] map ; inline
 
 : fuel-callers-xref ( word -- )
-    usage fuel-format-xrefs fuel-eval-set-result ; inline
+    usage fuel-format-xrefs fuel-sort-xrefs fuel-eval-set-result ; inline
 
 : fuel-callees-xref ( word -- )
-    uses fuel-format-xrefs fuel-eval-set-result ; inline
+    uses fuel-format-xrefs fuel-sort-xrefs fuel-eval-set-result ; inline
+
+: fuel-apropos-xref ( str -- )
+    words-matching fuel-format-xrefs fuel-eval-set-result ; inline
 
 ! Completion support
 
@@ -218,6 +234,134 @@ MEMO: (fuel-vocab-words) ( name -- seq )
 : fuel-get-words ( prefix names -- )
     (fuel-get-words) fuel-eval-set-result ; inline
 
+! Help support
+
+MEMO: fuel-articles-seq ( -- seq )
+    articles get values ;
+
+: fuel-find-articles ( title -- seq )
+    [ [ article-title ] dip = ] curry fuel-articles-seq swap filter ;
+
+MEMO: fuel-find-article ( title -- article/f )
+    fuel-find-articles dup empty? [ drop f ] [ first ] if ;
+
+MEMO: fuel-article-title ( name -- title/f )
+    articles get at [ article-title ] [ f ] if* ;
+
+: fuel-get-article ( name -- )
+    article fuel-eval-set-result ;
+
+: fuel-value-str ( word -- str )
+    [ pprint-short ] with-string-writer ; inline
+
+: fuel-definition-str ( word -- str )
+    [ see ] with-string-writer ; inline
+
+: fuel-methods-str ( word -- str )
+    methods dup empty? not [
+        [ [ see nl ] each ] with-string-writer
+    ] [ drop f ] if ; inline
+
+: fuel-related-words ( word -- seq )
+    dup "related" word-prop remove ; inline
+
+: fuel-parent-topics ( word -- seq )
+    help-path [ dup article-title swap 2array ] map ; inline
+
+: (fuel-word-help) ( word -- element )
+    dup \ article swap article-title rot
+    [
+        {
+            [ fuel-parent-topics [ \ $doc-path prefix , ] unless-empty ]
+            [ \ $vocabulary swap vocabulary>> 2array , ]
+            [ word-help % ]
+            [ fuel-related-words [ \ $related swap 2array , ] unless-empty ]
+            [ get-global [ \ $value swap fuel-value-str 2array , ] when* ]
+            [ \ $definition swap fuel-definition-str 2array , ]
+            [ fuel-methods-str [ \ $methods swap 2array , ] when* ]
+        } cleave
+    ] { } make 3array ;
+
+MEMO: fuel-find-word ( name -- word/f )
+    [ [ name>> ] dip = ] curry all-words swap filter
+    dup empty? not [ first ] [ drop f ] if ;
+
+: fuel-word-help ( name -- )
+    fuel-find-word [ [ auto-use? on (fuel-word-help) ] with-scope ] [ f ] if*
+    fuel-eval-set-result ; inline
+
+: (fuel-word-see) ( word -- elem )
+    [ name>> \ article swap ]
+    [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline
+
+: fuel-word-see ( name -- )
+    fuel-find-word [ [ auto-use? on (fuel-word-see) ] with-scope ] [ f ] if*
+    fuel-eval-set-result ; inline
+
+: fuel-vocab-help-row ( vocab -- element )
+    [ vocab-status-string ] [ vocab-name ] [ summary ] tri 3array ;
+
+: fuel-vocab-help-root-heading ( root -- element )
+    [ "Children from " prepend ] [ "Other children" ] if* \ $heading swap 2array ;
+
+SYMBOL: vocab-list
+
+: fuel-vocab-help-table ( vocabs -- element )
+    [ fuel-vocab-help-row ] map vocab-list prefix ;
+
+: fuel-vocab-list ( assoc -- seq )
+    [
+        [ drop f ] [
+            [ fuel-vocab-help-root-heading ]
+            [ fuel-vocab-help-table ] bi*
+            [ 2array ] [ drop f ] if*
+        ] if-empty
+    ] { } assoc>map [  ] filter ;
+
+: fuel-vocab-children-help ( name -- element )
+    all-child-vocabs fuel-vocab-list ; inline
+
+: fuel-vocab-describe-words ( name -- element )
+    [ describe-words ] with-string-writer \ describe-words swap 2array ; inline
+
+: (fuel-vocab-help) ( name -- element )
+    \ article swap dup >vocab-link
+    [
+        {
+            [ vocab-authors [ \ $authors prefix , ] when* ]
+            [ vocab-tags [ \ $tags prefix , ] when* ]
+            [ summary [ { $heading "Summary" } swap 2array , ] when* ]
+            [ drop \ $nl , ]
+            [ vocab-help [ article content>> % ] when* ]
+            [ name>> fuel-vocab-describe-words , ]
+            [ name>> fuel-vocab-children-help % ]
+        } cleave
+    ] { } make 3array ;
+
+: fuel-vocab-help ( name -- )
+    dup empty? [ fuel-vocab-children-help ] [ (fuel-vocab-help) ] if
+    fuel-eval-set-result ; inline
+
+: (fuel-index) ( seq -- seq )
+    [ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ;
+
+: fuel-index ( quot: ( -- seq ) -- )
+    call (fuel-index) fuel-eval-set-result ; inline
+
+MEMO: (fuel-get-vocabs/author) ( author -- element )
+    [ "Vocabularies by " prepend \ $heading swap 2array ]
+    [ authored fuel-vocab-list ] bi 2array ;
+
+: fuel-get-vocabs/author ( author -- )
+    (fuel-get-vocabs/author) fuel-eval-set-result ;
+
+MEMO: (fuel-get-vocabs/tag ( tag -- element )
+    [ "Vocabularies tagged " prepend \ $heading swap 2array ]
+    [ tagged fuel-vocab-list ] bi 2array ;
+
+: fuel-get-vocabs/tag ( tag -- )
+    (fuel-get-vocabs/tag fuel-eval-set-result ;
+
 
 ! -run=fuel support
 

extra/inverse/inverse.factor

@@ -63,16 +63,20 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
 
 : enough? ( stack word -- ? )
     dup deferred? [ 2drop f ] [
-        [ [ length ] dip 1quotation infer in>> >= ]
+        [ [ length ] [ 1quotation infer in>> ] bi* >= ]
         [ 3drop f ] recover
     ] if ;
 
 : fold-word ( stack word -- stack )
     2dup enough?
-    [ 1quotation with-datastack ] [ [ % ] dip , { } ] if ;
+    [ 1quotation with-datastack ] [ [ % ] [ , ] bi* { } ] if ;
 
 : fold ( quot -- folded-quot )
-    [ { } swap [ fold-word ] each % ] [ ] make ; 
+    [ { } [ fold-word ] reduce % ] [ ] make ; 
+
+ERROR: no-recursive-inverse ;
+
+SYMBOL: visited
 
 : flattenable? ( object -- ? )
     { [ word? ] [ primitive? not ] [
@@ -80,18 +84,18 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
         [ word-prop ] with contains? not
     ] } 1&& ; 
 
-: (flatten) ( quot -- )
-    [ dup flattenable? [ def>> (flatten) ] [ , ] if ] each ;
-
- : retain-stack-overflow? ( error -- ? )
-    { "kernel-error" 14 f f } = ;
-
 : flatten ( quot -- expanded )
-    [ [ (flatten) ] [ ] make ] [
+    [
-        dup retain-stack-overflow?
+        visited [ over suffix ] change
-        [ drop "No inverse defined on recursive word" ] when
+        [
-        throw
+            dup flattenable? [
-    ] recover ;
+                def>>
+                [ visited get memq? [ no-recursive-inverse ] when ]
+                [ flatten ]
+                bi
+            ] [ 1quotation ] if
+        ] map concat
+    ] with-scope ;
 
 ERROR: undefined-inverse ;
 

extra/math/primes/erato/erato.factor

@@ -8,7 +8,7 @@ IN: math.primes.erato
     2 * 3 + ; inline
 
 : mark-multiples ( i arr -- )
-    [ dup index> [ + ] keep ] dip
+    [ index> [ sq >index ] keep ] dip
     [ length 1 - swap <range> f swap ] keep
     [ set-nth ] curry with each ;
 

extra/math/primes/list/list.factor

@@ -1,4 +1,4 @@
-USING: math.primes ;
+USING: math.primes memoize ;
 IN: math.primes.list
 
-: primes-under-million ( -- seq ) 1000000 primes-upto ;
+MEMO: primes-under-million ( -- seq ) 1000000 primes-upto ;

extra/math/primes/primes.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: binary-search combinators kernel lists.lazy math math.functions
+USING: combinators kernel lists.lazy math math.functions
-math.miller-rabin math.primes.erato math.ranges sequences ;
+math.miller-rabin math.order math.primes.erato math.ranges sequences ;
 IN: math.primes
 
 <PRIVATE
@@ -28,15 +28,11 @@ PRIVATE>
 : lprimes-from ( n -- list )
     dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
 
-: primes-upto ( n -- seq )
-    dup 2 < [
-        drop V{ }
-    ] [
-        3 swap 2 <range> [ prime? ] filter 2 prefix
-    ] if ; foldable
-
 : primes-between ( low high -- seq )
-    primes-upto [ 1- next-prime ] dip
+    [ dup 3 max dup even? [ 1 + ] when ] dip
-    [ natural-search drop ] [ length ] [ ] tri <slice> ; foldable
+    2 <range> [ prime? ] filter
+    swap 3 < [ 2 prefix ] when ;
+
+: primes-upto ( n -- seq ) 2 swap primes-between ;
 
 : coprime? ( a b -- ? ) gcd nip 1 = ; foldable

extra/project-euler/057/057.factor

@@ -0,0 +1,43 @@
+! Copyright (c) 2008 Samuel Tardieu
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions math.parser sequences ;
+IN: project-euler.057
+
+! http://projecteuler.net/index.php?section=problems&id=57
+
+! DESCRIPTION
+! -----------
+
+! It is possible to show that the square root of two can be expressed
+! as an infinite continued fraction.
+
+! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213...
+
+! By expanding this for the first four iterations, we get:
+
+! 1 + 1/2 = 3/2 = 1.5
+! 1 + 1/(2 + 1/2) = 7/5 = 1.4
+! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666...
+! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379...
+
+! The next three expansions are 99/70, 239/169, and 577/408, but the
+! eighth expansion, 1393/985, is the first example where the number of
+! digits in the numerator exceeds the number of digits in the
+! denominator.
+
+! In the first one-thousand expansions, how many fractions contain a
+! numerator with more digits than denominator?
+
+! SOLUTION
+! --------
+
+: longer-numerator? ( seq -- ? )
+    >fraction [ number>string length ] bi@ > ; inline
+
+: euler057 ( -- answer )
+    0 1000 [ drop 2 + recip dup 1+ longer-numerator? ] count nip ;
+
+! [ euler057 ] time
+! 3.375118 seconds
+
+MAIN: euler057

extra/project-euler/project-euler.factor

@@ -15,13 +15,13 @@ USING: definitions io io.files io.pathnames kernel math math.parser
     project-euler.041 project-euler.042 project-euler.043 project-euler.044
     project-euler.045 project-euler.046 project-euler.047 project-euler.048
     project-euler.052 project-euler.053 project-euler.055 project-euler.056
-    project-euler.059 project-euler.067 project-euler.071 project-euler.073
+    project-euler.057 project-euler.059 project-euler.067 project-euler.071
-    project-euler.075 project-euler.076 project-euler.079 project-euler.092
+    project-euler.073 project-euler.075 project-euler.076 project-euler.079
-    project-euler.097 project-euler.099 project-euler.100 project-euler.116
+    project-euler.092 project-euler.097 project-euler.099 project-euler.100
-    project-euler.117 project-euler.134 project-euler.148 project-euler.150
+    project-euler.116 project-euler.117 project-euler.134 project-euler.148
-    project-euler.151 project-euler.164 project-euler.169 project-euler.173
+    project-euler.150 project-euler.151 project-euler.164 project-euler.169
-    project-euler.175 project-euler.186 project-euler.190 project-euler.203
+    project-euler.173 project-euler.175 project-euler.186 project-euler.190
-    project-euler.215 ;
+    project-euler.203 project-euler.215 ;
 IN: project-euler
 
 <PRIVATE

license.txt

@@ -1,4 +1,4 @@
-Copyright (C) 2003, 2008 Slava Pestov and friends.
+Copyright (C) 2003, 2009 Slava Pestov and friends.
 
 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are met:

misc/fuel/README

@@ -1,15 +1,15 @@
-FUEL, Factor's Ultimate Emacs Library
+FUEL, Factor's Ultimate Emacs Library                              -*- org -*-
 -------------------------------------
 
 FUEL provides a complete environment for your Factor coding pleasure
 inside Emacs, including source code edition and interaction with a
 Factor listener instance running within Emacs.
 
-FUEL was started by Jose A Ortega as an extension to Ed Cavazos'
+FUEL was started by Jose A Ortega as an extension to Eduardo Cavazos'
-original factor.el code.
+original factor.el code. Eduardo is also responsible of naming the
+beast.
 
-Installation
+* Installation
-------------
 
   FUEL comes bundled with Factor's distribution. The folder misc/fuel
   contains Elisp code, and there's a fuel vocabulary in extras/fuel.
@@ -31,8 +31,7 @@ inside Emacs, you can use instead:
   (setq factor-mode-use-fuel nil)
   (require 'factor-mode)
 
-Basic usage
+* Basic usage
------------
 
   If you're using the default factor binary and images locations inside
   the Factor's source tree, that should be enough to start using FUEL.
@@ -44,13 +43,12 @@ To start the listener, try M-x run-factor.
   Many aspects of the environment can be customized:
   M-x customize-group fuel will show you how many.
 
-Quick key reference
+* Quick key reference
--------------------
 
   (Triple chords ending in a single letter <x> accept also C-<x> (e.g.
   C-cC-eC-r is the same as C-cC-er)).
 
-* In factor source files:
+*** In factor source files:
 
     - C-cz : switch to listener
     - C-co : cycle between code, tests and docs factor files
@@ -71,38 +69,52 @@ C-cC-eC-r is the same as C-cC-er)).
     - C-cC-dd : help for word at point
     - C-cC-ds : short help word at point
     - C-cC-de : show stack effect of current sexp (with prefix, region)
+    - C-cC-dp : find words containing given substring (M-x fuel-apropos)
 
     - C-cM-<, C-cC-d< : show callers of word at point
     - C-cM->, C-cC-d> : show callees of word at point
 
-* In the listener:
+*** In the listener:
 
     - TAB : complete word at point
     - M-. : edit word at point in Emacs
     - C-ca : toggle autodoc mode
+    - C-cp : find words containing given substring (M-x fuel-apropos)
     - C-cs : toggle stack mode
     - C-cv : edit vocabulary
     - C-ch : help for word at point
     - C-ck : run file
 
-* In the debugger (it pops up upon eval/compilation errors):
+*** In the debugger (it pops up upon eval/compilation errors):
 
     - g : go to error
     - <digit> : invoke nth restart
     - w/e/l : invoke :warnings, :errors, :linkage
     - q : bury buffer
 
-* In the Help browser:
+*** In the help browser:
 
- - RET : help for word at point
+    - h : help for word at point
- - f/b : next/previous page
+    - v : help for a vocabulary
+    - a : find words containing given substring (M-x fuel-apropos)
+    - e : edit current article
+    - ba : bookmark current page
+    - bb : display bookmarks
+    - bd : delete bookmark at point
+    - n/p : next/previous page
+    - l : previous page
     - SPC/S-SPC : scroll up/down
- - TAB/S-TAB : next/previous headline
+    - TAB/S-TAB : next/previous link
+    - k : kill current page and go to previous or next
+    - r : refresh page
+    - c : clean browsing history
+    - M-. : edit word at point in Emacs
     - C-cz : switch to listener
     - q : bury buffer
 
-* In crossref buffers
+*** In crossref buffers
 
     - TAB/BACKTAB : navigate links
     - RET/mouse click : follow link
+    - h : show help for word at point
     - q : bury buffer

misc/fuel/fuel-autodoc.el

@@ -1,6 +1,6 @@
 ;;; fuel-autodoc.el -- doc snippets in the echo area
 
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
 ;; See http://factorcode.org/license.txt for BSD license.
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@@ -15,6 +15,7 @@
 ;;; Code:
 
 (require 'fuel-eval)
+(require 'fuel-font-lock)
 (require 'fuel-syntax)
 (require 'fuel-base)
 
@@ -30,34 +31,24 @@
   :group 'fuel-autodoc
   :type 'boolean)
 
+
 
-;;; Autodoc mode:
+;;; Eldoc function:
 
-(defvar fuel-autodoc--font-lock-buffer
+(defvar fuel-autodoc--timeout 200)
-  (let ((buffer (get-buffer-create " *fuel help minibuffer messages*")))
-    (set-buffer buffer)
-    (fuel-font-lock--font-lock-setup)
-    buffer))
-
-(defun fuel-autodoc--font-lock-str (str)
-  (set-buffer fuel-autodoc--font-lock-buffer)
-  (erase-buffer)
-  (insert str)
-  (let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
-  (buffer-string))
 
 (defun fuel-autodoc--word-synopsis (&optional word)
   (let ((word (or word (fuel-syntax-symbol-at-point)))
         (fuel-log--inhibit-p t))
     (when word
       (let* ((cmd (if (fuel-syntax--in-using)
-                      `(:fuel* (,word fuel-vocab-summary) t t)
+                      `(:fuel* (,word fuel-vocab-summary) :in t)
-                    `(:fuel* (((:quote ,word) synopsis :get)) t)))
+                    `(:fuel* (((:quote ,word) synopsis :get)) :in)))
-             (ret (fuel-eval--send/wait cmd 20))
+             (ret (fuel-eval--send/wait cmd fuel-autodoc--timeout))
              (res (fuel-eval--retort-result ret)))
         (when (and ret (not (fuel-eval--retort-error ret)) (stringp res))
           (if fuel-autodoc-minibuffer-font-lock
-              (fuel-autodoc--font-lock-str res)
+              (fuel-font-lock--factor-str res)
             res))))))
 
 (make-variable-buffer-local
@@ -68,6 +59,9 @@
            (funcall fuel-autodoc--fallback-function))
       (fuel-autodoc--word-synopsis)))
 
+
+;;; Autodoc mode:
+
 (make-variable-buffer-local
  (defvar fuel-autodoc-mode-string " A"
    "Modeline indicator for fuel-autodoc-mode"))

misc/fuel/fuel-connection.el

@@ -1,6 +1,6 @@
 ;;; fuel-connection.el -- asynchronous comms with the fuel listener
 
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
 ;; See http://factorcode.org/license.txt for BSD license.
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@@ -193,7 +193,7 @@
       (condition-case cerr
           (with-current-buffer (or buffer (current-buffer))
             (funcall cont (fuel-con--comint-buffer-form))
-            (fuel-log--info "<%s>: processed\n\t%s" id req))
+            (fuel-log--info "<%s>: processed" id))
         (error (fuel-log--error
                 "<%s>: continuation failed %S \n\t%s" id rstr cerr))))))
 

misc/fuel/fuel-debug-uses.el

@@ -23,12 +23,6 @@
 
 ;;; Customization:
 
-(fuel-font-lock--defface fuel-font-lock-debug-missing-vocab
-  'font-lock-warning-face fuel-debug "missing vocabulary names")
-
-(fuel-font-lock--defface fuel-font-lock-debug-unneeded-vocab
-  'font-lock-warning-face fuel-debug "unneeded vocabulary names")
-
 (fuel-font-lock--defface fuel-font-lock-debug-uses-header
   'bold fuel-debug "headers in Uses buffers")
 
@@ -53,26 +47,6 @@
             (forward-line))
           (reverse lines))))))
 
-(defun fuel-debug--highlight-names (names ref face)
-  (dolist (n names)
-    (when (not (member n ref))
-      (put-text-property 0 (length n) 'font-lock-face face n))))
-
-(defun fuel-debug--uses-new-uses (file uses)
-  (pop-to-buffer (find-file-noselect file))
-  (goto-char (point-min))
-  (if (re-search-forward "^USING: " nil t)
-      (let ((begin (point))
-            (end (or (and (re-search-forward "\\_<;\\_>") (point)) (point))))
-        (kill-region begin end))
-    (re-search-forward "^IN: " nil t)
-    (beginning-of-line)
-    (open-line 2)
-    (insert "USING: "))
-  (let ((start (point)))
-    (insert (mapconcat 'substring-no-properties uses " ") " ;")
-    (fill-region start (point) nil)))
-
 (defun fuel-debug--uses-filter (restarts)
   (let ((result) (i 1) (rn 0))
     (dolist (r restarts (reverse result))
@@ -87,9 +61,6 @@
 (fuel-popup--define fuel-debug--uses-buffer
   "*fuel uses*" 'fuel-debug-uses-mode)
 
-(make-variable-buffer-local
- (defvar fuel-debug--uses nil))
-
 (make-variable-buffer-local
  (defvar fuel-debug--uses-file nil))
 
@@ -122,27 +93,15 @@
     (fuel-popup--display (fuel-debug--uses-buffer))))
 
 (defun fuel-debug--uses-cont (retort)
-  (let ((uses (fuel-eval--retort-result retort))
+  (let ((uses (fuel-debug--uses retort))
         (err (fuel-eval--retort-error retort)))
     (if uses (fuel-debug--uses-display uses)
       (fuel-debug--uses-display-err retort))))
 
-(defun fuel-debug--insert-vlist (title vlist)
-  (goto-char (point-max))
-  (insert title "\n\n  ")
-  (let ((i 0) (step 5))
-    (dolist (v vlist)
-      (setq i (1+ i))
-      (insert v)
-      (insert (if (zerop (mod i step)) "\n  " " ")))
-    (unless (zerop (mod i step)) (newline))
-    (newline)))
-
 (defun fuel-debug--uses-display (uses)
   (let* ((inhibit-read-only t)
          (old (with-current-buffer (find-file-noselect fuel-debug--uses-file)
-                (fuel-syntax--usings)))
+                (sort (fuel-syntax--find-usings t) 'string<)))
-         (old (sort old 'string<))
          (new (sort uses 'string<)))
     (erase-buffer)
     (fuel-debug--uses-insert-title)
@@ -177,14 +136,15 @@
 
 (defun fuel-debug--uses-update-usings ()
   (interactive)
-  (let ((inhibit-read-only t))
+  (let ((inhibit-read-only t)
-    (when (and fuel-debug--uses-file fuel-debug--uses)
+        (file fuel-debug--uses-file)
-      (fuel-debug--uses-new-uses fuel-debug--uses-file fuel-debug--uses)
+        (uses fuel-debug--uses))
-      (message "USING: updated!")
+    (when (and uses file)
-      (with-current-buffer (fuel-debug--uses-buffer)
       (insert "\nDone!")
       (fuel-debug--uses-clean)
-        (bury-buffer)))))
+      (fuel-popup--quit)
+      (fuel-debug--replace-usings file uses)
+      (message "USING: updated!"))))
 
 (defun fuel-debug--uses-restart (n)
   (when (and (> n 0) (<= n (length fuel-debug--uses-restarts)))

misc/fuel/fuel-debug.el

@@ -31,6 +31,12 @@
   :group 'fuel-debug
   :type 'hook)
 
+(defcustom fuel-debug-confirm-restarts-p t
+  "Whether to ask for confimation before executing a restart in
+the debugger."
+  :group 'fuel-debug
+  :type 'boolean)
+
 (defcustom fuel-debug-show-short-help t
   "Whether to show short help on available keys in debugger."
   :group 'fuel-debug
@@ -43,7 +49,9 @@
   (column variable-name "column numbers in errors/warnings")
   (info comment "information headers")
   (restart-number warning "restart numbers")
-  (restart-name function-name "restart names")))
+  (restart-name function-name "restart names")
+  (missing-vocab warning"missing vocabulary names")
+  (unneeded-vocab warning "unneeded vocabulary names")))
 
 
 ;;; Font lock and other pattern matching:
@@ -92,6 +100,9 @@
 (make-variable-buffer-local
  (defvar fuel-debug--file nil))
 
+(make-variable-buffer-local
+ (defvar fuel-debug--uses nil))
+
 (defun fuel-debug--prepare-compilation (file msg)
   (let ((inhibit-read-only t))
     (with-current-buffer (fuel-debug--buffer)
@@ -114,6 +125,7 @@
         (fuel-debug--display-restarts err)
         (delete-blank-lines)
         (newline))
+      (fuel-debug--display-uses ret)
       (let ((hstr (fuel-debug--help-string err fuel-debug--file)))
         (if fuel-debug-show-short-help
             (insert "-----------\n" hstr "\n")
@@ -124,6 +136,46 @@
       (when (and err (not no-pop)) (fuel-popup--display))
       (not err))))
 
+(defun fuel-debug--uses (ret)
+  (let ((uses (fuel-eval--retort-result ret)))
+    (and (eq :uses (car uses))
+         (cdr uses))))
+
+(defun fuel-debug--insert-vlist (title vlist)
+  (goto-char (point-max))
+  (insert title "\n\n  ")
+  (let ((i 0) (step 5))
+    (dolist (v vlist)
+      (setq i (1+ i))
+      (insert v)
+      (insert (if (zerop (mod i step)) "\n  " " ")))
+    (unless (zerop (mod i step)) (newline))
+    (newline)))
+
+(defun fuel-debug--highlight-names (names ref face)
+  (dolist (n names)
+    (when (not (member n ref))
+      (put-text-property 0 (length n) 'font-lock-face face n))))
+
+(defun fuel-debug--insert-uses (uses)
+  (let* ((file (or file fuel-debug--file))
+         (old (with-current-buffer (find-file-noselect file)
+                (sort (fuel-syntax--find-usings t) 'string<)))
+         (new (sort uses 'string<)))
+    (when (not (equalp old new))
+      (fuel-debug--highlight-names old new 'fuel-font-lock-debug-unneeded-vocab)
+      (newline)
+      (fuel-debug--insert-vlist "Correct vocabulary list:" new)
+      new)))
+
+(defun fuel-debug--display-uses (ret)
+  (when (setq fuel-debug--uses (fuel-debug--uses ret))
+    (newline)
+    (fuel-debug--highlight-names fuel-debug--uses
+                                 nil 'fuel-font-lock-debug-missing-vocab)
+    (fuel-debug--insert-vlist "Missing vocabularies:" fuel-debug--uses)
+    (newline)))
+
 (defun fuel-debug--display-output (ret)
   (let* ((last (fuel-eval--retort-output fuel-debug--last-ret))
          (current (fuel-eval--retort-output ret))
@@ -149,7 +201,7 @@
       (newline))))
 
 (defun fuel-debug--help-string (err &optional file)
-  (format "Press %s%s%sq bury buffer"
+  (format "Press %s%s%s%sq bury buffer"
           (if (or file (fuel-eval--error-file err)) "g go to file, " "")
           (let ((rsn (length (fuel-eval--error-restarts err))))
             (cond ((zerop rsn) "")
@@ -160,7 +212,8 @@
               (save-excursion
                 (goto-char (point-min))
                 (when (search-forward (car ci) nil t)
-                  (setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))))
+                  (setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))
+          (if (and (not err) fuel-debug--uses) "u to update USING:, " "")))
 
 (defun fuel-debug--buffer-file ()
   (with-current-buffer (fuel-debug--buffer)
@@ -229,6 +282,31 @@
              (fuel-eval--send/wait `(:fuel ((:factor ,info)))) "")
       (error "Sorry, no %s info available" info))))
 
+(defun fuel-debug--replace-usings (file uses)
+  (pop-to-buffer (find-file-noselect file))
+  (goto-char (point-min))
+  (if (re-search-forward "^USING: " nil t)
+      (let ((begin (point))
+            (end (or (and (re-search-forward "\\_<;\\_>") (point)) (point))))
+        (kill-region begin end))
+    (re-search-forward "^IN: " nil t)
+    (beginning-of-line)
+    (open-line 2)
+    (insert "USING: "))
+  (let ((start (point)))
+    (insert (mapconcat 'substring-no-properties uses " ") " ;")
+    (fill-region start (point) nil)))
+
+(defun fuel-debug-update-usings ()
+  (interactive)
+  (when (and fuel-debug--file fuel-debug--uses)
+    (let* ((file fuel-debug--file)
+           (old (with-current-buffer (find-file-noselect file)
+                  (fuel-syntax--find-usings t)))
+           (uses (sort (append fuel-debug--uses old) 'string<)))
+      (fuel-popup--quit)
+      (fuel-debug--replace-usings file uses))))
+
 
 ;;; Fuel Debug mode:
 
@@ -239,9 +317,11 @@
     (define-key map "\C-c\C-c" 'fuel-debug-goto-error)
     (define-key map "n" 'next-line)
     (define-key map "p" 'previous-line)
+    (define-key map "u" 'fuel-debug-update-usings)
     (dotimes (n 9)
       (define-key map (vector (+ ?1 n))
-        `(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t))))
+        `(lambda () (interactive)
+           (fuel-debug-exec-restart ,(1+ n) fuel-debug-confirm-restarts-p))))
     (dolist (ci fuel-debug--compiler-info-alist)
       (define-key map (vector (cdr ci))
         `(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci)))))

misc/fuel/fuel-edit.el

@@ -0,0 +1,104 @@
+;;; fuel-edit.el -- utilities for file editing
+
+;; Copyright (C) 2009 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: Mon Jan 05, 2009 21:16
+
+;;; Comentary:
+
+;; Locating and opening factor source and documentation files.
+
+;;; Code:
+
+(require 'fuel-completion)
+(require 'fuel-eval)
+(require 'fuel-base)
+
+
+;;; Auxiliar functions:
+
+(defun fuel-edit--try-edit (ret)
+  (let* ((err (fuel-eval--retort-error ret))
+         (loc (fuel-eval--retort-result ret)))
+    (when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
+      (error "Couldn't find edit location"))
+    (unless (file-readable-p (car loc))
+      (error "Couldn't open '%s' for read" (car loc)))
+    (find-file-other-window (car loc))
+    (goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
+
+(defun fuel-edit--read-vocabulary-name (refresh)
+  (let* ((vocabs (fuel-completion--vocabs refresh))
+         (prompt "Vocabulary name: "))
+    (if vocabs
+        (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history)
+      (read-string prompt nil fuel-edit--vocab-history))))
+
+(defun fuel-edit--edit-article (name)
+  (let ((cmd `(:fuel* (,name fuel-get-article-location) "fuel" t)))
+    (fuel-edit--try-edit (fuel-eval--send/wait cmd))))
+
+
+;;; Editing commands:
+
+(defvar fuel-edit--word-history nil)
+(defvar fuel-edit--vocab-history nil)
+
+(defun fuel-edit-vocabulary (&optional refresh vocab)
+  "Visits vocabulary file in Emacs.
+When called interactively, asks for vocabulary with completion.
+With prefix argument, refreshes cached vocabulary list."
+  (interactive "P")
+  (let* ((vocab (or vocab (fuel-edit--read-vocabulary-name refresh)))
+         (cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t)))
+    (fuel-edit--try-edit (fuel-eval--send/wait cmd))))
+
+(defun fuel-edit-word (&optional arg)
+  "Asks for a word to edit, with completion.
+With prefix, only words visible in the current vocabulary are
+offered."
+  (interactive "P")
+  (let* ((word (fuel-completion--read-word "Edit word: "
+                                           nil
+                                           fuel-edit--word-history
+                                           arg))
+         (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location))))
+    (fuel-edit--try-edit (fuel-eval--send/wait cmd))))
+
+(defun fuel-edit-word-at-point (&optional arg)
+  "Opens a new window visiting the definition of the word at point.
+With prefix, asks for the word to edit."
+  (interactive "P")
+  (let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point))
+                   (fuel-completion--read-word "Edit word: ")))
+         (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location))))
+    (condition-case nil
+        (fuel-edit--try-edit (fuel-eval--send/wait cmd))
+      (error (fuel-edit-vocabulary nil word)))))
+
+(defun fuel-edit-word-doc-at-point (&optional arg word)
+  "Opens a new window visiting the documentation file for the word at point.
+With prefix, asks for the word to edit."
+  (interactive "P")
+  (let* ((word (or word
+                   (and (not arg) (fuel-syntax-symbol-at-point))
+                   (fuel-completion--read-word "Edit word: ")))
+         (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location))))
+    (condition-case nil
+        (fuel-edit--try-edit (fuel-eval--send/wait cmd))
+      (error
+       (message "Documentation for '%s' not found" word)
+       (when (and (eq major-mode 'factor-mode)
+                  (y-or-n-p (concat "No documentation found. "
+                                    "Do you want to open the vocab's "
+                                    "doc file? ")))
+         (find-file-other-window
+          (format "%s-docs.factor"
+                  (file-name-sans-extension (buffer-file-name)))))))))
+
+
+(provide 'fuel-edit)
+;;; fuel-edit.el ends here

misc/fuel/fuel-eval.el

@@ -1,6 +1,6 @@
 ;;; fuel-eval.el --- evaluating Factor expressions
 
-;; Copyright (C) 2008  Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009  Jose Antonio Ortega Ruiz
 ;; See http://factorcode.org/license.txt for BSD license.
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@@ -13,9 +13,10 @@
 
 ;;; Code:
 
-(require 'fuel-base)
 (require 'fuel-syntax)
 (require 'fuel-connection)
+(require 'fuel-log)
+(require 'fuel-base)
 
 (eval-when-compile (require 'cl))
 
@@ -67,7 +68,7 @@
   (cons :array (mapcar 'factor lst)))
 
 (defsubst factor--fuel-in (in)
-  (cond ((null in) :in)
+  (cond ((or (eq in :in) (null in)) :in)
         ((eq in 'f) 'f)
         ((eq in 't) "fuel-scratchpad")
         ((stringp in) in)
@@ -125,6 +126,7 @@
   (fuel-eval--retort-make (cons 'fuel-parse-retort-error str) nil))
 
 (defun fuel-eval--parse-retort (ret)
+  (fuel-log--info "RETORT: %S" ret)
   (if (fuel-eval--retort-p ret) ret
     (fuel-eval--make-parse-error-retort ret)))
 

misc/fuel/fuel-font-lock.el

@@ -1,6 +1,6 @@
 ;;; fuel-font-lock.el -- font lock for factor code
 
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
 ;; See http://factorcode.org/license.txt for BSD license.
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@@ -99,5 +99,24 @@
                          fuel-syntax--syntactic-keywords))))))
 
 
+
+;;; Fontify strings as Factor code:
+
+(defvar fuel-font-lock--font-lock-buffer
+  (let ((buffer (get-buffer-create " *fuel font lock*")))
+    (set-buffer buffer)
+    (set-syntax-table fuel-syntax--syntax-table)
+    (fuel-font-lock--font-lock-setup)
+    buffer))
+
+(defun fuel-font-lock--factor-str (str)
+  (save-current-buffer
+    (set-buffer fuel-font-lock--font-lock-buffer)
+    (erase-buffer)
+    (insert str)
+    (let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
+    (buffer-string)))
+
+
 (provide 'fuel-font-lock)
 ;;; fuel-font-lock.el ends here

misc/fuel/fuel-help.el

@@ -1,6 +1,6 @@
 ;;; fuel-help.el -- accessing Factor's help system
 
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
 ;; See http://factorcode.org/license.txt for BSD license.
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@@ -14,13 +14,18 @@
 
 ;;; Code:
 
+(require 'fuel-edit)
 (require 'fuel-eval)
+(require 'fuel-markup)
 (require 'fuel-autodoc)
 (require 'fuel-completion)
+(require 'fuel-syntax)
 (require 'fuel-font-lock)
 (require 'fuel-popup)
 (require 'fuel-base)
 
+(require 'button)
+
 
 ;;; Customization:
 
@@ -33,50 +38,67 @@
   :type 'boolean
   :group 'fuel-help)
 
-(defcustom fuel-help-use-minibuffer t
-  "When enabled, use the minibuffer for short help messages."
-  :type 'boolean
-  :group 'fuel-help)
-
-(defcustom fuel-help-mode-hook nil
-  "Hook run by `factor-help-mode'."
-  :type 'hook
-  :group 'fuel-help)
-
 (defcustom fuel-help-history-cache-size 50
   "Maximum number of pages to keep in the help browser cache."
   :type 'integer
   :group 'fuel-help)
 
-(fuel-font-lock--defface fuel-font-lock-help-headlines
+(defcustom fuel-help-bookmarks nil
-  'bold fuel-hep "headlines in help buffers")
+  "Bookmars. Maintain this list using the help browser."
+  :type 'list
+  :group 'fuel-help)
 
 
 ;;; Help browser history:
 
-(defvar fuel-help--history
+(defun fuel-help--make-history ()
   (list nil                                        ; current
         (make-ring fuel-help-history-cache-size)   ; previous
         (make-ring fuel-help-history-cache-size))) ; next
 
-(defun fuel-help--history-push (term)
+(defsubst fuel-help--history-current ()
-  (when (and (car fuel-help--history)
+  (car fuel-help--history))
-             (not (string= (caar fuel-help--history) (car term))))
-    (ring-insert (nth 1 fuel-help--history) (car fuel-help--history)))
-  (setcar fuel-help--history term))
 
-(defun fuel-help--history-next ()
+(defun fuel-help--history-push (link)
+  (unless (equal link (car fuel-help--history))
+    (let ((next (fuel-help--history-next)))
+      (unless (equal link next)
+        (when next (fuel-help--history-previous))
+        (ring-insert (nth 1 fuel-help--history) (car fuel-help--history))
+        (setcar fuel-help--history link))))
+  link)
+
+(defun fuel-help--history-next (&optional forget-current)
   (when (not (ring-empty-p (nth 2 fuel-help--history)))
-    (when (car fuel-help--history)
+    (when (and (car fuel-help--history) (not forget-current))
       (ring-insert (nth 1 fuel-help--history) (car fuel-help--history)))
     (setcar fuel-help--history (ring-remove (nth 2 fuel-help--history) 0))))
 
-(defun fuel-help--history-previous ()
+(defun fuel-help--history-previous (&optional forget-current)
   (when (not (ring-empty-p (nth 1 fuel-help--history)))
-    (when (car fuel-help--history)
+    (when (and (car fuel-help--history) (not forget-current))
       (ring-insert (nth 2 fuel-help--history) (car fuel-help--history)))
     (setcar fuel-help--history (ring-remove (nth 1 fuel-help--history) 0))))
 
+(defvar fuel-help--history (fuel-help--make-history))
+
+
+;;; Page cache:
+
+(defun fuel-help--history-current-content ()
+  (fuel-help--cache-get (car fuel-help--history)))
+
+(defvar fuel-help--cache (make-hash-table :weakness 'key :test 'equal))
+
+(defsubst fuel-help--cache-get (name)
+  (gethash name fuel-help--cache))
+
+(defsubst fuel-help--cache-insert (name str)
+  (puthash name str fuel-help--cache))
+
+(defsubst fuel-help--cache-clear ()
+  (clrhash fuel-help--cache))
+
 
 ;;; Fuel help buffer and internals:
 
@@ -86,121 +108,203 @@
 
 (defvar fuel-help--prompt-history nil)
 
-(defun fuel-help--show-help (&optional see word)
+(make-local-variable
-  (let* ((def (or word (fuel-syntax-symbol-at-point)))
+ (defvar fuel-help--buffer-link nil))
+
+(defun fuel-help--read-word (see)
+  (let* ((def (fuel-syntax-symbol-at-point))
          (prompt (format "See%s help on%s: " (if see " short" "")
                          (if def (format " (%s)" def) "")))
-         (ask (or (not (memq major-mode '(factor-mode fuel-help-mode)))
+         (ask (or (not def) fuel-help-always-ask)))
-                  (not def)
+    (if ask
-                  fuel-help-always-ask))
+        (fuel-completion--read-word prompt
-         (def (if ask (fuel-completion--read-word prompt
                                         def
                                         'fuel-help--prompt-history
                                         t)
-                def))
+      def)))
-         (cmd `(:fuel* ((:quote ,def) ,(if see 'see 'help)) t)))
+
+(defun fuel-help--word-help (&optional see word)
+  (let ((def (or word (fuel-help--read-word see))))
+    (when def
+      (let ((cmd `(:fuel* (,def ,(if see 'fuel-word-see 'fuel-word-help))
+                          "fuel" t)))
         (message "Looking up '%s' ..." def)
-    (fuel-eval--send cmd `(lambda (r) (fuel-help--show-help-cont ,def r)))))
+        (let* ((ret (fuel-eval--send/wait cmd))
-
+               (res (fuel-eval--retort-result ret)))
-(defun fuel-help--show-help-cont (def ret)
+          (if (not res)
-  (let ((out (fuel-eval--retort-output ret)))
-    (if (or (fuel-eval--retort-error ret) (empty-string-p out))
               (message "No help for '%s'" def)
-      (fuel-help--insert-contents def out))))
+            (fuel-help--insert-contents (list def def 'word) res)))))))
 
-(defun fuel-help--insert-contents (def str &optional nopush)
+(defun fuel-help--get-article (name label)
+  (message "Retrieving article ...")
+  (let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t))
+         (ret (fuel-eval--send/wait cmd))
+         (res (fuel-eval--retort-result ret)))
+    (if (not res)
+        (message "Article '%s' not found" label)
+      (fuel-help--insert-contents (list name label 'article) res)
+      (message ""))))
+
+(defun fuel-help--get-vocab (name)
+  (message "Retrieving help vocabulary for vocabulary '%s' ..." name)
+  (let* ((cmd `(:fuel* ((,name fuel-vocab-help)) "fuel" (,name)))
+         (ret (fuel-eval--send/wait cmd))
+         (res (fuel-eval--retort-result ret)))
+    (if (not res)
+        (message "No help available for vocabulary '%s'" name)
+      (fuel-help--insert-contents (list name name 'vocab) res)
+      (message ""))))
+
+(defun fuel-help--get-vocab/author (author)
+  (message "Retrieving vocabularies by %s ..." author)
+  (let* ((cmd `(:fuel* ((,author fuel-get-vocabs/author)) "fuel" t))
+         (ret (fuel-eval--send/wait cmd))
+         (res (fuel-eval--retort-result ret)))
+    (if (not res)
+        (message "No vocabularies by %s" author)
+      (fuel-help--insert-contents (list author author 'author) res)
+      (message ""))))
+
+(defun fuel-help--get-vocab/tag (tag)
+  (message "Retrieving vocabularies tagged '%s' ..." tag)
+  (let* ((cmd `(:fuel* ((,tag fuel-get-vocabs/tag)) "fuel" t))
+         (ret (fuel-eval--send/wait cmd))
+         (res (fuel-eval--retort-result ret)))
+    (if (not res)
+        (message "No vocabularies tagged '%s'" tag)
+      (fuel-help--insert-contents (list tag tag 'tag) res)
+      (message ""))))
+
+(defun fuel-help--follow-link (link label type &optional no-cache)
+  (let* ((llink (list link label type))
+         (cached (and (not no-cache) (fuel-help--cache-get llink))))
+    (if (not cached)
+        (let ((fuel-help-always-ask nil))
+          (cond ((eq type 'word) (fuel-help--word-help nil link))
+                ((eq type 'article) (fuel-help--get-article link label))
+                ((eq type 'vocab) (fuel-help--get-vocab link))
+                ((eq type 'author) (fuel-help--get-vocab/author label))
+                ((eq type 'tag) (fuel-help--get-vocab/tag label))
+                ((eq type 'bookmarks) (fuel-help-display-bookmarks))
+                (t (error "Links of type %s not yet implemented" type))))
+      (fuel-help--insert-contents llink cached))))
+
+(defun fuel-help--insert-contents (key content)
   (let ((hb (fuel-help--buffer))
         (inhibit-read-only t)
         (font-lock-verbose nil))
     (set-buffer hb)
     (erase-buffer)
-    (insert str)
+    (if (stringp content)
-    (unless nopush
+        (insert content)
-      (goto-char (point-min))
+      (fuel-markup--print content)
-      (when (re-search-forward (format "^%s" def) nil t)
+      (fuel-markup--insert-newline)
-        (beginning-of-line)
+      (delete-blank-lines)
-        (kill-region (point-min) (point))
+      (fuel-help--cache-insert key (buffer-string)))
-        (fuel-help--history-push (cons def (buffer-string)))))
+    (fuel-help--history-push key)
+    (setq fuel-help--buffer-link key)
     (set-buffer-modified-p nil)
     (fuel-popup--display)
     (goto-char (point-min))
-    (message "%s" def)))
+    (message "")))
 
 
-;;; Help mode font lock:
+;;; Bookmarks:
 
-(defconst fuel-help--headlines
+(defun fuel-help-bookmark-page ()
-  (regexp-opt '("Class description"
+  "Add current help page to bookmarks."
-                "Definition"
+  (interactive)
-                "Errors"
+  (let ((link fuel-help--buffer-link))
-                "Examples"
+    (unless link (error "No link associated to this page"))
-                "Generic word contract"
+    (add-to-list 'fuel-help-bookmarks link)
-                "Inputs and outputs"
+    (customize-save-variable 'fuel-help-bookmarks fuel-help-bookmarks)
-                "Methods"
+    (message "Bookmark '%s' saved" (cadr link))))
-                "Notes"
-                "Parent topics:"
-                "See also"
-                "Syntax"
-                "Variable description"
-                "Variable value"
-                "Vocabulary"
-                "Warning"
-                "Word description")
-              t))
 
-(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
+(defun fuel-help-delete-bookmark ()
-
+  "Delete link at point from bookmarks."
-(defconst fuel-help--font-lock-keywords
+  (interactive)
-  `(,@fuel-font-lock--font-lock-keywords
+  (let ((link (fuel-markup--link-at-point)))
-    (,fuel-help--headlines-regexp . 'fuel-font-lock-help-headlines)))
+    (unless link (error "No link at point"))
+    (unless (member link fuel-help-bookmarks)
+      (error "'%s' is not bookmarked" (cadr link)))
+    (customize-save-variable 'fuel-help-bookmarks
+                             (remove link fuel-help-bookmarks))
+    (message "Bookmark '%s' delete" (cadr link))
+    (fuel-help-display-bookmarks)))
 
+(defun fuel-help-display-bookmarks ()
+  "Display bookmarked pages."
+  (interactive)
+  (let ((links (mapcar (lambda (l) (cons '$subsection l)) fuel-help-bookmarks)))
+    (unless links (error "No links to display"))
+    (fuel-help--insert-contents '("bookmarks" "Bookmars" bookmarks)
+                                `(article "Bookmarks" ,links))))
 
 
 ;;; Interactive help commands:
 
-(defun fuel-help-short (&optional arg)
+(defun fuel-help-short ()
-  "See a help summary of symbol at point.
+  "See help summary of symbol at point."
-By default, the information is shown in the minibuffer. When
+  (interactive)
-called with a prefix argument, the information is displayed in a
+  (fuel-help--word-help t))
-separate help buffer."
-  (interactive "P")
-  (if (if fuel-help-use-minibuffer (not arg) arg)
-      (fuel-help--word-synopsis)
-    (fuel-help--show-help t)))
 
 (defun fuel-help ()
   "Show extended help about the symbol at point, using a help
 buffer."
   (interactive)
-  (fuel-help--show-help))
+  (fuel-help--word-help))
 
-(defun fuel-help-next ()
+(defun fuel-help-vocab (vocab)
-  "Go to next page in help browser."
+  "Ask for a vocabulary name and show its help page."
-  (interactive)
+  (interactive (list (fuel-edit--read-vocabulary-name nil)))
-  (let ((item (fuel-help--history-next))
+  (fuel-help--get-vocab vocab))
-        (fuel-help-always-ask nil))
-    (unless item
-      (error "No next page"))
-    (fuel-help--insert-contents (car item) (cdr item) t)))
 
-(defun fuel-help-previous ()
+(defun fuel-help-next (&optional forget-current)
-  "Go to next page in help browser."
+  "Go to next page in help browser.
-  (interactive)
+With prefix, the current page is deleted from history."
-  (let ((item (fuel-help--history-previous))
-        (fuel-help-always-ask nil))
-    (unless item
-      (error "No previous page"))
-    (fuel-help--insert-contents (car item) (cdr item) t)))
-
-(defun fuel-help-next-headline (&optional count)
   (interactive "P")
-  (end-of-line)
+  (let ((item (fuel-help--history-next forget-current)))
-  (when (re-search-forward fuel-help--headlines-regexp nil t (or count 1))
+    (unless item (error "No next page"))
-    (beginning-of-line)))
+    (apply 'fuel-help--follow-link item)))
 
-(defun fuel-help-previous-headline (&optional count)
+(defun fuel-help-previous (&optional forget-current)
+  "Go to previous page in help browser.
+With prefix, the current page is deleted from history."
   (interactive "P")
-  (re-search-backward fuel-help--headlines-regexp nil t count))
+  (let ((item (fuel-help--history-previous forget-current)))
+    (unless item (error "No previous page"))
+    (apply 'fuel-help--follow-link item)))
+
+(defun fuel-help-kill-page ()
+  "Kill current page if a previous or next one exists."
+  (interactive)
+  (condition-case nil
+      (fuel-help-previous t)
+    (error (fuel-help-next t))))
+
+(defun fuel-help-refresh ()
+  "Refresh the contents of current page."
+  (interactive)
+  (when fuel-help--buffer-link
+    (apply 'fuel-help--follow-link (append fuel-help--buffer-link '(t)))))
+
+(defun fuel-help-clean-history ()
+  "Clean up the help browser cache of visited pages."
+  (interactive)
+  (when (y-or-n-p "Clean browsing history? ")
+    (fuel-help--cache-clear)
+    (setq fuel-help--history (fuel-help--make-history))
+    (fuel-help-refresh))
+  (message ""))
+
+(defun fuel-help-edit ()
+  "Edit the current article or word help."
+  (interactive)
+  (let ((link (car fuel-help--buffer-link))
+        (type (nth 2 fuel-help--buffer-link)))
+    (cond ((eq type 'word) (fuel-edit-word-doc-at-point nil link))
+          ((member type '(article vocab)) (fuel-edit--edit-article link))
+          (t (error "No document associated with this page")))))
 
 
 ;;;; Help mode map:
@@ -208,15 +312,20 @@ buffer."
 (defvar fuel-help-mode-map
   (let ((map (make-sparse-keymap)))
     (suppress-keymap map)
-    (define-key map "\C-m" 'fuel-help)
+    (set-keymap-parent map button-buffer-map)
-    (define-key map "b" 'fuel-help-previous)
+    (define-key map "a" 'fuel-apropos)
-    (define-key map "f" 'fuel-help-next)
+    (define-key map "ba" 'fuel-help-bookmark-page)
+    (define-key map "bb" 'fuel-help-display-bookmarks)
+    (define-key map "bd" 'fuel-help-delete-bookmark)
+    (define-key map "c" 'fuel-help-clean-history)
+    (define-key map "e" 'fuel-help-edit)
+    (define-key map "h" 'fuel-help)
+    (define-key map "k" 'fuel-help-kill-page)
+    (define-key map "n" 'fuel-help-next)
     (define-key map "l" 'fuel-help-previous)
     (define-key map "p" 'fuel-help-previous)
-    (define-key map "n" 'fuel-help-next)
+    (define-key map "r" 'fuel-help-refresh)
-    (define-key map (kbd "TAB") 'fuel-help-next-headline)
+    (define-key map "v" 'fuel-help-vocab)
-    (define-key map (kbd "S-TAB") 'fuel-help-previous-headline)
-    (define-key map [(backtab)] 'fuel-help-previous-headline)
     (define-key map (kbd "SPC")  'scroll-up)
     (define-key map (kbd "S-SPC") 'scroll-down)
     (define-key map "\M-." 'fuel-edit-word-at-point)
@@ -224,6 +333,16 @@ buffer."
     (define-key map "\C-c\C-z" 'run-factor)
     map))
 
+
+;;; IN: support
+
+(defun fuel-help--find-in ()
+  (save-excursion
+    (or (fuel-syntax--find-in)
+        (and (goto-char (point-min))
+             (re-search-forward "Vocabulary: \\(.+\\)$" nil t)
+             (match-string-no-properties 1)))))
+
 
 ;;; Help mode definition:
 
@@ -234,16 +353,11 @@ buffer."
   (kill-all-local-variables)
   (buffer-disable-undo)
   (use-local-map fuel-help-mode-map)
+  (set-syntax-table fuel-syntax--syntax-table)
   (setq mode-name "FUEL Help")
   (setq major-mode 'fuel-help-mode)
-
+  (setq fuel-syntax--current-vocab-function 'fuel-help--find-in)
-  (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t)
+  (setq fuel-markup--follow-link-function 'fuel-help--follow-link)
-
-  (setq fuel-autodoc-mode-string "")
-  (fuel-autodoc-mode)
-
-  (run-mode-hooks 'fuel-help-mode-hook)
-
   (setq buffer-read-only t))
 
 

misc/fuel/fuel-listener.el

@@ -1,6 +1,6 @@
 ;;; fuel-listener.el --- starting the fuel listener
 
-;; Copyright (C) 2008  Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009  Jose Antonio Ortega Ruiz
 ;; See http://factorcode.org/license.txt for BSD license.
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@@ -15,6 +15,7 @@
 
 (require 'fuel-stack)
 (require 'fuel-completion)
+(require 'fuel-xref)
 (require 'fuel-eval)
 (require 'fuel-connection)
 (require 'fuel-syntax)
@@ -169,6 +170,7 @@ buffer."
 (define-key fuel-listener-mode-map "\C-ca" 'fuel-autodoc-mode)
 (define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
 (define-key fuel-listener-mode-map "\C-cs" 'fuel-stack-mode)
+(define-key fuel-listener-mode-map "\C-cp" 'fuel-apropos)
 (define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
 (define-key fuel-listener-mode-map "\C-cv" 'fuel-edit-vocabulary)
 (define-key fuel-listener-mode-map "\C-c\C-v" 'fuel-edit-vocabulary)

misc/fuel/fuel-markup.el

@@ -0,0 +1,597 @@
+;;; fuel-markup.el -- printing factor help markup
+
+;; Copyright (C) 2009 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: Thu Jan 01, 2009 21:43
+
+;;; Comentary:
+
+;; Utilities for printing Factor's help markup.
+
+;;; Code:
+
+(require 'fuel-eval)
+(require 'fuel-font-lock)
+(require 'fuel-base)
+(require 'fuel-table)
+
+(require 'button)
+
+
+;;; Customization:
+
+(fuel-font-lock--defface fuel-font-lock-markup-title
+  'bold fuel-help "article titles in help buffers")
+
+(fuel-font-lock--defface fuel-font-lock-markup-heading
+  'bold fuel-help "headlines in help buffers")
+
+(fuel-font-lock--defface fuel-font-lock-markup-link
+  'link fuel-help "links to topics in help buffers")
+
+(fuel-font-lock--defface fuel-font-lock-markup-emphasis
+  'italic fuel-help "emphasized words in help buffers")
+
+(fuel-font-lock--defface fuel-font-lock-markup-strong
+  'link fuel-help "bold words in help buffers")
+
+
+;;; Links:
+
+(make-variable-buffer-local
+ (defvar fuel-markup--follow-link-function 'fuel-markup--echo-link))
+
+(define-button-type 'fuel-markup--button
+  'action 'fuel-markup--follow-link
+  'face 'fuel-font-lock-markup-link
+  'follow-link t)
+
+(defun fuel-markup--follow-link (button)
+  (when fuel-markup--follow-link-function
+    (funcall fuel-markup--follow-link-function
+             (button-get button 'markup-link)
+             (button-get button 'markup-label)
+             (button-get button 'markup-link-type))))
+
+(defun fuel-markup--echo-link (link label type)
+  (message "Link %s pointing to %s named %s" label type link))
+
+(defun fuel-markup--insert-button (label link type)
+  (let ((label (format "%s" label))
+        (link (format "%s" link)))
+    (insert-text-button label
+                        :type 'fuel-markup--button
+                        'markup-link link
+                        'markup-label label
+                        'markup-link-type type
+                        'help-echo (format "%s (%s)" label type))))
+
+(defun fuel-markup--article-title (name)
+  (fuel-eval--retort-result
+   (fuel-eval--send/wait `(:fuel* ((,name fuel-article-title :get)) "fuel"))))
+
+(defun fuel-markup--link-at-point ()
+  (let ((button (condition-case nil (forward-button 0) (error nil))))
+    (when button
+      (list (button-get button 'markup-link)
+            (button-get button 'markup-label)
+            (button-get button 'markup-link-type)))))
+
+
+;;; Markup printers:
+
+(defconst fuel-markup--printers
+  '(($all-tags . fuel-markup--all-tags)
+    ($all-authors . fuel-markup--all-authors)
+    ($author . fuel-markup--author)
+    ($authors . fuel-markup--authors)
+    ($class-description . fuel-markup--class-description)
+    ($code . fuel-markup--code)
+    ($command . fuel-markup--command)
+    ($command-map . fuel-markup--null)
+    ($contract . fuel-markup--contract)
+    ($curious . fuel-markup--curious)
+    ($definition . fuel-markup--definition)
+    ($describe-vocab . fuel-markup--describe-vocab)
+    ($description . fuel-markup--description)
+    ($doc-path . fuel-markup--doc-path)
+    ($emphasis . fuel-markup--emphasis)
+    ($error-description . fuel-markup--error-description)
+    ($errors . fuel-markup--errors)
+    ($example . fuel-markup--example)
+    ($examples . fuel-markup--examples)
+    ($heading . fuel-markup--heading)
+    ($index . fuel-markup--index)
+    ($instance . fuel-markup--instance)
+    ($io-error . fuel-markup--io-error)
+    ($link . fuel-markup--link)
+    ($links . fuel-markup--links)
+    ($list . fuel-markup--list)
+    ($low-level-note . fuel-markup--low-level-note)
+    ($markup-example . fuel-markup--markup-example)
+    ($maybe . fuel-markup--maybe)
+    ($methods . fuel-markup--methods)
+    ($nl . fuel-markup--newline)
+    ($notes . fuel-markup--notes)
+    ($operation . fuel-markup--link)
+    ($parsing-note . fuel-markup--parsing-note)
+    ($predicate . fuel-markup--predicate)
+    ($prettyprinting-note . fuel-markup--prettyprinting-note)
+    ($quotation . fuel-markup--quotation)
+    ($references . fuel-markup--references)
+    ($related . fuel-markup--related)
+    ($see . fuel-markup--see)
+    ($see-also . fuel-markup--see-also)
+    ($shuffle . fuel-markup--shuffle)
+    ($side-effects . fuel-markup--side-effects)
+    ($slot . fuel-markup--snippet)
+    ($snippet . fuel-markup--snippet)
+    ($strong . fuel-markup--strong)
+    ($subheading . fuel-markup--subheading)
+    ($subsection . fuel-markup--subsection)
+    ($synopsis . fuel-markup--synopsis)
+    ($syntax . fuel-markup--syntax)
+    ($table . fuel-markup--table)
+    ($tag . fuel-markup--tag)
+    ($tags . fuel-markup--tags)
+    ($unchecked-example . fuel-markup--example)
+    ($value . fuel-markup--value)
+    ($values . fuel-markup--values)
+    ($values-x/y . fuel-markup--values-x/y)
+    ($var-description . fuel-markup--var-description)
+    ($vocab-link . fuel-markup--vocab-link)
+    ($vocab-links . fuel-markup--vocab-links)
+    ($vocab-subsection . fuel-markup--vocab-subsection)
+    ($vocabulary . fuel-markup--vocabulary)
+    ($warning . fuel-markup--warning)
+    (article . fuel-markup--article)
+    (describe-words . fuel-markup--describe-words)
+    (vocab-list . fuel-markup--vocab-list)))
+
+(make-variable-buffer-local
+ (defvar fuel-markup--maybe-nl nil))
+
+(defun fuel-markup--print (e)
+  (cond ((null e))
+        ((stringp e) (fuel-markup--insert-string e))
+        ((and (listp e) (symbolp (car e))
+              (assoc (car e) fuel-markup--printers))
+         (funcall (cdr (assoc (car e) fuel-markup--printers)) e))
+        ((and (symbolp e)
+              (assoc e fuel-markup--printers))
+         (funcall (cdr (assoc e fuel-markup--printers)) e))
+        ((listp e) (mapc 'fuel-markup--print e))
+        ((symbolp e) (fuel-markup--print (list '$link e)))
+        (t (insert (format "\n%S\n" e)))))
+
+(defun fuel-markup--print-str (e)
+  (with-temp-buffer
+    (fuel-markup--print e)
+    (buffer-string)))
+
+(defun fuel-markup--maybe-nl ()
+  (setq fuel-markup--maybe-nl (point)))
+
+(defun fuel-markup--insert-newline (&optional justification nosqueeze)
+  (fill-region (save-excursion (beginning-of-line) (point))
+               (point)
+               (or justification 'left)
+               nosqueeze)
+  (newline))
+
+(defsubst fuel-markup--insert-nl-if-nb (&optional no-fill)
+  (unless (eq (save-excursion (beginning-of-line) (point)) (point))
+    (if no-fill (newline) (fuel-markup--insert-newline))))
+
+(defsubst fuel-markup--put-face (txt face)
+  (put-text-property 0 (length txt) 'font-lock-face face txt)
+  txt)
+
+(defun fuel-markup--insert-heading (txt &optional no-nl)
+  (fuel-markup--insert-nl-if-nb)
+  (delete-blank-lines)
+  (unless (bobp) (newline))
+  (fuel-markup--put-face txt 'fuel-font-lock-markup-heading)
+  (fuel-markup--insert-string txt)
+  (unless no-nl (newline)))
+
+(defun fuel-markup--insert-string (str)
+  (when fuel-markup--maybe-nl
+    (newline 2)
+    (setq fuel-markup--maybe-nl nil))
+  (insert str))
+
+(defun fuel-markup--article (e)
+  (setq fuel-markup--maybe-nl nil)
+  (insert (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-title))
+  (newline 2)
+  (fuel-markup--print (car (cddr e))))
+
+(defun fuel-markup--heading (e)
+  (fuel-markup--insert-heading (cadr e)))
+
+(defun fuel-markup--subheading (e)
+  (fuel-markup--insert-heading (cadr e)))
+
+(defun fuel-markup--subsection (e)
+  (fuel-markup--insert-nl-if-nb)
+  (insert "  - ")
+  (fuel-markup--link (cons '$link (cdr e)))
+  (fuel-markup--maybe-nl))
+
+(defun fuel-markup--vocab-subsection (e)
+  (fuel-markup--insert-nl-if-nb)
+  (insert "  - ")
+  (fuel-markup--vocab-link (cons '$vocab-link (cdr e)))
+  (fuel-markup--maybe-nl))
+
+(defun fuel-markup--newline (e)
+  (fuel-markup--insert-newline)
+  (newline))
+
+(defun fuel-markup--doc-path (e)
+  (fuel-markup--insert-heading "Related topics")
+  (insert "  ")
+  (dolist (art (cdr e))
+    (fuel-markup--insert-button (car art) (cadr art) 'article)
+    (insert ", "))
+  (delete-backward-char 2)
+  (fuel-markup--insert-newline 'left))
+
+(defun fuel-markup--emphasis (e)
+  (when (stringp (cadr e))
+    (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-emphasis)
+    (insert (cadr e))))
+
+(defun fuel-markup--strong (e)
+  (when (stringp (cadr e))
+    (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-strong)
+    (insert (cadr e))))
+
+(defun fuel-markup--snippet (e)
+  (let ((snip (format "%s" (cadr e))))
+    (insert (fuel-font-lock--factor-str snip))))
+
+(defun fuel-markup--code (e)
+  (fuel-markup--insert-nl-if-nb)
+  (newline)
+  (dolist (snip (cdr e))
+    (if (stringp snip)
+        (insert (fuel-font-lock--factor-str snip))
+      (fuel-markup--print snip))
+    (newline))
+  (newline))
+
+(defun fuel-markup--command (e)
+  (fuel-markup--snippet (list '$snippet (nth 3 e))))
+
+(defun fuel-markup--syntax (e)
+  (fuel-markup--insert-heading "Syntax")
+  (fuel-markup--print (cons '$code (cdr e)))
+  (newline))
+
+(defun fuel-markup--example (e)
+  (fuel-markup--insert-newline)
+  (dolist (s (cdr e))
+    (fuel-markup--snippet (list '$snippet s))
+    (newline)))
+
+(defun fuel-markup--markup-example (e)
+  (fuel-markup--insert-newline)
+  (fuel-markup--snippet (cons '$snippet (cdr e))))
+
+(defun fuel-markup--link (e)
+  (let* ((link (nth 1 e))
+         (type (or (nth 3 e) (if (symbolp link) 'word 'article)))
+         (label (or (nth 2 e)
+                    (and (eq type 'article)
+                         (fuel-markup--article-title link))
+                    link)))
+    (fuel-markup--insert-button label link type)))
+
+(defun fuel-markup--links (e)
+  (dolist (link (cdr e))
+    (fuel-markup--link (list '$link link))
+    (insert ", "))
+  (delete-backward-char 2))
+
+(defun fuel-markup--index-quotation (q)
+  (cond ((null q) null)
+        ((listp q) (vconcat (mapcar 'fuel-markup--index-quotation q)))
+        (t q)))
+
+(defun fuel-markup--index (e)
+  (let* ((q (fuel-markup--index-quotation (cadr e)))
+         (cmd `(:fuel* ((,q fuel-index)) "fuel"
+                       ("builtins" "help" "help.topics" "classes"
+                        "classes.builtin" "classes.tuple"
+                        "classes.singleton" "classes.union"
+                        "classes.intersection" "classes.predicate")))
+         (subs (fuel-eval--retort-result (fuel-eval--send/wait cmd 200))))
+    (when subs
+      (let ((start (point))
+            (sort-fold-case nil))
+        (fuel-markup--print subs)
+        (sort-lines nil start (point))))))
+
+(defun fuel-markup--vocab-link (e)
+  (fuel-markup--insert-button (cadr e) (cadr e) 'vocab))
+
+(defun fuel-markup--vocab-links (e)
+  (dolist (link (cdr e))
+    (insert " ")
+    (fuel-markup--vocab-link (list '$vocab-link link))
+    (insert " ")))
+
+(defun fuel-markup--vocab-list (e)
+  (let ((rows (mapcar '(lambda (elem)
+                         (list (car elem)
+                               (list '$vocab-link (cadr elem))
+                               (caddr elem)))
+                      (cdr e))))
+    (fuel-markup--table (cons '$table rows))))
+
+(defun fuel-markup--describe-vocab (e)
+  (fuel-markup--insert-nl-if-nb)
+  (let* ((cmd `(:fuel* ((,(cadr e) fuel-vocab-help)) "fuel" t))
+         (res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
+    (when res (fuel-markup--print res))))
+
+(defun fuel-markup--vocabulary (e)
+  (fuel-markup--insert-heading "Vocabulary: " t)
+  (fuel-markup--vocab-link (cons '$vocab-link (cdr e)))
+  (newline))
+
+(defun fuel-markup--parse-classes ()
+  (let ((elems))
+    (while (looking-at ".+ classes$")
+      (let ((heading `($heading ,(match-string-no-properties 0)))
+            (rows))
+        (forward-line)
+        (when (looking-at "Class *.+$")
+          (push (split-string (match-string-no-properties 0) nil t) rows)
+          (forward-line))
+        (while (not (looking-at "$"))
+          (let* ((objs (split-string (thing-at-point 'line) nil t))
+                 (class (list '$link (car objs) (car objs) 'word))
+                 (super (and (cadr objs)
+                             (list (list '$link (cadr objs) (cadr objs) 'word))))
+                 (slots (when (cddr objs)
+                          (list (mapcar '(lambda (s) (list s " ")) (cddr objs))))))
+            (push `(,class ,@super ,@slots) rows))
+          (forward-line))
+        (push `(,heading ($table ,@(reverse rows))) elems))
+      (forward-line))
+    (reverse elems)))
+
+(defun fuel-markup--parse-words ()
+  (let ((elems))
+    (while (looking-at ".+ words\\|Primitives$")
+      (let ((heading `($heading ,(match-string-no-properties 0)))
+            (rows))
+        (forward-line)
+        (when (looking-at "Word *Stack effect$")
+          (push '("Word" "Stack effect") rows)
+          (forward-line))
+        (while (looking-at "\\(.+?\\)\\( +\\(( .*\\)\\)?$")
+          (let ((word `($link ,(match-string-no-properties 1)
+                              ,(match-string-no-properties 1)
+                              word))
+                (se (and (match-string-no-properties 3)
+                         `(($snippet ,(match-string-no-properties 3))))))
+            (push `(,word ,@se) rows))
+          (forward-line))
+        (push `(,heading ($table ,@(reverse rows))) elems))
+      (forward-line))
+    (reverse elems)))
+
+(defun fuel-markup--parse-words-desc (desc)
+  (with-temp-buffer
+    (insert desc)
+    (goto-char (point-min))
+    (when (re-search-forward "^Words$" nil t)
+      (forward-line 2)
+      (let ((elems '(($heading "Words"))))
+        (push (fuel-markup--parse-classes) elems)
+        (push (fuel-markup--parse-words) elems)
+        (reverse elems)))))
+
+(defun fuel-markup--describe-words (e)
+  (when (cadr e)
+    (fuel-markup--print (fuel-markup--parse-words-desc (cadr e)))))
+
+(defun fuel-markup--tag (e)
+  (fuel-markup--link (list '$link (cadr e) (cadr e) 'tag)))
+
+(defun fuel-markup--tags (e)
+  (when (cdr e)
+    (fuel-markup--insert-heading "Tags: " t)
+    (dolist (tag (cdr e))
+      (fuel-markup--tag (list '$tag tag))
+      (insert ", "))
+    (delete-backward-char 2)
+    (fuel-markup--insert-newline)))
+
+(defun fuel-markup--all-tags (e)
+  (let* ((cmd `(:fuel* (all-tags :get) "fuel" t))
+         (tags (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
+    (fuel-markup--list
+     (cons '$list (mapcar (lambda (tag) (list '$link tag tag 'tag)) tags)))))
+
+(defun fuel-markup--author (e)
+  (fuel-markup--link (list '$link (cadr e) (cadr e) 'author)))
+
+(defun fuel-markup--authors (e)
+  (when (cdr e)
+    (fuel-markup--insert-heading "Authors: " t)
+    (dolist (a (cdr e))
+      (fuel-markup--author (list '$author a))
+      (insert ", "))
+    (delete-backward-char 2)
+    (fuel-markup--insert-newline)))
+
+(defun fuel-markup--all-authors (e)
+  (let* ((cmd `(:fuel* (all-authors :get) "fuel" t))
+         (authors (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
+    (fuel-markup--list
+     (cons '$list (mapcar (lambda (a) (list '$link a a 'author)) authors)))))
+
+(defun fuel-markup--list (e)
+  (fuel-markup--insert-nl-if-nb)
+  (dolist (elt (cdr e))
+    (insert " - ")
+    (fuel-markup--print elt)
+    (fuel-markup--insert-newline)))
+
+(defun fuel-markup--table (e)
+  (fuel-markup--insert-newline)
+  (delete-blank-lines)
+  (newline)
+  (fuel-table--insert
+   (mapcar '(lambda (row) (mapcar 'fuel-markup--print-str row)) (cdr e)))
+  (newline))
+
+(defun fuel-markup--instance (e)
+  (insert " an instance of ")
+  (fuel-markup--print (cadr e)))
+
+(defun fuel-markup--maybe (e)
+  (fuel-markup--instance (cons '$instance (cdr e)))
+  (insert " or f "))
+
+(defun fuel-markup--values (e)
+  (fuel-markup--insert-heading "Inputs and outputs")
+  (dolist (val (cdr e))
+    (insert " " (car val) " - ")
+    (fuel-markup--print (cdr val))
+    (newline)))
+
+(defun fuel-markup--predicate (e)
+  (fuel-markup--values '($values ("object" object) ("?" "a boolean")))
+  (let ((word (make-symbol (substring (format "%s" (cadr e)) 0 -1))))
+  (fuel-markup--description
+   `($description "Tests if the object is an instance of the "
+                  ($link ,word) " class."))))
+
+(defun fuel-markup--side-effects (e)
+  (fuel-markup--insert-heading "Side effects")
+  (insert "Modifies ")
+  (fuel-markup--print (cdr e))
+  (fuel-markup--insert-newline))
+
+(defun fuel-markup--definition (e)
+  (fuel-markup--insert-heading "Definition")
+  (fuel-markup--code (cons '$code (cdr e))))
+
+(defun fuel-markup--methods (e)
+  (fuel-markup--insert-heading "Methods")
+  (fuel-markup--code (cons '$code (cdr e))))
+
+(defun fuel-markup--value (e)
+  (fuel-markup--insert-heading "Variable value")
+  (insert "Current value in global namespace: ")
+  (fuel-markup--snippet (cons '$snippet (cdr e)))
+  (newline))
+
+(defun fuel-markup--values-x/y (e)
+  (fuel-markup--values '($values ("x" "number") ("y" "number"))))
+
+(defun fuel-markup--curious (e)
+  (fuel-markup--insert-heading "For the curious...")
+  (fuel-markup--print (cdr e)))
+
+(defun fuel-markup--references (e)
+  (fuel-markup--insert-heading "References")
+  (dolist (ref (cdr e))
+    (if (listp ref)
+        (fuel-markup--print ref)
+      (fuel-markup--subsection (list '$subsection ref)))))
+
+(defun fuel-markup--see-also (e)
+  (fuel-markup--insert-heading "See also")
+  (fuel-markup--links (cons '$links (cdr e))))
+
+(defun fuel-markup--related (e)
+  (fuel-markup--insert-heading "See also")
+  (fuel-markup--links (cons '$links (cadr e))))
+
+(defun fuel-markup--shuffle (e)
+  (insert "\nShuffle word. Re-arranges the stack "
+          "according to the stack effect pattern.")
+  (fuel-markup--insert-newline))
+
+(defun fuel-markup--low-level-note (e)
+  (fuel-markup--print '($notes "Calling this word directly is not necessary "
+                               "in most cases. "
+                               "Higher-level words call it automatically.")))
+
+(defun fuel-markup--parsing-note (e)
+  (fuel-markup--insert-nl-if-nb)
+  (insert "This word should only be called from parsing words.")
+  (fuel-markup--insert-newline))
+
+(defun fuel-markup--io-error (e)
+  (fuel-markup--errors '($errors "Throws an error if the I/O operation fails.")))
+
+(defun fuel-markup--prettyprinting-note (e)
+  (fuel-markup--print '($notes ("This word should only be called within the "
+                                ($link with-pprint) " combinator."))))
+
+(defun fuel-markup--elem-with-heading (elem heading)
+  (fuel-markup--insert-heading heading)
+  (fuel-markup--print (cdr elem))
+  (fuel-markup--insert-newline))
+
+(defun fuel-markup--quotation (e)
+  (insert "a ")
+  (fuel-markup--link (list '$link 'quotation 'quotation 'word))
+  (insert " with stack effect ")
+  (fuel-markup--snippet (list '$snippet (nth 1 e))))
+
+(defun fuel-markup--warning (e)
+  (fuel-markup--elem-with-heading e "Warning"))
+
+(defun fuel-markup--description (e)
+  (fuel-markup--elem-with-heading e "Word description"))
+
+(defun fuel-markup--class-description (e)
+  (fuel-markup--elem-with-heading e "Class description"))
+
+(defun fuel-markup--error-description (e)
+  (fuel-markup--elem-with-heading e "Error description"))
+
+(defun fuel-markup--var-description (e)
+  (fuel-markup--elem-with-heading e "Variable description"))
+
+(defun fuel-markup--contract (e)
+  (fuel-markup--elem-with-heading e "Generic word contract"))
+
+(defun fuel-markup--errors (e)
+  (fuel-markup--elem-with-heading e "Errors"))
+
+(defun fuel-markup--examples (e)
+  (fuel-markup--elem-with-heading e "Examples"))
+
+(defun fuel-markup--notes (e)
+  (fuel-markup--elem-with-heading e "Notes"))
+
+(defun fuel-markup--see (e)
+  (let* ((word (nth 1 e))
+         (cmd (and word `(:fuel* (,(format "%s" word) fuel-word-see) "fuel" t)))
+         (res (and cmd
+                   (fuel-eval--retort-result (fuel-eval--send/wait cmd 100)))))
+    (if res
+        (fuel-markup--code (list '$code res))
+      (fuel-markup--snippet (list '$snippet word)))))
+
+(defun fuel-markup--null (e))
+
+(defun fuel-markup--synopsis (e)
+  (insert (format " %S " e)))
+
+
+(provide 'fuel-markup)
+;;; fuel-markup.el ends here

misc/fuel/fuel-mode.el

@@ -1,6 +1,6 @@
 ;;; fuel-mode.el -- Minor mode enabling FUEL niceties
 
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
 ;; See http://factorcode.org/license.txt for BSD license.
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@@ -24,6 +24,7 @@
 (require 'fuel-stack)
 (require 'fuel-autodoc)
 (require 'fuel-font-lock)
+(require 'fuel-edit)
 (require 'fuel-syntax)
 (require 'fuel-base)
 
@@ -80,7 +81,6 @@ With prefix argument, ask for the file to run."
       (message "Compiling %s ... OK!" file)
     (message "")))
 
-
 (defun fuel-eval-region (begin end &optional arg)
   "Sends region to Fuel's listener for evaluation.
 Unless called with a prefix, switches to the compilation results
@@ -131,75 +131,8 @@ With prefix argument, ask for the file name."
   (let ((file (car (fuel-mode--read-file arg))))
     (when file (fuel-debug--uses-for-file file))))
 
-(defun fuel--try-edit (ret)
-  (let* ((err (fuel-eval--retort-error ret))
-         (loc (fuel-eval--retort-result ret)))
-    (when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
-      (error "Couldn't find edit location for '%s'" word))
-    (unless (file-readable-p (car loc))
-      (error "Couldn't open '%s' for read" (car loc)))
-    (find-file-other-window (car loc))
-    (goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
-
-(defun fuel-edit-word-at-point (&optional arg)
-  "Opens a new window visiting the definition of the word at point.
-With prefix, asks for the word to edit."
-  (interactive "P")
-  (let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point))
-                   (fuel-completion--read-word "Edit word: ")))
-         (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location))))
-    (condition-case nil
-        (fuel--try-edit (fuel-eval--send/wait cmd))
-      (error (fuel-edit-vocabulary nil word)))))
-
-(defun fuel-edit-word-doc-at-point (&optional arg)
-  "Opens a new window visiting the documentation file for the word at point.
-With prefix, asks for the word to edit."
-  (interactive "P")
-  (let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point))
-                   (fuel-completion--read-word "Edit word: ")))
-         (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location))))
-    (condition-case nil
-        (fuel--try-edit (fuel-eval--send/wait cmd))
-      (error (when (y-or-n-p (concat "No documentation found. "
-                                     "Do you want to open the vocab's "
-                                     "doc file? "))
-               (find-file-other-window
-                (format "%s-docs.factor"
-                        (file-name-sans-extension (buffer-file-name)))))))))
-
 (defvar fuel-mode--word-history nil)
 
-(defun fuel-edit-word (&optional arg)
-  "Asks for a word to edit, with completion.
-With prefix, only words visible in the current vocabulary are
-offered."
-  (interactive "P")
-  (let* ((word (fuel-completion--read-word "Edit word: "
-                                           nil
-                                           fuel-mode--word-history
-                                           arg))
-         (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location))))
-    (fuel--try-edit (fuel-eval--send/wait cmd))))
-
-(defvar fuel--vocabs-prompt-history nil)
-
-(defun fuel--read-vocabulary-name (refresh)
-  (let* ((vocabs (fuel-completion--vocabs refresh))
-         (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 (&optional refresh vocab)
-  "Visits vocabulary file in Emacs.
-When called interactively, asks for vocabulary with completion.
-With prefix argument, refreshes cached vocabulary list."
-  (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))))
-
 (defun fuel-show-callers (&optional arg)
   "Show a list of callers of word at point.
 With prefix argument, ask for word."
@@ -224,6 +157,11 @@ With prefix argument, ask for word."
       (message "Looking up %s's callees ..." word)
       (fuel-xref--show-callees word))))
 
+(defun fuel-apropos (str)
+  "Show a list of words containing the given substring."
+  (interactive "MFind words containing: ")
+  (message "Looking up %s's references ..." str)
+  (fuel-xref--apropos str))
 
 ;;; Minor mode definition:
 
@@ -289,6 +227,7 @@ interacting with a factor listener is at your disposal.
 (fuel-mode--key ?d ?> 'fuel-show-callees)
 (fuel-mode--key ?d ?< 'fuel-show-callers)
 (fuel-mode--key ?d ?a 'fuel-autodoc-mode)
+(fuel-mode--key ?d ?p 'fuel-apropos)
 (fuel-mode--key ?d ?d 'fuel-help)
 (fuel-mode--key ?d ?e 'fuel-stack-effect-sexp)
 (fuel-mode--key ?d ?s 'fuel-help-short)

misc/fuel/fuel-syntax.el

@@ -1,6 +1,6 @@
 ;;; fuel-syntax.el --- auxiliar definitions for factor code navigation.
 
-;; Copyright (C) 2008  Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009  Jose Antonio Ortega Ruiz
 ;; See http://factorcode.org/license.txt for BSD license.
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@@ -48,7 +48,7 @@
     "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
     "GENERIC#" "GENERIC:" "HEX:" "HOOK:"
     "IN:" "INSTANCE:" "INTERSECTION:"
-    "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "METHOD:" "MIXIN:"
+    "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:"
     "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
     "REQUIRE:"  "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
     "TUPLE:" "t" "t?" "TYPEDEF:"
@@ -103,7 +103,8 @@
 (defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
 
 (defconst fuel-syntax--definition-starters-regex
-  (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" "MEMO" "METHOD" ":" "")))
+  (regexp-opt
+   '("VARS" "TUPLE" "MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD" ":" "")))
 
 (defconst fuel-syntax--definition-start-regex
   (format "^\\(%s:\\) " fuel-syntax--definition-starters-regex))
@@ -157,19 +158,26 @@
     table))
 
 (defconst fuel-syntax--syntactic-keywords
-  `(("\\_<\\(#?!\\) .*\\(\n\\)" (1 "<") (2 ">"))
+  `(;; Comments:
-    ("\\_<\\(#?!\\)\\(\n\\)" (1 "<") (2 ">"))
+    ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">"))
+    ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
+    ;; CHARs:
+    ("CHAR: \\(.\\)\\( \\|$\\)" (1 "w"))
+    ;; Let and lambda:
     ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
     ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
     ("\\(\\[\\)\\(|\\) +[^|]* \\(|\\)" (1 "(]") (2 "(|") (3 ")|"))
     (" \\(|\\) " (1 "(|"))
     (" \\(|\\)$" (1 ")"))
-    ("CHAR: \\(\"\\)\\( \\|$\\)" (1 "w"))
+    ;; Opening brace words:
     (,(format "\\_<%s\\({\\)\\_>" (regexp-opt fuel-syntax--bracers)) (1 "(}"))
     ("\\_<\\({\\)\\_>" (1 "(}"))
     ("\\_<\\(}\\)\\_>" (1 "){"))
+    ;; Parenthesis:
     ("\\_<\\((\\)\\_>" (1 "()"))
     ("\\_<\\()\\)\\_>" (1 ")("))
+    ;; Quotations:
+    ("\\_<'\\(\\[\\)\\_>" (1 "(]"))      ; fried
     ("\\_<\\(\\[\\)\\_>" (1 "(]"))
     ("\\_<\\(\\]\\)\\_>" (1 ")["))))
 
@@ -294,21 +302,9 @@
   (funcall fuel-syntax--current-vocab-function))
 
 (defun fuel-syntax--find-in ()
-  (let* ((vocab)
-         (ip
   (save-excursion
     (when (re-search-backward fuel-syntax--current-vocab-regex nil t)
-              (setq vocab (match-string-no-properties 1))
+      (match-string-no-properties 1))))
-              (point)))))
-    (when ip
-      (let ((pp (save-excursion
-                  (when (re-search-backward fuel-syntax--sub-vocab-regex ip t)
-                    (point)))))
-        (when (and pp (> pp ip))
-          (let ((sub (match-string-no-properties 1)))
-            (unless (save-excursion (search-backward (format "%s>" sub) pp t))
-              (setq vocab (format "%s.%s" vocab (downcase sub))))))))
-    vocab))
 
 (make-variable-buffer-local
  (defvar fuel-syntax--usings-function 'fuel-syntax--find-usings))
@@ -316,13 +312,19 @@
 (defsubst fuel-syntax--usings ()
   (funcall fuel-syntax--usings-function))
 
-(defun fuel-syntax--find-usings ()
+(defun fuel-syntax--find-usings (&optional no-private)
   (save-excursion
     (let ((usings))
       (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 usings)))
+      (goto-char (point-min))
+      (when (and (not no-private)
+                 (re-search-forward "\\_<<PRIVATE\\_>" nil t)
+                 (re-search-forward "\\_<PRIVATE>\\_>" nil t))
+        (goto-char (point-max))
+        (push (concat (fuel-syntax--find-in) ".private") usings))
       usings)))
 
 

misc/fuel/fuel-table.el

@@ -0,0 +1,93 @@
+;;; fuel-table.el -- table creation
+
+;; Copyright (C) 2009 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: Tue Jan 06, 2009 13:44
+
+;;; Comentary:
+
+;; Utilities to insert ascii tables.
+
+;;; Code:
+
+(defun fuel-table--col-widths (rows)
+  (let* ((col-no (length (car rows)))
+         (available (- (window-width) 2 (* 2 col-no)))
+         (widths)
+         (c 0))
+    (while (< c col-no)
+      (let ((width 0)
+            (av-width (- available (* 5 (- col-no c)))))
+        (dolist (row rows)
+          (setq width
+                (min av-width
+                     (max width (length (nth c row))))))
+        (push width widths)
+        (setq available (- available width)))
+      (setq c (1+ c)))
+    (reverse widths)))
+
+(defun fuel-table--pad-str (str width)
+  (let ((len (length str)))
+    (cond ((= len width) str)
+          ((> len width) (concat (substring str 0 (- width 3)) "..."))
+          (t (concat str (make-string (- width (length str)) ?\ ))))))
+
+(defun fuel-table--str-lines (str width)
+  (if (<= (length str) width)
+      (list (fuel-table--pad-str str width))
+    (with-temp-buffer
+      (let ((fill-column width))
+        (insert str)
+        (fill-region (point-min) (point-max))
+        (mapcar '(lambda (s) (fuel-table--pad-str s width))
+                (split-string (buffer-string) "\n"))))))
+
+(defun fuel-table--pad-row (row)
+  (let* ((max-ln (apply 'max (mapcar 'length row)))
+         (result))
+    (dolist (lines row)
+      (let ((ln (length lines)))
+        (if (= ln max-ln) (push lines result)
+          (let ((lines (reverse lines))
+                (l 0)
+                (blank (make-string (length (car lines)) ?\ )))
+            (while (< l ln)
+              (push blank lines)
+              (setq l (1+ l)))
+            (push (reverse lines) result)))))
+    (reverse result)))
+
+(defun fuel-table--format-rows (rows widths)
+  (let ((col-no (length (car rows)))
+        (frows))
+    (dolist (row rows)
+      (let ((c 0) (frow))
+        (while (< c col-no)
+          (push (fuel-table--str-lines (nth c row) (nth c widths)) frow)
+          (setq c (1+ c)))
+        (push (fuel-table--pad-row (reverse frow)) frows)))
+    (reverse frows)))
+
+(defun fuel-table--insert (rows)
+  (let* ((widths (fuel-table--col-widths rows))
+         (rows (fuel-table--format-rows rows widths))
+         (ls (concat "+" (mapconcat (lambda (n) (make-string n ?-)) widths "-+") "-+")))
+    (insert ls "\n")
+    (dolist (r rows)
+      (let ((ln (length (car r)))
+            (l 0))
+        (while (< l ln)
+          (insert (concat "|" (mapconcat 'identity
+                                         (mapcar `(lambda (x) (nth ,l x)) r)
+                                         " |")
+                          " |\n"))
+          (setq l (1+ l))))
+      (insert ls "\n"))))
+
+
+(provide 'fuel-table)
+;;; fuel-table.el ends here

misc/fuel/fuel-xref.el

@@ -1,6 +1,6 @@
 ;;; fuel-xref.el -- showing cross-reference info
 
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
 ;; See http://factorcode.org/license.txt for BSD license.
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@@ -13,6 +13,7 @@
 
 ;;; Code:
 
+(require 'fuel-help)
 (require 'fuel-eval)
 (require 'fuel-syntax)
 (require 'fuel-popup)
@@ -72,14 +73,14 @@ cursor at the first ocurrence of the used word."
 
 (make-local-variable (defvar fuel-xref--word nil))
 
-(defvar fuel-xref--help-string "(Press RET or click to follow crossrefs)")
+(defvar fuel-xref--help-string
+  "(Press RET or click to follow crossrefs, or h for help on word at point)")
 
 (defun fuel-xref--title (word cc count)
-  (let ((cc (if cc "using" "used by")))
   (put-text-property 0 (length word) 'font-lock-face 'bold word)
   (cond ((zerop count) (format "No known words %s %s" cc word))
         ((= 1 count) (format "1 word %s %s:" cc word))
-          (t (format "%s words %s %s:" count cc word)))))
+        (t (format "%s words %s %s:" count cc word))))
 
 (defun fuel-xref--insert-ref (ref)
   (when (and (stringp (first ref))
@@ -124,21 +125,31 @@ cursor at the first ocurrence of the used word."
 (defun fuel-xref--show-callers (word)
   (let* ((cmd `(:fuel* (((:quote ,word) fuel-callers-xref))))
          (res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
-    (fuel-xref--fill-and-display word t res)))
+    (fuel-xref--fill-and-display word "using" res)))
 
 (defun fuel-xref--show-callees (word)
   (let* ((cmd `(:fuel* (((:quote ,word) fuel-callees-xref))))
          (res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
-    (fuel-xref--fill-and-display word nil res)))
+    (fuel-xref--fill-and-display word "used by" res)))
+
+(defun fuel-xref--apropos (str)
+  (let* ((cmd `(:fuel* ((,str fuel-apropos-xref))))
+         (res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
+    (fuel-xref--fill-and-display str "containing" res)))
 
 
 ;;; Xref mode:
 
+(defun fuel-xref-show-help ()
+  (interactive)
+  (let ((fuel-help-always-ask nil))
+    (fuel-help)))
+
 (defvar fuel-xref-mode-map
   (let ((map (make-sparse-keymap)))
     (suppress-keymap map)
     (set-keymap-parent map button-buffer-map)
-    (define-key map "q" 'bury-buffer)
+    (define-key map "h" 'fuel-xref-show-help)
     map))
 
 (defun fuel-xref-mode ()