Add 2tri* and 2tri@ combinators, clean up (3each), and fix failing unit test for 3map
Slava Pestov
parent
4c25fef273
commit
af49278d3f
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -346,15 +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 ] dip
|
||||
[ [ [ [ nth-unsafe ] curry ] tri@ tri ] 3curry ] dip compose ; inline
|
||||
[
|
||||
[ [ 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
|
||||
|
|
@ -411,23 +415,22 @@ 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 )
|
||||
(3each) map ; inline
|
||||
[ pick ] dip swap 3map-as ; inline
|
||||
|
||||
: find-from ( n seq quot -- i elt )
|
||||
[ (find-integer) ] (find-from) ; inline
|
||||
|
|
|
|||
Loading…
Reference in New Issue