extra/sequences/lib/lib.factor

   1 USING: combinators.lib kernel sequences math namespaces assocs
   2 random sequences.private shuffle math.functions mirrors ;
   3 USING: arrays math.parser sorting strings ;
   4 IN: sequences.lib
   5
   6 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   7
   8 : map-reduce ( seq map-quot reduce-quot -- result )
   9     >r [ unclip ] dip [ call ] keep r> compose reduce ; inline
  10
  11 : reduce* ( seq quot -- result ) [ ] swap map-reduce ; inline
  12
  13 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  14
  15 : higher ( a b quot -- c ) [ compare 0 > ] curry most ; inline
  16
  17 : lower  ( a b quot -- c ) [ compare 0 < ] curry most ; inline
  18
  19 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  20
  21 : longer  ( a b -- c ) [ length ] higher ;
  22
  23 : shorter ( a b -- c ) [ length ] lower ;
  24
  25 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  26
  27 : longest ( seq -- item ) [ longer ] reduce* ;
  28
  29 : shortest ( seq -- item ) [ shorter ] reduce* ;
  30
  31 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  32
  33 : bigger ( a b -- c ) [ ] higher ;
  34
  35 : smaller ( a b -- c ) [ ] lower ;
  36
  37 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  38
  39 : biggest ( seq -- item ) [ bigger ] reduce* ;
  40
  41 : smallest ( seq -- item ) [ smaller ] reduce* ;
  42
  43 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  44
  45 : minmax ( seq -- min max )
  46     #! find the min and max of a seq in one pass
  47     1/0. -1/0. rot [ tuck max >r min r> ] each ;
  48
  49 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  50
  51 : ,, building get peek push ;
  52 : v, V{ } clone , ;
  53 : ,v building get dup peek empty? [ dup pop* ] when drop ;
  54
  55 : monotonic-split ( seq quot -- newseq )
  56     [
  57         >r dup unclip add r>
  58         v, [ pick ,, call [ v, ] unless ] curry 2each ,v
  59     ] { } make ;
  60
  61 : singleton? ( seq -- ? )
  62     length 1 = ;
  63
  64 : delete-random ( seq -- value )
  65     [ length random ] keep [ nth ] 2keep delete-nth ;
  66
  67 : split-around ( seq quot -- before elem after )
  68     dupd find over [ "Element not found" throw ] unless
  69     >r cut-slice 1 tail r> swap ; inline
  70
  71 : (map-until) ( quot pred -- quot )
  72     [ dup ] swap 3compose
  73     [ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ;
  74
  75 : map-until ( seq quot pred -- newseq )
  76     (map-until) { } make ;
  77
  78 : take-while ( seq quot -- newseq )
  79     [ not ] compose
  80     [ find drop [ head-slice ] when* ] curry
  81     [ dup ] swap compose keep like ;
  82
  83 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  84
  85 <PRIVATE
  86 : translate-string ( n alphabet out-len -- seq )
  87     [ drop /mod ] curry* map nip  ;
  88
  89 : map-alphabet ( alphabet seq[seq] -- seq[seq] )
  90     [ [ swap nth ] curry* map ] curry* map ;
  91
  92 : exact-number-strings ( n out-len -- seqs )
  93     [ ^ ] 2keep [ translate-string ] 2curry map ;
  94
  95 : number-strings ( n max-length -- seqs )
  96     1+ [ exact-number-strings ] curry* map concat ;
  97 PRIVATE>
  98
  99 : exact-strings ( alphabet length -- seqs )
 100     >r dup length r> exact-number-strings map-alphabet ;
 101
 102 : strings ( alphabet length -- seqs )
 103     >r dup length r> number-strings map-alphabet ;
 104
 105 : nths ( nths seq -- subseq )
 106     ! nths is a sequence of ones and zeroes
 107     >r [ length ] keep [ nth 1 = ] curry subset r>
 108     [ nth ] curry { } map-as ;
 109
 110 : power-set ( seq -- subsets )
 111     2 over length exact-number-strings swap [ nths ] curry map ;
 112
 113 : cut-find ( seq pred -- before after )
 114     dupd find drop dup [ cut ] when ;
 115
 116 : cut3 ( seq pred -- first mid last )
 117     [ cut-find ] keep [ not ] compose cut-find ;
 118
 119 : (cut-all) ( seq pred quot -- )
 120     [ >r cut3 r> dip >r >r , r> [ , ] when* r> ] 2keep
 121     pick [ (cut-all) ] [ 3drop ] if ;
 122
 123 : cut-all ( seq pred quot -- first mid last )
 124     [ (cut-all) ] { } make ;
 125
 126 : human-sort ( seq -- newseq )
 127     [ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc
 128     sort-values keys ;