Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
839b5b14eb
|
|
@ -21,3 +21,4 @@ logs
|
|||
work
|
||||
build-support/wordsize
|
||||
*.bak
|
||||
.#*
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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> } "." }
|
||||
{ $see-also group } ;
|
||||
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." } ;
|
||||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
math.ranges namespaces random sequences hashtables sets ;
|
||||
USING: combinators kernel locals math math.functions math.ranges
|
||||
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* ;
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 )
|
||||
[ (2each) ] dip collect ; inline
|
||||
: 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 )
|
||||
[ 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
|
||||
[ [ 2map-into ] keep ] new-like ; inline
|
||||
[ (2each) ] dip map-as ; 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
|
||||
[ rot = [ over push ] [ drop ] if ]
|
||||
curry each-index ;
|
||||
swap V{ } clone
|
||||
[ [ (indices) ] 2curry each-index ] keep ;
|
||||
|
||||
: 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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
The Factor FAQ
|
||||
|
|
@ -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
|
||||
io.streams.string kernel lexer math math.order memoize namespaces
|
||||
parser prettyprint sequences sets sorting source-files strings summary
|
||||
tools.vocabs vectors vocabs vocabs.parser words ;
|
||||
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 quotations prettyprint
|
||||
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
|
||||
fuel-eval-result get-global
|
||||
fuel-eval-output get-global
|
||||
error get 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-forget-error
|
||||
fuel-forget-result
|
||||
fuel-forget-output ;
|
||||
fuel-push-status fuel-forget-status ; inline
|
||||
|
||||
: (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 -- )
|
||||
[
|
||||
auto-use? on
|
||||
[ amended-use get clone fuel-eval-set-result ] print-use-hook set
|
||||
call
|
||||
] curry with-scope ;
|
||||
: fuel-set-use-hook ( -- )
|
||||
[ amended-use get clone :uses prefix fuel-eval-set-result ]
|
||||
print-use-hook set ;
|
||||
|
||||
: fuel-run-file ( path -- )
|
||||
[ 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
|
||||
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
[ drop "No inverse defined on recursive word" ] when
|
||||
throw
|
||||
] recover ;
|
||||
[
|
||||
visited [ over suffix ] change
|
||||
[
|
||||
dup flattenable? [
|
||||
def>>
|
||||
[ visited get memq? [ no-recursive-inverse ] when ]
|
||||
[ flatten ]
|
||||
bi
|
||||
] [ 1quotation ] if
|
||||
] map concat
|
||||
] with-scope ;
|
||||
|
||||
ERROR: undefined-inverse ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
math.miller-rabin math.primes.erato math.ranges sequences ;
|
||||
USING: combinators kernel lists.lazy math math.functions
|
||||
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
|
||||
[ natural-search drop ] [ length ] [ ] tri <slice> ; foldable
|
||||
[ dup 3 max dup even? [ 1 + ] when ] dip
|
||||
2 <range> [ prime? ] filter
|
||||
swap 3 < [ 2 prefix ] when ;
|
||||
|
||||
: primes-upto ( n -- seq ) 2 swap primes-between ;
|
||||
|
||||
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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.075 project-euler.076 project-euler.079 project-euler.092
|
||||
project-euler.097 project-euler.099 project-euler.100 project-euler.116
|
||||
project-euler.117 project-euler.134 project-euler.148 project-euler.150
|
||||
project-euler.151 project-euler.164 project-euler.169 project-euler.173
|
||||
project-euler.175 project-euler.186 project-euler.190 project-euler.203
|
||||
project-euler.215 ;
|
||||
project-euler.057 project-euler.059 project-euler.067 project-euler.071
|
||||
project-euler.073 project-euler.075 project-euler.076 project-euler.079
|
||||
project-euler.092 project-euler.097 project-euler.099 project-euler.100
|
||||
project-euler.116 project-euler.117 project-euler.134 project-euler.148
|
||||
project-euler.150 project-euler.151 project-euler.164 project-euler.169
|
||||
project-euler.173 project-euler.175 project-euler.186 project-euler.190
|
||||
project-euler.203 project-euler.215 ;
|
||||
IN: project-euler
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -1,56 +1,54 @@
|
|||
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'
|
||||
original factor.el code.
|
||||
FUEL was started by Jose A Ortega as an extension to Eduardo Cavazos'
|
||||
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.
|
||||
FUEL comes bundled with Factor's distribution. The folder misc/fuel
|
||||
contains Elisp code, and there's a fuel vocabulary in extras/fuel.
|
||||
|
||||
To install FUEL, either add this line to your Emacs initialisation:
|
||||
To install FUEL, either add this line to your Emacs initialisation:
|
||||
|
||||
(load-file "<path/to/factor/installation>/misc/fuel/fu.el")
|
||||
|
||||
or
|
||||
or
|
||||
|
||||
(add-to-list load-path "<path/to/factor/installation>/fuel")
|
||||
(require 'fuel)
|
||||
|
||||
If all you want is a major mode for editing Factor code with pretty
|
||||
font colors and indentation, without running the factor listener
|
||||
inside Emacs, you can use instead:
|
||||
If all you want is a major mode for editing Factor code with pretty
|
||||
font colors and indentation, without running the factor listener
|
||||
inside Emacs, you can use instead:
|
||||
|
||||
(add-to-list load-path "<path/to/factor/installation>/fuel")
|
||||
(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.
|
||||
Editing any file with the extension .factor will put you in
|
||||
factor-mode; try C-hm for a summary of available commands.
|
||||
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.
|
||||
Editing any file with the extension .factor will put you in
|
||||
factor-mode; try C-hm for a summary of available commands.
|
||||
|
||||
To start the listener, try M-x run-factor.
|
||||
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.
|
||||
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)).
|
||||
(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
|
||||
- f/b : next/previous page
|
||||
- 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 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(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))
|
||||
(defvar fuel-autodoc--timeout 200)
|
||||
|
||||
(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* (((:quote ,word) synopsis :get)) t)))
|
||||
(ret (fuel-eval--send/wait cmd 20))
|
||||
`(:fuel* (,word fuel-vocab-summary) :in t)
|
||||
`(:fuel* (((:quote ,word) synopsis :get)) :in)))
|
||||
(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"))
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
(old (sort old 'string<))
|
||||
(sort (fuel-syntax--find-usings t) '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))
|
||||
(when (and fuel-debug--uses-file fuel-debug--uses)
|
||||
(fuel-debug--uses-new-uses fuel-debug--uses-file fuel-debug--uses)
|
||||
(message "USING: updated!")
|
||||
(with-current-buffer (fuel-debug--uses-buffer)
|
||||
(let ((inhibit-read-only t)
|
||||
(file fuel-debug--uses-file)
|
||||
(uses fuel-debug--uses))
|
||||
(when (and uses file)
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
'bold fuel-hep "headlines in help buffers")
|
||||
(defcustom fuel-help-bookmarks nil
|
||||
"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)
|
||||
(when (and (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))
|
||||
(defsubst fuel-help--history-current ()
|
||||
(car fuel-help--history))
|
||||
|
||||
(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)
|
||||
(let* ((def (or word (fuel-syntax-symbol-at-point)))
|
||||
(make-local-variable
|
||||
(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)))
|
||||
(not def)
|
||||
fuel-help-always-ask))
|
||||
(def (if ask (fuel-completion--read-word prompt
|
||||
(ask (or (not def) fuel-help-always-ask)))
|
||||
(if ask
|
||||
(fuel-completion--read-word prompt
|
||||
def
|
||||
'fuel-help--prompt-history
|
||||
t)
|
||||
def))
|
||||
(cmd `(:fuel* ((:quote ,def) ,(if see 'see 'help)) t)))
|
||||
def)))
|
||||
|
||||
(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)))))
|
||||
|
||||
(defun fuel-help--show-help-cont (def ret)
|
||||
(let ((out (fuel-eval--retort-output ret)))
|
||||
(if (or (fuel-eval--retort-error ret) (empty-string-p out))
|
||||
(let* ((ret (fuel-eval--send/wait cmd))
|
||||
(res (fuel-eval--retort-result ret)))
|
||||
(if (not res)
|
||||
(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)
|
||||
(unless nopush
|
||||
(goto-char (point-min))
|
||||
(when (re-search-forward (format "^%s" def) nil t)
|
||||
(beginning-of-line)
|
||||
(kill-region (point-min) (point))
|
||||
(fuel-help--history-push (cons def (buffer-string)))))
|
||||
(if (stringp content)
|
||||
(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)
|
||||
(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
|
||||
(regexp-opt '("Class description"
|
||||
"Definition"
|
||||
"Errors"
|
||||
"Examples"
|
||||
"Generic word contract"
|
||||
"Inputs and outputs"
|
||||
"Methods"
|
||||
"Notes"
|
||||
"Parent topics:"
|
||||
"See also"
|
||||
"Syntax"
|
||||
"Variable description"
|
||||
"Variable value"
|
||||
"Vocabulary"
|
||||
"Warning"
|
||||
"Word description")
|
||||
t))
|
||||
(defun fuel-help-bookmark-page ()
|
||||
"Add current help page to bookmarks."
|
||||
(interactive)
|
||||
(let ((link fuel-help--buffer-link))
|
||||
(unless link (error "No link associated to this page"))
|
||||
(add-to-list 'fuel-help-bookmarks link)
|
||||
(customize-save-variable 'fuel-help-bookmarks fuel-help-bookmarks)
|
||||
(message "Bookmark '%s' saved" (cadr link))))
|
||||
|
||||
(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
|
||||
|
||||
(defconst fuel-help--font-lock-keywords
|
||||
`(,@fuel-font-lock--font-lock-keywords
|
||||
(,fuel-help--headlines-regexp . 'fuel-font-lock-help-headlines)))
|
||||
(defun fuel-help-delete-bookmark ()
|
||||
"Delete link at point from bookmarks."
|
||||
(interactive)
|
||||
(let ((link (fuel-markup--link-at-point)))
|
||||
(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)
|
||||
"See a help summary of symbol at point.
|
||||
By default, the information is shown in the minibuffer. When
|
||||
called with a prefix argument, the information is displayed in a
|
||||
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-short ()
|
||||
"See help summary of symbol at point."
|
||||
(interactive)
|
||||
(fuel-help--word-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 ()
|
||||
"Go to next page in help browser."
|
||||
(interactive)
|
||||
(let ((item (fuel-help--history-next))
|
||||
(fuel-help-always-ask nil))
|
||||
(unless item
|
||||
(error "No next page"))
|
||||
(fuel-help--insert-contents (car item) (cdr item) t)))
|
||||
(defun fuel-help-vocab (vocab)
|
||||
"Ask for a vocabulary name and show its help page."
|
||||
(interactive (list (fuel-edit--read-vocabulary-name nil)))
|
||||
(fuel-help--get-vocab vocab))
|
||||
|
||||
(defun fuel-help-previous ()
|
||||
"Go to next page in help browser."
|
||||
(interactive)
|
||||
(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)
|
||||
(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")
|
||||
(end-of-line)
|
||||
(when (re-search-forward fuel-help--headlines-regexp nil t (or count 1))
|
||||
(beginning-of-line)))
|
||||
(let ((item (fuel-help--history-next forget-current)))
|
||||
(unless item (error "No next page"))
|
||||
(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)
|
||||
(define-key map "b" 'fuel-help-previous)
|
||||
(define-key map "f" 'fuel-help-next)
|
||||
(set-keymap-parent map button-buffer-map)
|
||||
(define-key map "a" 'fuel-apropos)
|
||||
(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 (kbd "TAB") 'fuel-help-next-headline)
|
||||
(define-key map (kbd "S-TAB") 'fuel-help-previous-headline)
|
||||
(define-key map [(backtab)] 'fuel-help-previous-headline)
|
||||
(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)
|
||||
|
|
@ -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)
|
||||
|
||||
(fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t)
|
||||
|
||||
(setq fuel-autodoc-mode-string "")
|
||||
(fuel-autodoc-mode)
|
||||
|
||||
(run-mode-hooks 'fuel-help-mode-hook)
|
||||
|
||||
(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))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 ">"))
|
||||
("\\_<\\(#?!\\)\\(\n\\)" (1 "<") (2 ">"))
|
||||
`(;; Comments:
|
||||
("\\_<\\(#?!\\) .*\\(\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))
|
||||
(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))
|
||||
(match-string-no-properties 1))))
|
||||
|
||||
(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)))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue