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 ERROR: groups-error seq group-size ;
   8 <PRIVATE
   9
  10 MIXIN: chunking
  11 INSTANCE: chunking sequence
  12
  13 GENERIC: group@ ( n groups -- from to seq )
  14
  15 M: chunking set-nth group@ <slice> 0 swap copy ;
  16 M: chunking like drop { } like ; inline
  17
  18 MIXIN: subseq-chunking
  19 INSTANCE: subseq-chunking chunking
  20 INSTANCE: subseq-chunking sequence
  21
  22 M: subseq-chunking nth group@ subseq ; inline
  23
  24 MIXIN: slice-chunking
  25 INSTANCE: slice-chunking chunking
  26 INSTANCE: slice-chunking sequence
  27
  28 M: slice-chunking nth group@ <slice> ; inline
  29 M: slice-chunking nth-unsafe group@ <slice-unsafe> ; inline
  30
  31 MIXIN: abstract-groups
  32 INSTANCE: abstract-groups sequence
  33
  34 M: abstract-groups length
  35     [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline
  36
  37 M: abstract-groups set-length
  38     [ n>> * ] [ seq>> ] bi set-length ; inline
  39
  40 M: abstract-groups group@
  41     [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline
  42
  43 MIXIN: abstract-clumps
  44 INSTANCE: abstract-clumps sequence
  45
  46 M: abstract-clumps length
  47     dup seq>> length [ drop 0 ] [
  48         swap [ 1 + ] [ n>> ] bi* [-]
  49     ] if-zero ; inline
  50
  51 M: abstract-clumps set-length
  52     [ n>> + 1 - ] [ seq>> ] bi set-length ; inline
  53
  54 M: abstract-clumps group@
  55     [ n>> over + ] [ seq>> ] bi ; inline
  56
  57 TUPLE: chunking-seq { seq read-only } { n read-only } ;
  58
  59 : check-groups ( seq n -- seq n )
  60     dup 0 <= [ throw-groups-error ] when ; inline
  61
  62 : new-groups ( seq n class -- groups )
  63     [ check-groups ] dip boa ; inline
  64
  65 PRIVATE>
  66
  67 TUPLE: groups < chunking-seq ;
  68 INSTANCE: groups slice-chunking
  69 INSTANCE: groups abstract-groups
  70
  71 : <groups> ( seq n -- groups )
  72     groups new-groups ; inline
  73
  74 TUPLE: clumps < chunking-seq ;
  75 INSTANCE: clumps slice-chunking
  76 INSTANCE: clumps abstract-clumps
  77
  78 : <clumps> ( seq n -- clumps )
  79     clumps new-groups ; inline
  80
  81 <PRIVATE
  82
  83 : map-like ( seq n quot -- seq )
  84     2keep drop '[ _ like ] map ; inline
  85
  86 PRIVATE>
  87
  88 : group ( seq n -- array ) [ <groups> ] map-like ; inline
  89
  90 : clump ( seq n -- array ) [ <clumps> ] map-like ; inline
  91
  92 : monotonic? ( seq quot: ( elt1 elt2 -- ? ) -- ? )
  93     over length dup 2 < [ 3drop t ] [
  94         2 = [
  95             [ first2-unsafe ] dip call
  96         ] [
  97             [ [ first-unsafe 1 ] [ ((each)) ] bi ] dip
  98             '[ @ _ keep swap ] (all-integers?) nip
  99         ] if
 100     ] if ; inline
 101
 102 : all-equal? ( seq -- ? ) [ = ] monotonic? ;
 103
 104 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
 105
 106 TUPLE: circular-slice
 107     { from integer read-only }
 108     { to integer read-only }
 109     { seq read-only } ;
 110
 111 INSTANCE: circular-slice virtual-sequence
 112
 113 M: circular-slice equal? over circular-slice? [ sequence= ] [ 2drop f ] if ;
 114
 115 M: circular-slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
 116
 117 M: circular-slice length [ to>> ] [ from>> ] bi - ; inline
 118
 119 M: circular-slice virtual-exemplar seq>> ; inline
 120
 121 M: circular-slice virtual@
 122     [ from>> + ] [ seq>> ] bi [ length rem ] keep ; inline
 123
 124 C: <circular-slice> circular-slice
 125
 126 TUPLE: circular-clumps < chunking-seq ;
 127 INSTANCE: circular-clumps sequence
 128
 129 M: circular-clumps length
 130     seq>> length ; inline
 131
 132 M: circular-clumps nth
 133     [ n>> over + ] [ seq>> ] bi <circular-slice> ; inline
 134
 135 : <circular-clumps> ( seq n -- clumps )
 136     circular-clumps new-groups ; inline
 137
 138 : circular-clump ( seq n -- array )
 139     [ <circular-clumps> ] map-like ; inline