basis/splitting/monotonic/monotonic.factor

   1 ! Copyright (C) 2008, 2009 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays fry kernel locals math namespaces
   4 sequences sequences.private sorting ;
   5 IN: splitting.monotonic
   6
   7 <PRIVATE
   8
   9 :: monotonic-split-impl ( seq quot slice-quot n -- pieces )
  10     V{ } clone :> accum
  11
  12     0 0 seq [ ] [
  13         [ 1 + ] 2dip [
  14             quot call [
  15                 [ seq slice-quot call accum push ] keep dup
  16             ] unless
  17         ] keep
  18     ] map-reduce drop
  19
  20     n = [ drop ] [ n seq slice-quot call accum push ] if
  21
  22     accum { } like ; inline
  23
  24 : (monotonic-split) ( seq quot slice-quot -- pieces )
  25     pick length [ 3drop { } ] [ monotonic-split-impl ] if-zero ; inline
  26
  27 PRIVATE>
  28
  29 : monotonic-split ( seq quot: ( obj1 obj2 -- ? ) -- pieces )
  30     [ subseq-unsafe ] (monotonic-split) ; inline
  31
  32 : monotonic-split-slice ( seq quot: ( obj1 obj2 -- ? ) -- pieces )
  33     [ <slice-unsafe> ] (monotonic-split) ; inline
  34
  35 TUPLE: downward-slice < slice ;
  36 TUPLE: stable-slice < slice ;
  37 TUPLE: upward-slice < slice ;
  38
  39 : downward-slices ( seq -- slices )
  40     [ > ] [ downward-slice boa ] (monotonic-split)
  41     [ length 1 > ] filter ;
  42
  43 : stable-slices ( seq -- slices )
  44     [ = ] [ stable-slice boa ] (monotonic-split)
  45     [ length 1 > ] filter ;
  46
  47 : upward-slices ( seq -- slices )
  48     [ < ] [ upward-slice boa ] (monotonic-split)
  49     [ length 1 > ] filter ;
  50
  51 : trends ( seq -- slices )
  52     dup length dup 1 > [
  53         drop
  54         [ downward-slices ]
  55         [ stable-slices ]
  56         [ upward-slices ] tri 3append [ from>> ] sort-with
  57     ] [
  58         zero? [ drop { } ] [ [ 0 1 ] dip stable-slice boa ] if
  59     ] if ;