1 USING: sequences kernel math locals math.order math.ranges
\r
2 accessors arrays namespaces combinators combinators.short-circuit ;
\r
6 : levenshtein-step ( insert delete change same? -- next )
\r
7 0 1 ? + >r [ 1+ ] bi@ r> min min ;
\r
9 : lcs-step ( insert delete change same? -- next )
\r
10 1 -1./0. ? + max max ; ! -1./0. is -inf (float)
\r
12 :: loop-step ( i j matrix old new step -- )
\r
13 i j 1+ matrix nth nth ! insertion
\r
14 i 1+ j matrix nth nth ! deletion
\r
15 i j matrix nth nth ! replace/retain
\r
16 i old nth j new nth = ! same?
\r
18 i 1+ j 1+ matrix nth set-nth ; inline
\r
20 : lcs-initialize ( |str1| |str2| -- matrix )
\r
21 [ drop 0 <array> ] with map ;
\r
23 : levenshtein-initialize ( |str1| |str2| -- matrix )
\r
24 [ [ + ] curry map ] with map ;
\r
26 :: run-lcs ( old new init step -- matrix )
\r
27 [let | matrix [ old length 1+ new length 1+ init call ] |
\r
30 [| j | i j matrix old new step loop-step ] each
\r
31 ] each matrix ] ; inline
\r
34 : levenshtein ( old new -- n )
\r
35 [ levenshtein-initialize ] [ levenshtein-step ]
\r
38 TUPLE: retain item ;
\r
39 TUPLE: delete item ;
\r
40 TUPLE: insert item ;
\r
43 TUPLE: trace-state old new table i j ;
\r
45 : old-nth ( state -- elt )
\r
46 [ i>> 1- ] [ old>> ] bi nth ;
\r
48 : new-nth ( state -- elt )
\r
49 [ j>> 1- ] [ new>> ] bi nth ;
\r
51 : top-beats-side? ( state -- ? )
\r
52 [ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ]
\r
53 [ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ;
\r
55 : retained? ( state -- ? )
\r
57 [ i>> 0 > ] [ j>> 0 > ]
\r
58 [ [ old-nth ] [ new-nth ] bi = ]
\r
61 : do-retain ( state -- state )
\r
62 dup old-nth retain boa ,
\r
63 [ 1- ] change-i [ 1- ] change-j ;
\r
65 : inserted? ( state -- ? )
\r
68 [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]
\r
71 : do-insert ( state -- state )
\r
72 dup new-nth insert boa , [ 1- ] change-j ;
\r
74 : deleted? ( state -- ? )
\r
77 [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]
\r
80 : do-delete ( state -- state )
\r
81 dup old-nth delete boa , [ 1- ] change-i ;
\r
83 : (trace-diff) ( state -- )
\r
85 { [ dup retained? ] [ do-retain (trace-diff) ] }
\r
86 { [ dup inserted? ] [ do-insert (trace-diff) ] }
\r
87 { [ dup deleted? ] [ do-delete (trace-diff) ] }
\r
91 : trace-diff ( old new table -- diff )
\r
92 [ ] [ first length 1- ] [ length 1- ] tri trace-state boa
\r
93 [ (trace-diff) ] { } make reverse ;
\r
96 : diff ( old new -- diff )
\r
97 2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;
\r
99 : lcs ( seq1 seq2 -- lcs )
\r
100 [ diff [ retain? ] filter ] keep [ item>> ] swap map-as ;
\r