basis/generalizations/generalizations.factor

   1 ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo\r
   2 ! Cavazos, Slava Pestov.\r
   3 ! See http://factorcode.org/license.txt for BSD license.\r
   4 USING: kernel sequences sequences.private namespaces math\r
   5 math.ranges combinators macros quotations fry arrays ;\r
   6 IN: generalizations\r
   7 \r
   8 MACRO: nsequence ( n seq -- quot )\r
   9     [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi\r
  10     [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce ;\r
  11 \r
  12 MACRO: narray ( n -- quot )\r
  13     '[ _ { } nsequence ] ;\r
  14 \r
  15 MACRO: firstn ( n -- )\r
  16     dup zero? [ drop [ drop ] ] [\r
  17         [ [ '[ [ _ ] dip nth-unsafe ] ] map ]\r
  18         [ 1- '[ [ _ ] dip bounds-check 2drop ] ]\r
  19         bi prefix '[ _ cleave ]\r
  20     ] if ;\r
  21 \r
  22 MACRO: npick ( n -- )\r
  23     1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;\r
  24 \r
  25 MACRO: ndup ( n -- )\r
  26     dup '[ _ npick ] n*quot ;\r
  27 \r
  28 MACRO: nrot ( n -- )\r
  29     1- dup saver swap [ r> swap ] n*quot append ;\r
  30 \r
  31 MACRO: -nrot ( n -- )\r
  32     1- dup [ swap >r ] n*quot swap restorer append ;\r
  33 \r
  34 MACRO: ndrop ( n -- )\r
  35     [ drop ] n*quot ;\r
  36 \r
  37 : nnip ( n -- )\r
  38     swap >r ndrop r> ; inline\r
  39 \r
  40 MACRO: ntuck ( n -- )\r
  41     2 + [ dupd -nrot ] curry ;\r
  42 \r
  43 MACRO: nrev ( n -- quot )\r
  44     1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;\r
  45 \r
  46 MACRO: ndip ( quot n -- )\r
  47     dup saver -rot restorer 3append ;\r
  48 \r
  49 MACRO: nslip ( n -- )\r
  50     dup saver [ call ] rot restorer 3append ;\r
  51 \r
  52 MACRO: nkeep ( n -- )\r
  53     [ ] [ 1+ ] [ ] tri\r
  54     '[ [ _ ndup ] dip _ -nrot _ nslip ] ;\r
  55 \r
  56 MACRO: ncurry ( n -- )\r
  57     [ curry ] n*quot ;\r
  58 \r
  59 MACRO: nwith ( n -- )\r
  60     [ with ] n*quot ;\r
  61 \r
  62 MACRO: napply ( n -- )\r
  63     2 [a,b]\r
  64     [ [ 1- ] keep '[ _ ntuck _ nslip ] ]\r
  65     map concat >quotation [ call ] append ;\r