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 : repeat ( n obj quot -- ) swapd times ; inline
  20
  21 >>
  22
  23 MACRO: nsum ( n -- quot )
  24     1 - [ + ] n*quot ;
  25
  26 ERROR: nonpositive-npick n ;
  27
  28 MACRO: npick ( n -- quot )
  29     {
  30         { [ dup 0 <= ] [ nonpositive-npick ] }
  31         { [ dup 1 = ] [ drop [ dup ] ] }
  32         [ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ]
  33     } cond ;
  34
  35 MACRO: nover ( n -- quot )
  36     dup 1 + '[ _ npick ] n*quot ;
  37
  38 : ndup ( n -- )
  39     [ '[ _ npick ] ] keep call-n ; inline
  40
  41 MACRO: dupn ( n -- quot )
  42     [ [ drop ] ]
  43     [ 1 - [ dup ] n*quot ] if-zero ;
  44
  45 MACRO: nrot ( n -- quot )
  46     1 - [ ] [ '[ _ dip swap ] ] repeat ;
  47
  48 MACRO: -nrot ( n -- quot )
  49     1 - [ ] [ '[ swap _ dip ] ] repeat ;
  50
  51 : ndip ( n -- )
  52     [ [ dip ] curry ] swap call-n call ; inline
  53
  54 : nrotates ( n depth -- quot )
  55     '[ _ [ _ nrot ] times ] call ; inline
  56
  57 : -nrotates ( n depth -- quot )
  58     '[ _ [ _ -nrot ] times ] call ; inline
  59
  60 : ndrop ( n -- )
  61     [ drop ] swap call-n ; inline
  62
  63 : nnip ( n -- )
  64     '[ _ ndrop ] dip ; inline
  65
  66 : nkeep ( n -- )
  67     dup '[ [ _ ndup ] dip _ ndip ] call ; inline
  68
  69 : ncurry ( n -- )
  70     [ curry ] swap call-n ; inline
  71
  72 : nwith ( n -- )
  73     [ with ] swap call-n ; inline
  74
  75 : nbi ( quot1 quot2 n -- )
  76     [ nip nkeep ] [ drop nip call ] 3bi ; inline
  77
  78 MACRO: ncleave ( quots n -- quot )
  79     [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
  80     compose ;
  81
  82 MACRO: nspread ( quots n -- quot )
  83     over empty? [ 2drop [ ] ] [
  84         [ [ but-last ] dip ]
  85         [ [ last ] dip ] 2bi
  86         swap
  87         '[ [ _ _ nspread ] _ ndip @ ]
  88     ] if ;
  89
  90 MACRO: spread* ( n -- quot )
  91     [ [ ] ] [
  92         [1..b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as
  93         [ call ] compose
  94     ] if-zero ;
  95
  96 MACRO: nspread* ( m n -- quot )
  97     [ drop [ ] ] [
  98         [ * 0 ] [ drop neg ] 2bi
  99         <range> rest >array dup length <iota> <reversed>
 100         [ '[ [ [ _ ndip ] curry ] _ ndip ] ] 2map
 101         [ [ ] concat-as ]
 102         [ length 1 - [ compose ] <array> concat append ] bi
 103         [ call ] compose
 104     ] if-zero ;
 105
 106 MACRO: cleave* ( n -- quot )
 107     [ [ ] ]
 108     [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ]
 109     if-zero ;
 110
 111 : napply ( quot n -- )
 112     [ dupn ] [ spread* ] bi ; inline
 113
 114 : mnapply ( quot m n -- )
 115     [ nip dupn ] [ nspread* ] 2bi ; inline
 116
 117 : apply-curry ( a... quot n -- )
 118     [ currier ] dip napply ; inline
 119
 120 : cleave-curry ( a quot... n -- )
 121     [ currier ] swap [ napply ] [ cleave* ] bi ; inline
 122
 123 : spread-curry ( a... quot... n -- )
 124     [ currier ] swap [ napply ] [ spread* ] bi ; inline
 125
 126 MACRO: mnswap ( m n -- quot )
 127     1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
 128
 129 MACRO: nweave ( n -- quot )
 130     [ dup <iota> <reversed> [ '[ _ _ mnswap ] ] with map ] keep
 131     '[ _ _ ncleave ] ;
 132
 133 : nbi-curry ( n -- )
 134     [ bi-curry ] swap call-n ; inline
 135
 136 MACRO: map-compose ( quots quot -- quot' )
 137     '[ _ compose ] map '[ _ ] ;