basis/lcs/lcs.factor

   1 USING: accessors arrays combinators combinators.short-circuit
   2 kernel make math math.order sequences sequences.private typed ;
   3 IN: lcs
   4
   5 <PRIVATE
   6
   7 : levenshtein-step ( insert delete change same? -- next )
   8     [ [ 1 + ] bi@ ] 2dip [ 1 + ] unless min min ;
   9
  10 : lcs-step ( insert delete change same? -- next )
  11     1 -1/0. ? + max max ; ! -1/0. is -inf (float)
  12
  13 TYPED:: loop-step ( i j matrix: array old new step -- )
  14     i j 1 + matrix nth-unsafe nth-unsafe ! insertion
  15     i 1 + j matrix nth-unsafe nth-unsafe ! deletion
  16     i j matrix nth-unsafe nth-unsafe ! replace/retain
  17     i old nth-unsafe j new nth-unsafe = ! same?
  18     step call
  19     i 1 + j 1 + matrix nth-unsafe set-nth-unsafe ; inline
  20
  21 : lcs-initialize ( |str1| |str2| -- matrix )
  22     <iota> [ drop 0 <array> ] with map ;
  23
  24 : levenshtein-initialize ( |str1| |str2| -- matrix )
  25     [ <iota> ] bi@ [ [ + ] curry map ] with map ;
  26
  27 :: run-lcs ( old new init step -- matrix )
  28     old length 1 + new length 1 + init call :> matrix
  29     old length <iota> [| i |
  30         new length <iota> [| j |
  31             i j matrix old new step loop-step
  32         ] each
  33     ] each matrix ; inline
  34
  35 PRIVATE>
  36
  37 : levenshtein ( old new -- n )
  38     [ levenshtein-initialize ] [ levenshtein-step ]
  39     run-lcs last last ;
  40
  41 TUPLE: retain item ;
  42 TUPLE: delete item ;
  43 TUPLE: insert item ;
  44
  45 <PRIVATE
  46
  47 TUPLE: trace-state old new table i j ;
  48
  49 : old-nth ( state -- elt )
  50     [ i>> 1 - ] [ old>> ] bi nth-unsafe ;
  51
  52 : new-nth ( state -- elt )
  53     [ j>> 1 - ] [ new>> ] bi nth-unsafe ;
  54
  55 : top-beats-side? ( state -- ? )
  56     [ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth-unsafe nth-unsafe ]
  57     [ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth-unsafe nth-unsafe ] bi > ;
  58
  59 : retained? ( state -- ? )
  60     {
  61         [ i>> 0 > ] [ j>> 0 > ]
  62         [ [ old-nth ] [ new-nth ] bi = ]
  63     } 1&& ;
  64
  65 : do-retain ( state -- state )
  66     dup old-nth retain boa ,
  67     [ 1 - ] change-i [ 1 - ] change-j ;
  68
  69 : inserted? ( state -- ? )
  70     {
  71         [ j>> 0 > ]
  72         [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]
  73     } 1&& ;
  74
  75 : do-insert ( state -- state )
  76     dup new-nth insert boa , [ 1 - ] change-j ;
  77
  78 : deleted? ( state -- ? )
  79     {
  80         [ i>> 0 > ]
  81         [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]
  82     } 1&& ;
  83
  84 : do-delete ( state -- state )
  85     dup old-nth delete boa , [ 1 - ] change-i ;
  86
  87 : (trace-diff) ( state -- )
  88     {
  89         { [ dup retained? ] [ do-retain (trace-diff) ] }
  90         { [ dup inserted? ] [ do-insert (trace-diff) ] }
  91         { [ dup deleted? ] [ do-delete (trace-diff) ] }
  92         [ drop ] ! i=j=0
  93     } cond ;
  94
  95 : trace-diff ( old new table -- diff )
  96     [ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa
  97     [ (trace-diff) ] { } make reverse! ;
  98
  99 PRIVATE>
 100
 101 : lcs-diff ( old new -- diff )
 102     2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;
 103
 104 : lcs ( seq1 seq2 -- lcs )
 105     [ lcs-diff [ retain? ] filter ] keep [ item>> ] swap map-as ;