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 sequences sequences.private math combinators
   5 macros quotations fry effects ;
   6 IN: generalizations
   7
   8 <<
   9
  10 : n*quot ( n quot -- quot' ) <repetition> concat >quotation ;
  11
  12 : repeat ( n obj quot -- ) swapd times ; inline
  13
  14 >>
  15
  16 MACRO: nsequence ( n seq -- )
  17     [
  18         [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
  19         [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
  20     ] keep
  21     '[ @ _ like ] ;
  22
  23 MACRO: narray ( n -- )
  24     '[ _ { } nsequence ] ;
  25
  26 MACRO: nsum ( n -- )
  27     1 - [ + ] n*quot ;
  28
  29 MACRO: firstn-unsafe ( n -- )
  30     [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
  31
  32 MACRO: firstn ( n -- )
  33     dup zero? [ drop [ drop ] ] [
  34         [ 1 - swap bounds-check 2drop ]
  35         [ firstn-unsafe ]
  36         bi-curry '[ _ _ bi ]
  37     ] if ;
  38
  39 MACRO: npick ( n -- )
  40     1 - [ dup ] [ '[ _ dip swap ] ] repeat ;
  41
  42 MACRO: nover ( n -- )
  43     dup 1 + '[ _ npick ] n*quot ;
  44
  45 MACRO: ndup ( n -- )
  46     dup '[ _ npick ] n*quot ;
  47
  48 MACRO: nrot ( n -- )
  49     1 - [ ] [ '[ _ dip swap ] ] repeat ;
  50
  51 MACRO: -nrot ( n -- )
  52     1 - [ ] [ '[ swap _ dip ] ] repeat ;
  53
  54 MACRO: ndrop ( n -- )
  55     [ drop ] n*quot ;
  56
  57 MACRO: nnip ( n -- )
  58     '[ [ _ ndrop ] dip ] ;
  59
  60 MACRO: ntuck ( n -- )
  61     2 + '[ dup _ -nrot ] ;
  62
  63 MACRO: ndip ( quot n -- )
  64     [ '[ _ dip ] ] times ;
  65
  66 MACRO: nkeep ( quot n -- )
  67     tuck '[ _ ndup _ _ ndip ] ;
  68
  69 MACRO: ncurry ( n -- )
  70     [ curry ] n*quot ;
  71
  72 MACRO: nwith ( n -- )
  73     [ with ] n*quot ;
  74
  75 MACRO: nbi ( n -- )
  76     '[ [ _ nkeep ] dip call ] ;
  77
  78 MACRO: ncleave ( quots n -- )
  79     [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
  80     compose ;
  81
  82 MACRO: nspread ( quots n -- )
  83     over empty? [ 2drop [ ] ] [
  84         [ [ but-last ] dip ]
  85         [ [ last ] dip ] 2bi
  86         swap
  87         '[ [ _ _ nspread ] _ ndip @ ]
  88     ] if ;
  89
  90 MACRO: napply ( quot n -- )
  91     swap <repetition> spread>quot ;
  92
  93 MACRO: mnswap ( m n -- )
  94     1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
  95
  96 MACRO: nweave ( n -- )
  97     [ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
  98     '[ _ _ ncleave ] ;
  99
 100 MACRO: nbi-curry ( n -- )
 101     [ bi-curry ] n*quot ;
 102
 103 : nappend-as ( n exemplar -- seq )
 104     [ narray concat ] dip like ; inline
 105
 106 : nappend ( n -- seq ) narray concat ; inline