core/grouping/grouping.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math math.order strings arrays vectors sequences
   4 accessors ;
   5 IN: grouping
   6
   7 TUPLE: abstract-groups seq n ;
   8
   9 : check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
  10
  11 : new-groups ( seq n class -- groups )
  12     >r check-groups r> boa ; inline
  13
  14 GENERIC: group@ ( n groups -- from to seq )
  15
  16 M: abstract-groups nth group@ subseq ;
  17
  18 M: abstract-groups set-nth group@ <slice> 0 swap copy ;
  19
  20 M: abstract-groups like drop { } like ;
  21
  22 INSTANCE: abstract-groups sequence
  23
  24 TUPLE: groups < abstract-groups ;
  25
  26 : <groups> ( seq n -- groups )
  27     groups new-groups ; inline
  28
  29 M: groups length
  30     [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
  31
  32 M: groups set-length
  33     [ n>> * ] [ seq>> ] bi set-length ;
  34
  35 M: groups group@
  36     [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
  37
  38 TUPLE: sliced-groups < groups ;
  39
  40 : <sliced-groups> ( seq n -- groups )
  41     sliced-groups new-groups ; inline
  42
  43 M: sliced-groups nth group@ <slice> ;
  44
  45 TUPLE: clumps < abstract-groups ;
  46
  47 : <clumps> ( seq n -- clumps )
  48     clumps new-groups ; inline
  49
  50 M: clumps length
  51     [ seq>> length ] [ n>> ] bi - 1+ ;
  52
  53 M: clumps set-length
  54     [ n>> + 1- ] [ seq>> ] bi set-length ;
  55
  56 M: clumps group@
  57     [ n>> over + ] [ seq>> ] bi ;
  58
  59 TUPLE: sliced-clumps < groups ;
  60
  61 : <sliced-clumps> ( seq n -- clumps )
  62     sliced-clumps new-groups ; inline
  63
  64 M: sliced-clumps nth group@ <slice> ;
  65
  66 : group ( seq n -- array ) <groups> { } like ;
  67
  68 : clump ( seq n -- array ) <clumps> { } like ;