extra/grouping/extras/extras.factor

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