basis/lcs/lcs.factor

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