basis/splitting/monotonic/monotonic.factor

   1 ! Copyright (C) 2008, 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: make namespaces sequences kernel fry arrays compiler.utilities
   4 math accessors circular grouping combinators sorting math.order ;
   5 IN: splitting.monotonic
   6
   7 <PRIVATE
   8
   9 : ,, ( obj -- ) building get last push ;
  10 : v, ( -- ) V{ } clone , ;
  11 : ,v ( -- ) building get dup last empty? [ dup pop* ] when drop ;
  12
  13 : (monotonic-split) ( seq quot -- newseq )
  14     [
  15         [ dup unclip suffix ] dip
  16         v, '[ over ,, @ [ v, ] unless ] 2each ,v
  17     ] { } make ; inline
  18
  19 PRIVATE>
  20
  21 : monotonic-split ( seq quot -- newseq )
  22     over empty? [ 2drop { } ] [ (monotonic-split) ] if ; inline
  23
  24 <PRIVATE
  25
  26 : (monotonic-slice) ( seq quot class -- slices )
  27     [
  28         dupd '[
  29             [ length ] [ ] [ <circular> 1 over change-circular-start ] tri
  30             [ @ not [ , ] [ drop ] if ] 3each
  31         ] { } make
  32         dup empty? [ over length 1 - prefix ] when -1 prefix 2 clump
  33         swap
  34     ] dip
  35     '[ first2 [ 1 + ] bi@ _ _ boa ] map ; inline
  36
  37 PRIVATE>
  38
  39 : monotonic-slice ( seq quot class -- slices )
  40     pick length {
  41         { 0 [ 2drop ] }
  42         { 1 [ nip [ 0 1 rot ] dip boa 1array ] }
  43         [ drop (monotonic-slice) ]
  44     } case ; inline
  45
  46 TUPLE: downward-slice < slice ;
  47 TUPLE: stable-slice < slice ;
  48 TUPLE: upward-slice < slice ;
  49
  50 : downward-slices ( seq -- slices )
  51     [ > ] downward-slice monotonic-slice [ length 1 > ] filter ;
  52
  53 : stable-slices ( seq -- slices )
  54     [ = ] stable-slice monotonic-slice [ length 1 > ] filter ;
  55
  56 : upward-slices ( seq -- slices )
  57     [ < ] upward-slice monotonic-slice [ length 1 > ] filter ;
  58
  59 : trends ( seq -- slices )
  60     dup length {
  61         { 0 [ ] }
  62         { 1 [ [ 0 1 ] dip stable-slice boa ] }
  63         [
  64             drop
  65             [ downward-slices ]
  66             [ stable-slices ]
  67             [ upward-slices ] tri 3append [ from>> ] sort-with
  68         ]
  69     } case ;