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: nsequence ( n seq -- quot )
   8     [ [nsequence] ] keep '[ @ _ like ] ;
   9
  10 MACRO: narray ( n -- quot )
  11     '[ _ { } nsequence ] ;
  12
  13 MACRO: firstn-unsafe ( n -- quot )
  14     [firstn] ;
  15
  16 MACRO: firstn ( n -- quot )
  17     [ [ drop ] ] [
  18         [ 1 - swap bounds-check 2drop ]
  19         [ firstn-unsafe ]
  20         bi-curry '[ _ _ bi ]
  21     ] if-zero ;
  22
  23 MACRO: set-firstn-unsafe ( n -- quot )
  24     [ 1 + ]
  25     [ <iota> [ '[ _ rot [ set-nth-unsafe ] keep ] ] map ] bi
  26     '[ _ -nrot _ spread drop ] ;
  27
  28 MACRO: set-firstn ( n -- quot )
  29     [ [ drop ] ] [
  30         [ 1 - swap bounds-check 2drop ]
  31         [ set-firstn-unsafe ]
  32         bi-curry '[ _ _ bi ]
  33     ] if-zero ;
  34
  35 : nappend ( n -- seq ) narray concat ; inline
  36
  37 : nappend-as ( n exemplar -- seq )
  38     [ narray ] [ concat-as ] bi* ; inline
  39
  40 MACRO: nmin-length ( n -- quot )
  41     dup 1 - [ min ] n*quot
  42     '[ [ length ] _ napply @ ] ;
  43
  44 : nnth ( n seq... n -- )
  45     [ nth ] swap [ apply-curry ] [ cleave* ] bi ; inline
  46
  47 : nnth-unsafe ( n seq... n -- )
  48     [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
  49
  50 MACRO: nset-nth-unsafe ( n -- quot )
  51     [ [ drop ] ]
  52     [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
  53     if-zero ;
  54
  55 : (neach) ( seq... quot n -- len quot' )
  56     dup dup dup
  57     '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
  58
  59 : neach ( seq... quot n -- )
  60     (neach) each-integer ; inline
  61
  62 : nmap-as ( seq... quot exemplar n -- result )
  63     '[ _ (neach) ] dip map-integers ; inline
  64
  65 : nmap ( seq... quot n -- result )
  66     dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
  67
  68 MACRO: nnew-sequence ( n -- quot )
  69     [ [ drop ] ]
  70     [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
  71
  72 : nnew-like ( len exemplar... quot n -- result... )
  73     5 dupn '[
  74         _ nover
  75         [ [ _ nnew-sequence ] dip call ]
  76         _ ndip [ like ]
  77         _ apply-curry
  78         _ spread*
  79     ] call ; inline
  80
  81 MACRO: (ncollect) ( n -- quot )
  82     3 dupn 1 +
  83     '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
  84
  85 : ncollect ( len quot into... n -- )
  86     (ncollect) each-integer ; inline
  87
  88 : nmap-integers ( len quot exemplar... n -- result... )
  89     4 dupn
  90     '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
  91
  92 : mnmap-as ( m*seq quot n*exemplar m n -- result*n )
  93     dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
  94
  95 : mnmap ( m*seq quot m n -- result*n )
  96     2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
  97
  98 : ncollector-as ( quot exemplar... n -- quot' vec... )
  99     5 dupn '[
 100         [ [ length ] keep new-resizable ] _ napply
 101         [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
 102     ] call ; inline
 103
 104 : ncollector ( quot n -- quot' vec... )
 105     [ V{ } swap dupn ] keep ncollector-as ; inline
 106
 107 : nproduce-as ( pred quot exemplar... n -- seq... )
 108     7 dupn '[
 109         _ ndup
 110         [ _ ncollector-as [ while ] _ ndip ]
 111         _ ncurry _ ndip
 112         [ like ] _ apply-curry _ spread*
 113     ] call ; inline
 114
 115 : nproduce ( pred quot n -- seq... )
 116     [ { } swap dupn ] keep nproduce-as ; inline
 117
 118 MACRO: nmap-reduce ( map-quot reduce-quot n -- quot )
 119     -rot dupd compose [ over ] dip over '[
 120         [ [ first ] _ napply @ 1 ] _ nkeep
 121         _ _ (neach) (each-integer)
 122     ] ;
 123
 124 : nall? ( seqs... quot n -- ? )
 125     (neach) all-integers? ; inline
 126
 127 MACRO: finish-nfind ( n -- quot )
 128     [ 1 + ] keep dup dup dup '[
 129         _ npick
 130         [ [ dup ] _ ndip _ nnth-unsafe ]
 131         [ _ ndrop _ [ f ] times ]
 132         if
 133     ] ;
 134
 135 : (nfind) ( seqs... quot n quot' -- i elts... )
 136     over
 137     [ '[ _ _ (neach) @ ] ] dip
 138     [ '[ _ finish-nfind ] ] keep
 139     nbi ; inline
 140
 141 : nfind ( seqs... quot n -- i elts... )
 142     [ find-integer ] (nfind) ; inline
 143
 144 : nany? ( seqs... quot n -- ? )
 145     [ nfind ] [ ndrop ] bi >boolean ; inline