\ Levenshtein's Edit Distance                                    uho 2009-10-04
\
\ This program defines the word
\ 
\          LEVENSHTEIN ( c-addr1 len1 c-addr2 len2 -- u )
\ 
\ which calculates the edit distance u of the two given strings.
\
\ This is an ANS Forth Program with environmental dependencies
\
\    - Requiring ] [ THEN SWAP ROT R@ R> LOOP LITERAL J IMMEDIATE
\        IF I ELSE DUP DROP DOES> DO CREATE CR CHARS CELLS CELL+ C@
\        @ >R = ; : 2DUP 2DROP 1- 1+ . - , + * ! S" (
\      from the Core word set.
\   - Requiring MARKER .( \ from the Core Extensions word set.
\   - Requiring THROW from the Exception word set.
\   - Requiring S" ( from the File Access word set.
\   - Requiring FREE ALLOCATE from the Memory-Allocation word set.
\   - Requiring [THEN] [IF] [ELSE] from the Programming-Tools Extensions word
\     set.
\
\ Required program documentation
\   - Environmental dependencies
\     * This program has no known environmental dependencies.
\     * Using lower case for standard definition names.
\
\   - Other program documentation
\     * After loading this program, a Standard System still exists.

: Matrix ( -- )
     Create 0 ( 'buffer ) , 0 ( rowsize ) , 0 ( colsize ) ,
   Does> ( -- a-addr ) ;
   
: >buffer ( 'matrix -- ''buffer ) ; immediate
: >rowsize ( 'matrix -- 'rowsize ) cell+ ;
: >colsize ( 'matrix -- 'colsize ) [ 2 cells ] Literal + ;

: [][] ( row col 'matrix -- a-addr ) >r
    r@ >colsize @ *
    swap + cells
    r> >buffer @ + ;
     
: allocate-matrix ( colsize rowsize 'matrix -- )
    >r dup >r cells  swap  dup >r
    * cells allocate throw
    r> ( rowsize )
    r> ( colsize ) r@ >colsize !
                   r@ >rowsize !
    r> >buffer ! ;

: free-matrix ( 'matrix -- )
    dup >r >buffer @ free throw
    r@ >buffer off
    r@ >rowsize off
    r> >colsize off ;

: last-element ( 'matrix -- a-addr )
   dup >r >colsize @ 1-  r@ >rowsize @ 1- r> [][] ;

: init-col0 ( 'matrix -- )
    dup >rowsize @ 0 
    DO  dup   0 I rot [][]   I swap !  LOOP
    drop ;

: init-row0 ( 'matrix -- )
    dup >colsize @ 0
    DO  dup   I 0 rot [][]   I swap !  LOOP
    drop ;

Matrix dist

: edit-distance ( c-addr1 c-addr2 -- )
    dist init-col0
    dist init-row0 
    dist >colsize @ 1
    DO
       dist >rowsize @ 1
       DO ( c-addr1 c-addr2 )
          2dup I 1- chars + c@
          swap J 1- chars + c@  = IF 0 ELSE 1 THEN
          J 1- I 1- dist [][] @ +
          J    I 1- dist [][] @ 1+ umin
          J 1- I    dist [][] @ 1+ umin
          J I dist [][] !
       LOOP
    LOOP
    2drop ;

: levenshtein ( c-addr1 len1 c-addr2 len2 -- u )
   1+ rot 1+ dist allocate-matrix
   edit-distance
   dist last-element @
   dist free-matrix ;

Marker *Test*

: Tor s" Tor" ;
: Tier s" Tier" ;
Tier Tor levenshtein dup 2 -

*Test*
[IF] 
  . .( Levenshtein test failed!) abort
[ELSE]
  drop .( Levenshtein) cr
[THEN]