basis/lcs/lcs.factor

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