basis/generalizations/generalizations.factor

   1 ! Copyright (C) 2007, 2008 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 math.ranges
   5 combinators macros quotations fry ;
   6 IN: generalizations
   7
   8 <<
   9
  10 : n*quot ( n seq -- seq' ) <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: firstn ( n -- )
  27     dup zero? [ drop [ drop ] ] [
  28         [ [ '[ [ _ ] dip nth-unsafe ] ] map ]
  29         [ 1- '[ [ _ ] dip bounds-check 2drop ] ]
  30         bi prefix '[ _ cleave ]
  31     ] if ;
  32
  33 MACRO: npick ( n -- )
  34     1- [ dup ] [ '[ _ dip swap ] ] repeat ;
  35
  36 MACRO: ndup ( n -- )
  37     dup '[ _ npick ] n*quot ;
  38
  39 MACRO: nrot ( n -- )
  40     1- [ ] [ '[ _ dip swap ] ] repeat ;
  41
  42 MACRO: -nrot ( n -- )
  43     1- [ ] [ '[ swap _ dip ] ] repeat ;
  44
  45 MACRO: ndrop ( n -- )
  46     [ drop ] n*quot ;
  47
  48 MACRO: nnip ( n -- )
  49     '[ [ _ ndrop ] dip ] ;
  50
  51 MACRO: ntuck ( n -- )
  52     2 + '[ dup _ -nrot ] ;
  53
  54 MACRO: nrev ( n -- )
  55     1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
  56
  57 MACRO: ndip ( quot n -- )
  58     [ '[ _ dip ] ] times ;
  59
  60 MACRO: nslip ( n -- )
  61     '[ [ call ] _ ndip ] ;
  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: napply ( n -- )
  77     2 [a,b]
  78     [ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
  79     map concat >quotation [ call ] append ;
  80
  81 MACRO: mnswap ( m n -- )
  82     1+ '[ _ -nrot ] <repetition> spread>quot ;