basis/grouping/grouping.factor

   1 ! Copyright (C) 2005, 2009 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 fry ;
   5 IN: grouping
   6
   7 <PRIVATE
   8
   9 TUPLE: chunking-seq { seq read-only } { n read-only } ;
  10
  11 : check-groups ( n -- n )
  12     dup 0 <= [ "Invalid group count" throw ] when ; inline
  13
  14 : new-groups ( seq n class -- groups )
  15     [ check-groups ] dip boa ; inline
  16
  17 GENERIC: group@ ( n groups -- from to seq )
  18
  19 M: chunking-seq set-nth group@ <slice> 0 swap copy ;
  20
  21 M: chunking-seq like drop { } like ;
  22
  23 INSTANCE: chunking-seq sequence
  24
  25 MIXIN: subseq-chunking
  26
  27 M: subseq-chunking nth group@ subseq ;
  28
  29 MIXIN: slice-chunking
  30
  31 M: slice-chunking nth group@ <slice> ;
  32
  33 M: slice-chunking nth-unsafe group@ slice boa ;
  34
  35 TUPLE: abstract-groups < chunking-seq ;
  36
  37 M: abstract-groups length
  38     [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ;
  39
  40 M: abstract-groups set-length
  41     [ n>> * ] [ seq>> ] bi set-length ;
  42
  43 M: abstract-groups group@
  44     [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
  45
  46 TUPLE: abstract-clumps < chunking-seq ;
  47
  48 M: abstract-clumps length
  49     [ seq>> length ] [ n>> ] bi - 1 + ;
  50
  51 M: abstract-clumps set-length
  52     [ n>> + 1 - ] [ seq>> ] bi set-length ;
  53
  54 M: abstract-clumps group@
  55     [ n>> over + ] [ seq>> ] bi ;
  56
  57 PRIVATE>
  58
  59 TUPLE: groups < abstract-groups ;
  60
  61 : <groups> ( seq n -- groups )
  62     groups new-groups ; inline
  63
  64 INSTANCE: groups subseq-chunking
  65
  66 TUPLE: sliced-groups < abstract-groups ;
  67
  68 : <sliced-groups> ( seq n -- groups )
  69     sliced-groups new-groups ; inline
  70
  71 INSTANCE: sliced-groups slice-chunking
  72
  73 TUPLE: clumps < abstract-clumps ;
  74
  75 : <clumps> ( seq n -- clumps )
  76     clumps new-groups ; inline
  77
  78 INSTANCE: clumps subseq-chunking
  79
  80 TUPLE: sliced-clumps < abstract-clumps ;
  81
  82 : <sliced-clumps> ( seq n -- clumps )
  83     sliced-clumps new-groups ; inline
  84
  85 INSTANCE: sliced-clumps slice-chunking
  86
  87 : group ( seq n -- array ) <groups> { } like ;
  88
  89 : clump ( seq n -- array ) <clumps> { } like ;
  90
  91 : monotonic? ( seq quot -- ? )
  92     over length 2 < [ 2drop t ] [
  93         over length 2 = [
  94             [ first2-unsafe ] dip call
  95         ] [
  96             [ 2 <sliced-clumps> ] dip
  97             '[ first2-unsafe @ ] all?
  98         ] if
  99     ] if ; inline
 100
 101 : all-equal? ( seq -- ? ) [ = ] monotonic? ;
 102
 103 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;