basis/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 sequences.private accessors ;
   5 IN: grouping
   6
   7 <PRIVATE
   8
   9 TUPLE: chunking-seq { seq read-only } { n read-only } ;
  10
  11 : check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
  12
  13 : new-groups ( seq n class -- groups )
  14     >r check-groups r> boa ; inline
  15
  16 GENERIC: group@ ( n groups -- from to seq )
  17
  18 M: chunking-seq set-nth group@ <slice> 0 swap copy ;
  19
  20 M: chunking-seq like drop { } like ;
  21
  22 INSTANCE: chunking-seq sequence
  23
  24 MIXIN: subseq-chunking
  25
  26 M: subseq-chunking nth group@ subseq ;
  27
  28 MIXIN: slice-chunking
  29
  30 M: slice-chunking nth group@ <slice> ;
  31
  32 M: slice-chunking nth-unsafe group@ slice boa ;
  33
  34 TUPLE: abstract-groups < chunking-seq ;
  35
  36 M: abstract-groups length
  37     [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
  38
  39 M: abstract-groups set-length
  40     [ n>> * ] [ seq>> ] bi set-length ;
  41
  42 M: abstract-groups group@
  43     [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
  44
  45 TUPLE: abstract-clumps < chunking-seq ;
  46
  47 M: abstract-clumps length
  48     [ seq>> length ] [ n>> ] bi - 1+ ;
  49
  50 M: abstract-clumps set-length
  51     [ n>> + 1- ] [ seq>> ] bi set-length ;
  52
  53 M: abstract-clumps group@
  54     [ n>> over + ] [ seq>> ] bi ;
  55
  56 PRIVATE>
  57
  58 TUPLE: groups < abstract-groups ;
  59
  60 : <groups> ( seq n -- groups )
  61     groups new-groups ; inline
  62
  63 INSTANCE: groups subseq-chunking
  64
  65 TUPLE: sliced-groups < abstract-groups ;
  66
  67 : <sliced-groups> ( seq n -- groups )
  68     sliced-groups new-groups ; inline
  69
  70 INSTANCE: sliced-groups slice-chunking
  71
  72 TUPLE: clumps < abstract-clumps ;
  73
  74 : <clumps> ( seq n -- clumps )
  75     clumps new-groups ; inline
  76
  77 INSTANCE: clumps subseq-chunking
  78
  79 TUPLE: sliced-clumps < abstract-clumps ;
  80
  81 : <sliced-clumps> ( seq n -- clumps )
  82     sliced-clumps new-groups ; inline
  83
  84 INSTANCE: sliced-clumps slice-chunking
  85
  86 : group ( seq n -- array ) <groups> { } like ;
  87
  88 : clump ( seq n -- array ) <clumps> { } like ;