extra/sequences/lib/lib.factor

   1 ! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
   2 !                    Eduardo Cavazos, Daniel Ehrenberg.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: combinators.lib kernel sequences math namespaces make
   5 assocs random sequences.private shuffle math.functions arrays
   6 math.parser math.private sorting strings ascii macros assocs.lib
   7 quotations hashtables math.order locals generalizations ;
   8 IN: sequences.lib
   9
  10 : each-withn ( seq quot n -- ) nwith each ; inline
  11
  12 : each-with ( seq quot -- ) with each ; inline
  13
  14 : each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
  15
  16 : map-withn ( seq quot n -- newseq ) nwith map ; inline
  17
  18 : map-with ( seq quot -- ) with map ; inline
  19
  20 : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
  21
  22 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  23
  24 : each-percent ( seq quot -- )
  25   >r
  26   dup length
  27   dup [ / ] curry
  28   [ 1+ ] prepose
  29   r> compose
  30   2each ;                       inline
  31
  32 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  33
  34 : map-reduce ( seq map-quot reduce-quot -- result )
  35     >r [ unclip ] dip [ call ] keep r> compose reduce ; inline
  36
  37 : reduce* ( seq quot -- result ) [ ] swap map-reduce ; inline
  38
  39 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  40
  41 : higher ( a b quot -- c ) [ compare +gt+ eq? ] curry most ; inline
  42
  43 : lower  ( a b quot -- c ) [ compare +lt+ eq? ] curry most ; inline
  44
  45 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  46
  47 : longer  ( a b -- c ) [ length ] higher ;
  48
  49 : shorter ( a b -- c ) [ length ] lower ;
  50
  51 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  52
  53 : longest ( seq -- item ) [ longer ] reduce* ;
  54
  55 : shortest ( seq -- item ) [ shorter ] reduce* ;
  56
  57 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  58
  59 : bigger ( a b -- c ) [ ] higher ;
  60
  61 : smaller ( a b -- c ) [ ] lower ;
  62
  63 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  64
  65 : biggest ( seq -- item ) [ bigger ] reduce* ;
  66
  67 : smallest ( seq -- item ) [ smaller ] reduce* ;
  68
  69 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  70
  71 : minmax ( seq -- min max )
  72     #! find the min and max of a seq in one pass
  73     1/0. -1/0. rot [ tuck max >r min r> ] each ;
  74
  75 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  76
  77 : ,, ( obj -- ) building get peek push ;
  78 : v, ( -- ) V{ } clone , ;
  79 : ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
  80
  81 : (monotonic-split) ( seq quot -- newseq )
  82     [
  83         >r dup unclip suffix r>
  84         v, [ pick ,, call [ v, ] unless ] curry 2each ,v
  85     ] { } make ;
  86
  87 : monotonic-split ( seq quot -- newseq )
  88     over empty? [ 2drop { } ] [ (monotonic-split) ] if ;
  89
  90 ERROR: element-not-found ;
  91 : split-around ( seq quot -- before elem after )
  92     dupd find over [ element-not-found ] unless
  93     >r cut rest r> swap ; inline
  94
  95 : (map-until) ( quot pred -- quot )
  96     [ dup ] swap 3compose
  97     [ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ;
  98
  99 : map-until ( seq quot pred -- newseq )
 100     (map-until) { } make ;
 101
 102 : take-while ( seq quot -- newseq )
 103     [ not ] compose
 104     [ find drop [ head-slice ] when* ] curry
 105     [ dup ] prepose keep like ;
 106
 107 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 108
 109 <PRIVATE
 110 : translate-string ( n alphabet out-len -- seq )
 111     [ drop /mod ] with map nip  ;
 112
 113 : map-alphabet ( alphabet seq[seq] -- seq[seq] )
 114     [ [ swap nth ] with map ] with map ;
 115
 116 : exact-number-strings ( n out-len -- seqs )
 117     [ ^ ] 2keep [ translate-string ] 2curry map ;
 118
 119 : number-strings ( n max-length -- seqs )
 120     1+ [ exact-number-strings ] with map concat ;
 121 PRIVATE>
 122
 123 : exact-strings ( alphabet length -- seqs )
 124     >r dup length r> exact-number-strings map-alphabet ;
 125
 126 : strings ( alphabet length -- seqs )
 127     >r dup length r> number-strings map-alphabet ;
 128
 129 : switches ( seq1 seq -- subseq )
 130     ! seq1 is a sequence of ones and zeroes
 131     >r [ length ] keep [ nth 1 = ] curry filter r>
 132     [ nth ] curry { } map-as ;
 133
 134 : power-set ( seq -- subsets )
 135     2 over length exact-number-strings swap [ switches ] curry map ;
 136
 137 : cut-find ( seq pred -- before after )
 138     dupd find drop dup [ cut ] when ;
 139
 140 : cut3 ( seq pred -- first mid last )
 141     [ cut-find ] keep [ not ] compose cut-find ;
 142
 143 : (cut-all) ( seq pred quot -- )
 144     [ >r cut3 r> dip >r >r , r> [ , ] when* r> ] 2keep
 145     pick [ (cut-all) ] [ 3drop ] if ;
 146
 147 : cut-all ( seq pred quot -- first mid last )
 148     [ (cut-all) ] { } make ;
 149
 150 : human-sort ( seq -- newseq )
 151     [ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc
 152     sort-values keys ;
 153
 154 : ?first ( seq -- first/f ) 0 swap ?nth ; inline
 155 : ?second ( seq -- second/f ) 1 swap ?nth ; inline
 156 : ?third ( seq -- third/f ) 2 swap ?nth ; inline
 157 : ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
 158
 159 : ?first2 ( seq -- 1st/f 2nd/f ) dup ?first swap ?second ; inline
 160 : ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline
 161 : ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline
 162
 163 USE: continuations
 164 : ?subseq ( from to seq -- subseq )
 165     >r >r 0 max r> r>
 166     [ length tuck min >r min r> ] keep subseq ;
 167
 168 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 169
 170 ! List the positions of obj in seq
 171
 172 : indices ( seq obj -- seq )
 173   >r dup length swap r>
 174   [ = [ ] [ drop f ] if ] curry
 175   2map
 176   sift ;
 177
 178 <PRIVATE
 179 : (attempt-each-integer) ( i n quot -- result )
 180     [
 181         iterate-step roll
 182         [ 3nip ] [ iterate-next (attempt-each-integer) ] if*
 183     ] [ 3drop f ] if-iterate? ; inline recursive
 184 PRIVATE>
 185
 186 : attempt-each ( seq quot -- result )
 187     (each) iterate-prep (attempt-each-integer) ; inline
 188
 189 : ?nth* ( n seq -- elt/f ? )
 190     2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable