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