basis/grouping/grouping.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math math.order strings arrays vectors sequences
   4 sequences.private accessors fry combinators ;
   5 IN: grouping
   6
   7 <PRIVATE
   8
   9 MIXIN: chunking
  10 INSTANCE: chunking sequence
  11
  12 GENERIC: group@ ( n groups -- from to seq )
  13
  14 M: chunking set-nth group@ <slice> 0 swap copy ;
  15 M: chunking like drop { } like ; inline
  16
  17 MIXIN: subseq-chunking
  18 INSTANCE: subseq-chunking chunking
  19 INSTANCE: subseq-chunking sequence
  20
  21 M: subseq-chunking nth group@ subseq ; inline
  22
  23 MIXIN: slice-chunking
  24 INSTANCE: slice-chunking chunking
  25 INSTANCE: slice-chunking sequence
  26
  27 M: slice-chunking nth group@ <slice> ; inline
  28 M: slice-chunking nth-unsafe group@ <slice-unsafe> ; inline
  29
  30 MIXIN: abstract-groups
  31 INSTANCE: abstract-groups sequence
  32
  33 M: abstract-groups length
  34     [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline
  35
  36 M: abstract-groups set-length
  37     [ n>> * ] [ seq>> ] bi set-length ; inline
  38
  39 M: abstract-groups group@
  40     [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline
  41
  42 MIXIN: abstract-clumps
  43 INSTANCE: abstract-clumps sequence
  44
  45 M: abstract-clumps length
  46     [ seq>> length 1 + ] [ n>> ] bi [-] ; inline
  47
  48 M: abstract-clumps set-length
  49     [ n>> + 1 - ] [ seq>> ] bi set-length ; inline
  50
  51 M: abstract-clumps group@
  52     [ n>> over + ] [ seq>> ] bi ; inline
  53
  54 TUPLE: chunking-seq { seq read-only } { n read-only } ;
  55
  56 : check-groups ( n -- n )
  57     dup 0 <= [ "Invalid group count" throw ] when ; inline
  58
  59 : new-groups ( seq n class -- groups )
  60     [ check-groups ] dip boa ; inline
  61
  62 : slice-mod ( n length -- n' )
  63     2dup >= [ - ] [ drop ] if ; inline
  64
  65 : check-circular-clumps ( seq n -- seq n )
  66     2dup 1 - swap bounds-check 2drop ; inline
  67
  68 PRIVATE>
  69
  70 TUPLE: groups < chunking-seq ;
  71 INSTANCE: groups subseq-chunking
  72 INSTANCE: groups abstract-groups
  73
  74 : <groups> ( seq n -- groups )
  75     groups new-groups ; inline
  76
  77 TUPLE: sliced-groups < chunking-seq ;
  78 INSTANCE: sliced-groups slice-chunking
  79 INSTANCE: sliced-groups abstract-groups
  80
  81 : <sliced-groups> ( seq n -- groups )
  82     sliced-groups new-groups ; inline
  83
  84 TUPLE: clumps < chunking-seq ;
  85 INSTANCE: clumps subseq-chunking
  86 INSTANCE: clumps abstract-clumps
  87
  88 : <clumps> ( seq n -- clumps )
  89     clumps new-groups ; inline
  90
  91 TUPLE: sliced-clumps < chunking-seq ;
  92 INSTANCE: sliced-clumps slice-chunking
  93 INSTANCE: sliced-clumps abstract-clumps
  94
  95 : <sliced-clumps> ( seq n -- clumps )
  96     sliced-clumps new-groups ; inline
  97
  98 : group ( seq n -- array ) <groups> { } like ;
  99
 100 : clump ( seq n -- array ) <clumps> { } like ;
 101
 102 : monotonic? ( seq quot: ( elt1 elt2 -- ? ) -- ? )
 103     over length 2 < [ 2drop t ] [
 104         over length 2 = [
 105             [ first2-unsafe ] dip call
 106         ] [
 107             [ 2 <sliced-clumps> ] dip
 108             '[ first2-unsafe @ ] all?
 109         ] if
 110     ] if ; inline
 111
 112 : all-equal? ( seq -- ? ) [ = ] monotonic? ;
 113
 114 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
 115
 116 TUPLE: circular-slice { from read-only } { to read-only } { seq read-only } ;
 117
 118 INSTANCE: circular-slice virtual-sequence
 119
 120 M: circular-slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
 121
 122 M: circular-slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
 123
 124 M: circular-slice length [ to>> ] [ from>> ] bi - ; inline
 125
 126 M: circular-slice virtual-exemplar seq>> ; inline
 127
 128 M: circular-slice virtual@
 129     [ from>> + ] [ seq>> ] bi [ length slice-mod ] keep ; inline
 130
 131 C: <circular-slice> circular-slice
 132
 133 TUPLE: sliced-circular-clumps < chunking-seq ;
 134 INSTANCE: sliced-circular-clumps sequence
 135
 136 M: sliced-circular-clumps length
 137     seq>> length ; inline
 138
 139 M: sliced-circular-clumps nth
 140     [ n>> over + ] [ seq>> ] bi <circular-slice> ; inline
 141
 142 : <sliced-circular-clumps> ( seq n -- clumps )
 143     check-circular-clumps sliced-circular-clumps boa ; inline
 144
 145 TUPLE: circular-clumps < chunking-seq ;
 146 INSTANCE: circular-clumps sequence
 147
 148 M: circular-clumps length
 149     seq>> length ; inline
 150
 151 M: circular-clumps nth
 152     [ n>> over + ] [ seq>> ] bi [ <circular-slice> ] [ like ] bi ; inline
 153
 154 : <circular-clumps> ( seq n -- clumps )
 155     check-circular-clumps circular-clumps boa ; inline
 156
 157 : circular-clump ( seq n -- array )
 158     <circular-clumps> { } like ; inline