undo.ml

let hd list = List.nth_opt list 0

let (>>) f g x = g (f x)

let unoption = function
  | None -> assert false
  | Some a -> a


module Zipper = struct
  module List = struct
    type 'a t = {left: 'a list; right: 'a list}

    let append left right = {left=List.rev left; right}
    let empty = {left=[]; right=[]}

    module Left = struct
      let peek t = hd t.left
      let insert t item = {t with left=item :: t.left}

      module All = struct
        let clear t = {t with left=[]}
      end
    end

    module Right = struct
      let peek t = hd t.right
      let insert t item = {t with right=item :: t.right}

      module All = struct
        let clear t = {t with right=[]}
      end
    end

    module Non_empty = struct
      type 'a t = {left: 'a list; focus: 'a; right: 'a list}
      let create left focus right = {left=List.rev left; focus; right}
      let singleton focus = {left=[]; focus; right=[]}

      module Focus = struct
        let peek t = t.focus
        let replace t replacement = {t with focus=replacement}
      end

      module Left = struct
        let peek t = hd t.left
        let insert t item = {t with left=item :: t.left}
        let push t item = {left=t.focus :: t.left; focus=item; right=t.right}
        let move t = match t.left with
          | [] -> None
          | head :: tail ->
              Some {left=tail; focus=head; right=t.focus :: t.right}

        module All = struct
          let clear t = {t with left=[]}
        end
      end

      module Right = struct
        let peek t = hd t.right
        let insert t item = {t with right=item :: t.right}
        let push t item = {t with focus=item; right=t.focus :: t.right}
        let move t = match t.right with
          | [] -> None
          | head :: tail ->
              Some {left=t.focus :: t.left; focus=head; right=tail}

        module All = struct
          let clear t = {t with right=[]}
        end
      end
    end
  end
end


let (=>) left right = print_char (if left = right then '.' else 'F')
module Test_zipper_list = struct
  let module Z = Zipper.List in
  Z.empty => Z.append [] [];

  Z.Left.peek (Z.append [1; 2] [3; 4]) => Some 2;
  Z.Left.peek (Z.append [] [3; 4]) => None;
  Z.Left.insert (Z.append [1; 2] [3; 4]) 9 => Z.append [1; 2; 9] [3; 4];
  Z.Left.All.clear (Z.append [1; 2] [3; 4]) => Z.append [] [3; 4];

  Z.Right.peek (Z.append [1; 2] [3; 4]) => Some 3;
  Z.Right.peek (Z.append [1; 2] []) => None;
  Z.Right.insert (Z.append [1; 2] [3; 4]) 9 => Z.append [1; 2] [9; 3; 4];
  Z.Right.All.clear (Z.append [1; 2] [3; 4]) => Z.append [1; 2] [];
end

module Test_zipper_list_non_empty = struct
  let module Z = Zipper.List.Non_empty in
  Z.singleton 1 => Z.create [] 1 [];
  Z.Focus.peek (Z.create [1; 2] 3 [4; 5]) => 3;
  Z.Focus.replace (Z.create [1; 2] 3 [4; 5]) 9 => Z.create [1; 2] 9 [4; 5];

  Z.Left.peek (Z.create [1; 2] 3 [4; 5]) => Some 2;
  Z.Left.peek (Z.create [] 3 [4; 5]) => None;
  Z.Left.insert (Z.create [1; 2] 3 [4; 5]) 9 => Z.create [1; 2; 9] 3 [4; 5];
  Z.Left.push (Z.create [1; 2] 3 [4; 5]) 9 => Z.create [1; 2; 3] 9 [4; 5];
  Z.Left.move (Z.create [1; 2] 3 [4; 5]) => Some (Z.create [1] 2 [3; 4; 5]);
  Z.Left.move (Z.create [] 3 [4; 5]) => None;
  Z.Left.All.clear (Z.create [1; 2] 3 [4; 5]) => Z.create [] 3 [4; 5];

  Z.Right.peek (Z.create [1; 2] 3 [4; 5]) => Some 4;
  Z.Right.peek (Z.create [1; 2] 3 []) => None;
  Z.Right.insert (Z.create [1; 2] 3 [4; 5]) 9 => Z.create [1; 2] 3 [9; 4; 5];
  Z.Right.push (Z.create [1; 2] 3 [4; 5]) 9 => Z.create [1; 2] 9 [3; 4; 5];
  Z.Right.move (Z.create [1; 2] 3 [4; 5]) => Some (Z.create [1; 2; 3] 4 [5]);
  Z.Right.move (Z.create [1; 2] 3 []) => None;
  Z.Right.All.clear (Z.create [1; 2] 3 [4; 5]) => Z.create [1; 2] 3 [];
end




module Undo_redo = struct
  module Z = Zipper.List.Non_empty
  type 'a t = 'a Z.t

  let create = Z.singleton
  let peek = Z.Focus.peek
  let do' = Z.Right.All.clear >> Z.Left.push
  let undo = Z.Left.move
  let redo = Z.Right.move
end



module Test_undo_redo = struct
  let module U = Undo_redo in
  let t = U.create 1 in
  U.peek t => 1;
  let t = U.do' t 2 in
  U.peek t => 2;
  let t = U.undo t |> unoption in
  U.peek t => 1;
  U.undo t => None;
  U.peek t => 1;
  let t = U.redo t |> unoption in
  U.peek t => 2;
  U.redo t => None;
  U.peek t => 2;
  let t = U.undo t |> unoption in
  U.peek t => 1;
  let t = U.do' t 3 in
  U.peek t => 3;
  U.redo t => None;
end