basis/sequences/generalizations/generalizations.factor

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