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

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> second ."
+        "{ 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> second ."
+        "T{ slice { from 1 } { to 4 } { seq { 1 2 3 4 5 6 } } }"
+    }
+} ;
 
 { clumps groups } related-words
 

basis/io/directories/search/search-docs.factor

@@ -0,0 +1,66 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations ;
+IN: io.directories.search
+
+HELP: each-file
+{ $values
+     { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
+}
+{ $description "Performs a directory traversal, breadth-first or depth-first, and calls the quotation on the full pathname of each file." }
+{ $examples
+    { $unchecked-example "USING: sequences io.directories.search ;"
+        "\"resource:misc\" t [ . ] each-file"
+        "! Recursive directory listing prints here"
+    }
+} ;
+
+HELP: recursive-directory
+{ $values
+     { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" }
+     { "paths" "a sequence of pathname strings" }
+}
+{ $description "Traverses a directory path recursively and returns a sequence of files in a breadth-first or depth-first manner." } ;
+
+HELP: find-file
+{ $values
+     { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
+     { "path/f" "a pathname string or f" }
+}
+{ $description "Finds the first file in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ;
+
+HELP: find-in-directories
+{ $values
+     { "directories" "a sequence of pathnames" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
+     { "path'" "a pathname string" }
+}
+{ $description "Finds the first file in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
+
+HELP: find-all-files
+{ $values
+     { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
+     { "paths" "a sequence of pathname strings" }
+}
+{ $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ;
+
+HELP: find-all-in-directories
+{ $values
+     { "directories" "a sequence of directory paths" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
+     { "paths" "a sequence of pathname strings" }
+}
+{ $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
+
+{ find-file find-all-files find-in-directories find-all-in-directories } related-words
+
+ARTICLE: "io.directories.search" "io.directories.search"
+"The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl
+"Traversing directories:"
+{ $subsection recursive-directory }
+{ $subsection each-file }
+"Finding files:"
+{ $subsection find-file }
+{ $subsection find-all-files }
+{ $subsection find-in-directories }
+{ $subsection find-all-in-directories } ;
+
+ABOUT: "io.directories.search"

basis/io/directories/search/search.factor

@@ -5,10 +5,10 @@ io.directories io.files io.files.info io.pathnames kernel
 sequences system vocabs.loader ;
 IN: io.directories.search
 
-TUPLE: directory-iterator path bfs queue ;
-
 <PRIVATE
 
+TUPLE: directory-iterator path bfs queue ;
+
 : qualified-directory ( path -- seq )
     dup directory-files [ append-path ] with map ;
 
@@ -38,22 +38,25 @@ TUPLE: directory-iterator path bfs queue ;
 
 PRIVATE>
 
+: each-file ( path bfs? quot: ( obj -- ) -- )
+    [ <directory-iterator> ] dip
+    [ f ] compose iterate-directory drop ; inline
+
+: recursive-directory ( path bfs? -- paths )
+    [ ] accumulator [ each-file ] dip ;
+
 : find-file ( path bfs? quot: ( obj -- ? ) -- path/f )
     [ <directory-iterator> ] dip
     [ keep and ] curry iterate-directory ; inline
 
-: each-file ( path bfs? quot: ( obj -- ? ) -- )
-    [ <directory-iterator> ] dip
-    [ f ] compose iterate-directory drop ; inline
-
 : find-all-files ( path bfs? quot: ( obj -- ? ) -- paths )
     [ <directory-iterator> ] dip
     pusher [ [ f ] compose iterate-directory drop ] dip ; inline
 
-: recursive-directory ( path bfs? -- paths )
+: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path' )
-    [ ] accumulator [ each-file ] dip ;
+    '[ _ _ find-file ] attempt-all ;
 
-: find-in-directories ( directories bfs? quot -- path' )
+: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths )
-    '[ _ _ find-file ] attempt-all ; inline
+    '[ _ _ find-all-files ] map concat ;
 
 os windows? [ "io.directories.search.windows" require ] when

basis/unix/users/users-docs.factor

@@ -50,7 +50,7 @@ HELP: set-real-user
 HELP: user-passwd
 { $values
      { "obj" object }
-     { "passwd" passwd } }
+     { "passwd/f" "passwd or f" } }
 { $description "Returns the passwd tuple given a username string or user id." } ;
 
 HELP: username

basis/unix/users/users-tests.factor

@@ -24,3 +24,7 @@ IN: unix.users.tests
 [ ] [ effective-user-id [ ] with-effective-user ] unit-test
 
 [ ] [ [ ] with-user-cache ] unit-test
+
+[ "9999999999999999999" ] [ 9999999999999999999 username ] unit-test
+
+[ f ] [ 89898989898989898989898989898 user-passwd ] unit-test

basis/unix/users/users.factor

@@ -47,17 +47,18 @@ SYMBOL: user-cache
 : with-user-cache ( quot -- )
     [ <user-cache> user-cache ] dip with-variable ; inline
 
-GENERIC: user-passwd ( obj -- passwd )
+GENERIC: user-passwd ( obj -- passwd/f )
 
 M: integer user-passwd ( id -- passwd/f )
     user-cache get
-    [ at ] [ getpwuid passwd>new-passwd ] if* ;
+    [ at ] [ getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
 
 M: string user-passwd ( string -- passwd/f )
     getpwnam dup [ passwd>new-passwd ] when ;
 
 : username ( id -- string )
-    user-passwd username>> ;
+    dup user-passwd
+    [ nip username>> ] [ number>string ] if* ;
 
 : user-id ( string -- id )
     user-passwd uid>> ;

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

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

extra/benchmark/crc32/crc32.factor

@@ -1,10 +1,10 @@
 USING: checksums checksums.crc32 io.encodings.ascii io.files kernel math ;
 IN: benchmark.crc32
 
-: crc32-primes-list ( -- )
+: crc32-file ( -- )
     10 [
-        "resource:extra/math/primes/list/list.factor"
+        "resource:basis/mime/multipart/multipart-tests.factor"
         crc32 checksum-file drop
     ] times ;
 
-MAIN: crc32-primes-list
+MAIN: crc32-file

extra/benchmark/md5/md5.factor

@@ -1,7 +1,7 @@
 USING: checksums checksums.md5 io.files kernel ;
 IN: benchmark.md5
 
-: md5-primes-list ( -- )
+: md5-file ( -- )
-    "resource:extra/math/primes/list/list.factor" md5 checksum-file drop ;
+    "resource:basis/mime/multipart/multipart-tests.factor" md5 checksum-file drop ;
 
-MAIN: md5-primes-list
+MAIN: md5-file

extra/benchmark/sha1/sha1.factor

@@ -1,7 +1,7 @@
 USING: checksums checksums.sha1 io.files kernel ;
 IN: benchmark.sha1
 
-: sha1-primes-list ( -- )
+: sha1-file ( -- )
-    "resource:extra/math/primes/list/list.factor" sha1 checksum-file drop ;
+    "resource:basis/mime/multipart/multipart-tests.factor" sha1 checksum-file drop ;
 
-MAIN: sha1-primes-list
+MAIN: sha1-file

extra/fuel/fuel.factor

@@ -4,9 +4,9 @@
 USING: accessors arrays assocs classes.tuple combinators
 compiler.units continuations debugger definitions help help.crossref
 help.markup help.topics io io.pathnames io.streams.string kernel lexer
-make math math.order memoize namespaces parser prettyprint sequences
+make math math.order memoize namespaces parser quotations prettyprint
-sets sorting source-files strings summary tools.crossref tools.vocabs
+sequences sets sorting source-files strings summary tools.crossref
-vectors vocabs vocabs.parser words ;
+tools.vocabs tools.vocabs.browser vectors vocabs vocabs.parser words ;
 
 IN: fuel
 
@@ -74,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
@@ -163,18 +165,22 @@ SYMBOL: :uses
 ! 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 )
@@ -292,16 +298,49 @@ MEMO: fuel-find-word ( name -- word/f )
     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
     [
-        [ summary [ , ] [ "No summary available" , ] if* ]
+        {
+            [ vocab-authors [ \ $authors prefix , ] when* ]
+            [ vocab-tags [ \ $tags prefix , ] when* ]
+            [ summary [ { $heading "Summary" } swap 2array , ] when* ]
             [ drop \ $nl , ]
-        [ vocab-help article [ content>> % ] when* ] tri
+            [ vocab-help [ article content>> % ] when* ]
+            [ name>> fuel-vocab-describe-words , ]
+            [ name>> fuel-vocab-children-help % ]
+        } cleave
     ] { } make 3array ;
 
 : fuel-vocab-help ( name -- )
-    (fuel-vocab-help) fuel-eval-set-result ; inline
+    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 ;
@@ -309,6 +348,21 @@ MEMO: fuel-find-word ( name -- word/f )
 : 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
 
 : fuel-startup ( -- ) "listener" run-file ; inline

extra/html/parser/utils/utils.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs circular combinators continuations hashtables
 hashtables.private io kernel math namespaces prettyprint
-quotations sequences splitting state-parser strings ;
+quotations sequences splitting state-parser strings
+combinators.short-circuit ;
 IN: html.parser.utils
 
 : string-parse-end? ( -- ? ) get-next not ;
@@ -13,26 +14,26 @@ IN: html.parser.utils
     dup length rot length 1- - head next* ;
 
 : trim1 ( seq ch -- newseq )
-    [ ?head drop ] [ ?tail drop ] bi ;
+    [ [ ?head-slice drop ] [ ?tail-slice drop ] bi ] 2keep drop like ;
 
-: single-quote ( str -- newstr )
+: quote? ( ch -- ? ) "'\"" member? ;
-    "'" dup surround ;
 
-: double-quote ( str -- newstr )
+: single-quote ( str -- newstr ) "'" dup surround ;
-    "\"" dup surround ;
+
+: double-quote ( str -- newstr ) "\"" dup surround ;
 
 : quote ( str -- newstr )
     CHAR: ' over member?
     [ double-quote ] [ single-quote ] if ;
 
 : quoted? ( str -- ? )
-    [ f ]
+    {
-    [ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] if-empty ;
+        [ length 1 > ]
+        [ first quote? ]
+        [ [ first ] [ peek ] bi = ]
+    } 1&& ;
 
-: ?quote ( str -- newstr )
+: ?quote ( str -- newstr ) dup quoted? [ quote ] unless ;
-    dup quoted? [ quote ] unless ;
 
 : unquote ( str -- newstr )
     dup quoted? [ but-last-slice rest-slice >string ] when ;
-
-: quote? ( ch -- ? ) "'\"" member? ;

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/authors.txt

@@ -0,0 +1 @@
+Samuel Tardieu

extra/math/primes/erato/erato.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2009 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
 USING: bit-arrays kernel math math.functions math.ranges sequences ;
 IN: math.primes.erato
 

extra/math/primes/erato/summary.txt

@@ -0,0 +1 @@
+Eratosthene sieve

extra/math/primes/factors/factors-tests.factor

@@ -1,6 +1,8 @@
 USING: math.primes.factors tools.test ;
 
 { { 999983 999983 1000003 } } [ 999969000187000867 factors ] unit-test
+{ { } } [ -5 factors ] unit-test
 { { { 999983 2 } { 1000003 1 } } } [ 999969000187000867 group-factors ] unit-test
 { { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test
 { 999967000236000612 } [ 999969000187000867 totient ] unit-test
+{ 0 } [ 1 totient ] unit-test

extra/math/primes/factors/factors.factor

@@ -1,39 +1,36 @@
-! Copyright (C) 2007 Samuel Tardieu.
+! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel lists make math math.primes sequences ;
 IN: math.primes.factors
 
 <PRIVATE
 
-: (factor) ( n d -- n' )
+: count-factor ( n d -- n' c )
-    2dup mod zero? [ [ / ] keep dup , (factor) ] [ drop ] if ;
+    0 [ [ 2dup mod zero? ] dip swap ] [ [ [ / ] keep ] dip 1+ ] [ ] while nip ;
+
+: (factor) ( n d -- n' ) dup [ , ] curry [ count-factor ] dip times ;
 
 : (count) ( n d -- n' )
-    [ (factor) ] { } make
+    dup [ swap 2array , ] curry
-    [ [ first ] [ length ] bi 2array , ] unless-empty ;
+    [ count-factor dup zero? [ drop ] ] dip if ;
 
 : (unique) ( n d -- n' )
-    [ (factor) ] { } make
+    dup [ , ] curry [ count-factor zero? ] dip unless ;
-    [ first , ] unless-empty ;
 
 : (factors) ( quot list n -- )
     dup 1 > [
         swap uncons swap [ pick call ] dip swap (factors)
-    ] [ 3drop ] if ;
+    ] [ 3drop ] if ; inline recursive
 
-: (decompose) ( n quot -- seq )
+: decompose ( n quot -- seq ) [ lprimes rot (factors) ] { } make ; inline
-    [ lprimes rot (factors) ] { } make ;
 
 PRIVATE>
 
-: factors ( n -- seq )
+: factors ( n -- seq ) [ (factor) ] decompose ; flushable
-    [ (factor) ] (decompose) ; foldable
 
-: group-factors ( n -- seq )
+: group-factors ( n -- seq ) [ (count) ] decompose ; flushable
-    [ (count) ] (decompose) ; foldable
 
-: unique-factors ( n -- seq )
+: unique-factors ( n -- seq ) [ (unique) ] decompose ; flushable
-    [ (unique) ] (decompose) ; foldable
 
 : totient ( n -- t )
     dup 2 < [

extra/math/primes/list/authors.txt

@@ -1 +0,0 @@
-Doug Coleman

extra/math/primes/list/list.factor

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

extra/project-euler/057/057-tests.factor

@@ -0,0 +1,3 @@
+USING: project-euler.057 tools.test ;
+
+{ 153 } [ euler057 ] unit-test

misc/fuel/README

@@ -95,13 +95,17 @@ beast.
 *** In the help browser:
 
     - h : help for word at point
+    - 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 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
@@ -112,4 +116,5 @@ beast.
 
     - TAB/BACKTAB : navigate links
     - RET/mouse click : follow link
+    - h : show help for word at point
     - q : bury buffer

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-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))
 
@@ -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-help.el

@@ -14,11 +14,12 @@
 
 ;;; Code:
 
+(require 'fuel-edit)
 (require 'fuel-eval)
 (require 'fuel-markup)
 (require 'fuel-autodoc)
-(require 'fuel-xref)
 (require 'fuel-completion)
+(require 'fuel-syntax)
 (require 'fuel-font-lock)
 (require 'fuel-popup)
 (require 'fuel-base)
@@ -67,15 +68,15 @@
         (setcar fuel-help--history link))))
   link)
 
-(defun fuel-help--history-next ()
+(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))))
 
@@ -114,10 +115,9 @@
   (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
-    (if ask (fuel-completion--read-word prompt
                                         def
                                         'fuel-help--prompt-history
                                         t)
@@ -129,7 +129,7 @@
       (let ((cmd `(:fuel* (,def ,(if see 'fuel-word-see 'fuel-word-help))
                           "fuel" t)))
         (message "Looking up '%s' ..." def)
-        (let* ((ret (fuel-eval--send/wait cmd 2000))
+        (let* ((ret (fuel-eval--send/wait cmd))
                (res (fuel-eval--retort-result ret)))
           (if (not res)
               (message "No help for '%s'" def)
@@ -138,7 +138,7 @@
 (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 2000))
+         (ret (fuel-eval--send/wait cmd))
          (res (fuel-eval--retort-result ret)))
     (if (not res)
         (message "Article '%s' not found" label)
@@ -146,15 +146,35 @@
       (message ""))))
 
 (defun fuel-help--get-vocab (name)
-  (message "Retrieving vocabulary help ...")
+  (message "Retrieving help vocabulary for vocabulary '%s' ..." name)
   (let* ((cmd `(:fuel* ((,name fuel-vocab-help)) "fuel" (,name)))
-         (ret (fuel-eval--send/wait cmd 2000))
+         (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))))
@@ -163,6 +183,8 @@
           (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))))
@@ -177,6 +199,7 @@
         (insert content)
       (fuel-markup--print content)
       (fuel-markup--insert-newline)
+      (delete-blank-lines)
       (fuel-help--cache-insert key (buffer-string)))
     (fuel-help--history-push key)
     (setq fuel-help--buffer-link key)
@@ -231,20 +254,34 @@ buffer."
   (interactive)
   (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))
+
+(defun fuel-help-next (&optional forget-current)
+  "Go to next page in help browser.
+With prefix, the current page is deleted from history."
+  (interactive "P")
+  (let ((item (fuel-help--history-next forget-current)))
     (unless item (error "No next page"))
     (apply 'fuel-help--follow-link item)))
 
-(defun fuel-help-previous ()
+(defun fuel-help-previous (&optional forget-current)
-  "Go to previous page in help browser."
+  "Go to previous page in help browser.
-  (interactive)
+With prefix, the current page is deleted from history."
-  (let ((item (fuel-help--history-previous)))
+  (interactive "P")
+  (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)
@@ -260,6 +297,15 @@ buffer."
     (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:
 
@@ -272,10 +318,14 @@ buffer."
     (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 "r" 'fuel-help-refresh)
+    (define-key map "v" 'fuel-help-vocab)
     (define-key map (kbd "SPC")  'scroll-up)
     (define-key map (kbd "S-SPC") 'scroll-down)
     (define-key map "\M-." 'fuel-edit-word-at-point)
@@ -283,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:
 
@@ -296,6 +356,7 @@ buffer."
   (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)
   (setq fuel-markup--follow-link-function 'fuel-help--follow-link)
   (setq buffer-read-only t))
 

misc/fuel/fuel-markup.el

@@ -16,9 +16,9 @@
 (require 'fuel-eval)
 (require 'fuel-font-lock)
 (require 'fuel-base)
+(require 'fuel-table)
 
 (require 'button)
-(require 'table)
 
 
 ;;; Customization:
@@ -84,12 +84,18 @@
 ;;; Markup printers:
 
 (defconst fuel-markup--printers
-  '(($class-description . fuel-markup--class-description)
+  '(($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)
@@ -110,6 +116,7 @@
     ($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)
@@ -128,6 +135,8 @@
     ($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)
@@ -138,7 +147,9 @@
     ($vocab-subsection . fuel-markup--vocab-subsection)
     ($vocabulary . fuel-markup--vocabulary)
     ($warning . fuel-markup--warning)
-    (article . fuel-markup--article)))
+    (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))
@@ -164,10 +175,11 @@
 (defun fuel-markup--maybe-nl ()
   (setq fuel-markup--maybe-nl (point)))
 
-(defun fuel-markup--insert-newline (&optional justification)
+(defun fuel-markup--insert-newline (&optional justification nosqueeze)
   (fill-region (save-excursion (beginning-of-line) (point))
                (point)
-               (or justification 'left))
+               (or justification 'left)
+               nosqueeze)
   (newline))
 
 (defsubst fuel-markup--insert-nl-if-nb (&optional no-fill)
@@ -180,6 +192,7 @@
 
 (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)
@@ -239,7 +252,7 @@
     (insert (cadr e))))
 
 (defun fuel-markup--snippet (e)
-  (let ((snip (format "%s" (cdr e))))
+  (let ((snip (format "%s" (cadr e))))
     (insert (fuel-font-lock--factor-str snip))))
 
 (defun fuel-markup--code (e)
@@ -260,17 +273,15 @@
   (fuel-markup--print (cons '$code (cdr e)))
   (newline))
 
-(defun fuel-markup--examples (e)
+(defun fuel-markup--example (e)
-  (fuel-markup--insert-heading "Examples")
+  (fuel-markup--insert-newline)
-  (dolist (ex (cdr e))
+  (dolist (s (cdr e))
-    (fuel-markup--print ex)
+    (fuel-markup--snippet (list '$snippet s))
     (newline)))
 
-(defun fuel-markup--example (e)
-  (fuel-markup--snippet (list '$snippet (cadr e))))
-
 (defun fuel-markup--markup-example (e)
-  (fuel-markup--snippet (cons '$snippet (cadr e))))
+  (fuel-markup--insert-newline)
+  (fuel-markup--snippet (cons '$snippet (cdr e))))
 
 (defun fuel-markup--link (e)
   (let* ((link (nth 1 e))
@@ -301,7 +312,10 @@
                         "classes.intersection" "classes.predicate")))
          (subs (fuel-eval--retort-result (fuel-eval--send/wait cmd 200))))
     (when subs
-      (fuel-markup--print 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))
@@ -312,11 +326,119 @@
     (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))
@@ -326,19 +448,10 @@
 
 (defun fuel-markup--table (e)
   (fuel-markup--insert-newline)
+  (delete-blank-lines)
   (newline)
-  (let ((start (point))
+  (fuel-table--insert
-        (col-delim "<~end-of-col~>")
+   (mapcar '(lambda (row) (mapcar 'fuel-markup--print-str row)) (cdr e)))
-        (col-no (length (cadr e))))
-    (dolist (row (cdr e))
-      (dolist (col row)
-        (fuel-markup--print col)
-        (insert col-delim)))
-    (table-capture start (point)
-                   col-delim nil nil
-                   (/ (- (window-width) 10) col-no) col-no))
-  (goto-char (point-max))
-  (table-recognize -1)
   (newline))
 
 (defun fuel-markup--instance (e)
@@ -459,6 +572,9 @@
 (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"))
 
@@ -471,6 +587,8 @@
         (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)))
 

misc/fuel/fuel-mode.el

@@ -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."

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))

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

@@ -13,6 +13,7 @@
 
 ;;; Code:
 
+(require 'fuel-help)
 (require 'fuel-eval)
 (require 'fuel-syntax)
 (require 'fuel-popup)
@@ -72,7 +73,8 @@ 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)
   (put-text-property 0 (length word) 'font-lock-face 'bold word)
@@ -138,10 +140,16 @@ cursor at the first ocurrence of the used word."
 
 ;;; 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 "h" 'fuel-xref-show-help)
     map))
 
 (defun fuel-xref-mode ()