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

Minor refactoring in lcs and interval-maps

db4
Daniel Ehrenberg 2008-05-09 15:42:02 -05:00
parent c04da7bdfb
commit 1005e5e939
2 changed files with 14 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
extra/interval-maps/interval-maps.factor
View File

@ -1,4 +1,4 @@
USING: kernel sequences arrays accessors USING: kernel sequences arrays accessors tuple-arrays
math.order sorting math assocs locals namespaces ; math.order sorting math assocs locals namespaces ;
IN: interval-maps IN: interval-maps
@ -6,7 +6,6 @@ TUPLE: interval-map array ;
<PRIVATE <PRIVATE
TUPLE: interval-node from to value ; TUPLE: interval-node from to value ;
: range ( node -- from to ) [ from>> ] [ to>> ] bi ;
: fixup-value ( value ? -- value/f ? ) : fixup-value ( value ? -- value/f ? )
[ drop f f ] unless* ; [ drop f f ] unless* ;
@ -14,12 +13,12 @@ TUPLE: interval-node from to value ;
: find-interval ( key interval-map -- i ) : find-interval ( key interval-map -- i )
[ from>> <=> ] binsearch ; [ from>> <=> ] binsearch ;
GENERIC: >interval ( object -- 2array ) : interval-contains? ( object interval-node -- ? )
M: number >interval dup 2array ; [ from>> ] [ to>> ] bi between? ;
M: sequence >interval ;
: all-intervals ( sequence -- intervals ) : all-intervals ( sequence -- intervals )
[ >r >interval r> ] assoc-map ; [ >r dup number? [ dup 2array ] when r> ] assoc-map
{ } assoc-like ;
: disjoint? ( node1 node2 -- ? ) : disjoint? ( node1 node2 -- ? )
[ to>> ] [ from>> ] bi* < ; [ to>> ] [ from>> ] bi* < ;
@ -28,8 +27,8 @@ M: sequence >interval ;
dup [ disjoint? ] monotonic? dup [ disjoint? ] monotonic?
[ "Intervals are not disjoint" throw ] unless ; [ "Intervals are not disjoint" throw ] unless ;
: interval-contains? ( object interval-node -- ? ) : >intervals ( specification -- intervals )
range between? ; [ >r first2 r> interval-node boa ] { } assoc>map ;
PRIVATE> PRIVATE>
: interval-at* ( key map -- value ? ) : interval-at* ( key map -- value ? )
@ -41,10 +40,9 @@ PRIVATE>
: interval-key? ( key map -- ? ) interval-at* nip ; : interval-key? ( key map -- ? ) interval-at* nip ;
: <interval-map> ( specification -- map ) : <interval-map> ( specification -- map )
all-intervals { } assoc-like all-intervals [ [ first second ] compare ] sort
[ [ first second ] compare ] sort >intervals ensure-disjoint >tuple-array
[ >r first2 r> interval-node boa ] { } assoc>map interval-map boa ;
ensure-disjoint interval-map boa ;
:: coalesce ( alist -- specification ) :: coalesce ( alist -- specification )
! Only works with integer keys, because they're discrete ! Only works with integer keys, because they're discrete

9
extra/lcs/lcs.factor
View File

@ -7,7 +7,7 @@ IN: lcs
0 1 ? + >r [ 1+ ] bi@ r> min min ; 0 1 ? + >r [ 1+ ] bi@ r> min min ;
: lcs-step ( insert delete change same? -- next ) : lcs-step ( insert delete change same? -- next )
1 -9999 ? + max max ; ! Replace -9999 with -inf when added 1 -1./0. ? + max max ; ! -1./0. is -inf (float)
:: loop-step ( i j matrix old new step -- ) :: loop-step ( i j matrix old new step -- )
i j 1+ matrix nth nth ! insertion i j 1+ matrix nth nth ! insertion
@ -25,10 +25,9 @@ IN: lcs
:: run-lcs ( old new init step -- matrix ) :: run-lcs ( old new init step -- matrix )
[let | matrix [ old length 1+ new length 1+ init call ] | [let | matrix [ old length 1+ new length 1+ init call ] |
old length [0,b) [| i | old length [| i |
new length [0,b) new length
[| j | i j matrix old new step loop-step ] [| j | i j matrix old new step loop-step ] each
each
] each matrix ] ; inline ] each matrix ] ; inline
PRIVATE> PRIVATE>