basis/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: kernel kernel.private sequences sequences.private math
   5 combinators macros math.order math.ranges quotations fry effects
   6 memoize.private arrays ;
   7 IN: generalizations
   8
   9 ! These words can be inline combinators the word does no math on
  10 ! the input parameters, e.g. n.
  11 ! If math is done, the word needs to be a macro so the math can
  12 ! be done at compile-time.
  13 <<
  14
  15 ALIAS: n*quot (n*quot)
  16
  17 MACRO: call-n ( n -- quot )
  18     [ call ] <repetition> '[ _ cleave ] ;
  19
  20 : repeat ( n obj quot -- ) swapd times ; inline
  21
  22 >>
  23
  24 MACRO: nsum ( n -- quot )
  25     1 - [ + ] n*quot ;
  26
  27 ERROR: nonpositive-npick n ;
  28
  29 MACRO: npick ( n -- quot )
  30     {
  31         { [ dup 0 <= ] [ throw-nonpositive-npick ] }
  32         { [ dup 1 = ] [ drop [ dup ] ] }
  33         [ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ]
  34     } cond ;
  35
  36 MACRO: nover ( n -- quot )
  37     dup 1 + '[ _ npick ] n*quot ;
  38
  39 : ndup ( n -- )
  40     [ '[ _ npick ] ] keep call-n ; inline
  41
  42 MACRO: dupn ( n -- quot )
  43     [ [ drop ] ]
  44     [ 1 - [ dup ] n*quot ] if-zero ;
  45
  46 MACRO: nrot ( n -- quot )
  47     1 - [ ] [ '[ _ dip swap ] ] repeat ;
  48
  49 MACRO: -nrot ( n -- quot )
  50     1 - [ ] [ '[ swap _ dip ] ] repeat ;
  51
  52 : ndrop ( n -- )
  53     [ drop ] swap call-n ; inline
  54
  55 : nnip ( n -- )
  56     '[ _ ndrop ] dip ; inline
  57
  58 : ndip ( n -- )
  59     [ [ dip ] curry ] swap call-n call ; inline
  60
  61 : nkeep ( n -- )
  62     dup '[ [ _ ndup ] dip _ ndip ] call ; inline
  63
  64 : ncurry ( n -- )
  65     [ curry ] swap call-n ; inline
  66
  67 : nwith ( n -- )
  68     [ with ] swap call-n ; inline
  69
  70 : nbi ( quot1 quot2 n -- )
  71     [ nip nkeep ] [ drop nip call ] 3bi ; inline
  72
  73 MACRO: ncleave ( quots n -- quot )
  74     [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
  75     compose ;
  76
  77 MACRO: nspread ( quots n -- quot )
  78     over empty? [ 2drop [ ] ] [
  79         [ [ but-last ] dip ]
  80         [ [ last ] dip ] 2bi
  81         swap
  82         '[ [ _ _ nspread ] _ ndip @ ]
  83     ] if ;
  84
  85 MACRO: spread* ( n -- quot )
  86     [ [ ] ] [
  87         [1,b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as
  88         [ call ] compose
  89     ] if-zero ;
  90
  91 MACRO: nspread* ( m n -- quot )
  92     [ drop [ ] ] [
  93         [ * 0 ] [ drop neg ] 2bi
  94         <range> rest >array dup length iota <reversed>
  95         [
  96             '[ [ [ _ ndip ] curry ] _ ndip ]
  97         ] 2map dup rest-slice [ [ compose ] compose ] map! drop
  98         [ ] concat-as [ call ] compose
  99     ] if-zero ;
 100
 101 MACRO: cleave* ( n -- quot )
 102     [ [ ] ]
 103     [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ]
 104     if-zero ;
 105
 106 : napply ( quot n -- )
 107     [ dupn ] [ spread* ] bi ; inline
 108
 109 : mnapply ( quot m n -- )
 110     [ nip dupn ] [ nspread* ] 2bi ; inline
 111
 112 : apply-curry ( a... quot n -- )
 113     [ [curry] ] dip napply ; inline
 114
 115 : cleave-curry ( a quot... n -- )
 116     [ [curry] ] swap [ napply ] [ cleave* ] bi ; inline
 117
 118 : spread-curry ( a... quot... n -- )
 119     [ [curry] ] swap [ napply ] [ spread* ] bi ; inline
 120
 121 MACRO: mnswap ( m n -- quot )
 122     1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
 123
 124 MACRO: nweave ( n -- quot )
 125     [ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
 126     '[ _ _ ncleave ] ;
 127
 128 : nbi-curry ( n -- )
 129     [ bi-curry ] swap call-n ; inline