-USING: accessors arrays combinators combinators.short-circuit\r
-kernel locals make math math.order sequences sequences.private\r
-typed ;\r
-IN: lcs\r
-\r
-<PRIVATE\r
-\r
-: levenshtein-step ( insert delete change same? -- next )\r
- [ [ 1 + ] bi@ ] 2dip [ 1 + ] unless min min ;\r
-\r
-: lcs-step ( insert delete change same? -- next )\r
- 1 -1/0. ? + max max ; ! -1/0. is -inf (float)\r
-\r
-TYPED:: loop-step ( i j matrix: array old new step -- )\r
- i j 1 + matrix nth-unsafe nth-unsafe ! insertion\r
- i 1 + j matrix nth-unsafe nth-unsafe ! deletion\r
- i j matrix nth-unsafe nth-unsafe ! replace/retain\r
- i old nth-unsafe j new nth-unsafe = ! same?\r
- step call\r
- i 1 + j 1 + matrix nth-unsafe set-nth-unsafe ; inline\r
-\r
-: lcs-initialize ( |str1| |str2| -- matrix )\r
- iota [ drop 0 <array> ] with map ;\r
-\r
-: levenshtein-initialize ( |str1| |str2| -- matrix )\r
- [ iota ] bi@ [ [ + ] curry map ] with map ;\r
-\r
-:: run-lcs ( old new init step -- matrix )\r
- old length 1 + new length 1 + init call :> matrix\r
- old length iota [| i |\r
- new length iota [| j |\r
- i j matrix old new step loop-step\r
- ] each\r
- ] each matrix ; inline\r
-\r
-PRIVATE>\r
-\r
-: levenshtein ( old new -- n )\r
- [ levenshtein-initialize ] [ levenshtein-step ]\r
- run-lcs last last ;\r
-\r
-TUPLE: retain item ;\r
-TUPLE: delete item ;\r
-TUPLE: insert item ;\r
-\r
-<PRIVATE\r
-\r
-TUPLE: trace-state old new table i j ;\r
-\r
-: old-nth ( state -- elt )\r
- [ i>> 1 - ] [ old>> ] bi nth-unsafe ;\r
-\r
-: new-nth ( state -- elt )\r
- [ j>> 1 - ] [ new>> ] bi nth-unsafe ;\r
-\r
-: top-beats-side? ( state -- ? )\r
- [ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth-unsafe nth-unsafe ]\r
- [ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth-unsafe nth-unsafe ] bi > ;\r
-\r
-: retained? ( state -- ? )\r
- {\r
- [ i>> 0 > ] [ j>> 0 > ]\r
- [ [ old-nth ] [ new-nth ] bi = ]\r
- } 1&& ;\r
-\r
-: do-retain ( state -- state )\r
- dup old-nth retain boa ,\r
- [ 1 - ] change-i [ 1 - ] change-j ;\r
-\r
-: inserted? ( state -- ? )\r
- {\r
- [ j>> 0 > ]\r
- [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]\r
- } 1&& ;\r
-\r
-: do-insert ( state -- state )\r
- dup new-nth insert boa , [ 1 - ] change-j ;\r
-\r
-: deleted? ( state -- ? )\r
- {\r
- [ i>> 0 > ]\r
- [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]\r
- } 1&& ;\r
-\r
-: do-delete ( state -- state )\r
- dup old-nth delete boa , [ 1 - ] change-i ;\r
-\r
-: (trace-diff) ( state -- )\r
- {\r
- { [ dup retained? ] [ do-retain (trace-diff) ] }\r
- { [ dup inserted? ] [ do-insert (trace-diff) ] }\r
- { [ dup deleted? ] [ do-delete (trace-diff) ] }\r
- [ drop ] ! i=j=0\r
- } cond ;\r
-\r
-: trace-diff ( old new table -- diff )\r
- [ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa\r
- [ (trace-diff) ] { } make reverse! ;\r
-\r
-PRIVATE>\r
-\r
-: lcs-diff ( old new -- diff )\r
- 2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;\r
-\r
-: lcs ( seq1 seq2 -- lcs )\r
- [ lcs-diff [ retain? ] filter ] keep [ item>> ] swap map-as ;\r
+USING: accessors arrays combinators combinators.short-circuit
+kernel locals make math math.order sequences sequences.private
+typed ;
+IN: lcs
+
+<PRIVATE
+
+: levenshtein-step ( insert delete change same? -- next )
+ [ [ 1 + ] bi@ ] 2dip [ 1 + ] unless min min ;
+
+: lcs-step ( insert delete change same? -- next )
+ 1 -1/0. ? + max max ; ! -1/0. is -inf (float)
+
+TYPED:: loop-step ( i j matrix: array old new step -- )
+ 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?
+ step call
+ i 1 + j 1 + matrix nth-unsafe set-nth-unsafe ; inline
+
+: lcs-initialize ( |str1| |str2| -- matrix )
+ iota [ drop 0 <array> ] with map ;
+
+: levenshtein-initialize ( |str1| |str2| -- matrix )
+ [ iota ] bi@ [ [ + ] curry map ] with map ;
+
+:: run-lcs ( old new init step -- matrix )
+ old length 1 + new length 1 + init call :> matrix
+ old length iota [| i |
+ new length iota [| j |
+ i j matrix old new step loop-step
+ ] each
+ ] each matrix ; inline
+
+PRIVATE>
+
+: levenshtein ( old new -- n )
+ [ levenshtein-initialize ] [ levenshtein-step ]
+ run-lcs last last ;
+
+TUPLE: retain item ;
+TUPLE: delete item ;
+TUPLE: insert item ;
+
+<PRIVATE
+
+TUPLE: trace-state old new table i j ;
+
+: old-nth ( state -- elt )
+ [ i>> 1 - ] [ old>> ] bi nth-unsafe ;
+
+: new-nth ( state -- elt )
+ [ j>> 1 - ] [ new>> ] bi nth-unsafe ;
+
+: top-beats-side? ( state -- ? )
+ [ [ 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 = ]
+ } 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
+ [ (trace-diff) ] { } make reverse! ;
+
+PRIVATE>
+
+: lcs-diff ( old new -- diff )
+ 2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;
+
+: lcs ( seq1 seq2 -- lcs )
+ [ lcs-diff [ retain? ] filter ] keep [ item>> ] swap map-as ;
projects / factor.git / blobdiff