From e82fb3b6dc3729fbe920b77c9e0ac42a9c760232 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Mon, 5 May 2008 19:52:56 -0500
Subject: [PATCH 1/6] Coalesce function for interval maps

---
 .../interval-maps/interval-maps-tests.factor  |  5 +++++
 extra/interval-maps/interval-maps.factor      | 21 ++++++++++++++++---
 2 files changed, 23 insertions(+), 3 deletions(-)

diff --git a/extra/interval-maps/interval-maps-tests.factor b/extra/interval-maps/interval-maps-tests.factor
index 54d2e9d26b..5a4b508939 100755
--- a/extra/interval-maps/interval-maps-tests.factor
+++ b/extra/interval-maps/interval-maps-tests.factor
@@ -11,3 +11,8 @@ SYMBOL: test
 [ 2 ] [ 1 test get interval-at ] unit-test
 [ f ] [ 2 test get interval-at ] unit-test
 [ f ] [ 0 test get interval-at ] unit-test
+
+[ { { { 1 4 } 3 } { { 4 8 } 6 } } <interval-map> ] must-fail
+
+[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ]
+[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test
diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor
index bc23d0d346..84d762a232 100755
--- a/extra/interval-maps/interval-maps.factor
+++ b/extra/interval-maps/interval-maps.factor
@@ -1,5 +1,5 @@
 USING: kernel sequences arrays math.intervals accessors
-math.order sorting math assocs  ;
+math.order sorting math assocs locals namespaces ;
 IN: interval-maps
 
 TUPLE: interval-map array ;
@@ -24,6 +24,8 @@ M: interval >interval ;
 : ensure-disjoint ( intervals -- intervals )
     dup keys [ interval-intersect not ] monotonic?
     [ "Intervals are not disjoint" throw ] unless ;
+
+
 PRIVATE>
 
 : interval-at* ( key map -- value ? )
@@ -35,7 +37,20 @@ PRIVATE>
 : interval-key? ( key map -- ? ) interval-at* nip ;
 
 : <interval-map> ( specification -- map )
-    all-intervals ensure-disjoint
-    [ [ first to>> ] compare ] sort
+    all-intervals { } assoc-like
+    [ [ first to>> ] compare ] sort ensure-disjoint
     [ interval-node boa ] { } assoc>map
     interval-map boa ;
+
+:: coalesce ( assoc -- specification )
+    ! Only works with integer keys, because they're discrete
+    ! Makes 2array keys
+    [
+        assoc sort-keys unclip first2 dupd roll
+        [| oldkey oldval key val | ! Underneath is start
+            oldkey 1+ key =
+            oldval val = and
+            [ oldkey 2array oldval 2array , key ] unless
+            key val
+        ] assoc-each [ 2array ] bi@ ,
+    ] { } make ;

From e3808cc50355c1dc68fbeae257bf786f9ea1b430 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Mon, 5 May 2008 23:46:51 -0500
Subject: [PATCH 2/6] Coalescing in interval maps

---
 extra/interval-maps/interval-maps.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor
index 84d762a232..7dcb9466cc 100755
--- a/extra/interval-maps/interval-maps.factor
+++ b/extra/interval-maps/interval-maps.factor
@@ -42,11 +42,11 @@ PRIVATE>
     [ interval-node boa ] { } assoc>map
     interval-map boa ;
 
-:: coalesce ( assoc -- specification )
+:: coalesce ( alist -- specification )
     ! Only works with integer keys, because they're discrete
     ! Makes 2array keys
     [
-        assoc sort-keys unclip first2 dupd roll
+        alist sort-keys unclip first2 dupd roll
         [| oldkey oldval key val | ! Underneath is start
             oldkey 1+ key =
             oldval val = and

From d5f63983c39ace23bddbc931386e6c725de1dca6 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Mon, 5 May 2008 23:47:22 -0500
Subject: [PATCH 3/6] Unicode script uses interval maps

---
 extra/unicode/script/script.factor | 46 +++++++++++++-----------------
 1 file changed, 20 insertions(+), 26 deletions(-)

diff --git a/extra/unicode/script/script.factor b/extra/unicode/script/script.factor
index 14fba46c4d..d0bb4ac30d 100755
--- a/extra/unicode/script/script.factor
+++ b/extra/unicode/script/script.factor
@@ -1,12 +1,12 @@
 USING: unicode.syntax.backend kernel sequences assocs io.files
 io.encodings ascii math.ranges io splitting math.parser 
 namespaces byte-arrays locals math sets io.encodings.ascii
-words compiler.units ;
+words compiler.units arrays interval-maps ;
 IN: unicode.script
 
 <PRIVATE
-VALUE: char>num-table
-VALUE: num>name-table
+VALUE: script-table
+SYMBOL: interned
 
 : parse-script ( stream -- assoc )
     ! assoc is code point/range => name
@@ -14,26 +14,18 @@ VALUE: num>name-table
         ";" split1 [ [ blank? ] trim ] bi@
     ] H{ } map>assoc ;
 
-: set-if ( value var -- )
-    dup 500000 < [ set ] [ 2drop ] if ;
+: range, ( value key -- )
+    swap interned get
+    [ word-name = ] with find nip 2array , ;
 
-: expand-ranges ( assoc -- char-assoc )
-    ! char-assoc is code point => name
-    [ [
-        CHAR: . pick member? [
-            swap ".." split1 [ hex> ] bi@ [a,b]
-            [ set-if ] with each
-        ] [ swap hex> set-if ] if
-    ] assoc-each ] H{ } make-assoc ;
-
-: hash>byte-array ( hash -- byte-array )
-    [ keys supremum 1+ <byte-array> dup ] keep
-    [ -rot set-nth ] with assoc-each ;
-
-: make-char>num ( assoc -- char>num-table )
-    expand-ranges
-    [ num>name-table index ] assoc-map
-    hash>byte-array ;
+: expand-ranges ( assoc -- interval-map )
+    [
+        [
+            CHAR: . pick member? [
+                swap ".." split1 [ hex> ] bi@ 2array
+            ] [ swap hex> ] if range,
+        ] assoc-each
+    ] { } make <interval-map> ;
 
 : >symbols ( strings -- symbols )
     [
@@ -41,9 +33,9 @@ VALUE: num>name-table
     ] with-compilation-unit ;
 
 : process-script ( ranges -- )
-    [ values prune \ num>name-table set-value ]
-    [ make-char>num \ char>num-table set-value ] bi
-    num>name-table >symbols \ num>name-table set-value ;
+    dup values prune >symbols interned [
+        expand-ranges \ script-table set-value
+    ] with-variable ;
 
 : load-script ( -- )
     "resource:extra/unicode/script/Scripts.txt"
@@ -52,5 +44,7 @@ VALUE: num>name-table
 load-script
 PRIVATE>
 
+SYMBOL: Unknown
+
 : script-of ( char -- script )
-    char>num-table nth num>name-table nth ;
+    script-table interval-at [ Unknown ] unless* ;

From 70ea40681e0b5172caf09bbdaf3bbe2e46462538 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Tue, 6 May 2008 03:46:44 -0500
Subject: [PATCH 4/6] extra/lcs replaces extra/levenshtein... not fully
 debugged

---
 extra/lcs/authors.txt                         |  1 +
 extra/lcs/lcs-docs.factor                     |  6 ++
 .../lcs-tests.factor}                         |  9 +-
 extra/lcs/lcs.factor                          | 94 +++++++++++++++++++
 extra/lcs/summary.txt                         |  1 +
 extra/lcs/tags.txt                            |  1 +
 extra/levenshtein/authors.txt                 |  1 -
 extra/levenshtein/levenshtein.factor          | 47 ----------
 extra/levenshtein/summary.txt                 |  1 -
 9 files changed, 110 insertions(+), 51 deletions(-)
 create mode 100755 extra/lcs/authors.txt
 create mode 100755 extra/lcs/lcs-docs.factor
 rename extra/{levenshtein/levenshtein-tests.factor => lcs/lcs-tests.factor} (55%)
 mode change 100644 => 100755
 create mode 100755 extra/lcs/lcs.factor
 create mode 100755 extra/lcs/summary.txt
 create mode 100755 extra/lcs/tags.txt
 delete mode 100644 extra/levenshtein/authors.txt
 delete mode 100644 extra/levenshtein/levenshtein.factor
 delete mode 100644 extra/levenshtein/summary.txt

diff --git a/extra/lcs/authors.txt b/extra/lcs/authors.txt
new file mode 100755
index 0000000000..504363d316
--- /dev/null
+++ b/extra/lcs/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/extra/lcs/lcs-docs.factor b/extra/lcs/lcs-docs.factor
new file mode 100755
index 0000000000..6c5e2ae992
--- /dev/null
+++ b/extra/lcs/lcs-docs.factor
@@ -0,0 +1,6 @@
+USING: help.syntax help.markup ;
+IN: lcs
+
+HELP: levenshtein
+{ $values { "old" "a sequence" } { "new" "a sequence" } { "n" "the Levenshtein distance" } }
+{ $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ;
diff --git a/extra/levenshtein/levenshtein-tests.factor b/extra/lcs/lcs-tests.factor
old mode 100644
new mode 100755
similarity index 55%
rename from extra/levenshtein/levenshtein-tests.factor
rename to extra/lcs/lcs-tests.factor
index 722ccb86ca..45297c1bff
--- a/extra/levenshtein/levenshtein-tests.factor
+++ b/extra/lcs/lcs-tests.factor
@@ -1,9 +1,14 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: levenshtein.tests
-USING: tools.test levenshtein ;
+USING: tools.test lcs ;
 
 [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
 [ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
 [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
 [ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
+
+[ "hell" ] [ "hello" "hell" lcs ] unit-test
+[ "hell" ] [ "hell" "hello" lcs ] unit-test
+[ "ell" ] [ "ell" "hell" lcs ] unit-test
+[ "ell" ] [ "hell" "ell" lcs ] unit-test
+[ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor
new file mode 100755
index 0000000000..b1584af78b
--- /dev/null
+++ b/extra/lcs/lcs.factor
@@ -0,0 +1,94 @@
+USING: sequences kernel math locals math.order math.ranges
+accessors combinators.lib arrays namespaces combinators ;
+IN: lcs
+
+! Classic dynamic programming O(n^2) algorithm for the
+! Longest Common Subsequence
+! Slight modification to get Levenshtein distance
+
+! j is row, i is column
+! Going from str1 to str2
+! str1 along side column, str2 along top row
+
+:: lcs-step ( i j matrix old new change-cost -- )
+    i j matrix nth nth
+        i old nth j new nth = 0 change-cost ? +
+    i j 1+ matrix nth nth 1+ ! insertion cost
+    i 1+ j matrix nth nth 1+ ! deletion cost
+    min min
+    i 1+ j 1+ matrix nth set-nth ;
+
+: lcs-initialize ( |str1| |str2| -- matrix )
+    [ drop 0 <array> ] with map ;
+
+: levenshtein-initialize ( |str1| |str2| -- matrix )
+    [ [ + ] curry map ] with map ;
+
+:: run-lcs ( old new quot change-cost -- matrix )
+    [let | matrix [ old length 1+ new length 1+ quot call ] |
+        old length [0,b) [| i |
+            new length [0,b)
+            [| j | i j matrix old new change-cost lcs-step ]
+            each
+        ] each matrix ] ;
+
+: levenshtein ( old new -- n )
+    [ levenshtein-initialize ] 1 run-lcs peek peek ;
+
+TUPLE: retain item ;
+TUPLE: delete item ;
+TUPLE: insert item ;
+
+TUPLE: trace-state old new table i j ;
+
+: old-nth ( state -- elt )
+    [ i>> 1- ] [ old>> ] bi nth ;
+
+: new-nth ( state -- elt )
+    [ j>> 1- ] [ new>> ] bi nth ;
+
+: top-beats-side? ( state -- ? )
+    [ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ]
+    [ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ;
+
+: retained? ( state -- ? )
+    {
+        [ i>> 0 > ] [ j>> 0 > ]
+        [ [ old-nth ] [ new-nth ] bi = ]
+    } <-&& ;
+
+: do-retain ( state -- state )
+    dup old-nth retain boa ,
+    [ 1- ] change-i [ 1- ] change-j ;
+
+: inserted? ( state -- ? )
+    [ j>> 0 > ]
+    [ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;
+
+: do-insert ( state -- state )
+    dup new-nth insert boa , [ 1- ] change-j ;
+
+: deleted? ( state -- ? )
+    [ i>> 0 > ]
+    [ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;
+
+: 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 ;
+
+: diff ( old new -- diff )
+    2dup [ lcs-initialize ] 2 run-lcs trace-diff ;
+
+: lcs ( str1 str2 -- lcs )
+    [ diff [ retain? ] filter ] keep [ item>> ] swap map-as ;
diff --git a/extra/lcs/summary.txt b/extra/lcs/summary.txt
new file mode 100755
index 0000000000..9e70fd7e63
--- /dev/null
+++ b/extra/lcs/summary.txt
@@ -0,0 +1 @@
+Levenshtein distance and diff between sequences
diff --git a/extra/lcs/tags.txt b/extra/lcs/tags.txt
new file mode 100755
index 0000000000..4d914f4c46
--- /dev/null
+++ b/extra/lcs/tags.txt
@@ -0,0 +1 @@
+algorithms
diff --git a/extra/levenshtein/authors.txt b/extra/levenshtein/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/extra/levenshtein/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/extra/levenshtein/levenshtein.factor b/extra/levenshtein/levenshtein.factor
deleted file mode 100644
index 07731bfb84..0000000000
--- a/extra/levenshtein/levenshtein.factor
+++ /dev/null
@@ -1,47 +0,0 @@
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help io kernel math namespaces sequences
-math.order ;
-IN: levenshtein
-
-: <matrix> ( m n -- matrix )
-    [ drop 0 <array> ] with map ; inline
-
-: matrix-> nth nth ; inline
-: ->matrix nth set-nth ; inline
-
-SYMBOL: d
-
-: ->d ( n i j -- ) d get ->matrix ; inline
-: d-> ( i j -- n ) d get matrix-> ; inline
-
-SYMBOL: costs
-
-: init-d ( str1 str2 -- )
-    [ length 1+ ] bi@ 2dup <matrix> d set
-    [ 0 over ->d ] each
-    [ dup 0 ->d ] each ; inline
-
-: compute-costs ( str1 str2 -- )
-    swap [
-        [ = 0 1 ? ] with { } map-as
-    ] curry { } map-as costs set ; inline
-
-: levenshtein-step ( i j -- )
-    [ 1+ d-> 1+ ] 2keep
-    [ >r 1+ r> d-> 1+ ] 2keep
-    [ d-> ] 2keep
-    [ costs get matrix-> + min min ] 2keep
-    >r 1+ r> 1+ ->d ; inline
-
-: levenshtein-result ( -- n ) d get peek peek ; inline
-
-: levenshtein ( str1 str2 -- n )
-    [
-        2dup init-d
-        2dup compute-costs
-        [ length ] bi@ [
-            [ levenshtein-step ] curry each
-        ] with each
-        levenshtein-result
-    ] with-scope ;
diff --git a/extra/levenshtein/summary.txt b/extra/levenshtein/summary.txt
deleted file mode 100644
index 583669a8b0..0000000000
--- a/extra/levenshtein/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Levenshtein edit distance algorithm

From 32d032e8fcc3cec47b0d6d224feccbb2cd050cd1 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Tue, 6 May 2008 03:47:39 -0500
Subject: [PATCH 5/6] lcs update

---
 extra/lcs/lcs-tests.factor | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/extra/lcs/lcs-tests.factor b/extra/lcs/lcs-tests.factor
index 45297c1bff..c3f1e61342 100755
--- a/extra/lcs/lcs-tests.factor
+++ b/extra/lcs/lcs-tests.factor
@@ -7,8 +7,8 @@ USING: tools.test lcs ;
 [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
 [ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
 
-[ "hell" ] [ "hello" "hell" lcs ] unit-test
-[ "hell" ] [ "hell" "hello" lcs ] unit-test
+! [ "hell" ] [ "hello" "hell" lcs ] unit-test
+! [ "hell" ] [ "hell" "hello" lcs ] unit-test
 [ "ell" ] [ "ell" "hell" lcs ] unit-test
 [ "ell" ] [ "hell" "ell" lcs ] unit-test
-[ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
+! [ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test

From d1545ac9297b058832b74ad63085a503677e337f Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Tue, 6 May 2008 15:51:34 -0500
Subject: [PATCH 6/6] LCS docs, bug fixes

---
 extra/lcs/lcs-docs.factor  | 29 +++++++++++++++++++++++++
 extra/lcs/lcs-tests.factor | 17 ++++++++++++---
 extra/lcs/lcs.factor       | 43 ++++++++++++++++++++------------------
 3 files changed, 66 insertions(+), 23 deletions(-)

diff --git a/extra/lcs/lcs-docs.factor b/extra/lcs/lcs-docs.factor
index 6c5e2ae992..49e46c7641 100755
--- a/extra/lcs/lcs-docs.factor
+++ b/extra/lcs/lcs-docs.factor
@@ -4,3 +4,32 @@ IN: lcs
 HELP: levenshtein
 { $values { "old" "a sequence" } { "new" "a sequence" } { "n" "the Levenshtein distance" } }
 { $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ;
+
+HELP: lcs
+{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "lcs" "a longest common subsequence" } }
+{ $description "Given two sequences, calculates a longest common subsequence between them. Note two things: this is only one of the many possible LCSs, and the LCS may not be contiguous." } ;
+
+HELP: diff
+{ $values { "old" "a sequence" } { "new" "a sequence" } { "diff" "an edit script" } }
+{ $description "Given two sequences, find a minimal edit script from the old to the new. There may be more than one minimal edit script, and this chooses one arbitrarily. This script is in the form of an array of the tuples of the classes " { $link retain } ", " { $link delete } " and " { $link insert } " which have their information stored in the 'item' slot." } ;
+
+HELP: retain
+{ $class-description "Represents an action in an edit script where an item is kept, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is retained" } ;
+
+HELP: delete
+{ $class-description "Represents an action in an edit script where an item is deleted, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is deleted" } ;
+
+HELP: insert
+{ $class-description "Represents an action in an edit script where an item is added, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is inserted" } ;
+
+ARTICLE: "lcs" "LCS, Diffing and Distance"
+"This vocabulary provides words for three apparently unrelated but in fact very similar problems: finding a longest common subsequence between two sequences, getting a minimal edit script (diff) between two sequences, and calculating the Levenshtein distance between two sequences. The implementations of these algorithms are very closely related, and all running times are O(nm), where n and m are the lengths of the input sequences."
+{ $subsection lcs }
+{ $subsection diff }
+{ $subsection levenshtein }
+"The " { $link diff } " word returns a sequence of tuples of the following classes. They all hold their contents in the 'item' slot."
+{ $subsection insert }
+{ $subsection delete }
+{ $subsection retain } ;
+
+ABOUT: "lcs"
diff --git a/extra/lcs/lcs-tests.factor b/extra/lcs/lcs-tests.factor
index c3f1e61342..3aa10a0687 100755
--- a/extra/lcs/lcs-tests.factor
+++ b/extra/lcs/lcs-tests.factor
@@ -7,8 +7,19 @@ USING: tools.test lcs ;
 [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
 [ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
 
-! [ "hell" ] [ "hello" "hell" lcs ] unit-test
-! [ "hell" ] [ "hell" "hello" lcs ] unit-test
+[ "hell" ] [ "hello" "hell" lcs ] unit-test
+[ "hell" ] [ "hell" "hello" lcs ] unit-test
 [ "ell" ] [ "ell" "hell" lcs ] unit-test
 [ "ell" ] [ "hell" "ell" lcs ] unit-test
-! [ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
+[ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
+
+[ {
+        T{ delete f CHAR: f }
+        T{ retain f CHAR: a }
+        T{ delete f CHAR: x }
+        T{ retain f CHAR: b }
+        T{ delete f CHAR: c }
+        T{ retain f CHAR: d }
+        T{ insert f CHAR: e }
+        T{ insert f CHAR: f }
+} ] [ "faxbcd" "abdef" diff ] unit-test
diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor
index b1584af78b..cdebfc4325 100755
--- a/extra/lcs/lcs.factor
+++ b/extra/lcs/lcs.factor
@@ -2,21 +2,20 @@ USING: sequences kernel math locals math.order math.ranges
 accessors combinators.lib arrays namespaces combinators ;
 IN: lcs
 
-! Classic dynamic programming O(n^2) algorithm for the
-! Longest Common Subsequence
-! Slight modification to get Levenshtein distance
+<PRIVATE
+: levenshtein-step ( insert delete change same? -- next )
+    0 1 ? + >r [ 1+ ] bi@ r> min min ;
 
-! j is row, i is column
-! Going from str1 to str2
-! str1 along side column, str2 along top row
+: lcs-step ( insert delete change same? -- next )
+    1 -9999 ? + max max ; ! Replace -9999 with -inf when added
 
-:: lcs-step ( i j matrix old new change-cost -- )
-    i j matrix nth nth
-        i old nth j new nth = 0 change-cost ? +
-    i j 1+ matrix nth nth 1+ ! insertion cost
-    i 1+ j matrix nth nth 1+ ! deletion cost
-    min min
-    i 1+ j 1+ matrix nth set-nth ;
+:: loop-step ( i j matrix old new step -- )
+    i j 1+ matrix nth nth ! insertion
+    i 1+ j matrix nth nth ! deletion
+    i j matrix nth nth ! replace/retain
+    i old nth j new nth = ! same?
+    step call
+    i 1+ j 1+ matrix nth set-nth ; inline
 
 : lcs-initialize ( |str1| |str2| -- matrix )
     [ drop 0 <array> ] with map ;
@@ -24,21 +23,24 @@ IN: lcs
 : levenshtein-initialize ( |str1| |str2| -- matrix )
     [ [ + ] curry map ] with map ;
 
-:: run-lcs ( old new quot change-cost -- matrix )
-    [let | matrix [ old length 1+ new length 1+ quot call ] |
+:: run-lcs ( old new init step -- matrix )
+    [let | matrix [ old length 1+ new length 1+ init call ] |
         old length [0,b) [| i |
             new length [0,b)
-            [| j | i j matrix old new change-cost lcs-step ]
+            [| j | i j matrix old new step loop-step ]
             each
-        ] each matrix ] ;
+        ] each matrix ] ; inline
+PRIVATE>
 
 : levenshtein ( old new -- n )
-    [ levenshtein-initialize ] 1 run-lcs peek peek ;
+    [ levenshtein-initialize ] [ levenshtein-step ]
+    run-lcs peek peek ;
 
 TUPLE: retain item ;
 TUPLE: delete item ;
 TUPLE: insert item ;
 
+<PRIVATE
 TUPLE: trace-state old new table i j ;
 
 : old-nth ( state -- elt )
@@ -86,9 +88,10 @@ TUPLE: trace-state old new table i j ;
 : trace-diff ( old new table -- diff )
     [ ] [ first length 1- ] [ length 1- ] tri trace-state boa
     [ (trace-diff) ] { } make reverse ;
+PRIVATE>
 
 : diff ( old new -- diff )
-    2dup [ lcs-initialize ] 2 run-lcs trace-diff ;
+    2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;
 
-: lcs ( str1 str2 -- lcs )
+: lcs ( seq1 seq2 -- lcs )
     [ diff [ retain? ] filter ] keep [ item>> ] swap map-as ;