factor/basis/lcs/lcs.factor

107 lines
2.9 KiB
Factor
Raw Normal View History

2013-03-21 20:55:09 -04:00
USING: accessors arrays combinators combinators.short-circuit
2013-03-22 00:16:34 -04:00
kernel locals make math math.order sequences sequences.private
typed ;
IN: lcs
2008-05-06 16:51:34 -04:00
<PRIVATE
2013-03-21 20:55:09 -04:00
2008-05-06 16:51:34 -04:00
: levenshtein-step ( insert delete change same? -- next )
2013-03-21 20:55:09 -04:00
[ [ 1 + ] bi@ ] 2dip [ 1 + ] unless min min ;
2008-05-06 16:51:34 -04:00
: lcs-step ( insert delete change same? -- next )
2009-04-14 16:04:58 -04:00
1 -1/0. ? + max max ; ! -1/0. is -inf (float)
2008-05-06 16:51:34 -04:00
2013-03-22 00:16:34 -04:00
TYPED:: loop-step ( i j matrix: array old new step -- )
2013-03-21 20:55:09 -04:00
i j 1 + matrix nth-unsafe nth-unsafe ! insertion
i 1 + j matrix nth-unsafe nth-unsafe ! deletion
i j matrix nth-unsafe nth-unsafe ! replace/retain
i old nth-unsafe j new nth-unsafe = ! same?
2008-05-06 16:51:34 -04:00
step call
2013-03-21 20:55:09 -04:00
i 1 + j 1 + matrix nth-unsafe set-nth-unsafe ; inline
: lcs-initialize ( |str1| |str2| -- matrix )
2010-01-14 10:10:13 -05:00
iota [ drop 0 <array> ] with map ;
: levenshtein-initialize ( |str1| |str2| -- matrix )
2010-01-14 10:10:13 -05:00
[ iota ] bi@ [ [ + ] curry map ] with map ;
2008-05-06 16:51:34 -04:00
:: run-lcs ( old new init step -- matrix )
2009-10-27 22:50:31 -04:00
old length 1 + new length 1 + init call :> matrix
2010-01-14 10:10:13 -05:00
old length iota [| i |
2013-03-21 20:55:09 -04:00
new length iota [| j |
i j matrix old new step loop-step
] each
2009-10-27 22:50:31 -04:00
] each matrix ; inline
2013-03-21 20:55:09 -04:00
2008-05-06 16:51:34 -04:00
PRIVATE>
: levenshtein ( old new -- n )
2008-05-06 16:51:34 -04:00
[ levenshtein-initialize ] [ levenshtein-step ]
run-lcs last last ;
TUPLE: retain item ;
TUPLE: delete item ;
TUPLE: insert item ;
2008-05-06 16:51:34 -04:00
<PRIVATE
2013-03-21 20:55:09 -04:00
TUPLE: trace-state old new table i j ;
: old-nth ( state -- elt )
2013-03-21 20:55:09 -04:00
[ i>> 1 - ] [ old>> ] bi nth-unsafe ;
: new-nth ( state -- elt )
2013-03-21 20:55:09 -04:00
[ j>> 1 - ] [ new>> ] bi nth-unsafe ;
: top-beats-side? ( state -- ? )
2013-03-21 20:55:09 -04:00
[ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth-unsafe nth-unsafe ]
[ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth-unsafe nth-unsafe ] bi > ;
: retained? ( state -- ? )
{
[ i>> 0 > ] [ j>> 0 > ]
[ [ old-nth ] [ new-nth ] bi = ]
2008-06-10 21:42:55 -04:00
} 1&& ;
: do-retain ( state -- state )
dup old-nth retain boa ,
[ 1 - ] change-i [ 1 - ] change-j ;
: inserted? ( state -- ? )
{
[ j>> 0 > ]
[ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]
} 1&& ;
: do-insert ( state -- state )
dup new-nth insert boa , [ 1 - ] change-j ;
: deleted? ( state -- ? )
{
[ i>> 0 > ]
[ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]
} 1&& ;
: do-delete ( state -- state )
dup old-nth delete boa , [ 1 - ] change-i ;
: (trace-diff) ( state -- )
{
{ [ dup retained? ] [ do-retain (trace-diff) ] }
{ [ dup inserted? ] [ do-insert (trace-diff) ] }
{ [ dup deleted? ] [ do-delete (trace-diff) ] }
[ drop ] ! i=j=0
} cond ;
: trace-diff ( old new table -- diff )
[ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa
2013-03-21 20:55:09 -04:00
[ (trace-diff) ] { } make reverse! ;
2008-05-06 16:51:34 -04:00
PRIVATE>
: diff ( old new -- diff )
2008-05-06 16:51:34 -04:00
2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;
2008-05-06 16:51:34 -04:00
: lcs ( seq1 seq2 -- lcs )
[ diff [ retain? ] filter ] keep [ item>> ] swap map-as ;