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: ndup ( n -- )
  43     dup '[ _ npick ] n*quot ;
  44
  45 MACRO: nrot ( n -- )
  46     1- [ ] [ '[ _ dip swap ] ] repeat ;
  47
  48 MACRO: -nrot ( n -- )
  49     1- [ ] [ '[ swap _ dip ] ] repeat ;
  50
  51 MACRO: ndrop ( n -- )
  52     [ drop ] n*quot ;
  53
  54 MACRO: nnip ( n -- )
  55     '[ [ _ ndrop ] dip ] ;
  56
  57 MACRO: ntuck ( n -- )
  58     2 + '[ dup _ -nrot ] ;
  59
  60 MACRO: ndip ( quot n -- )
  61     [ '[ _ dip ] ] times ;
  62
  63 MACRO: nkeep ( quot n -- )
  64     tuck '[ _ ndup _ _ ndip ] ;
  65
  66 MACRO: ncurry ( n -- )
  67     [ curry ] n*quot ;
  68
  69 MACRO: nwith ( n -- )
  70     [ with ] n*quot ;
  71
  72 MACRO: ncleave ( quots n -- )
  73     [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
  74     compose ;
  75
  76 MACRO: nspread ( quots n -- )
  77     over empty? [ 2drop [ ] ] [
  78         [ [ but-last ] dip ]
  79         [ [ peek ] dip ] 2bi
  80         swap
  81         '[ [ _ _ nspread ] _ ndip @ ]
  82     ] if ;
  83
  84 MACRO: napply ( quot n -- )
  85     swap <repetition> spread>quot ;
  86
  87 MACRO: mnswap ( m n -- )
  88     1+ '[ _ -nrot ] swap '[ _ _ napply ] ;
  89
  90 MACRO: nweave ( n -- )
  91     [ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
  92     '[ _ _ ncleave ] ;
  93
  94 : nappend-as ( n exemplar -- seq )
  95     [ narray concat ] dip like ; inline
  96
  97 : nappend ( n -- seq ) narray concat ; inline