basis/lcs/lcs.factor

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