+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: combinators help.markup help.syntax ;
-
-IN: combinators.extras
-
-HELP: cond-case
-{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
-{ $description
- "Similar to " { $link case } ", this evaluates an " { $snippet "obj" } " according to the first quotation in each pair. If any quotation returns true, calls the second quotation without " { $snippet "obj" } " on the stack."
- $nl
- "If there is no quotation that returns true, the default case is taken. If the last element of " { $snippet "assoc" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is raised."
-}
-{ $examples
- { $example
- "USING: combinators.extras io kernel math ;"
- "0 {"
- " { [ 0 > ] [ \"positive\" ] }"
- " { [ 0 < ] [ \"negative\" ] }"
- " [ drop \"zero\" ]"
- "} cond-case print"
- "zero"
- }
-} ;
+++ /dev/null
-! Copyright (C) 2013 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs combinators.extras io.files kernel math sequences
-splitting tools.test ;
-
-{ "a b" }
-[ "a" "b" [ " " glue ] once ] unit-test
-
-{ "a b c" }
-[ "a" "b" "c" [ " " glue ] twice ] unit-test
-
-{ "a b c d" }
-[ "a" "b" "c" "d" [ " " glue ] thrice ] unit-test
-
-{ { "negative" 0 "positive" } } [
- { -1 0 1 } [
- {
- { [ 0 > ] [ "positive" ] }
- { [ 0 < ] [ "negative" ] }
- [ ]
- } cond-case
- ] map
-] unit-test
-
-{ { 1 2 3 } } [ 1 { [ ] [ 1 + ] [ 2 + ] } cleave-array ] unit-test
-
-{ 2 15 } [ 1 2 3 4 5 6 [ - - ] [ + + ] 3bi* ] unit-test
-
-{ 2 5 } [ 1 2 3 4 5 6 [ - - ] 3bi@ ] unit-test
-
-{ 3 1 } [ 1 2 [ + ] keepd ] unit-test
-
-{ "1" "123" } [ "1" "123" [ length ] [ > ] swap-when ] unit-test
-{ "123" "1" } [ "1" "123" [ length ] [ < ] swap-when ] unit-test
-
-
-{ t } [ "resource:" [ exists? ] ?1arg >boolean ] unit-test
-{ f } [ f [ exists? ] ?1arg ] unit-test
-{ f } [ "/homeasdfasdf123123" [ exists? ] ?1arg ] unit-test
-
-{ "hi " "there" } [
- "hi there" {
- { [ "there" over subseq-start ] [ cut ] }
- [ f ]
- } cond*
-] unit-test
-
-{ "hi " "there" } [
- "hi there" {
- { [ "foo" over subseq-start ] [ head f ] }
- { [ "there" over subseq-start ] [ cut ] }
- [ f ]
- } cond*
-] unit-test
-
-{ "hi there" f } [
- "hi there" {
- { [ "foo" over subseq-start ] [ head f ] }
- { [ "bar" over subseq-start ] [ cut ] }
- [ f ]
- } cond*
-] unit-test
-
-{ f } [ f { } chain ] unit-test
-{ 3 } [ H{ { 1 H{ { 2 3 } } } } { [ 1 of ] [ 2 of ] } chain ] unit-test
-{ f } [ H{ { 1 H{ { 3 4 } } } } { [ 1 of ] [ 2 of ] } chain ] unit-test
-{ f } [ H{ { 2 H{ { 3 4 } } } } { [ 1 of ] [ 2 of ] } chain ] unit-test
-{ 5 } [
- "hello factor!" { [ " " split ] [ first ] [ length ] } chain
-] unit-test
+++ /dev/null
-! Copyright (C) 2013 Doug Coleman, John Benediktsson.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators combinators.smart fry
-generalizations kernel locals macros math math.order namespaces
-quotations sequences sequences.generalizations sequences.private
-stack-checker.transforms system words ;
-IN: combinators.extras
-
-: once ( quot -- ) call ; inline
-: twice ( quot -- ) dup [ call ] dip call ; inline
-: thrice ( quot -- ) dup dup [ call ] 2dip [ call ] dip call ; inline
-: forever ( quot -- ) [ t ] compose loop ; inline
-
-MACRO: cond-case ( assoc -- quot )
- [
- dup callable? not [
- [ first [ dup ] prepose ]
- [ second [ drop ] prepose ] bi 2array
- ] when
- ] map [ cond ] curry ;
-
-MACRO: cleave-array ( quots -- quot )
- [ '[ _ cleave ] ] [ length '[ _ narray ] ] bi compose ;
-
-: 3bi* ( u v w x y z p q -- )
- [ 3dip ] dip call ; inline
-
-: 3bi@ ( u v w x y z quot -- )
- dup 3bi* ; inline
-
-: 4bi ( w x y z p q -- )
- [ 4keep ] dip call ; inline
-
-: 4bi* ( s t u v w x y z p q -- )
- [ 4dip ] dip call ; inline
-
-: 4bi@ ( s t u v w x y z quot -- )
- dup 4bi* ; inline
-
-: 4tri ( w x y z p q r -- )
- [ [ 4keep ] dip 4keep ] dip call ; inline
-
-: plox ( ... x/f quot: ( ... x -- ... y ) -- ... y/f )
- dupd when ; inline
-
-MACRO: smart-plox ( true -- quot )
- [ inputs [ 1 - [ and ] n*quot ] keep ] keep swap
- '[ _ _ [ _ ndrop f ] smart-if ] ;
-
-: throttle ( quot millis -- quot' )
- 1,000,000 * '[
- _ nano-count { 0 } 2dup first-unsafe _ + >=
- [ 0 swap set-nth-unsafe call ] [ 3drop ] if
- ] ; inline
-
-: swap-when ( x y quot: ( x -- n ) quot: ( n n -- ? ) -- x' y' )
- '[ _ _ 2dup _ bi@ @ [ swap ] when ] call ; inline
-
-
-! ?1arg-result-falsify
-
-: 1falsify ( obj/f -- obj/f ) ; inline
-: 2falsify ( obj1 obj2 -- obj1/f obj2/f ) 2dup and [ 2drop f f ] unless ; inline
-: 3falsify ( obj1 obj2 obj3 -- obj1/f obj2/f obj3/f ) 3dup and and [ 3drop f f f ] unless ; inline
-
-MACRO: n-and ( n -- quot )
- 1 [-] [ and ] n*quot ;
-
-MACRO: n*obj ( n obj -- quot )
- 1quotation n*quot ;
-
-MACRO:: n-falsify ( n -- quot )
- [ n ndup n n-and [ n ndrop n f n*obj ] unless ] ;
-
-! plox
-: ?1res ( ..a obj/f quot -- ..b )
- dupd when ; inline
-
-! when both args are true, call quot. otherwise dont
-: ?2res ( ..a obj1 obj2 quot: ( obj1 obj2 -- ? ) -- ..b )
- [ 2dup and ] dip [ 2drop f ] if ; inline
-
-! try the quot, keep the original arg if quot is true
-: ?1arg ( obj quot: ( obj -- ? ) -- obj/f )
- [ ?1res ] keepd '[ _ ] [ f ] if ; inline
-
-: ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
- [ ?2res ] 2keepd '[ _ _ ] [ f f ] if ; inline
-
-<<
-: alist>quot* ( default assoc -- quot )
- [ rot \ if* 3array append [ ] like ] assoc-each ;
-
-: cond*>quot ( assoc -- quot )
- [ dup pair? [ [ drop ] prepend [ t ] swap 2array ] unless ] map
- reverse! [ no-cond ] swap alist>quot* ;
-
-DEFER: cond*
-\ cond* [ cond*>quot ] 1 define-transform
-\ cond* t "no-compile" set-word-prop
->>
-: cond* ( assoc -- )
- [ dup callable? [ drop t ] [ first call ] if ] map-find
- [ dup callable? [ nip call ] [ second call ] if ]
- [ no-cond ] if* ;
-
-MACRO: chain ( quots -- quot )
- <reversed> [ ] [ swap '[ [ @ @ ] [ f ] if* ] ] reduce ;
-
-: with-output-variable ( value variable quot -- value )
- over [ get ] curry compose with-variable ; inline
-
-: loop1 ( ..a quot: ( ..a -- ..a obj ? ) -- ..a obj )
- [ call ] keep '[ drop _ loop1 ] when ; inline recursive
-
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: combinators help.markup help.syntax ;
+
+IN: combinators.extras
+
+HELP: cond-case
+{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
+{ $description
+ "Similar to " { $link case } ", this evaluates an " { $snippet "obj" } " according to the first quotation in each pair. If any quotation returns true, calls the second quotation without " { $snippet "obj" } " on the stack."
+ $nl
+ "If there is no quotation that returns true, the default case is taken. If the last element of " { $snippet "assoc" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is raised."
+}
+{ $examples
+ { $example
+ "USING: combinators.extras io kernel math ;"
+ "0 {"
+ " { [ 0 > ] [ \"positive\" ] }"
+ " { [ 0 < ] [ \"negative\" ] }"
+ " [ drop \"zero\" ]"
+ "} cond-case print"
+ "zero"
+ }
+} ;
--- /dev/null
+! Copyright (C) 2013 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs combinators.extras io.files kernel math sequences
+splitting tools.test ;
+
+{ "a b" }
+[ "a" "b" [ " " glue ] once ] unit-test
+
+{ "a b c" }
+[ "a" "b" "c" [ " " glue ] twice ] unit-test
+
+{ "a b c d" }
+[ "a" "b" "c" "d" [ " " glue ] thrice ] unit-test
+
+{ { "negative" 0 "positive" } } [
+ { -1 0 1 } [
+ {
+ { [ 0 > ] [ "positive" ] }
+ { [ 0 < ] [ "negative" ] }
+ [ ]
+ } cond-case
+ ] map
+] unit-test
+
+{ { 1 2 3 } } [ 1 { [ ] [ 1 + ] [ 2 + ] } cleave-array ] unit-test
+
+{ 2 15 } [ 1 2 3 4 5 6 [ - - ] [ + + ] 3bi* ] unit-test
+
+{ 2 5 } [ 1 2 3 4 5 6 [ - - ] 3bi@ ] unit-test
+
+{ 3 1 } [ 1 2 [ + ] keepd ] unit-test
+
+{ "1" "123" } [ "1" "123" [ length ] [ > ] swap-when ] unit-test
+{ "123" "1" } [ "1" "123" [ length ] [ < ] swap-when ] unit-test
+
+
+{ t } [ "resource:" [ exists? ] ?1arg >boolean ] unit-test
+{ f } [ f [ exists? ] ?1arg ] unit-test
+{ f } [ "/homeasdfasdf123123" [ exists? ] ?1arg ] unit-test
+
+{ "hi " "there" } [
+ "hi there" {
+ { [ "there" over subseq-start ] [ cut ] }
+ [ f ]
+ } cond*
+] unit-test
+
+{ "hi " "there" } [
+ "hi there" {
+ { [ "foo" over subseq-start ] [ head f ] }
+ { [ "there" over subseq-start ] [ cut ] }
+ [ f ]
+ } cond*
+] unit-test
+
+{ "hi there" f } [
+ "hi there" {
+ { [ "foo" over subseq-start ] [ head f ] }
+ { [ "bar" over subseq-start ] [ cut ] }
+ [ f ]
+ } cond*
+] unit-test
+
+{ f } [ f { } chain ] unit-test
+{ 3 } [ H{ { 1 H{ { 2 3 } } } } { [ 1 of ] [ 2 of ] } chain ] unit-test
+{ f } [ H{ { 1 H{ { 3 4 } } } } { [ 1 of ] [ 2 of ] } chain ] unit-test
+{ f } [ H{ { 2 H{ { 3 4 } } } } { [ 1 of ] [ 2 of ] } chain ] unit-test
+{ 5 } [
+ "hello factor!" { [ " " split ] [ first ] [ length ] } chain
+] unit-test
--- /dev/null
+! Copyright (C) 2013 Doug Coleman, John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators combinators.smart fry
+generalizations kernel locals macros math math.order namespaces
+quotations sequences sequences.generalizations sequences.private
+stack-checker.transforms system words ;
+IN: combinators.extras
+
+: once ( quot -- ) call ; inline
+: twice ( quot -- ) dup [ call ] dip call ; inline
+: thrice ( quot -- ) dup dup [ call ] 2dip [ call ] dip call ; inline
+: forever ( quot -- ) [ t ] compose loop ; inline
+
+MACRO: cond-case ( assoc -- quot )
+ [
+ dup callable? not [
+ [ first [ dup ] prepose ]
+ [ second [ drop ] prepose ] bi 2array
+ ] when
+ ] map [ cond ] curry ;
+
+MACRO: cleave-array ( quots -- quot )
+ [ '[ _ cleave ] ] [ length '[ _ narray ] ] bi compose ;
+
+: 3bi* ( u v w x y z p q -- )
+ [ 3dip ] dip call ; inline
+
+: 3bi@ ( u v w x y z quot -- )
+ dup 3bi* ; inline
+
+: 4bi ( w x y z p q -- )
+ [ 4keep ] dip call ; inline
+
+: 4bi* ( s t u v w x y z p q -- )
+ [ 4dip ] dip call ; inline
+
+: 4bi@ ( s t u v w x y z quot -- )
+ dup 4bi* ; inline
+
+: 4tri ( w x y z p q r -- )
+ [ [ 4keep ] dip 4keep ] dip call ; inline
+
+: plox ( ... x/f quot: ( ... x -- ... y ) -- ... y/f )
+ dupd when ; inline
+
+MACRO: smart-plox ( true -- quot )
+ [ inputs [ 1 - [ and ] n*quot ] keep ] keep swap
+ '[ _ _ [ _ ndrop f ] smart-if ] ;
+
+: throttle ( quot millis -- quot' )
+ 1,000,000 * '[
+ _ nano-count { 0 } 2dup first-unsafe _ + >=
+ [ 0 swap set-nth-unsafe call ] [ 3drop ] if
+ ] ; inline
+
+: swap-when ( x y quot: ( x -- n ) quot: ( n n -- ? ) -- x' y' )
+ '[ _ _ 2dup _ bi@ @ [ swap ] when ] call ; inline
+
+
+! ?1arg-result-falsify
+
+: 1falsify ( obj/f -- obj/f ) ; inline
+: 2falsify ( obj1 obj2 -- obj1/f obj2/f ) 2dup and [ 2drop f f ] unless ; inline
+: 3falsify ( obj1 obj2 obj3 -- obj1/f obj2/f obj3/f ) 3dup and and [ 3drop f f f ] unless ; inline
+
+MACRO: n-and ( n -- quot )
+ 1 [-] [ and ] n*quot ;
+
+MACRO: n*obj ( n obj -- quot )
+ 1quotation n*quot ;
+
+MACRO:: n-falsify ( n -- quot )
+ [ n ndup n n-and [ n ndrop n f n*obj ] unless ] ;
+
+! plox
+: ?1res ( ..a obj/f quot -- ..b )
+ dupd when ; inline
+
+! when both args are true, call quot. otherwise dont
+: ?2res ( ..a obj1 obj2 quot: ( obj1 obj2 -- ? ) -- ..b )
+ [ 2dup and ] dip [ 2drop f ] if ; inline
+
+! try the quot, keep the original arg if quot is true
+: ?1arg ( obj quot: ( obj -- ? ) -- obj/f )
+ [ ?1res ] keepd '[ _ ] [ f ] if ; inline
+
+: ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
+ [ ?2res ] 2keepd '[ _ _ ] [ f f ] if ; inline
+
+<<
+: alist>quot* ( default assoc -- quot )
+ [ rot \ if* 3array append [ ] like ] assoc-each ;
+
+: cond*>quot ( assoc -- quot )
+ [ dup pair? [ [ drop ] prepend [ t ] swap 2array ] unless ] map
+ reverse! [ no-cond ] swap alist>quot* ;
+
+DEFER: cond*
+\ cond* [ cond*>quot ] 1 define-transform
+\ cond* t "no-compile" set-word-prop
+>>
+: cond* ( assoc -- )
+ [ dup callable? [ drop t ] [ first call ] if ] map-find
+ [ dup callable? [ nip call ] [ second call ] if ]
+ [ no-cond ] if* ;
+
+MACRO: chain ( quots -- quot )
+ <reversed> [ ] [ swap '[ [ @ @ ] [ f ] if* ] ] reduce ;
+
+: with-output-variable ( value variable quot -- value )
+ over [ get ] curry compose with-variable ; inline
+
+: loop1 ( ..a quot: ( ..a -- ..a obj ? ) -- ..a obj )
+ [ call ] keep '[ drop _ loop1 ] when ; inline recursive
+
projects / factor.git / commitdiff