basis/sequences/generalizations/generalizations.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: kernel sequences sequences.private math
   3 combinators macros math.order math.ranges quotations fry effects
   4 memoize.private generalizations ;
   5 IN: sequences.generalizations
   6
   7 MACRO: nmin-length ( n -- )
   8     dup 1 - [ min ] n*quot
   9     '[ [ length ] _ napply @ ] ;
  10
  11 : nnth-unsafe ( n ...seq n -- )
  12     [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
  13 MACRO: nset-nth-unsafe ( n -- )
  14     [ [ drop ] ]
  15     [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
  16     if-zero ;
  17
  18 : (neach) ( ...seq quot n -- len quot' )
  19     dup dup dup
  20     '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
  21
  22 : neach ( ...seq quot n -- )
  23     (neach) each-integer ; inline
  24
  25 : nmap-as ( ...seq quot exemplar n -- result )
  26     '[ _ (neach) ] dip map-integers ; inline
  27
  28 : nmap ( ...seq quot n -- result )
  29     dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
  30
  31 MACRO: nnew-sequence ( n -- )
  32     [ [ drop ] ]
  33     [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
  34
  35 : nnew-like ( len ...exemplar quot n -- result... )
  36     5 dupn '[
  37         _ nover
  38         [ [ _ nnew-sequence ] dip call ]
  39         _ ndip [ like ]
  40         _ apply-curry
  41         _ spread*
  42     ] call ; inline
  43
  44 MACRO: (ncollect) ( n -- )
  45     3 dupn 1 +
  46     '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
  47
  48 : ncollect ( len quot ...into n -- )
  49     (ncollect) each-integer ; inline
  50
  51 : nmap-integers ( len quot ...exemplar n -- result... )
  52     4 dupn
  53     '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
  54
  55 : mnmap-as ( m*seq quot n*exemplar m n -- result*n )
  56     dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
  57
  58 : mnmap ( m*seq quot m n -- result*n )
  59     2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
  60
  61 : ncollector-for ( quot ...exemplar n -- quot' vec... )
  62     5 dupn '[
  63         [ [ length ] keep new-resizable ] _ napply
  64         [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
  65     ] call ; inline
  66
  67 : ncollector ( quot n -- quot' vec... )
  68     [ V{ } swap dupn ] keep ncollector-for ; inline
  69
  70 : nproduce-as ( pred quot ...exemplar n -- seq... )
  71     7 dupn '[
  72         _ ndup
  73         [ _ ncollector-for [ while ] _ ndip ]
  74         _ ncurry _ ndip
  75         [ like ] _ apply-curry _ spread*
  76     ] call ; inline
  77
  78 : nproduce ( pred quot n -- seq... )
  79     [ { } swap dupn ] keep nproduce-as ; inline