myers.ml

type ('a, 'b) machine =
   | Continue of 'a
   | Done of 'b

module Kind :
sig

  type 'a t =
    | Eq  of 'a
    | Del of 'a
    | Ins of 'a

  val map     : ('a -> 'b) -> 'a t -> 'b t
  val extract : 'a t -> 'a
  val replace : 'a t -> 'b -> 'b t
  val same : 'a t -> 'b t -> bool

end = struct

  type 'a t =
    | Eq  of 'a
    | Del of 'a
    | Ins of 'a

  let extract = function
      Eq x | Del x | Ins x -> x
                                               
  let map f = function
    | Eq x  -> Eq  (f x)
    | Del x -> Del (f x)
    | Ins x -> Ins (f x)

  let replace kind value =
    map (fun _ -> value) kind

  let same a b = match (a, b) with
    | Eq _, Eq _ | Del _, Del _ | Ins _, Ins _ -> true
    | _ -> false

end
    
let first_of = function
  | i, _, _, _ -> i

let rec reverse = function
  | [], acc -> acc
             
  | elem :: rest, result :: acc when Kind.same elem result ->
     let elt = Kind.extract elem in
     let step = Kind.map (fun xs -> elt :: xs) result in
     reverse (rest, step :: acc)

  | rest, Kind.(Eq a :: Ins b :: Eq oth :: acc) when a = b ->
     let ins = Kind.Ins a in
     let eq = Kind.Eq (b @ oth) in
     reverse (rest, ins :: eq :: acc)
     
  | kind :: rest, acc ->
     reverse (rest, (Kind.map (fun x -> [x]) kind) :: acc)

let move_down = function
  | y, elem :: rest, l2, xs -> (y + 1, rest, l2, (Kind.Del elem) :: xs)
  | y, [], l2, edits -> (succ y, [], l2, edits)

let move_right = function
  | y, l1, elem :: rest, xs -> (y, l1, rest, (Kind.Ins elem) :: xs)
  | y, l1, [], xs -> (y, l1, [], xs)

let proceed_path = function
  | 0, 0, [path] -> (path, []) 
  | d, l, ((path :: _) as paths) when d = -l -> (move_down path, paths)
  | d, l, [path] when d = l -> (move_right path, [])
  | _, _, p1 :: p2 :: rest ->
     if (first_of p1) > (first_of p2)
     then (move_right p1, p2 :: rest)
     else (move_down p2, p2 :: rest)
  | _ -> failwith "impossible"

let rec snake = function
  | y, elem :: rest1, b :: rest2, edits when elem = b ->
     snake (y + 1, rest1, rest2, Kind.(Eq elem) :: edits)
  | _, [], [], edits -> Done edits
  | path -> Continue path
  
     
let rec diagonals d limit paths next_paths =
  if d > limit then Continue (List.rev next_paths)
  else
    let (path, rest) = proceed_path(d, limit, paths) in
    match snake path with
    | Continue path -> diagonals (d + 2) limit rest (path :: next_paths)
    | Done edits -> Done edits

let rec find envelope max paths =
  match diagonals (-envelope) envelope paths [] with
  | Done edits -> reverse (edits, [])
  | Continue paths -> find (succ envelope) max paths

let diff first second =
  let path = (0, first, second, []) in
  let len = List.((length first) + (length second)) in
  find 0 len [path]

let string_of_chars chars = 
  let buf = Buffer.create 16 in
  List.iter (Buffer.add_char buf) chars;
  Buffer.contents buf
  
let str_diff str_a str_b =
  let a = String.to_seq str_a |> List.of_seq in
  let b = String.to_seq str_b |> List.of_seq in
  diff a b
  |> List.map (Kind.map string_of_chars)