basis/grouping/extras/extras.factor

   1 USING: accessors arrays combinators fry grouping
   2 grouping.private kernel locals macros math math.ranges sequences
   3 sequences.generalizations sequences.private vectors ;
   4
   5 IN: grouping.extras
   6
   7 : 2clump-map-as ( seq quot: ( elt1 elt2 -- newelt ) exemplar -- seq' )
   8     [ dup 1 short tail-slice ] 2dip 2map-as ; inline
   9
  10 : 2clump-map ( seq quot: ( elt1 elt2 -- newelt ) -- seq' )
  11     { } 2clump-map-as ; inline
  12
  13 : 3clump-map-as ( seq quot: ( elt1 elt2 elt3 -- newelt ) exemplar -- seq' )
  14     [
  15         dup [ 1 short tail-slice ] [ 2 short tail-slice ] bi
  16     ] 2dip 3map-as ; inline
  17
  18 : 3clump-map ( seq quot: ( elt1 elt2 elt3 -- newelt ) -- seq' )
  19     { } 3clump-map-as ; inline
  20
  21 MACRO: nclump-map-as ( seq quot exemplar n -- result )
  22     [ nip [1,b) [ [ short tail-slice ] curry ] map swap ] 2keep
  23     '[ _ dup _ cleave _ _ _ nmap-as ] ;
  24
  25 : nclump-map ( seq quot n -- result )
  26     { } swap nclump-map-as ; inline
  27
  28 TUPLE: head-clumps seq ;
  29 C: <head-clumps> head-clumps
  30 M: head-clumps length seq>> length ;
  31 M: head-clumps nth-unsafe seq>> swap 1 + head-slice ;
  32 INSTANCE: head-clumps immutable-sequence
  33
  34 : head-clump ( seq -- array )
  35     [ <head-clumps> ] [ [ like ] curry map ] bi ;
  36
  37 TUPLE: tail-clumps seq ;
  38 C: <tail-clumps> tail-clumps
  39 M: tail-clumps length seq>> length ;
  40 M: tail-clumps nth-unsafe seq>> swap tail-slice ;
  41 INSTANCE: tail-clumps immutable-sequence
  42
  43 : tail-clump ( seq -- array )
  44     [ <tail-clumps> ] [ [ like ] curry map ] bi ;
  45
  46 : clump-as ( seq n exemplar -- array )
  47     [ <clumps> ] dip [ like ] curry map ;
  48
  49 : group-as ( seq n exemplar -- array )
  50     [ <groups> ] dip [ like ] curry map ;
  51
  52 <PRIVATE
  53
  54 : (group-by) ( groups elt key -- groups )
  55     pick [ t ] [ last first dupd = not ] if-empty [
  56         swap 1vector 2array over push
  57     ] [
  58         drop over last last push
  59     ] if ; inline
  60
  61 PRIVATE>
  62
  63 : group-by ( seq quot: ( elt -- key ) -- groups )
  64     '[ dup _ call( x -- y ) (group-by) ] V{ } clone swap reduce ;
  65
  66 :: <n-groups> ( seq n -- groups )
  67     seq length :> len
  68     len n /mod :> ( step rem! )
  69     0 n [
  70         dup len < [
  71             dup step + rem zero? [ 1 + rem 1 - rem! ] unless
  72             [ seq <slice> ] keep swap
  73         ] [ f ] if
  74     ] replicate nip ;
  75
  76 : n-group ( seq n -- groups )
  77     [ <n-groups> ] map-like ;