steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

splitting.monotonic: cleanup, a little faster.

db4
John Benediktsson 2012-07-14 15:22:34 -07:00
parent 6dc49d6014
commit 1ea580d911
1 changed files with 15 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
basis/splitting/monotonic/monotonic.factor
View File

@ -20,21 +20,21 @@ IN: splitting.monotonic
PRIVATE> PRIVATE>
: monotonic-split ( seq quot: ( obj1 obj2 -- ? ) -- newseq ) : monotonic-split ( seq quot: ( obj1 obj2 -- ? ) -- newseq )
over empty? [ 2drop { } ] [ (monotonic-split) ] if ; inline [ drop { } ] [ (monotonic-split) ] if-empty ; inline
<PRIVATE <PRIVATE
: (monotonic-slice) ( seq quot class -- slices ) : (monotonic-slice) ( seq quot class -- slices )
[ [
dupd '[ dupd '[
[ length iota ] [ ] [ <circular> 1 over change-circular-start ] tri [ length iota ] [ ] [ 1 circular boa ] tri
[ @ not [ 1 + , ] [ drop ] if ] 3each [ @ not [ 1 + , ] [ drop ] if ] 3each
] { } make ] { } make
2dup { 2dup {
[ nip empty? ] [ nip empty? ]
[ [ length ] [ last ] bi* = not ] [ [ length ] [ last ] bi* = not ]
} 2|| [ over length suffix ] when } 2|| [ over length suffix ] when
0 prefix 2 clump 0 prefix 2 <clumps>
swap swap
] dip ] dip
'[ first2 _ _ boa ] map ; inline '[ first2 _ _ boa ] map ; inline
@ -42,11 +42,10 @@ PRIVATE>
PRIVATE> PRIVATE>
: monotonic-slice ( seq quot: ( obj1 obj2 -- ? ) class -- slices ) : monotonic-slice ( seq quot: ( obj1 obj2 -- ? ) class -- slices )
pick length { pick length dup 1 >
{ 0 [ 2drop ] } [ drop (monotonic-slice) ]
{ 1 [ nip [ 0 1 rot ] dip boa 1array ] } [ zero? [ 2drop ] [ nip [ 0 1 ] 2dip boa 1array ] if ]
[ drop (monotonic-slice) ] if ; inline
} case ; inline
TUPLE: downward-slice < slice ; TUPLE: downward-slice < slice ;
TUPLE: stable-slice < slice ; TUPLE: stable-slice < slice ;
@ -62,13 +61,11 @@ TUPLE: upward-slice < slice ;
[ < ] upward-slice monotonic-slice [ length 1 > ] filter ; [ < ] upward-slice monotonic-slice [ length 1 > ] filter ;
: trends ( seq -- slices ) : trends ( seq -- slices )
dup length { dup length dup 1 > [
{ 0 [ ] } drop
{ 1 [ [ 0 1 ] dip stable-slice boa ] } [ downward-slices ]
[ [ stable-slices ]
drop [ upward-slices ] tri 3append [ from>> ] sort-with
[ downward-slices ] ] [
[ stable-slices ] zero? [ ] [ [ 0 1 ] dip stable-slice boa ] if
[ upward-slices ] tri 3append [ from>> ] sort-with ] if ;
]
} case ;