basis/lcs/lcs.factor

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