work
build-support/wordsize
*.bak
+.#*
: 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
! 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
[ "<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
\ No newline at end of file
} 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
}
} ;
+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" } "." }
}
} ;
+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."
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 } "." } ;
{ $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
{ $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"
{ $subsection 2bi@ }
"Three quotations:"
{ $subsection tri@ }
+{ $subsection 2tri@ }
"A pair of utility words built from " { $link bi@ } ":"
{ $subsection both? }
{ $subsection either? } ;
{ $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 }
[ [ 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
\ No newline at end of file
: 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
: 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
: 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 )
{ "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 }
[ 4 CHAR: o ]
[ 3 "hello world" "aeiou" [ member? ] curry find-from ] unit-test
-[ f ] [ 3 [ ] member? ] unit-test
-[ f ] [ 3 [ 1 2 ] member? ] unit-test
+[ f ] [ 3 [ ] member? ] unit-test
+[ f ] [ 3 [ 1 2 ] member? ] unit-test
[ t ] [ 1 [ 1 2 ] member? ] unit-test
[ t ] [ 2 [ 1 2 ] member? ] unit-test
[ [ 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
[ "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
\ No newline at end of file
-! 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 ;
[ 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
[ 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
+
+: 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 )
+ [ over ] 2dip [ over ] dip [ nth-unsafe ] 2tri@ ; inline
-: 2map-into ( seq1 seq2 quot into -- newseq )
- [ (2each) ] dip collect ; 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
[ -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
: 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 ;
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 ;
: supremum ( seq -- n ) dup first [ max ] reduce ;
-: sigma ( seq quot -- n ) 0 -rot [ rot slip + ] curry each ; inline
+: sigma ( seq quot -- n ) [ 0 ] 2dip [ rot slip + ] curry each ; inline
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-! 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 ;
+++ /dev/null
-The Factor FAQ
-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:
projects / factor.git / commitdiff