basis/sequences/generalizations/generalizations.factor

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