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