extra/sequences/extras/extras.factor

   1 USING: arrays grouping kernel locals math math.order math.ranges
   2 sequences splitting ;
   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     [ dup ?first ] dip [ max-by ] curry reduce ; inline
  34
  35 : minimum ( seq quot: ( ... elt -- ... x ) -- elt )
  36     [ dup ?first ] dip [ min-by ] curry reduce ; inline
  37
  38 : all-subseqs ( seq -- seqs )
  39     dup length [1,b] [ <clumps> ] with map concat ;
  40
  41 :: each-subseq ( ... seq quot: ( ... x -- ... ) -- ... )
  42     seq length [0,b] [
  43         :> from
  44         from seq length (a,b] [
  45             :> to
  46             from to seq subseq quot call( x -- )
  47         ] each
  48     ] each ;
  49
  50 :: longest-subseq ( seq1 seq2 -- subseq )
  51     seq1 length :> len1
  52     seq2 length :> len2
  53     0 :> n!
  54     0 :> end!
  55     len1 1 + [ len2 1 + 0 <array> ] replicate :> table
  56     len1 [1,b] [| x |
  57         len2 [1,b] [| y |
  58             x 1 - seq1 nth
  59             y 1 - seq2 nth = [
  60                 y 1 - x 1 - table nth nth 1 + :> len
  61                 len y x table nth set-nth
  62                 len n > [ len n! x end! ] when
  63             ] [ 0 y x table nth set-nth ] if
  64         ] each
  65     ] each end n - end seq1 subseq ;
  66
  67 : pad-longest ( seq1 seq2 elt -- seq1 seq2 )
  68     [ 2dup max-length ] dip [ pad-tail ] 2curry bi@ ;
  69
  70 : change-nths ( ... indices seq quot: ( ... elt -- ... elt' ) -- ... )
  71     [ change-nth ] 2curry each ; inline
  72
  73 : push-if-index ( ..a elt i quot: ( ..a elt i -- ..b ? ) accum -- ..b )
  74     [ 2keep drop ] dip rot [ push ] [ 2drop ] if ; inline
  75
  76 : index-selector-for ( quot exemplar -- selector accum )
  77     [ length ] keep new-resizable [ [ push-if-index ] 2curry ] keep ; inline
  78
  79 : filter-index-as ( ... seq quot: ( ... elt i -- ... ? ) exemplar -- ... seq' )
  80     dup [ index-selector-for [ each-index ] dip ] curry dip like ; inline
  81
  82 : filter-index ( ... seq quot: ( ... elt i -- ... ? ) -- ... seq' )
  83     over filter-index-as ; inline
  84
  85 : even-indices ( seq -- seq' ) [ nip even? ] filter-index ;
  86
  87 : odd-indices ( seq -- seq' ) [ nip odd? ] filter-index ;
  88
  89 : compact ( seq quot elt -- seq' )
  90     [ split-when harvest ] dip join ; inline
  91
  92 : collapse ( seq quot elt -- seq' )
  93     [ split-when ] dip
  94     [ [ harvest ] dip join ]
  95     [ [ first empty? ] dip [ prepend ] curry when ]
  96     [ [ last empty? ] dip [ append ] curry when ]
  97     2tri ; inline
  98
  99 :: slice-when ( seq quot: ( elt -- ? ) -- seq' )
 100     seq length :> len
 101     0 [ len dupd < ] [
 102         dup seq quot find-from drop
 103         [ 2dup = [ 1 + ] when ] [ len ] if*
 104         [ seq <slice> ] keep len or swap
 105     ] produce nip ; inline