extra/sequences/lib/lib.factor

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