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: narray ( n -- quot )\r
   9     [ <reversed> ] [ '[ , f <array> ] ] bi\r
  10     [ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ;\r
  11 \r
  12 MACRO: firstn ( n -- )\r
  13     dup zero? [ drop [ drop ] ] [\r
  14         [ [ '[ , _ nth-unsafe ] ] map ]\r
  15         [ 1- '[ , _ bounds-check 2drop ] ]\r
  16         bi prefix '[ , cleave ]\r
  17     ] if ;\r
  18 \r
  19 MACRO: npick ( n -- )\r
  20     1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;\r
  21 \r
  22 MACRO: ndup ( n -- )\r
  23     dup '[ , npick ] n*quot ;\r
  24 \r
  25 MACRO: nrot ( n -- )\r
  26     1- dup saver swap [ r> swap ] n*quot append ;\r
  27 \r
  28 MACRO: -nrot ( n -- )\r
  29     1- dup [ swap >r ] n*quot swap restorer append ;\r
  30 \r
  31 MACRO: ndrop ( n -- )\r
  32     [ drop ] n*quot ;\r
  33 \r
  34 : nnip ( n -- )\r
  35     swap >r ndrop r> ; inline\r
  36 \r
  37 MACRO: ntuck ( n -- )\r
  38     2 + [ dupd -nrot ] curry ;\r
  39 \r
  40 MACRO: nrev ( n -- quot )\r
  41     1 [a,b] [ ] [ '[ @ , -nrot ] ] reduce ;\r
  42 \r
  43 MACRO: ndip ( quot n -- )\r
  44     dup saver -rot restorer 3append ;\r
  45 \r
  46 MACRO: nslip ( n -- )\r
  47     dup saver [ call ] rot restorer 3append ;\r
  48 \r
  49 MACRO: nkeep ( n -- )\r
  50     [ ] [ 1+ ] [ ] tri\r
  51     '[ [ , ndup ] dip , -nrot , nslip ] ;\r
  52 \r
  53 MACRO: ncurry ( n -- )\r
  54     [ curry ] n*quot ;\r
  55 \r
  56 MACRO: nwith ( n -- )\r
  57     [ with ] n*quot ;\r
  58 \r
  59 MACRO: napply ( n -- )\r
  60     2 [a,b]\r
  61     [ [ 1- ] keep '[ , ntuck , nslip ] ]\r
  62     map concat >quotation [ call ] append ;\r