unmaintained/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 math.ranges random fry ;
   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   [
  27     dup length
  28     dup [ / ] curry
  29     [ 1+ ] prepose
  30   ] dip compose
  31   2each ;                       inline
  32
  33 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  34
  35 : reduce* ( seq quot -- result ) [ ] swap map-reduce ; inline
  36
  37 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  38
  39 : higher ( a b quot -- c ) [ compare +gt+ eq? ] curry most ; inline
  40
  41 : lower  ( a b quot -- c ) [ compare +lt+ eq? ] curry most ; inline
  42
  43 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  44
  45 : longer  ( a b -- c ) [ length ] higher ;
  46
  47 : shorter ( a b -- c ) [ length ] lower ;
  48
  49 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  50
  51 : longest ( seq -- item ) [ longer ] reduce* ;
  52
  53 : shortest ( seq -- item ) [ shorter ] reduce* ;
  54
  55 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  56
  57 : bigger ( a b -- c ) [ ] higher ;
  58
  59 : smaller ( a b -- c ) [ ] lower ;
  60
  61 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  62
  63 : biggest ( seq -- item ) [ bigger ] reduce* ;
  64
  65 : smallest ( seq -- item ) [ smaller ] reduce* ;
  66
  67 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  68
  69 : minmax ( seq -- min max )
  70     #! find the min and max of a seq in one pass
  71     1/0. -1/0. rot [ tuck max [ min ] dip ] each ;
  72
  73 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  74
  75 : ,, ( obj -- ) building get peek push ;
  76 : v, ( -- ) V{ } clone , ;
  77 : ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
  78
  79 : (monotonic-split) ( seq quot -- newseq )
  80     [
  81         [ dup unclip suffix ] dip
  82         v, [ pick ,, call [ v, ] unless ] curry 2each ,v
  83     ] { } make ;
  84
  85 : monotonic-split ( seq quot -- newseq )
  86     over empty? [ 2drop { } ] [ (monotonic-split) ] if ;
  87
  88 ERROR: element-not-found ;
  89 : split-around ( seq quot -- before elem after )
  90     dupd find over [ element-not-found ] unless
  91     [ cut rest ] dip swap ; inline
  92
  93 : map-until ( seq quot pred -- newseq )
  94     '[ [ @ dup @ [ drop t ] [ , f ] if ] find 2drop ] { } make ;
  95
  96 : take-while ( seq quot -- newseq )
  97     [ not ] compose
  98     [ find drop [ head-slice ] when* ] curry
  99     [ dup ] prepose keep like ;
 100
 101 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 102
 103 <PRIVATE
 104 : translate-string ( n alphabet out-len -- seq )
 105     [ drop /mod ] with map nip  ;
 106
 107 : map-alphabet ( alphabet seq[seq] -- seq[seq] )
 108     [ [ swap nth ] with map ] with map ;
 109
 110 : exact-number-strings ( n out-len -- seqs )
 111     [ ^ ] 2keep [ translate-string ] 2curry map ;
 112
 113 : number-strings ( n max-length -- seqs )
 114     1+ [ exact-number-strings ] with map concat ;
 115 PRIVATE>
 116
 117 : exact-strings ( alphabet length -- seqs )
 118     [ dup length ] dip exact-number-strings map-alphabet ;
 119
 120 : strings ( alphabet length -- seqs )
 121     [ dup length ] dip number-strings map-alphabet ;
 122
 123 : switches ( seq1 seq -- subseq )
 124     ! seq1 is a sequence of ones and zeroes
 125     [ [ length ] keep [ nth 1 = ] curry filter ] dip
 126     [ nth ] curry { } map-as ;
 127
 128 : power-set ( seq -- subsets )
 129     2 over length exact-number-strings swap [ switches ] curry map ;
 130
 131 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 132
 133 <PRIVATE
 134 : (attempt-each-integer) ( i n quot -- result )
 135     [
 136         iterate-step roll
 137         [ 3nip ] [ iterate-next (attempt-each-integer) ] if*
 138     ] [ 3drop f ] if-iterate? ; inline recursive
 139 PRIVATE>
 140
 141 : attempt-each ( seq quot -- result )
 142     (each) iterate-prep (attempt-each-integer) ; inline
 143
 144 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 145
 146 : randomize ( seq -- seq' )
 147     dup length 1 (a,b] [ dup random pick exchange ] each ;
 148
 149 : enumerate ( seq -- seq' ) <enum> >alist ;