(* Éditeur de texte, en utilisant la structure de zipper pour une liste *)

(* Programme 73 page 308 *)
module L = struct

  type 'a zipper = { left: 'a list; right: 'a list; }

  let of_list l =
    { left = []; right = l }

  let move_right z = match z.right with
    | [] -> invalid_arg "move_right"
    | x :: r -> { left = x :: z.left; right = r }

  let move_left z = match z.left with
    | [] -> invalid_arg "move_left"
    | x :: l -> { left = l; right = x :: z.right }

  let insert z x =
    { z with left = x :: z.left }

  let delete_left z =  match z.left with
    | [] -> invalid_arg "delete_left"
    | _ :: l -> { z with left = l }

  let delete_right z =  match z.right with
    | [] -> invalid_arg "delete_right"
    | _ :: r -> { z with right = r }

  let to_start z =
    { left = []; right = List.rev_append z.left z.right }

  let to_end z =
    { left = List.rev_append z.right z.left; right = [] }

end

module TextEditor : sig

  type line
  type text

  val empty: text
  val insert_char: text -> char -> text
  val return: text -> text
  val backspace: text -> text
  val delete: text -> text
  val up: text -> text
  val left: text -> text

end = struct

  open L

  (* une ligne = une zipper pour une liste de caractères *)
  type line = char zipper

  (* la ligne courante + un zipper pour représenter les lignes avant et après *)
  type text = line zipper * line

  let empty = of_list [], of_list []

  let insert_char (ctx, l) c =
    (ctx, insert l c)

  let return (ctx, line) =
    { left = { left = line.left; right = [] } :: ctx.left;
      right = ctx.right },
    { left = []; right = line.right }

  let backspace ((ctx, line) as text) =
    try ctx, delete_left line
    with Invalid_argument _ -> match ctx.left with
      | [] -> (* début du texte *) text
      | prev :: left ->
          { ctx with left = left }, { (to_end prev) with right = line.right }

  let delete ((ctx, line) as text) =
    try ctx, delete_right line
    with Invalid_argument _ -> match ctx.right with
      | [] -> (* fin du texte *) text
      | next :: right ->
          { ctx with right = right }, { (to_start next) with left = line.left }

  let up ((ctx, line) as text) = match ctx.left with
    | [] -> (* première ligne *) text
    | prev :: left -> { left = left; right = line :: ctx.right }, prev

  (* laissé en exercice: down *)

  let left ((ctx, line) as text) =
    try ctx, move_left line
    with Invalid_argument _ -> match ctx.left with
      | [] -> (* début du texte *) text
      | prev :: left -> { left = left; right = line :: ctx.right}, to_end prev

  (* laissé en exercice: right *)

end

This document was generated using caml2html