core/sequences/generalizations/generalizations.factor

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