core/generalizations/generalizations.factor

   1 ! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo
   2 ! Cavazos, Slava Pestov.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: arrays combinators kernel kernel.private math ranges
   5 memoize.private sequences ;
   6 IN: generalizations
   7
   8 ! These words can be inline combinators when the word does no math
   9 ! on the input parameters, e.g. n.
  10 ! If math is done, the word needs to be a macro so the math can
  11 ! be done at compile-time.
  12 <<
  13
  14 ALIAS: n*quot (n*quot)
  15
  16 MACRO: call-n ( n -- quot )
  17     [ call ] <repetition> '[ _ cleave ] ;
  18
  19 >>
  20
  21 MACRO: nsum ( n -- quot )
  22     1 - [ + ] n*quot ;
  23
  24 ERROR: nonpositive-npick n ;
  25
  26 MACRO: npick ( n -- quot )
  27     {
  28         { [ dup 0 <= ] [ nonpositive-npick ] }
  29         { [ dup 1 = ] [ drop [ dup ] ] }
  30         [ 1 - [ dup ] [ '[ _ dip swap ] ] swapd times ]
  31     } cond ;
  32
  33 : ndup ( n -- )
  34     [ '[ _ npick ] ] keep call-n ; inline
  35
  36 MACRO: dupn ( n -- quot )
  37     [ [ drop ] ]
  38     [ 1 - [ dup ] n*quot ] if-zero ;
  39
  40 MACRO: nrot ( n -- quot )
  41     1 - [ ] [ '[ _ dip swap ] ] swapd times ;
  42
  43 MACRO: -nrot ( n -- quot )
  44     1 - [ ] [ '[ swap _ dip ] ] swapd times ;
  45
  46 : ndip ( n -- )
  47     [ [ dip ] curry ] swap call-n call ; inline
  48
  49 : ndrop ( n -- )
  50     [ drop ] swap call-n ; inline
  51
  52 : nnip ( n -- )
  53     '[ _ ndrop ] dip ; inline
  54
  55 DEFER: -nrotd
  56 MACRO: nrotd ( n d -- quot )
  57     over 0 < [
  58         [ neg ] dip '[ _ _ -nrotd ]
  59     ] [
  60         [ 1 - [ ] [ '[ _ dip swap ] ] swapd times ] dip '[ _ _ ndip ]
  61     ] if ;
  62
  63 MACRO: -nrotd ( n d -- quot )
  64     over 0 < [
  65         [ neg ] dip '[ _ _ nrotd ]
  66     ] [
  67         [ 1 - [ ] [ '[ swap _ dip ] ] swapd times ] dip '[ _ _ ndip ]
  68     ] if ;
  69
  70 MACRO: nrotated ( nrots depth dip -- quot )
  71     [ '[ [ _ nrot ] ] replicate [ ] concat-as ] dip '[ _ _ ndip ] ;
  72
  73 MACRO: -nrotated ( -nrots depth dip -- quot )
  74     [ '[ [ _ -nrot ] ] replicate [ ] concat-as ] dip '[ _ _ ndip ] ;
  75
  76 MACRO: nrotate-heightd ( n height dip -- quot )
  77     [ '[ [ _ nrot ] ] replicate concat ] dip '[ _ _ ndip ] ;
  78
  79 MACRO: -nrotate-heightd ( n height dip -- quot )
  80     [
  81         '[ [ _ -nrot ] ] replicate concat
  82     ] dip '[ _ _ ndip ] ;
  83
  84 : ndupd ( n dip -- ) '[ [ _ ndup ] _ ndip ] call ; inline
  85
  86 MACRO: ntuckd ( ntuck ndip -- quot )
  87     [ 1 + ] dip '[ [ dup _ -nrot ] _ ndip ] ;
  88
  89 MACRO: nover ( n -- quot )
  90     dup 1 + '[ _ npick ] n*quot ;
  91
  92 MACRO: noverd ( n depth dip -- quot' )
  93     [ + ] [ 2drop ] [ [ + ] dip ] 3tri
  94     '[ _ _ ndupd _ _ _ nrotated ] ;
  95
  96 MACRO: mntuckd ( ndup depth ndip -- quot )
  97     { [ nip ] [ 2drop ] [ drop + ] [ 2nip ] } 3cleave
  98     '[ _ _ ndupd _ _ _ -nrotated ] ;
  99
 100 : nkeep ( n -- )
 101     dup '[ [ _ ndup ] dip _ ndip ] call ; inline
 102
 103 : ncurry ( n -- )
 104     [ curry ] swap call-n ; inline
 105
 106 : nwith ( n -- )
 107     [ with ] swap call-n ; inline
 108
 109 : nbi ( quot1 quot2 n -- )
 110     [ nip nkeep ] [ drop nip call ] 3bi ; inline
 111
 112 MACRO: ncleave ( quots n -- quot )
 113     [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
 114     compose ;
 115
 116 MACRO: nspread ( quots n -- quot )
 117     over empty? [ 2drop [ ] ] [
 118         [ [ but-last ] dip ]
 119         [ [ last ] dip ] 2bi
 120         swap
 121         '[ [ _ _ nspread ] _ ndip @ ]
 122     ] if ;
 123
 124 MACRO: spread* ( n -- quot )
 125     [ [ ] ] [
 126         [1..b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as
 127         [ call ] compose
 128     ] if-zero ;
 129
 130 MACRO: nspread* ( m n -- quot )
 131     [ drop [ ] ] [
 132         [ * 0 ] [ drop neg ] 2bi
 133         <range> rest >array dup length <iota> <reversed>
 134         [ '[ [ [ _ ndip ] curry ] _ ndip ] ] 2map
 135         [ [ ] concat-as ]
 136         [ length 1 - [ compose ] <array> concat append ] bi
 137         [ call ] compose
 138     ] if-zero ;
 139
 140 MACRO: cleave* ( n -- quot )
 141     [ [ ] ]
 142     [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ]
 143     if-zero ;
 144
 145 : napply ( quot n -- )
 146     [ dupn ] [ spread* ] bi ; inline
 147
 148 : mnapply ( quot m n -- )
 149     [ nip dupn ] [ nspread* ] 2bi ; inline
 150
 151 : apply-curry ( a... quot n -- )
 152     [ currier ] dip napply ; inline
 153
 154 : cleave-curry ( a quot... n -- )
 155     [ currier ] swap [ napply ] [ cleave* ] bi ; inline
 156
 157 : spread-curry ( a... quot... n -- )
 158     [ currier ] swap [ napply ] [ spread* ] bi ; inline
 159
 160 MACRO: mnswap ( m n -- quot )
 161     1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
 162
 163 MACRO: nweave ( n -- quot )
 164     [ dup <iota> <reversed> [ '[ _ _ mnswap ] ] with map ] keep
 165     '[ _ _ ncleave ] ;
 166
 167 : nbi-curry ( n -- )
 168     [ bi-curry ] swap call-n ; inline
 169
 170 MACRO: map-compose ( quots quot -- quot' )
 171     '[ _ compose ] map '[ _ ] ;