extra/sequences/extras/extras.factor

   1 USING: arrays grouping kernel locals math math.order math.ranges
   2 sequences ;
   3
   4 IN: sequences.extras
   5
   6 : reduce1 ( seq quot -- result ) [ unclip ] dip reduce ; inline
   7
   8 :: reduce-r
   9     ( list identity quot: ( obj1 obj2 -- obj ) -- result )
  10     list empty?
  11     [ identity ]
  12     [ list rest identity quot reduce-r list first quot call ] if ;
  13     inline recursive
  14
  15 ! Quot must have static stack effect, unlike "reduce"
  16 :: reduce* ( seq id quot -- result ) seq
  17     [ id ]
  18     [ unclip id swap quot call( prev elt -- next ) quot reduce* ] if-empty ; inline recursive
  19
  20 :: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ;
  21 : find-all ( seq quot -- elts ) [ [ length iota ] keep ] dip
  22     [ dupd call( a -- ? ) [ 2array ] [ 2drop f ] if ] curry 2map [ ] filter ; inline
  23
  24 : insert-sorted ( elt seq -- seq ) 2dup [ < ] with find drop over length or swap insert-nth ;
  25
  26 : max-by ( obj1 obj2 quot: ( obj -- n ) -- obj1/obj2 )
  27     [ bi@ [ max ] keep eq? not ] curry most ; inline
  28
  29 : min-by ( obj1 obj2 quot: ( obj -- n ) -- obj1/obj2 )
  30     [ bi@ [ min ] keep eq? not ] curry most ; inline
  31
  32 : maximum ( seq quot: ( ... elt -- ... x ) -- elt )
  33     [ keep 2array ] curry
  34     [ [ first ] max-by ] map-reduce second ; inline
  35
  36 : minimum ( seq quot: ( ... elt -- ... x ) -- elt )
  37     [ keep 2array ] curry
  38     [ [ first ] min-by ] map-reduce second ; inline
  39
  40 : all-subseqs ( seq -- seqs )
  41     dup length [1,b] [ <clumps> ] with map concat ;
  42
  43 :: each-subseq ( ... seq quot: ( ... x -- ... ) -- ... )
  44     seq length [0,b] [
  45         :> from
  46         from seq length (a,b] [
  47             :> to
  48             from to seq subseq quot call( x -- )
  49         ] each
  50     ] each ;
  51
  52 :: longest-subseq ( seq1 seq2 -- subseq )
  53     seq1 length :> len1
  54     seq2 length :> len2
  55     0 :> n!
  56     0 :> end!
  57     len1 1 + [ len2 1 + 0 <array> ] replicate :> table
  58     len1 [1,b] [| x |
  59         len2 [1,b] [| y |
  60             x 1 - seq1 nth
  61             y 1 - seq2 nth = [
  62                 y 1 - x 1 - table nth nth 1 + :> len
  63                 len y x table nth set-nth
  64                 len n > [ len n! x end! ] when
  65             ] [ 0 y x table nth set-nth ] if
  66         ] each
  67     ] each end n - end seq1 subseq ;
  68