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

sequences.extras: faster longest-subseq, cleanup other words.

db4
John Benediktsson 2012-04-25 16:30:08 -07:00
parent a976e31f39
commit 40e79d4b56
1 changed files with 19 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
extra/sequences/extras/extras.factor
View File

@ -1,12 +1,11 @@
USING: arrays grouping kernel locals math math.order math.ranges USING: arrays grouping kernel locals math math.order math.ranges
sequences splitting ; sequences sequences.private splitting ;
IN: sequences.extras IN: sequences.extras
: reduce1 ( seq quot -- result ) [ unclip ] dip reduce ; inline : reduce1 ( seq quot -- result ) [ unclip ] dip reduce ; inline
:: reduce-r :: reduce-r ( list identity quot: ( obj1 obj2 -- obj ) -- result )
( list identity quot: ( obj1 obj2 -- obj ) -- result )
list empty? list empty?
[ identity ] [ identity ]
[ list rest identity quot reduce-r list first quot call ] if ; [ list rest identity quot reduce-r list first quot call ] if ;
@ -17,11 +16,16 @@ IN: sequences.extras
[ id ] [ id ]
[ unclip id swap quot call( prev elt -- next ) quot reduce* ] if-empty ; inline recursive [ unclip id swap quot call( prev elt -- next ) quot reduce* ] if-empty ; inline recursive
:: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ; :: combos ( list1 list2 -- result )
: find-all ( seq quot -- elts ) [ [ length iota ] keep ] dip list2 [ [ 2array ] curry list1 swap map ] map concat ;
[ dupd call( a -- ? ) [ 2array ] [ 2drop f ] if ] curry 2map [ ] filter ; inline
: insert-sorted ( elt seq -- seq ) 2dup [ < ] with find drop over length or swap insert-nth ; : find-all ( seq quot -- elts )
[ [ length iota ] keep ] dip
[ dupd call( a -- ? ) [ 2array ] [ 2drop f ] if ] curry
2map [ ] filter ; inline
: insert-sorted ( elt seq -- seq )
2dup [ < ] with find drop over length or swap insert-nth ;
: max-by ( obj1 obj2 quot: ( obj -- n ) -- obj1/obj2 ) : max-by ( obj1 obj2 quot: ( obj -- n ) -- obj1/obj2 )
[ bi@ [ max ] keep eq? not ] curry most ; inline [ bi@ [ max ] keep eq? not ] curry most ; inline
@ -39,9 +43,10 @@ IN: sequences.extras
dup length [1,b] [ <clumps> ] with map concat ; dup length [1,b] [ <clumps> ] with map concat ;
:: each-subseq ( ... seq quot: ( ... x -- ... ) -- ... ) :: each-subseq ( ... seq quot: ( ... x -- ... ) -- ... )
seq length [0,b] [ seq length :> len
len [0,b] [
:> from :> from
from seq length (a,b] [ from len (a,b] [
:> to :> to
from to seq subseq quot call( x -- ) from to seq subseq quot call( x -- )
] each ] each
@ -55,12 +60,12 @@ IN: sequences.extras
len1 1 + [ len2 1 + 0 <array> ] replicate :> table len1 1 + [ len2 1 + 0 <array> ] replicate :> table
len1 [1,b] [| x | len1 [1,b] [| x |
len2 [1,b] [| y | len2 [1,b] [| y |
x 1 - seq1 nth x 1 - seq1 nth-unsafe
y 1 - seq2 nth = [ y 1 - seq2 nth-unsafe = [
y 1 - x 1 - table nth nth 1 + :> len y 1 - x 1 - table nth-unsafe nth-unsafe 1 + :> len
len y x table nth set-nth len y x table nth-unsafe set-nth-unsafe
len n > [ len n! x end! ] when len n > [ len n! x end! ] when
] [ 0 y x table nth set-nth ] if ] [ 0 y x table nth-unsafe set-nth-unsafe ] if
] each ] each
] each end n - end seq1 subseq ; ] each end n - end seq1 subseq ;