combinators.smart: Fix reduce-outputs, rename quot*n to call-n, rewrite more macros as combinators.

db4
Doug Coleman 2011-11-28 12:41:50 -08:00
parent 9a55bfb5a2
commit 41e4c48647
4 changed files with 47 additions and 42 deletions

View File

@ -40,6 +40,9 @@ M: input-parameter infer-known* \ inputs/outputs unknown-macro-input ;
M: object infer-known* \ inputs/outputs bad-macro-input ;
: drop-inputs ( quot -- newquot )
inputs ndrop ; inline
: drop-outputs ( quot -- )
[ call ] [ outputs ndrop ] bi ; inline
@ -59,7 +62,7 @@ M: object infer-known* \ inputs/outputs bad-macro-input ;
[ inputs firstn-unsafe ] [ call ] bi ; inline
MACRO: reduce-outputs ( quot operation -- newquot )
[ dup outputs 1 [-] ] dip n*quot compose ;
[ [ ] [ outputs 1 [-] ] bi ] dip swap '[ @ _ _ call-n ] ;
: sum-outputs ( quot -- n )
[ + ] reduce-outputs ; inline
@ -70,37 +73,38 @@ MACRO: reduce-outputs ( quot operation -- newquot )
: map-reduce-outputs ( quot mapper reducer -- )
[ '[ _ _ map-outputs ] ] dip reduce-outputs ; inline
MACRO: append-outputs-as ( quot exemplar -- newquot )
[ dup outputs ] dip '[ @ _ _ nappend-as ] ;
: append-outputs-as ( quot exemplar -- newquot )
[ [ call ] [ outputs ] bi ] dip nappend-as ; inline
MACRO: append-outputs ( quot -- seq )
'[ _ { } append-outputs-as ] ;
: append-outputs ( quot -- seq )
{ } append-outputs-as ; inline
MACRO: preserving ( quot -- )
[ inputs ] keep '[ _ ndup @ ] ;
: preserving ( quot -- )
[ inputs ndup ] [ call ] bi ; inline
MACRO: dropping ( quot -- quot' )
inputs '[ [ _ ndrop ] ] ;
: dropping ( quot -- quot' )
inputs '[ _ ndrop ] ; inline
MACRO: nullary ( quot -- quot' ) dropping ;
: nullary ( quot -- quot' )
dropping call ; inline
MACRO: smart-if ( pred true false -- quot )
'[ _ preserving _ _ if ] ;
: smart-if ( pred true false -- quot )
[ preserving ] 2dip if ; inline
MACRO: smart-when ( pred true -- quot )
'[ _ _ [ ] smart-if ] ;
: smart-when ( pred true -- quot )
[ ] smart-if ; inline
MACRO: smart-unless ( pred false -- quot )
'[ _ [ ] _ smart-if ] ;
: smart-unless ( pred false -- quot )
[ [ ] ] dip smart-if ; inline
MACRO: smart-if* ( pred true false -- quot )
'[ _ [ preserving ] [ dropping ] bi _ swap _ compose if ] ;
: smart-if* ( pred true false -- quot )
[ [ [ preserving ] [ dropping ] bi ] dip swap ] dip compose if ; inline
MACRO: smart-when* ( pred true -- quot )
'[ _ _ [ ] smart-if* ] ;
: smart-when* ( pred true -- quot )
[ ] smart-if* ; inline
MACRO: smart-unless* ( pred false -- quot )
'[ _ [ ] _ smart-if* ] ;
: smart-unless* ( pred false -- quot )
[ [ ] ] dip smart-if* ; inline
MACRO: smart-apply ( quot n -- quot )
[ dup inputs ] dip '[ _ _ _ mnapply ] ;
: smart-apply ( quot n -- quot )
[ dup inputs ] dip mnapply ; inline

View File

@ -6,11 +6,15 @@ combinators macros math.order math.ranges quotations fry effects
memoize.private arrays ;
IN: generalizations
! These words can be inline combinators the word does no math on
! the input parameters, e.g. n.
! If math is done, the word needs to be a macro so the math can
! be done at compile-time.
<<
ALIAS: n*quot (n*quot)
MACRO: quot*n ( n -- )
MACRO: call-n ( n -- )
[ call ] <repetition> '[ _ cleave ] ;
: repeat ( n obj quot -- ) swapd times ; inline
@ -27,7 +31,7 @@ MACRO: nover ( n -- )
dup 1 + '[ _ npick ] n*quot ;
: ndup ( n -- )
[ '[ _ npick ] ] keep quot*n ; inline
[ '[ _ npick ] ] keep call-n ; inline
MACRO: dupn ( n -- )
[ [ drop ] ]
@ -40,25 +44,25 @@ MACRO: -nrot ( n -- )
1 - [ ] [ '[ swap _ dip ] ] repeat ;
: ndrop ( n -- )
[ drop ] swap quot*n ; inline
[ drop ] swap call-n ; inline
: nnip ( n -- )
'[ _ ndrop ] dip ; inline
: ndip ( n -- )
[ [ dip ] curry ] swap quot*n call ; inline
[ [ dip ] curry ] swap call-n call ; inline
: nkeep ( n -- )
dup '[ [ _ ndup ] dip _ ndip ] call ; inline
: ncurry ( n -- )
[ curry ] swap quot*n ; inline
[ curry ] swap call-n ; inline
: nwith ( n -- )
[ with ] swap quot*n ; inline
[ with ] swap call-n ; inline
MACRO: nbi ( n -- )
'[ [ _ nkeep ] dip call ] ;
: nbi ( quot1 quot2 n -- )
[ nip nkeep ] [ drop nip call ] 3bi ; inline
MACRO: ncleave ( quots n -- )
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
@ -115,5 +119,5 @@ MACRO: nweave ( n -- )
[ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;
MACRO: nbi-curry ( n -- )
[ bi-curry ] n*quot ;
: nbi-curry ( n -- )
[ bi-curry ] swap call-n ; inline

View File

@ -1,10 +1,10 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs effects fry generalizations
grouping kernel lexer macros math math.order math.vectors
namespaces parser effects.parser quotations sequences
sequences.private splitting.monotonic stack-checker strings
unicode.case words ;
USING: accessors arrays assocs combinators.smart effects
effects.parser fry generalizations grouping kernel lexer macros
math math.order math.vectors namespaces parser quotations
sequences sequences.private splitting.monotonic stack-checker
strings unicode.case words ;
IN: roman
<PRIVATE

View File

@ -20,9 +20,6 @@ TUPLE: xml-test id uri sections description type ;
CONSTANT: base "vocab:xml/tests/xmltest/"
MACRO: drop-inputs ( quot -- newquot )
inputs '[ _ ndrop ] ;
: fails? ( quot -- ? )
[ drop-outputs f ] [ nip drop-inputs t ] bi-curry recover ; inline