(** * Finite Modular Maps: Red-Black Trees *)

(** Author: Pierre Letouzey (Université de Paris - INRIA),
    adapted from earlier works in Coq Standard Library, see README.md.
    License: LGPL-2.1-only, see file LICENSE. *)

(** This module implements finite maps using Red-Black trees.
    This code is based on [MSetRBT.v] in Coq's Stdlib, due initially to
    Andrew W. Appel, 2011. See initial comment at the beginning
    of [MSetRBT.v].

    Note that we only prove here that the operations below preserve
    the binary search tree invariant ([Bst], a.k.a [Ok] predicate here),
    but *not* the Red/Black balancing invariant. Indeed, the former
    is enough to implement the desired interface [S], and ensure
    observational correctness. And proceeding this way is quite lighter.
    For the proofs of RBT balancing, see [MMaps.RBTproofs].
*)

From Coq Require Rtauto.
From Coq Require Import Bool BinPos Pnat Setoid SetoidList PeanoNat.
From Coq Require Import Orders OrdersFacts OrdersLists.
From MMaps Require Import Utils Interface OrdList GenTree.

Local Set Implicit Arguments.
Local Unset Strict Implicit.
Import ListNotations.

(* For nicer extraction, we create inductive principles
   only when needed *)
Local Unset Elimination Schemes.

(** The type of color annotation. *)

Inductive color := Red | Black.

Module Color.
 Definition t := color.
End Color.

(** Functor of pure functions + separate proofs of invariant
   preservation *)

Module MakeRaw (K: OrderedType) <: Raw.S K.

(** ** Functions *)

(** *** Generic trees instantiated with Red/Black colors *)

(** We reuse a generic definition of trees where the information
    parameter is a [Color.t]. Functions like mem or fold are also
    provided by this generic functor. *)

Include MMaps.GenTree.Ops K Color.
Import GenTree.PairNotations. (* #1 and #2 for fst and snd *)
Local Open Scope lazy_bool_scope.
Local Notation color := Color.t.
Local Arguments Leaf {elt}.
Local Notation Rd := (@Node _ Red).
Local Notation Bk := (@Node _ Black).

Section Elt.
Variable elt : Type.
Local Notation t := (tree elt).
Implicit Types l r m : t.
Implicit Types e : elt.

(** *** Basic tree *)

Definition singleton (k : key) (v : elt) : t :=
  Node Black Leaf k v Leaf.

(** *** Changing root color *)

Definition makeBlack m : t :=
 match m with
 | Leaf => Leaf
 | Node _ a x v b => Bk a x v b
 end.

Definition makeRed m : t :=
 match m with
 | Leaf => Leaf
 | Node _ a x v b => Rd a x v b
 end.

(** *** Balancing *)

(** We adapt when one side is not a true red-black tree.
    Both sides have the same black depth. *)

Definition lbal l k vk r :=
 match l with
 | Rd (Rd a x vx b) y vy c => Rd (Bk a x vx b) y vy (Bk c k vk r)
 | Rd a x vx (Rd b y vy c) => Rd (Bk a x vx b) y vy (Bk c k vk r)
 | _ => Bk l k vk r
 end.

Definition rbal l k vk r :=
 match r with
 | Rd (Rd b y vy c) z vz d => Rd (Bk l k vk b) y vy (Bk c z vz d)
 | Rd b y vy (Rd c z vz d) => Rd (Bk l k vk b) y vy (Bk c z vz d)
 | _ => Bk l k vk r
 end.

(** A variant of [rbal], with reverse pattern order. *)

Definition rbal' l k vk r :=
 match r with
 | Rd b y vy (Rd c z vz d) => Rd (Bk l k vk b) y vy (Bk c z vz d)
 | Rd (Rd b y vy c) z vz d => Rd (Bk l k vk b) y vy (Bk c z vz d)
 | _ => Bk l k vk r
 end.

(** Balancing with different black depth.
    One side is almost a red-black tree, while the other is
    a true red-black tree, but with black depth + 1.
    Used in deletion. *)

Definition lbalS l k vk r :=
 match l with
 | Rd a x vx b => Rd (Bk a x vx b) k vk r
 | _ =>
   match r with
   | Bk a y vy b => rbal' l k vk (Rd a y vy b)
   | Rd (Bk a y vy b) z vz c => Rd (Bk l k vk a) y vy (rbal' b z vz (makeRed c))
   | _ => Rd l k vk r (* impossible *)
   end
 end.

Definition rbalS l k vk r :=
 match r with
 | Rd b y vy c => Rd l k vk (Bk b y vy c)
 | _ =>
   match l with
   | Bk a x vx b => lbal (Rd a x vx b) k vk r
   | Rd a x vx (Bk b y vy c) => Rd (lbal (makeRed a) x vx b) y vy (Bk c k vk r)
   | _ => Rd l k vk r (* impossible *)
   end
 end.

(** *** Insertion *)

Fixpoint ins x vx s :=
 match s with
 | Leaf => Rd Leaf x vx Leaf
 | Node c l y vy r =>
   match K.compare x y with
   | Eq => Node c l y vx r
   | Lt =>
     match c with
     | Red => Rd (ins x vx l) y vy r
     | Black => lbal (ins x vx l) y vy r
     end
   | Gt =>
     match c with
     | Red => Rd l y vy (ins x vx r)
     | Black => rbal l y vy (ins x vx r)
     end
   end
 end.

Definition add x vx s := makeBlack (ins x vx s).

(** *** Deletion *)

Fixpoint append (l:t) : t -> t :=
 match l with
 | Leaf => fun r => r
 | Node lc ll lx lv lr =>
   fix append_l (r:t) : t :=
   match r with
   | Leaf => l
   | Node rc rl rx rv rr =>
     match lc, rc with
     | Red, Red =>
       let lrl := append lr rl in
       match lrl with
       | Rd lr' x v rl' => Rd (Rd ll lx lv lr') x v (Rd rl' rx rv rr)
       | _ => Rd ll lx lv (Rd lrl rx rv rr)
       end
     | Black, Black =>
       let lrl := append lr rl in
       match lrl with
       | Rd lr' x v rl' => Rd (Bk ll lx lv lr') x v (Bk rl' rx rv rr)
       | _ => lbalS ll lx lv (Bk lrl rx rv rr)
       end
     | Black, Red => Rd (append_l rl) rx rv rr
     | Red, Black => Rd ll lx lv (append lr r)
     end
   end
 end.

Fixpoint del x m : t :=
 match m with
 | Leaf => Leaf
 | Node _ a y v b =>
   match K.compare x y with
   | Eq => append a b
   | Lt =>
     match a with
     | Bk _ _ _ _ => lbalS (del x a) y v b
     | _ => Rd (del x a) y v b
     end
   | Gt =>
     match b with
     | Bk _ _ _ _ => rbalS a y v (del x b)
     | _ => Rd a y v (del x b)
     end
   end
 end.

Definition remove x m := makeBlack (del x m).

(** *** Tree-ification

    We rebuild a tree of size [if pred then n-1 else n] as soon
    as the list [l] has enough elements *)

Definition klist A := list (key * A).
Local Notation treeify_t := (klist elt -> t * klist elt).

Definition bogus : t * klist elt := (Leaf, nil).

Definition treeify_zero : treeify_t :=
 fun acc => (Leaf,acc).

Definition treeify_one : treeify_t :=
 fun acc => match acc with
 | (x,v)::acc => (Rd Leaf x v Leaf, acc)
 | _ => bogus
 end.

Definition treeify_cont (f g : treeify_t) : treeify_t :=
 fun acc =>
 match f acc with
 | (l, (x,v)::acc) =>
   match g acc with
   | (r, acc) => (Bk l x v r, acc)
   end
 | _ => bogus
 end.

Fixpoint treeify_aux (pred:bool)(n: positive) : treeify_t :=
 match n with
 | xH => if pred then treeify_zero else treeify_one
 | xO n => treeify_cont (treeify_aux pred n) (treeify_aux true n)
 | xI n => treeify_cont (treeify_aux false n) (treeify_aux pred n)
 end.

Fixpoint plength_aux (l:klist elt)(p:positive) := match l with
 | nil => p
 | _::l => plength_aux l (Pos.succ p)
end.

Definition plength (l:klist elt) := plength_aux l 1.

Definition treeify (l:klist elt) :=
 fst (treeify_aux true (plength l) l).

End Elt.

(** *** Map with removal *)

Definition ocons {A B} (a:A) (o:option B) (l:list (A*B)) :=
 match o with
 | None => l
 | Some b => (a,b)::l
 end.

Section Mapo.
Variable elt elt' : Type.
Variable f : key -> elt -> option elt'.

Fixpoint mapoL (l : klist elt)(acc : klist elt') : klist elt' :=
  match l with
   | nil => acc
   | (k,v)::l => mapoL l (ocons k (f k v) acc)
  end.

Definition mapo (m : t elt) : t elt' :=
 treeify (mapoL (rev_bindings m) nil).

End Mapo.

(** *** Merge *)

Section Merge.
Variable elt elt' elt'' : Type.
Variable f : key -> option elt -> option elt' -> option elt''.

Fixpoint mergeL (l1:klist elt) :
 klist elt' -> klist elt'' -> klist elt'' :=
 match l1 with
 | nil => mapoL (fun k v' => f k None (Some v'))
 | (x,vx)::l1' =>
    fix mergeL_l1 l2 acc :=
    match l2 with
    | nil => mapoL (fun k v => f k (Some v) None) l1 acc
    | (y,vy)::l2' =>
       match K.compare x y with
       | Eq => mergeL l1' l2' (ocons x (f x (Some vx) (Some vy)) acc)
       | Lt => mergeL_l1 l2' (ocons y (f y None (Some vy)) acc)
       | Gt => mergeL l1' l2 (ocons x (f x (Some vx) None) acc)
       end
    end
 end.

Definition merge (m1 : t elt) (m2 : t elt') : t elt'' :=
 treeify (mergeL (rev_bindings m1) (rev_bindings m2) nil).

End Merge.

(** ** Correctness proofs *)

Include MMaps.GenTree.Props K Color.
Import Ind.

Local Infix "∈" := In (at level 70).
Local Infix "==" := K.eq (at level 70).
Local Infix "<" := lessthan.
Local Infix "===" := Equal (at level 70).
Local Notation "m @ x ↦ e" := (MapsTo x e m)
 (at level 9, format "m '@' x  '↦'  e").

Local Hint Constructors tree MapsTo Bst : map.
Local Hint Unfold Ok Bst_Ok In : map.
Local Hint Immediate F.eq_sym : map.
Local Hint Resolve F.eq_refl : map.
Local Hint Resolve above_notin above_trans below_notin below_trans : map.
Local Hint Resolve above_leaf below_leaf : map.

Ltac rtauto := Rtauto.rtauto.
Ltac autorew := autorewrite with map.
Tactic Notation "autorew" "in" ident(H) := autorewrite with map in H.
Ltac treeorder := try intro; autorew; intuition_in; order.

Ltac induct m :=
 induction m as [|c l IHl x' vx' r IHr]; simpl; intros;
 [|case K.compare_spec; intros; invok; chok].

Ltac destmatch :=
 match goal with
 | |- context [match K.compare _ _ with _ => _ end] =>
   case K.compare_spec; destmatch
 | |- context [match ?x with _ => _ end] =>
   destruct x; destmatch
 | _ => idtac
 end.

Section Elt.
Variable elt : Type.
Implicit Types m : t elt.
Implicit Types k x y : key.
Implicit Types v vx vy : elt.

(** *** Singleton set *)

Lemma singleton_spec x (e:elt) : bindings (singleton x e) = (x,e)::nil.
Proof.
 unfold singleton. now rewrite bindings_node.
Qed.

#[export] Instance singleton_ok x vx : Ok (singleton x vx).
Proof.
 unfold singleton. ok.
Qed.

(** *** makeBlack and makeRed *)

#[export] Instance makeBlack_ok m `{!Ok m} : Ok (makeBlack m).
Proof.
 destruct m; simpl; ok.
Qed.

#[export] Instance makeRed_ok m `{!Ok m} : Ok (makeRed m).
Proof.
 destruct m; simpl; ok.
Qed.

Lemma makeBlack_mapsto m x v : (makeBlack m)@x ↦ v <-> m@x ↦ v.
Proof.
 destruct m; simpl; intuition_m.
Qed.

Lemma makeRed_mapsto m x v : (makeRed m)@x ↦ v <-> m@x ↦ v.
Proof.
 destruct m; simpl; intuition_m.
Qed.

Lemma makeBlack_in m x : x ∈ (makeBlack m) <-> x ∈ m.
Proof.
 destruct m; simpl; intuition_in.
Qed.

Lemma makeRed_in m x : x ∈ (makeRed m) <-> x ∈ m.
Proof.
 destruct m; simpl; intuition_in.
Qed.

Lemma makeBlack_find m : makeBlack m === m.
Proof.
 now destruct m.
Qed.

Lemma makeRed_find m : makeRed m === m.
Proof.
 now destruct m.
Qed.

(** *** Generic handling for red-matching and red-red-matching *)

Definition isblack m :=
 match m with Bk _ _ _ _ => True | _ => False end.

Definition notblack m :=
 match m with Bk _ _ _ _ => False | _ => True end.

Definition notred m :=
 match m with Rd _ _ _ _ => False | _ => True end.

Definition rcase {A} f g m : A :=
 match m with
 | Rd a x v b => f a x v b
 | _ => g m
 end.

Inductive rspec {A} f g : t elt -> A -> Prop :=
 | rred a x v b : rspec f g (Rd a x v b) (f a x v b)
 | relse t : notred t -> rspec f g t (g t).

Fact rmatch {A} f g m : rspec (A:=A) f g m (rcase f g m).
Proof.
unfold rcase. destmatch; now constructor.
Qed.

Definition rrcase {A} f g m : A :=
 match m with
 | Rd (Rd a x vx b) y vy c => f a x vx b y vy c
 | Rd a x vx (Rd b y vy c) => f a x vx  b y vy c
 | _ => g m
 end.

Notation notredred := (rrcase (fun _ _ _ _ _ _ _ => False) (fun _ => True)).

Inductive rrspec {A} f g : t elt -> A -> Prop :=
 | rrleft a x vx b y vy c :
     rrspec f g (Rd (Rd a x vx b) y vy c) (f a x vx b y vy c)
 | rrright a x vx b y vy c :
     rrspec f g (Rd a x vx (Rd b y vy c)) (f a x vx b y vy c)
 | rrelse m : notredred m -> rrspec f g m (g m).

Fact rrmatch {A} f g m : rrspec (A:=A) f g m (rrcase f g m).
Proof.
unfold rrcase. destmatch; now constructor.
Qed.

Definition rrcase' {A} f g m : A :=
 match m with
 | Rd a x vx (Rd b y vy c) => f a x vx b y vy c
 | Rd (Rd a x vx b) y vy c => f a x vx b y vy c
 | _ => g m
 end.

Fact rrmatch' {A} f g m : rrspec (A:=A) f g m (rrcase' f g m).
Proof.
unfold rrcase'. destmatch; now constructor.
Qed.

(** Balancing operations are instances of generic match *)

Fact lbal_match l k v r :
 rrspec
   (fun a x vx b y vy c => Rd (Bk a x vx b) y vy (Bk c k v r))
   (fun l => Bk l k v r)
   l
   (lbal l k v r).
Proof.
 exact (rrmatch _ _ _).
Qed.

Fact rbal_match l k v r :
 rrspec
   (fun a x vx b y vy c => Rd (Bk l k v a) x vx (Bk b y vy c))
   (fun r => Bk l k v r)
   r
   (rbal l k v r).
Proof.
 exact (rrmatch _ _ _).
Qed.

Fact rbal'_match l k v r :
 rrspec
   (fun a x vx b y vy c => Rd (Bk l k v a) x vx (Bk b y vy c))
   (fun r => Bk l k v r)
   r
   (rbal' l k v r).
Proof.
 exact (rrmatch' _ _ _).
Qed.

Fact lbalS_match l x vx r :
 rspec
  (fun a y vy b => Rd (Bk a y vy b) x vx r)
  (fun l =>
    match r with
    | Bk a y vy b => rbal' l x vx (Rd a y vy b)
    | Rd (Bk a y vy b) z vz c =>
      Rd (Bk l x vx a) y vy (rbal' b z vz (makeRed c))
    | _ => Rd l x vx r
    end)
  l
  (lbalS l x vx r).
Proof.
 exact (rmatch _ _ _).
Qed.

Fact rbalS_match l x vx r :
 rspec
  (fun a y vy b => Rd l x vx (Bk a y vy b))
  (fun r =>
    match l with
    | Bk a y vy b => lbal (Rd a y vy b) x vx r
    | Rd a y vy (Bk b z vz c) =>
      Rd (lbal (makeRed a) y vy b) z vz (Bk c x vx r)
    | _ => Rd l x vx r
    end)
  r
  (rbalS l x vx r).
Proof.
 exact (rmatch _ _ _).
Qed.

(** *** Balancing for insertion *)

 #[export] Instance lbal_ok l x v r `(!Ok l, !Ok r, l < x, x < r) :
 Ok (lbal l x v r).
Proof.
 destruct (lbal_match l x v r); ok; invlt; intuition; eautom.
Qed.

 #[export] Instance rbal_ok l x v r `(!Ok l, !Ok r, l < x, x < r) :
 Ok (rbal l x v r).
Proof.
 destruct (rbal_match l x v r); ok; invlt; intuition; eautom.
Qed.

 #[export] Instance rbal'_ok l x v r `(!Ok l, !Ok r, l < x, x < r) :
 Ok (rbal' l x v r).
Proof.
 destruct (rbal'_match l x v r); ok; invlt; intuition; eautom.
Qed.

(** Note : Rd is arbitrary here and in all similar results below *)

Lemma lbal_mapsto l x vx r y vy :
 (lbal l x vx r)@y ↦ vy <-> (Rd l x vx r)@y ↦ vy.
Proof.
 case lbal_match; intuition_m.
Qed.

Lemma rbal_mapsto l x vx r y vy :
 (rbal l x vx r)@y ↦ vy <-> (Rd l x vx r)@y ↦ vy.
Proof.
 case rbal_match; intuition_m.
Qed.

Lemma rbal'_mapsto l x vx r y vy :
 (rbal' l x vx r)@y ↦ vy <-> (Rd l x vx r)@y ↦ vy.
Proof.
 case rbal'_match; intuition_m.
Qed.

Lemma lbal_in l x v r y :
 y ∈ (lbal l x v r) <-> y == x \/ y ∈ l \/ y ∈ r.
Proof.
 unfold "∈". setoid_rewrite lbal_mapsto. setoid_rewrite node_mapsto.
 firstorder. exists v. firstorder.
Qed.

Lemma rbal_in l x v r y :
 y ∈ (rbal l x v r) <-> y == x \/ y ∈ l \/ y ∈ r.
Proof.
 unfold "∈". setoid_rewrite rbal_mapsto; setoid_rewrite node_mapsto.
 firstorder. exists v. firstorder.
Qed.

Lemma rbal'_in l x r v y :
 y ∈ (rbal' l x v r) <-> y == x \/ y ∈ l \/ y ∈ r.
Proof.
 unfold "∈". setoid_rewrite rbal'_mapsto; setoid_rewrite node_mapsto.
 firstorder. exists v. firstorder.
Qed.

Lemma lbal_find l x v r `{!Ok l, !Ok r} :
 l < x -> x < r ->
 lbal l x v r === Rd l x v r.
Proof.
 intros Hl Hr y. apply find_mapsto_equiv; auto using lbal_mapsto; autok.
Qed.

Lemma rbal_find l x v r `{!Ok l, !Ok r} :
 l < x -> x < r ->
 rbal l x v r === Rd l x v r.
Proof.
 intros Hl Hr y. apply find_mapsto_equiv; auto using rbal_mapsto; autok.
Qed.

Lemma rbal'_find l x v r `{!Ok l, !Ok r} :
 l < x -> x < r ->
 rbal' l x v r === Rd l x v r.
Proof.
 intros Hl Hr y. apply find_mapsto_equiv; auto using rbal'_mapsto; autok.
Qed.

Hint Rewrite (@in_node elt) makeRed_in makeBlack_in : map.
Hint Rewrite lbal_in rbal_in rbal'_in : map.

(** *** Insertion *)

Lemma ins_in m x v y :
 y ∈ (ins x v m) <-> y == x \/ y ∈ m.
Proof.
 induct m; destmatch; autorew; rewrite ?IHl, ?IHr; intuition_in.
 setoid_replace y with x; eauto.
Qed.
Hint Rewrite ins_in : map.

Lemma ins_above m x v y : m < y -> x < y -> ins x v m < y.
Proof.
 intros. treeorder.
Qed.

Lemma ins_below m x v y : y < m -> y < x -> y < ins x v m.
Proof.
 intros. treeorder.
Qed.
Local Hint Resolve ins_above ins_below : map.

#[export] Instance ins_ok m x v `{!Ok m} : Ok (ins x v m).
Proof.
 induct m; auto; destmatch;
 (eapply lbal_ok || eapply rbal_ok || ok); auto; treeorder.
Qed.

Lemma ins_spec1 m x v `{!Ok m} : find x (ins x v m) = Some v.
Proof.
 induct m; simpl; destmatch;
  rewrite ?lbal_find, ?rbal_find by eauto with *;
  simpl; destmatch; auto; try order.
Qed.

Lemma ins_spec2 m x y v `{!Ok m} : ~ x == y ->
 find y (ins x v m) = find y m.
Proof.
 induct m; simpl; destmatch;
  rewrite ?lbal_find, ?rbal_find by eauto with *;
  simpl; destmatch; auto; try order.
Qed.

Lemma ins_find m x y v `{!Ok m} :
 find y (ins x v m) =
  match K.compare y x with Eq => Some v | _ => find y m end.
Proof.
 destmatch; intros E.
 - apply find_spec; autok. rewrite E. apply find_spec; autok.
   now apply ins_spec1.
 - apply ins_spec2; trivial; order.
 - apply ins_spec2; trivial; order.
Qed.

#[export] Instance add_ok m x v `{!Ok m} : Ok (add x v m).
Proof.
 unfold add; autok.
Qed.

Lemma add_in m x v y :
 y ∈ (add x v m) <-> y == x \/ y ∈ m.
Proof.
 unfold add. now autorew.
Qed.
Hint Rewrite add_in : map.

Lemma add_spec1 m x v `{!Ok m} : find x (add x v m) = Some v.
Proof.
unfold add. rewrite makeBlack_find. now apply ins_spec1.
Qed.

Lemma add_spec2 m x y v `{!Ok m} : ~ x == y ->
 find y (add x v m) = find y m.
Proof.
unfold add. rewrite makeBlack_find. now apply ins_spec2.
Qed.

(** *** Balancing for deletion *)

#[export] Instance lbalS_ok l x v r :
  forall `(!Ok l, !Ok r, l < x, x < r), Ok (lbalS l x v r).
Proof.
 case lbalS_match; intros; destmatch; try treeorder; invok; invlt.
 - ok; intuition auto.
 - constructor; chok; try treeorder. apply rbal'_ok; treeorder.
 - apply rbal'_ok; treeorder.
Qed.

 #[export] Instance rbalS_ok l x v r :
 forall `(!Ok l, !Ok r, l < x, x < r), Ok (rbalS l x v r).
Proof.
 case rbalS_match; intros; destmatch; try treeorder; invok; invlt.
 - ok; intuition.
 - constructor; chok; try treeorder. apply lbal_ok; treeorder.
 - apply lbal_ok; treeorder.
Qed.

Lemma lbalS_mapsto l x v r y vy :
  (lbalS l x v r)@y ↦ vy <-> (Rd l x v r)@y ↦ vy.
Proof.
 case lbalS_match; intros.
 - intuition_m.
 - destmatch; intuition_m;
   rewrite ?rbal'_mapsto in *; intuition_m;
   rewrite ?makeRed_mapsto in *; intuition_m;
   apply MapsRight; rewrite rbal'_mapsto; intuition_m.
   apply MapsRight. now rewrite makeRed_mapsto.
Qed.

Lemma rbalS_mapsto l x v r y vy :
  (rbalS l x v r)@y ↦ vy <-> (Rd l x v r)@y ↦ vy.
Proof.
 case rbalS_match; intros.
 - intuition_m.
 - destmatch; intuition_m;
   rewrite ?lbal_mapsto in *; intuition_m;
   rewrite ?makeRed_mapsto in *; intuition_m;
   apply MapsLeft; rewrite lbal_mapsto; intuition_m.
   apply MapsLeft. now rewrite makeRed_mapsto.
Qed.

Lemma lbalS_in l x v r y :
  y ∈ (lbalS l x v r) <-> y == x \/ y ∈ l \/ y ∈ r.
Proof.
 unfold "∈"; setoid_rewrite lbalS_mapsto; setoid_rewrite node_mapsto.
 firstorder. exists v. firstorder.
Qed.

Lemma rbalS_in l x r v y :
  y ∈ (rbalS l x v r) <-> y == x \/ y ∈ l \/ y ∈ r.
Proof.
 unfold "∈"; setoid_rewrite rbalS_mapsto; setoid_rewrite node_mapsto.
 firstorder. exists v. firstorder.
Qed.

Lemma lbalS_find l x v r `{!Ok l, !Ok r} : l < x -> x < r ->
  lbalS l x v r === Rd l x v r.
Proof.
 intros Hl Hr y. apply find_mapsto_equiv; auto using lbalS_mapsto; autok.
Qed.

Lemma rbalS_find l x v r `{!Ok l, !Ok r} : l < x -> x < r ->
  rbalS l x v r === Rd l x v r.
Proof.
 intros Hl Hr y. apply find_mapsto_equiv; auto using rbalS_mapsto; autok.
Qed.

Hint Rewrite lbalS_in rbalS_in : map.

(** *** Append for deletion *)

Ltac append_tac l r :=
 induction l as [| lc ll _ lx lv lr IHlr];
 [intro r; simpl
 |induction r as [| rc rl IHrl rx rv rr _];
   [simpl
   |destruct lc, rc;
     [specialize (IHlr rl); clear IHrl
     |simpl;
      assert (Hr:notred (Bk rl rx rv rr)) by (simpl; trivial);
      set (r:=Bk rl rx rv rr) in *; clearbody r; clear IHrl rl rx rv rr;
      specialize (IHlr r)
     |change (append _ _) with (Rd (append (Bk ll lx lv lr) rl) rx rv rr);
      assert (Hl:notred (Bk ll lx lv lr)) by (simpl; trivial);
      set (l:=Bk ll lx lv lr) in *; clearbody l; clear IHlr ll lx lv lr
     |specialize (IHlr rl); clear IHrl]]].

Lemma mapsto_2levels c cl ll lx lv lr x v cr rl rx rv rr y e :
 (Node c (Node cl ll lx lv lr) x v (Node cr rl rx rv rr))@y ↦ e <->
  (Node cl ll lx lv Leaf)@y ↦ e \/
  (Node c lr x v rl)@y ↦ e \/
  (Node cr Leaf rx rv rr)@y ↦ e.
Proof.
 rewrite !node_mapsto, !leaf_mapsto. rtauto.
Qed.

Lemma append_mapsto l r y v :
  (append l r)@y ↦ v <-> l@y ↦ v \/ r@y ↦ v.
Proof.
 revert r.
 append_tac l r; try (intuition_m; fail).
 - (* Rd / Rd *)
   simpl. destmatch.
   + intuition_m.
   + rewrite mapsto_2levels. factornode m.
     rewrite !node_mapsto, !leaf_mapsto. rtauto.
   + factornode m. rewrite !node_mapsto. rtauto.
 - (* Bk / Bk *)
   simpl. destmatch; rewrite ?lbalS_mapsto.
   + intuition_m.
   + rewrite mapsto_2levels. factornode m.
     rewrite !node_mapsto, !leaf_mapsto. rtauto.
   + factornode m. rewrite !node_mapsto. rtauto.
Qed.

Lemma append_in (l r : t elt) x :
 x ∈ (append l r) <-> x ∈ l \/ x ∈ r.
Proof.
 unfold "∈". setoid_rewrite append_mapsto. firstorder.
Qed.

Hint Rewrite append_in : map.

#[export] Instance append_ok : forall l r `{!Ok l, !Ok r},
 l < r -> Ok (@append elt l r).
Proof.
 append_tac l r; trivial; intros OK OK' AP;
 rewrite ?apart_node_l, ?apart_node_r in AP;
 decompose [and] AP; clear AP; ok; try treeorder.
 - (* Rd / Rd *)
   assert (U : Ok (append lr rl)) by auto.
   assert (V : lx < append lr rl) by (invlt;treeorder).
   assert (W : append lr rl < rx) by (invlt;treeorder).
   simpl. destmatch; invlt; ok; intuition; eautom.
 - (* Bk / Bk *)
   assert (U : Ok (append lr rl)) by auto.
   assert (V : lx < append lr rl) by (invlt;treeorder).
   assert (W : append lr rl < rx) by (invlt;treeorder).
   simpl. destmatch; try apply lbalS_ok; invlt; ok; intuition; eautom.
Qed.

(** *** Deletion *)

Lemma del_in m x y `{!Ok m} :
 y ∈ (del x m) <-> y ∈ m /\ ~ y==x.
Proof.
induct m; destmatch; autorew; try rewrite IHl; try rewrite IHr;
 try clear IHl IHr; treeorder.
Qed.

Hint Rewrite del_in : map.

 #[export] Instance del_ok m x `{!Ok m} : Ok (del x m).
Proof.
induct m.
- trivial.
- eapply append_ok; eauto using between.
- assert (del x l < x') by treeorder.
  destmatch; ok.
- assert (x' < del x r) by treeorder.
  destmatch; ok.
Qed.

Lemma del_spec1 m x `{!Ok m} : find x (del x m) = None.
Proof.
apply not_find_iff; ok. rewrite del_in; treeorder.
Qed.

Lemma del_spec2 m x y `{!Ok m} : ~ x == y ->
 find y (del x m) = find y m.
Proof.
intros.
apply find_mapsto_equiv; ok.
induct m.
- easy.
- rewrite append_mapsto, node_mapsto. treeorder.
- destmatch.
  + simpl. intuition_m.
  + rewrite 2 node_mapsto. factornode l. now rewrite IHl by ok.
  + rewrite lbalS_mapsto, 2 node_mapsto. factornode l.
    now rewrite IHl by ok.
- destmatch.
  + simpl. intuition_m.
  + rewrite 2 node_mapsto. factornode r. now rewrite IHr by ok.
  + rewrite rbalS_mapsto, 2 node_mapsto. factornode r.
    now rewrite IHr by ok.
Qed.

Lemma remove_in m x y `{!Ok m} :
 y ∈ (remove x m) <-> y ∈ m /\ ~ y==x.
Proof.
unfold remove. now autorew.
Qed.

Hint Rewrite remove_in : map.

#[export] Instance remove_ok m x `{!Ok m} : Ok (remove x m).
Proof.
unfold remove; ok.
Qed.

Lemma remove_spec1 m x `{!Ok m} : find x (remove x m) = None.
Proof.
unfold remove. rewrite makeBlack_find. now apply del_spec1.
Qed.

Lemma remove_spec2 m x y `{!Ok m} : ~ x == y ->
 find y (remove x m) = find y m.
Proof.
unfold remove. rewrite makeBlack_find. now apply del_spec2.
Qed.

(** *** Treeify *)

Local Notation ifpred p n := (if p then pred n else n%nat).
Local Notation treeify_t := (klist elt -> t elt * klist elt).

Definition treeify_invariant size (f:treeify_t) :=
 forall acc,
 size <= length acc ->
 let (m,acc') := f acc in
 cardinal m = size /\ acc = bindings m ++ acc'.

Lemma treeify_zero_spec : treeify_invariant 0 (@treeify_zero elt).
Proof.
 intro. simpl. auto.
Qed.

Lemma treeify_one_spec : treeify_invariant 1 (@treeify_one elt).
Proof.
 intros [|x acc]; simpl; auto. inversion 1.
 destruct x. simpl; auto.
Qed.

Lemma treeify_cont_spec f g size1 size2 size :
 treeify_invariant size1 f ->
 treeify_invariant size2 g ->
 size = S (size1 + size2) ->
 treeify_invariant size (treeify_cont f g).
Proof.
 intros Hf Hg EQ acc LE. unfold treeify_cont.
 specialize (Hf acc).
 destruct (f acc) as (t1,acc1).
 destruct Hf as (Hf1,Hf2).
  { transitivity size; trivial. subst. auto with arith. }
 destruct acc1 as [|x acc1].
  { exfalso. revert LE. apply Nat.lt_nge. subst.
    rewrite app_nil_r, <- cardinal_spec; auto with arith. }
 specialize (Hg acc1).
 destruct (g acc1) as (t2,acc2).
 destruct Hg as (Hg1,Hg2).
  { revert LE. subst.
    rewrite app_length, <- cardinal_spec. simpl.
    rewrite Nat.add_succ_r, <- Nat.succ_le_mono.
    apply Nat.add_le_mono_l. }
 destruct x; simpl.
 rewrite bindings_node_acc. subst; auto.
Qed.

Lemma treeify_aux_spec n (p:bool) :
 treeify_invariant (ifpred p (Pos.to_nat n)) (treeify_aux p n).
Proof.
 revert p.
 induction n as [n|n|]; intros p; simpl treeify_aux.
 - eapply treeify_cont_spec; [ apply (IHn false) | apply (IHn p) | ].
   rewrite Pos2Nat.inj_xI.
   assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H.
   destruct p; simpl; intros; rewrite Nat.add_0_r; trivial.
   now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial.
 - eapply treeify_cont_spec; [ apply (IHn p) | apply (IHn true) | ].
   rewrite Pos2Nat.inj_xO.
   assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H.
   rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial.
   destruct p; simpl; intros; rewrite Nat.add_0_r; trivial.
   symmetry. now apply Nat.add_pred_l.
 - destruct p; [ apply treeify_zero_spec | apply treeify_one_spec ].
Qed.

Lemma plength_aux_spec l p :
  Pos.to_nat (@plength_aux elt l p) = length l + Pos.to_nat p.
Proof.
 revert p. induction l; trivial. simpl plength_aux.
 intros. now rewrite IHl, Pos2Nat.inj_succ, Nat.add_succ_r.
Qed.

Lemma plength_spec l : Pos.to_nat (@plength elt l) = S (length l).
Proof.
 unfold plength. rewrite plength_aux_spec. apply Nat.add_1_r.
Qed.

Lemma treeify_bindings l : bindings (@treeify elt l) = l.
Proof.
 assert (H := @treeify_aux_spec (plength l) true l).
 unfold treeify. destruct treeify_aux as (t,acc); simpl in *.
 destruct H as (H,H'). { now rewrite plength_spec. }
 subst l. rewrite plength_spec, app_length, <- cardinal_spec in *.
 destruct acc.
 * now rewrite app_nil_r.
 * exfalso. revert H. simpl.
   rewrite Nat.add_succ_r, Nat.add_comm.
   apply Nat.succ_add_discr.
Qed.

Lemma treeify_mapsto x v l : (treeify l)@x ↦ v <-> InA O.eqke (x,v) l.
Proof.
 intros. now rewrite <- bindings_spec1, treeify_bindings.
Qed.

(** Apart predicate on lists *)

 #[export] Instance lt_klist A B : LessThan (klist A) (klist B)
  := fun lA lB =>
      forall ka kb, List.In ka lA -> List.In kb lB -> ka#1 < kb#1.

Section ApartList.
Variable A B : Type.
Implicit Types lA : klist A.
Implicit Types lB : klist B.

Lemma ApartL_rev lA lB : (rev lA) < lB <-> lA < lB.
Proof.
 unfold "<", lt_klist. now setoid_rewrite <- in_rev.
Qed.

Lemma ApartL_appl lA lA' lB :
 lA++lA' < lB <-> lA < lB /\ lA' < lB.
Proof.
 unfold "<", lt_klist. setoid_rewrite in_app_iff; firstorder.
Qed.

Lemma ApartL_appr lA lB lB' :
 lA < lB++lB' <-> lA < lB /\ lA < lB'.
Proof.
 unfold "<", lt_klist. setoid_rewrite in_app_iff; firstorder.
Qed.

Lemma ApartL_consl ka lA lB :
 (ka::lA) < lB <-> [ka] < lB /\ lA < lB.
Proof.
 apply (ApartL_appl [ka]).
Qed.

Lemma ApartL_consr kb lA lB :
 lA < (kb::lB) <-> lA < [kb] /\ lA < lB.
Proof.
 apply (ApartL_appr lA [kb]).
Qed.

End ApartList.

Lemma ApartL_eqk_l A B B' (lA : klist A) (kb:key*B) (kb':key*B') :
 [kb] < lA -> kb#1 == kb'#1 -> [kb'] < lA.
Proof.
 intros AP E (k,b') (k',a) [<-|[ ]] Hy; simpl.
 rewrite <-E. apply (AP kb (k',a)); simpl; auto.
Qed.

Lemma ApartL_ltk_l A B B' (lA : klist A) (kb:key*B) (kb':key*B') :
 [kb] < lA -> kb'#1 < kb#1 -> [kb'] < lA.
Proof.
 intros AP LT (k,b') (k',a) [<-|[ ]] Hy; simpl.
 rewrite LT. apply (AP kb (k',a)); simpl; auto.
Qed.

Lemma ApartL_eqk_r A B B' (lA : klist A) (kb:key*B) (kb':key*B') :
 lA < [kb] -> kb#1 == kb'#1 -> lA < [kb'].
Proof.
 intros AP E (k,a) (k',b') Hx [<-|[ ]]; simpl.
 rewrite <-E. apply (AP (k,a) kb); simpl; auto.
Qed.

Lemma ApartL_ltk_r A B B' (lA : klist A) (kb:key*B) (kb':key*B') :
 lA < [kb] -> kb#1 < kb'#1 -> lA < [kb'].
Proof.
 intros AP LT (k,a) (k',b') Hx [<-|[ ]]; simpl.
 rewrite <-LT. apply (AP (k,a) kb); simpl; auto.
Qed.

Lemma sort_app_key (l l' : klist elt) :
 sort O.ltk (l++l') <-> sort O.ltk l /\ sort O.ltk l' /\ l < l'.
Proof.
 apply SortA_app_iff with (eqA:=O.eqk)(ltA:=O.ltk); ok.
Qed.

Lemma sort_cons_key p (l : klist elt) :
 sort O.ltk (p::l) <-> sort O.ltk l /\ [p] < l.
Proof.
 rewrite (sort_app_key [p] l). firstorder.
Qed.

Lemma bindings_above x (e:elt) (m:t elt) :
  m < x <-> bindings m < [(x,e)].
Proof.
 split.
 - intros H p q Hp [<-|[ ]]. simpl. apply H.
   exists (p#2). rewrite <- bindings_spec1.
   apply In_InA; ok. now destruct p.
 - intros H y (v,M).
   rewrite <- bindings_spec1, InA_alt in M.
   destruct M as (p & E & IN). redk. destruct E as (->,->).
   apply (H _ (x,e)); simpl; auto.
Qed.

Lemma bindings_below x (e:elt) (m:t elt) :
  x < m <-> [(x,e)] < bindings m.
Proof.
 split.
 - intros H p q [<-|[ ]] Hq. simpl. apply H.
   exists (q#2). rewrite <- bindings_spec1.
   apply In_InA; ok. now destruct q.
 - intros H y (v,M).
   rewrite <- bindings_spec1, InA_alt in M.
   destruct M as (p & E & IN). redk. destruct E as (->,->).
   apply (H (x,e)); simpl; auto.
Qed.

Lemma bindings_sort (m:t elt) : sort O.ltk (bindings m) <-> Ok m.
Proof.
 split; auto using bindings_spec2.
 induction m as [|c l IHl x v r IHr].
 - unfold bindings. simpl. constructor.
 - rewrite bindings_node; simpl.
   rewrite sort_app_key, sort_cons_key, (@ApartL_consr _ elt). (* TODO *)
   rewrite <- bindings_above, <- bindings_below. intuition auto; ok.
Qed.

#[export] Instance treeify_ok l : sort O.ltk l -> Ok (@treeify elt l).
Proof.
 intros. apply bindings_sort. rewrite treeify_bindings; auto.
Qed.

End Elt.

Definition oelse {A} (o o' : option A) :=
 match o with
 | None => o'
 | _ => o
 end.

Definition obind {A B} (o:option A) (f:A->option B) :=
  match o with Some a => f a | None => None end.

(** [findL] : List assoc based on [K.compare] *)

Fixpoint findL {elt} x (l : klist elt) :=
 match l with
 | [] => None
 | (y,v) :: l =>
   match K.compare x y with
   | Eq => Some v
   | _ => findL x l
   end
 end.

Lemma findL_app {elt} x (l l' : klist elt) :
  findL x (l++l') = oelse (findL x l) (findL x l').
Proof.
 induction l as [|(y,v) l IH]; simpl; auto.
 rewrite IH. destmatch; auto.
Qed.

Lemma findL_inA {elt} x e (l : klist elt) :
 findL x l = Some e -> InA O.eqke (x,e) l.
Proof.
 induction l as [|(k,v) l IH]; simpl; try easy.
 destmatch; intro E; auto. intros [= ->]; auto.
Qed.

Lemma findL_inA_iff {elt} x e (l : klist elt) : sort O.ltk l ->
 (findL x l = Some e <-> InA O.eqke (x,e) l).
Proof.
 intros Sl. split; [apply findL_inA| ]. revert Sl.
 induction l as [|(k,v) l IH]; simpl; try easy.
 inversion_clear 1. rewrite InA_cons. redk. intros [(E,->)|IN].
 - destmatch; intros; auto || order.
 - destmatch; intros; auto.
   assert (LT : O.ltk (k,v) (x,e))
     by (eapply SortA_InfA_InA with (eqA:=O.eqke); ok).
   compute in LT. order.
Qed.

Lemma findL_find {elt} x (m : t elt) `{!Ok m} :
 findL x (bindings m) = find x m.
Proof.
 apply eq_option_alt. intro e.
 rewrite findL_inA_iff by now apply bindings_spec2.
 rewrite find_spec by auto.
 apply bindings_spec1.
Qed.

Section Mapo.
Variable elt elt' : Type.
Variable f : key -> elt -> option elt'.

Lemma mapoL_sorted l acc :
 sort O.ltk (rev l) -> sort O.ltk acc -> l < acc ->
 sort O.ltk (mapoL f l acc).
Proof.
 revert acc.
 induction l as [|(k,e) l IH]; simpl; auto.
 intros acc Sl Sacc AP.
 rewrite sort_app_key in Sl; ok. destruct Sl as (Sl & _ & AP').
 apply -> ApartL_rev in AP'.
 apply -> ApartL_consl in AP. destruct AP as (AP1,AP).
 apply IH; clear IH; simpl; auto; destruct (f k e); simpl; auto.
 - apply sort_cons_key. eauto using ApartL_eqk_l with map.
 - apply ApartL_consr. eauto using ApartL_eqk_r with map.
Qed.

 #[export] Instance mapo_ok m `{!Ok m} : Ok (mapo f m).
Proof.
 unfold mapo. apply treeify_ok. apply mapoL_sorted; simpl; auto.
 - rewrite rev_bindings_rev, rev_involutive. now apply bindings_spec2.
 - inversion 2.
Qed.

Lemma mapoL_find l acc x :
 sort O.ltk (rev l) ->
 exists y : K.t,
    y == x /\
    findL x (mapoL f l acc) =
     oelse (obind (findL x (rev l)) (f y)) (findL x acc).
Proof.
 revert acc.
 induction l as [|(k,e) l IH]; simpl; intros acc Sl.
 - now exists x.
 - rewrite sort_app_key in Sl. destruct Sl as (Sl & _ & AP).
   apply -> ApartL_rev in AP.
   destruct (IH (ocons k (f k e) acc) Sl) as (y & Hy & E). clear IH.
   setoid_rewrite findL_app. setoid_rewrite E. clear E.
   destruct (findL x (rev l)) eqn:El; simpl in *; auto.
   + exists y; split; auto.
     unfold oelse, ocons; destmatch; auto. simpl.
     destmatch; auto; intros.
     apply findL_inA in El. rewrite InA_rev in El. apply InA_alt in El.
     destruct El as ((x',e') & (Hx',_) & IN).
     compute in Hx'.
     enough (x' < k) by order.
     apply (AP (x',e') (k,e)); simpl; auto.
   + clear l Sl AP El.
     destruct (f k e) eqn:Fk; simpl; destmatch; intros; firstorder;
      exists k; simpl; now rewrite Fk.
Qed.

Lemma mapoL_mapsto l acc x v' :
 InA O.eqke (x,v') (mapoL f l acc) <->
 (exists y v, y == x /\ List.In (y,v) l /\ f y v = Some v') \/
  InA O.eqke (x,v') acc.
Proof.
 revert acc.
 induction l as [|(k,e) l IH]; simpl; intros.
 - firstorder.
 - destruct (f k e) eqn:Hf; simpl in *; rewrite IH; clear IH; auto.
   rewrite ?InA_cons.
   + firstorder; try red in H; try red in H0; simpl in *; subst.
     * left. exists k, e; autom.
     * injection H0 as <- <-. right; left. compute; split; autom.
       congruence.
   + firstorder. injection H0 as <- <-. congruence.
Qed.

Lemma mapo_mapsto m x v' :
  (mapo f m)@x ↦ v' ->
   exists y v, y == x /\ m@x ↦ v /\ f y v = Some v'.
Proof.
 unfold mapo.
 rewrite treeify_mapsto, mapoL_mapsto, InA_nil; auto.
 intros [(y & v & E & IN & Hf)|[ ]].
 rewrite rev_bindings_rev, <-In_rev in IN.
 exists y, v. repeat split; auto. apply bindings_spec1.
 rewrite InA_alt. exists (y, v). split; autom.
Qed.

Lemma mapo_find m x `{!Ok m} :
  exists y, y == x /\
            find x (mapo f m) = obind (find x m) (f y).
Proof.
 assert (Ok (mapo f m)) by ok.
 destruct (@mapoL_find (rev_bindings m) nil x) as (y & Hy & EQ).
 - rewrite rev_bindings_rev, rev_involutive; now apply bindings_spec2.
 - exists y; split; auto.
   unfold mapo in *. rewrite <- !findL_find; auto.
   rewrite treeify_bindings, EQ. simpl. clear EQ.
   rewrite rev_bindings_rev, rev_involutive. now destruct obind.
Qed.

End Mapo.

Section Merge.
Variable elt elt' elt'' : Type.
Implicit Type f : key -> option elt -> option elt' -> option elt''.

Lemma mergeL_eqn f l l' acc k k' v v' :
 mergeL f ((k,v)::l) ((k',v')::l') acc =
 match K.compare k k' with
 | Eq => mergeL f l l' (ocons k (f k (Some v) (Some v')) acc)
 | Lt => mergeL f ((k,v)::l) l' (ocons k' (f k' None (Some v')) acc)
 | Gt => mergeL f l ((k',v')::l') (ocons k (f k (Some v) None) acc)
 end.
Proof.
 reflexivity.
Qed.

Lemma mergeL_sorted f l l' acc :
 sort O.ltk (rev l) -> sort O.ltk (rev l') -> sort O.ltk acc ->
 l < acc -> l' < acc ->
 sort O.ltk (mergeL f l l' acc).
Proof.
 revert l' acc.
 induction l as [|(x,e) l IHl].
 - simpl. intros. apply mapoL_sorted; auto.
 - induction l' as [|(x',e') l' IHl'].
   + intros. apply mapoL_sorted; auto.
   + intros acc Sl Sl' Sacc AP AP'. simpl in Sl, Sl'.
     assert (Sl0 := Sl). assert (Sl0' := Sl').
     assert (AP0 := AP). assert (AP0' := AP').
     apply sort_app_key in Sl. destruct Sl as (Sl & _ & APl).
     apply sort_app_key in Sl'. destruct Sl' as (Sl' & _ & APl').
     apply -> ApartL_rev in APl. apply -> ApartL_rev in APl'.
     apply -> ApartL_consl in AP. destruct AP as (AP1,AP).
     apply -> ApartL_consl in AP'. destruct AP' as (AP1',AP').
     rewrite mergeL_eqn; destmatch; [intro EQ|intro LT|intro LT];
      apply IHl || apply IHl'; clear IHl IHl'; auto;
      destruct f; simpl; auto; try apply sort_cons_key;
       try apply ApartL_consr; try apply ApartL_consl; split; auto;
       eauto using ApartL_eqk_l, ApartL_eqk_r with map;
       apply ApartL_consl; split; try (eapply ApartL_ltk_r; eautom; fail);
       intros (?,?) (?,?); compute; intuition congruence.
Qed.

 #[export] Instance merge_ok f m m' `{!Ok m, !Ok m'} : Ok (merge f m m').
Proof.
apply treeify_ok, mergeL_sorted; auto;
 rewrite ?rev_bindings_rev, ?rev_involutive;
 now apply bindings_sort || firstorder.
Qed.

Lemma mergeL_in f l l' acc x :
 (exists v, InA O.eqke (x,v) (mergeL f l l' acc)) ->
    (exists v, InA O.eqke (x,v) l) \/
    (exists v, InA O.eqke (x,v) l') \/
    (exists v, InA O.eqke (x,v) acc).
Proof.
 revert l' acc.
 induction l as [|(y,e) l IHl].
 - simpl. intros l' acc (v,H). right.
   apply mapoL_mapsto in H.
   destruct H as [(y & v' & E & IN & _)|H].
   + left; exists v'. rewrite InA_alt. exists (y,v'); split; autom.
   + firstorder.
 - induction l' as [|(y',e') l' IHl']; intros acc.
   + intros (v,H). apply mapoL_mapsto in H; simpl in *.
     destruct H as [(y' & v' & E & [[= <- <-]|IN] & _)|H].
     * left. exists e; eautom.
     * left. exists v'. rewrite InA_cons. right. rewrite InA_alt.
       exists (y',v'); autom.
     * firstorder.
   + rewrite mergeL_eqn.
     destmatch; [intros EQ H| intros LT H|intros LT H];
      apply IHl in H || apply IHl' in H; clear IHl IHl'; firstorder;
       setoid_rewrite InA_cons; firstorder;
       destruct f; simpl in *; firstorder;
       rewrite InA_cons in H; destruct H as [(H,_)|H]; firstorder;
       compute in H.
     * left; exists e. now left.
     * right;left; exists e'. now left.
     * left; exists e. now left.
Qed.

Lemma merge_spec2' f m m' x :
  x ∈ (merge f m m') -> x ∈ m \/ x ∈ m'.
Proof.
 unfold merge, "∈".
 setoid_rewrite treeify_mapsto.
 intros H. apply mergeL_in in H. destruct H as [(v,H)|[(v,H)|(v,H)]].
 - left. exists v. rewrite rev_bindings_rev, InA_rev in H.
   now apply bindings_spec1.
 - right. exists v. rewrite rev_bindings_rev, InA_rev in H.
   now apply bindings_spec1.
 - now rewrite InA_nil in H.
Qed.

Lemma merge_spec2 f m m' x `{!Ok m, !Ok m'} :
  x ∈ (merge f m m') -> x ∈ m \/ x ∈ m'.
Proof. apply merge_spec2'. Qed.

Ltac breako :=
 destmatch; auto; try order;
 unfold oelse, ocons; destmatch; simpl; auto;
  destmatch; auto; order.

Lemma merge_find_eq f l l' acc x y y' z e e' :
  (forall k : key, f k None None = None) ->
  l < [(y, e)] ->
  l' < [(y', e')] ->
  y == y' -> z == x ->
  exists y0 : K.t,
    y0 == x /\
    oelse (f z (findL x l) (findL x l'))
      (findL x (ocons y (f y (Some e) (Some e')) acc)) =
    oelse
      (f y0 (findL x (l ++ [(y, e)])) (findL x (l' ++ [(y', e')])))
      (findL x acc).
Proof.
 intros Hf AP AP' Ey Ez. simpl.
 setoid_rewrite findL_app; simpl.
 destruct findL eqn:INl.
 - exists z; split; auto.
   assert (x < y).
   { apply findL_inA in INl. apply InA_alt in INl.
     destruct INl as ((x',e0') & (Hx',_) & INl).
     compute in Hx'. rewrite Hx'.
     apply (AP (x',e0') (y,e)); simpl; auto. }
   destruct (findL x l'); simpl; breako.
 - clear INl. simpl.
   destruct (findL x l') eqn:INl'; simpl.
   + exists z; split; auto.
     enough (x < y') by breako.
     { apply findL_inA in INl'. apply InA_alt in INl'.
       destruct INl' as ((x',e0') & (Hx',_) & INl').
       compute in Hx'. rewrite Hx'.
       apply (AP' (x',e0') (y',e')); simpl; auto. }
   + clear INl'. rewrite Hf. simpl.
     destruct (f y _ _) eqn:Fy; simpl;
       destmatch; try order;
        try setoid_rewrite Hf; firstorder;
         exists y; now rewrite Fy.
Qed.

Lemma merge_find_lt f l l' acc x y y' z e e' :
  (forall k : key, f k None None = None) ->
  l < [(y, e)] ->
  l' < [(y', e')] ->
  y < y' -> z == x ->
  exists y0 : K.t,
    y0 == x /\
    oelse (f z (findL x (l++[(y,e)])) (findL x l'))
      (findL x (ocons y' (f y' None (Some e')) acc)) =
    oelse
      (f y0 (findL x (l++[(y, e)])) (findL x (l'++[(y', e')])))
      (findL x acc).
Proof.
 intros Hf AP AP' Ey Ez. simpl.
 destruct findL eqn:INl.
 - exists z; split; auto.
   assert (x < y').
   { apply findL_inA in INl. apply InA_alt in INl.
     destruct INl as ((x',e0') & (Hx',_) & INl).
     compute in Hx'. rewrite Hx'.
     rewrite in_app_iff in INl. destruct INl.
     - rewrite <- Ey. apply (AP (x',e0') (y,e)); simpl; auto.
     - simpl in H. destruct H as [[= <- _]|[  ]]; auto. }
   setoid_rewrite findL_app.
   destruct (findL x l'); simpl; breako.
 - clear INl.
   setoid_rewrite findL_app.
   destruct (findL x l') eqn:INl'; simpl.
   + exists z; split; auto.
     enough (x < y') by breako.
     { apply findL_inA in INl'. apply InA_alt in INl'.
       destruct INl' as ((x',e0') & (Hx',_) & INl').
       compute in Hx'. rewrite Hx'.
       apply (AP' (x',e0') (y',e')); simpl; auto. }
   + clear INl'. rewrite Hf. simpl.
     destruct (f y' _ _) eqn:Fy'; simpl;
      destmatch; try setoid_rewrite Hf; firstorder;
        exists y'; now rewrite Fy'.
Qed.

Lemma merge_find_gt f l l' acc x y y' z e e' :
  (forall k : key, f k None None = None) ->
  l < [(y, e)] ->
  l' < [(y', e')] ->
  y' < y -> z == x ->
  exists y0 : K.t,
    y0 == x /\
    oelse (f z (findL x l) (findL x (l' ++ [(y',e')])))
      (findL x (ocons y (f y (Some e) None) acc)) =
    oelse
      (f y0 (findL x (l ++ [(y, e)])) (findL x (l' ++ [(y', e')])))
      (findL x acc).
Proof.
 intros Hf AP AP' Ey Ez.
 simpl. setoid_rewrite (findL_app x l).
 destruct findL eqn:INl.
 - exists z; split; auto.
   assert (x < y).
   { apply findL_inA in INl. apply InA_alt in INl.
     destruct INl as ((x',e0') & (Hx',_) & INl).
     compute in Hx'. rewrite Hx'.
     apply (AP (x',e0') (y,e)); simpl; auto. }
   destruct (findL x (l' ++ _)); simpl; breako.
 - clear INl.
   destruct (findL x (l' ++ _)) eqn:INl'; simpl.
   + exists z; split; auto.
     enough (x < y) by breako.
     { apply findL_inA in INl'. apply InA_alt in INl'.
       destruct INl' as ((x',e0') & (Hx',_) & INl').
       compute in Hx'. rewrite Hx'.
       rewrite in_app_iff in INl'. simpl in *. destruct INl'.
       - rewrite <- Ey. apply (AP' (x',e0') (y',e')); simpl; auto.
       - destruct H as [[= <- _]|[  ]]; auto. }
   + clear INl'. rewrite Hf. simpl.
     destruct (f y _ _) eqn:Fy; simpl;
      destmatch; try setoid_rewrite Hf; firstorder;
        exists y; now rewrite Fy.
Qed.

Lemma mergeL_find f l l' acc x :
 (forall k, f k None None = None) ->
 sort O.ltk (rev l) ->
 sort O.ltk (rev l') ->
 exists y, y == x /\
  findL x (mergeL f l l' acc) =
  oelse (f y (findL x (rev l)) (findL x (rev l'))) (findL x acc).
Proof.
 intros Hf.
 revert l' acc.
 induction l as [|(y,e) l IHl].
 - simpl. intros l' acc _ Sl'.
   destruct (@mapoL_find _ _ (fun k v' => f k None (Some v')) l' acc x Sl')
     as (y & Hy & EQ).
   exists y; split; auto; rewrite EQ; clear EQ.
   destruct findL; simpl; rewrite ?Hf; auto.
 - induction l' as [|(y',e') l' IHl'].
   + intros acc Sl _. clear IHl.
     destruct (@mapoL_find _ _ (fun k v => f k (Some v) None) _ acc x Sl)
       as (z & Hz & EQ).
     exists z; split; auto. cbn - [mapoL]. rewrite EQ; clear EQ.
     simpl. destruct findL; simpl; rewrite ?Hf; auto.
   + intros acc Sl Sl'.
     simpl in Sl, Sl'.
     assert (Sl0 := Sl). assert (Sl0' := Sl').
     rewrite sort_app_key in Sl, Sl'.
     destruct Sl as (Sl & _ & AP). destruct Sl' as (Sl' & _ & AP').
     rewrite mergeL_eqn. destmatch; [intro EQ | intro LT | intro LT];
      set (acc' := ocons _ _ _).
     * destruct (IHl l' acc') as (z & Hz & E); auto.
       rewrite E. apply merge_find_eq; auto.
     * destruct (IHl' acc') as (z & Hz & E); auto.
       setoid_rewrite E. apply merge_find_lt; auto.
     * destruct (IHl ((y',e')::l') acc') as (z & Hz & E); auto.
       setoid_rewrite E. apply merge_find_gt; auto.
Qed.

Lemma merge_spec1n f m m' x `{!Ok m, !Ok m'} :
 (forall k, f k None None = None) ->
 exists y, y == x /\
           find x (merge f m m') = f y (find x m) (find x m').
Proof.
 intros Hf.
 assert (Ok (merge f m m')) by ok.
 destruct (@mergeL_find f (rev_bindings m) (rev_bindings m') nil x)
   as (y & Hy & EQ); auto.
 - rewrite rev_bindings_rev, rev_involutive; now apply bindings_sort.
 - rewrite rev_bindings_rev, rev_involutive; now apply bindings_sort.
 - exists y; split; auto.
   unfold merge in *. rewrite <- !findL_find; auto.
   rewrite treeify_bindings, EQ. simpl. clear EQ.
   rewrite rev_bindings_rev, rev_involutive.
   rewrite rev_bindings_rev, rev_involutive.
   now destruct f.
Qed.

Lemma merge_spec1 f m m' x `{!Ok m, !Ok m'} :
 (x ∈ m \/ x ∈ m') ->
 exists y, y == x /\
           find x (merge f m m') = f y (find x m) (find x m').
Proof.
 set (g := fun x o o' => match o,o' with None, None => None
                                        | _,_ => f x o o' end).
 destruct (@merge_spec1n g m m' x) as (y & Hy & EQ); auto.
 change (merge f) with (merge g).
 exists y; split; auto. rewrite EQ.
 destruct (find x m) eqn:F; simpl; auto.
 destruct (find x m') eqn:F'; simpl; auto.
 rewrite not_find_iff in F, F'; intuition.
Qed.

End Merge.

(** *** Filtering *)

Section Filter.
Variable elt : Type.
Implicit Types f : key -> elt -> bool.

Fixpoint filter_aux f m acc :=
 match m with
 | Leaf => acc
 | Node _ l k v r =>
   let acc := filter_aux f r acc in
   if f k v then filter_aux f l ((k,v)::acc)
   else filter_aux f l acc
 end.

Definition filter f m := treeify (filter_aux f m nil).

Fixpoint partition_aux f m acc1 acc2 :=
 match m with
 | Leaf => (acc1,acc2)
 | Node _ l k v r =>
   let (acc1, acc2) := partition_aux f r acc1 acc2 in
   if f k v then partition_aux f l ((k,v)::acc1) acc2
   else partition_aux f l acc1 ((k,v)::acc2)
 end.

Definition partition f m :=
  let (l1,l2) := partition_aux f m nil nil in
  (treeify l1, treeify l2).

(** *** Filter *)

Lemma filter_aux_bindings f m acc :
 filter_aux f m acc = List.filter (fun '(k,e) => f k e) (bindings m) ++ acc.
Proof.
 revert acc.
 induction m as [|c l IHl x v r IHr]; trivial.
 intros acc.
 rewrite <- (List.app_nil_r (bindings _)).
 rewrite bindings_node, !filter_app. simpl. rewrite List.app_nil_r.
 destruct (f x v); now rewrite IHl, IHr, app_ass.
Qed.

Lemma filter_spec0 f m :
 bindings (filter f m) = List.filter (fun '(k,e) => f k e) (bindings m).
Proof.
 unfold filter.
 now rewrite treeify_bindings, filter_aux_bindings, app_nil_r.
Qed.

Lemma filter_spec f m `{!Ok m} :
 bindings (filter f m) = List.filter (fun '(k,e) => f k e) (bindings m).
Proof.
 unfold filter.
 now rewrite treeify_bindings, filter_aux_bindings, app_nil_r.
Qed.

 #[export] Instance filter_ok f m `(!Ok m) : Ok (filter f m).
Proof.
 apply bindings_sort.
 rewrite filter_spec0.
 apply filter_sort with O.eqk; ok. now apply bindings_sort.
Qed.

Lemma filter_mapsto f m (Hf : Proper (K.eq==>eq==>eq) f) k v :
 MapsTo k v (filter f m) <-> MapsTo k v m /\ f k v = true.
Proof.
 rewrite <- bindings_spec1, filter_spec0, filter_InA, bindings_spec1.
 easy.
 intros (?,?) (?,?) (?,?); now apply Hf.
Qed.

(** *** Partition *)

Lemma partition_aux_spec f m acc1 acc2 :
 partition_aux f m acc1 acc2 =
  (filter_aux f m acc1, filter_aux (fun k e => negb (f k e)) m acc2).
Proof.
 revert acc1 acc2.
 induction m as [ | c l Hl x e r Hr ]; simpl.
 - trivial.
 - intros acc1 acc2.
   destruct (f x e); simpl; now rewrite Hr, Hl.
Qed.

Lemma partition_alt f m :
 partition f m = (filter f m, filter (fun k e => negb (f k e)) m).
Proof.
 unfold partition, filter. now rewrite partition_aux_spec.
Qed.

Lemma partition_spec1 f m :
 Proper (K.eq==>eq==>eq) f ->
 Equal (fst (partition f m)) (filter f m).
Proof. now rewrite partition_alt. Qed.

Lemma partition_spec2 f m :
 Proper (K.eq==>eq==>eq) f ->
 Equal (snd (partition f m)) (filter (fun k e => negb (f k e)) m).
Proof. now rewrite partition_alt. Qed.

#[export] Instance partition_ok1 f m `(!Ok m) : Ok (fst (partition f m)).
Proof. rewrite partition_alt; now apply filter_ok. Qed.

#[export] Instance partition_ok2 f m `(!Ok m) : Ok (snd (partition f m)).
Proof. rewrite partition_alt; now apply filter_ok. Qed.

Lemma partition_spec f m `{!Ok m} :
 prodmap (@bindings _) (partition f m) =
 List.partition (fun '(k,e) => f k e) (bindings m).
Proof.
 rewrite partition_alt, partition_filter. unfold prodmap. f_equal.
 - now apply filter_spec.
 - rewrite filter_spec; auto. f_equiv. now intros (k,e) ? <-.
Qed.

End Filter.
End MakeRaw.

(** ** Encapsulation

   Now, in order to really provide a functor implementing [S], we
   need to encapsulate everything into a type of binary search trees. *)

Module Make (K: OrderedType) <: Interface.S K.
 Module Raw := MakeRaw K.
 Include Raw.Pack K Raw.
End Make.


From Hammer Require Import Hammer.

Require Import Arith.
From IntMap Require Import Allmaps.
From TreeAutomata Require Import bases.
From TreeAutomata Require Import defs.
From TreeAutomata Require Import semantics.
From TreeAutomata Require Import signature.

Inductive pl_path : Set :=
| pl_path_nil : pl_path
| pl_path_cons : ad -> pl_path -> pl_path.

Inductive pl_path_incl : pl_path -> prec_list -> Prop :=
| pl_path_incl_nil : pl_path_incl pl_path_nil prec_empty
| pl_path_incl_cons :
forall (plp : pl_path) (a : ad) (la ls : prec_list),
pl_path_incl plp la ->
pl_path_incl (pl_path_cons a plp) (prec_cons a la ls)
| pl_path_incl_next :
forall (plp : pl_path) (a : ad) (la ls : prec_list),
pl_path_incl plp ls ->
plp <> pl_path_nil -> pl_path_incl plp (prec_cons a la ls).

Inductive pl_path_recon : preDTA -> term_list -> pl_path -> Prop :=
| pl_path_rec_nil : forall d : preDTA, pl_path_recon d tnil pl_path_nil
| pl_path_rec_cons :
forall (d : preDTA) (a : ad) (t : term) (plp : pl_path)
(tl : term_list),
reconnaissance d a t ->
pl_path_recon d tl plp ->
pl_path_recon d (tcons t tl) (pl_path_cons a plp).

Definition pl_path_rec_equiv_0_def (d : preDTA) (pl : prec_list)
(tl : term_list) :=
liste_reconnait d pl tl ->
exists plp : pl_path, pl_path_incl plp pl /\ pl_path_recon d tl plp.

Fixpoint pl_path_length (plp : pl_path) : nat :=
match plp with
| pl_path_nil => 0
| pl_path_cons _ p => S (pl_path_length p)
end.

Lemma pl_path_exists :
forall pl : prec_list, exists p : pl_path, pl_path_incl p pl.
Proof. hammer_hook "pl_path" "pl_path.pl_path_exists".
simple induction pl. intros. elim H. intros. split with (pl_path_cons a x).
exact (pl_path_incl_cons x a p p0 H1). split with pl_path_nil.
exact pl_path_incl_nil.
Qed.

Lemma non_empty_pl_path_exists :
forall pl : prec_list,
pl <> prec_empty ->
exists p : pl_path, pl_path_incl p pl /\ 1 <= pl_path_length p.
Proof. hammer_hook "pl_path" "pl_path.non_empty_pl_path_exists".
simple induction pl. intros. elim (pl_path_exists p). intros. split with (pl_path_cons a x).
split. exact (pl_path_incl_cons x a p p0 H2). simpl in |- *. exact (le_n_S _ _ (le_O_n (pl_path_length x))). intros. elim (H (refl_equal _)).
Qed.

Lemma pl_path_rec_equiv_0_0 :
forall d : preDTA, pl_path_rec_equiv_0_def d prec_empty tnil.
Proof. hammer_hook "pl_path" "pl_path.pl_path_rec_equiv_0_0".
unfold pl_path_rec_equiv_0_def in |- *. intros. inversion H. split with pl_path_nil.
split. exact pl_path_incl_nil. exact (pl_path_rec_nil d).
Qed.

Lemma pl_path_rec_equiv_0_1 :
forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
(tl : term_list),
reconnaissance d a hd ->
liste_reconnait d la tl ->
pl_path_rec_equiv_0_def d la tl ->
pl_path_rec_equiv_0_def d (prec_cons a la ls) (tcons hd tl).
Proof. hammer_hook "pl_path" "pl_path.pl_path_rec_equiv_0_1".
unfold pl_path_rec_equiv_0_def in |- *. intros. elim (H1 H0). intros. elim H3. intros.
split with (pl_path_cons a x). split. exact (pl_path_incl_cons x a la ls H4).
exact (pl_path_rec_cons d a hd x tl H H5).
Qed.

Lemma pl_path_rec_equiv_0_2 :
forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
(tl : term_list),
liste_reconnait d ls (tcons hd tl) ->
pl_path_rec_equiv_0_def d ls (tcons hd tl) ->
pl_path_rec_equiv_0_def d (prec_cons a la ls) (tcons hd tl).
Proof. hammer_hook "pl_path" "pl_path.pl_path_rec_equiv_0_2".
unfold pl_path_rec_equiv_0_def in |- *. intros. elim (H0 H). intros. split with x.
elim H2. intros. split. apply (pl_path_incl_next x a la ls). exact H3.
intro. rewrite H5 in H4. inversion H4. exact H4.
Qed.

Lemma pl_path_rec_equiv_0_3 :
forall (p : preDTA) (p0 : prec_list) (t : term_list),
liste_reconnait p p0 t -> pl_path_rec_equiv_0_def p p0 t.
Proof. hammer_hook "pl_path" "pl_path.pl_path_rec_equiv_0_3".
exact
(liste_reconnait_ind pl_path_rec_equiv_0_def pl_path_rec_equiv_0_0
pl_path_rec_equiv_0_1 pl_path_rec_equiv_0_2).
Qed.

Lemma pl_path_rec_equiv_0 :
forall (d : preDTA) (pl : prec_list) (tl : term_list),
liste_reconnait d pl tl ->
exists plp : pl_path, pl_path_incl plp pl /\ pl_path_recon d tl plp.
Proof. hammer_hook "pl_path" "pl_path.pl_path_rec_equiv_0".
intros. elim (pl_path_rec_equiv_0_3 d pl tl H H). intros. split with x. exact H0.
Qed.

Definition pl_path_rec_equiv_1_def (plp : pl_path)
(pl : prec_list) :=
pl_path_incl plp pl ->
forall (d : preDTA) (tl : term_list) (n : nat),
pl_path_recon d tl plp -> pl_tl_length pl n -> liste_reconnait d pl tl.

Lemma pl_path_rec_equiv_1_0 : pl_path_rec_equiv_1_def pl_path_nil prec_empty.
Proof. hammer_hook "pl_path" "pl_path.pl_path_rec_equiv_1_0".
unfold pl_path_rec_equiv_1_def in |- *. intros. inversion H0.
exact (rec_empty d).
Qed.

Lemma pl_path_rec_equiv_1_1 :
forall (plp : pl_path) (a : ad) (la ls : prec_list),
pl_path_incl plp la ->
pl_path_rec_equiv_1_def plp la ->
pl_path_rec_equiv_1_def (pl_path_cons a plp) (prec_cons a la ls).
Proof. hammer_hook "pl_path" "pl_path.pl_path_rec_equiv_1_1".
unfold pl_path_rec_equiv_1_def in |- *. intros. inversion H2. apply (rec_consi d a la ls t tl0). exact H8. induction  n as [| n Hrecn]. inversion H3. apply (H0 H d tl0 n H9). inversion H3. exact H11. exact H12.
Qed.

Lemma pl_path_rec_equiv_1_2 :
forall (plp : pl_path) (a : ad) (la ls : prec_list),
pl_path_incl plp ls ->
pl_path_rec_equiv_1_def plp ls ->
plp <> pl_path_nil -> pl_path_rec_equiv_1_def plp (prec_cons a la ls).
Proof. hammer_hook "pl_path" "pl_path.pl_path_rec_equiv_1_2".
unfold pl_path_rec_equiv_1_def in |- *. intros. induction  n as [| n Hrecn].
inversion_clear H4.
induction  tl as [| t tl Hrectl]. inversion H3. rewrite <- H7 in H2. inversion_clear H2.
elim H8; trivial.
apply (rec_consn d a la ls t tl).
apply (H0 H d (tcons t tl) (S n) H3). inversion H4. rewrite <- H8 in H.
inversion H. elim H1; auto.
exact H10.
Qed.

Lemma pl_path_rec_equiv_1_3 :
forall (p : pl_path) (p0 : prec_list),
pl_path_incl p p0 -> pl_path_rec_equiv_1_def p p0.
Proof. hammer_hook "pl_path" "pl_path.pl_path_rec_equiv_1_3".
exact
(pl_path_incl_ind pl_path_rec_equiv_1_def pl_path_rec_equiv_1_0
pl_path_rec_equiv_1_1 pl_path_rec_equiv_1_2).
Qed.

Lemma pl_path_rec_equiv_1 :
forall (plp : pl_path) (pl : prec_list),
pl_path_incl plp pl ->
forall (d : preDTA) (tl : term_list) (n : nat),
pl_path_recon d tl plp -> pl_tl_length pl n -> liste_reconnait d pl tl.
Proof. hammer_hook "pl_path" "pl_path.pl_path_rec_equiv_1".
intros. exact (pl_path_rec_equiv_1_3 plp pl H H d tl n H0 H1).
Qed.

Lemma pl_path_rec_length :
forall (plp : pl_path) (tl : term_list) (d : preDTA),
pl_path_recon d tl plp -> pl_path_length plp = lst_length tl.
Proof. hammer_hook "pl_path" "pl_path.pl_path_rec_length".
simple induction plp. intros. inversion H. simpl in |- *. reflexivity. intros. inversion H0.
simpl in |- *. rewrite (H tl0 d). reflexivity. exact H6.
Qed.

Definition liste_rec_length_def (d : preDTA) (pl : prec_list)
(tl : term_list) : Prop :=
forall n : nat,
liste_reconnait d pl tl -> pl_tl_length pl n -> n = lst_length tl.

Lemma liste_rec_length_0 :
forall d : preDTA, liste_rec_length_def d prec_empty tnil.
Proof. hammer_hook "pl_path" "pl_path.liste_rec_length_0".
unfold liste_rec_length_def in |- *. intros. inversion H0. reflexivity.
Qed.

Lemma liste_rec_length_1 :
forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
(tl : term_list),
reconnaissance d a hd ->
liste_reconnait d la tl ->
liste_rec_length_def d la tl ->
liste_rec_length_def d (prec_cons a la ls) (tcons hd tl).
Proof. hammer_hook "pl_path" "pl_path.liste_rec_length_1".
unfold liste_rec_length_def in |- *. intros. induction  n as [| n Hrecn]. inversion H3. inversion H3.
simpl in |- *. rewrite <- (H1 n H0 H5). reflexivity. simpl in |- *. rewrite <- (H1 n H0 H6).
reflexivity.
Qed.

Lemma liste_rec_length_2 :
forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
(tl : term_list),
liste_reconnait d ls (tcons hd tl) ->
liste_rec_length_def d ls (tcons hd tl) ->
liste_rec_length_def d (prec_cons a la ls) (tcons hd tl).
Proof. hammer_hook "pl_path" "pl_path.liste_rec_length_2".
unfold liste_rec_length_def in |- *. intros. simpl in |- *. induction  n as [| n Hrecn]. inversion H2.
simpl in H0. inversion H2. rewrite <- H6 in H. inversion H.
rewrite <- (H0 (S n) H H8). reflexivity.
Qed.

Lemma liste_rec_length_3 :
forall (p : preDTA) (p0 : prec_list) (t : term_list),
liste_reconnait p p0 t -> liste_rec_length_def p p0 t.
Proof. hammer_hook "pl_path" "pl_path.liste_rec_length_3".
exact
(liste_reconnait_ind liste_rec_length_def liste_rec_length_0
liste_rec_length_1 liste_rec_length_2).
Qed.

Lemma liste_rec_length :
forall (pl : prec_list) (tl : term_list) (d : preDTA) (n : nat),
liste_reconnait d pl tl -> pl_tl_length pl n -> n = lst_length tl.
Proof. hammer_hook "pl_path" "pl_path.liste_rec_length".
intros. exact (liste_rec_length_3 d pl tl H n H H0).
Qed.

Definition pl_path_incl_length_def (plp : pl_path)
(pl : prec_list) : Prop :=
forall n : nat,
pl_path_incl plp pl -> pl_tl_length pl n -> pl_path_length plp = n.

Lemma pl_path_incl_length_0 : pl_path_incl_length_def pl_path_nil prec_empty.
Proof. hammer_hook "pl_path" "pl_path.pl_path_incl_length_0".
unfold pl_path_incl_length_def in |- *. intros. inversion H0. reflexivity.
Qed.

Lemma pl_path_incl_length_1 :
forall (plp : pl_path) (a : ad) (la ls : prec_list),
pl_path_incl plp la ->
pl_path_incl_length_def plp la ->
pl_path_incl_length_def (pl_path_cons a plp) (prec_cons a la ls).
Proof. hammer_hook "pl_path" "pl_path.pl_path_incl_length_1".
unfold pl_path_incl_length_def in |- *. intros. inversion H2. simpl in |- *.
rewrite (H0 n0 H H7). reflexivity. simpl in |- *. rewrite (H0 n0 H H7).
reflexivity.
Qed.

Lemma pl_path_incl_length_2 :
forall (plp : pl_path) (a : ad) (la ls : prec_list),
pl_path_incl plp ls ->
pl_path_incl_length_def plp ls ->
plp <> pl_path_nil -> pl_path_incl_length_def plp (prec_cons a la ls).
Proof. hammer_hook "pl_path" "pl_path.pl_path_incl_length_2".
unfold pl_path_incl_length_def in |- *. intros. inversion H3. rewrite <- H7 in H.
inversion H. elim (H1 (sym_eq H9)). exact (H0 (S n0) H H9).
Qed.

Lemma pl_path_incl_length_3 :
forall (p : pl_path) (p0 : prec_list),
pl_path_incl p p0 -> pl_path_incl_length_def p p0.
Proof. hammer_hook "pl_path" "pl_path.pl_path_incl_length_3".
exact
(pl_path_incl_ind pl_path_incl_length_def pl_path_incl_length_0
pl_path_incl_length_1 pl_path_incl_length_2).
Qed.

Lemma pl_path_incl_length :
forall (plp : pl_path) (pl : prec_list) (n : nat),
pl_path_incl plp pl -> pl_tl_length pl n -> pl_path_length plp = n.
Proof. hammer_hook "pl_path" "pl_path.pl_path_incl_length".
intros. exact
(pl_path_incl_ind pl_path_incl_length_def pl_path_incl_length_0
pl_path_incl_length_1 pl_path_incl_length_2 plp pl H n H H0).
Qed.

Lemma forall_incl_length :
forall (pl : prec_list) (n : nat),
(forall p : pl_path, pl_path_incl p pl -> pl_path_length p = n) ->
pl_tl_length pl n.
Proof. hammer_hook "pl_path" "pl_path.forall_incl_length".
simple induction pl. intros. elim (nat_sum n); intros. rewrite H2 in H1.
elim (non_empty_pl_path_exists (prec_cons a p p0)). intros.
elim (le_Sn_O 0). elim H3. intros. rewrite (H1 x H4) in H5. exact H5.
intro. inversion H3. elim H2. intros. rewrite H3. rewrite H3 in H1.
elim (pl_sum p0); intros. rewrite H4. apply (pl_tl_S a p x). apply (H x). intros. apply (Sn_eq_Sm_n_eq_m (pl_path_length p1) x). replace (S (pl_path_length p1)) with (pl_path_length (pl_path_cons a p1)).
apply (H1 (pl_path_cons a p1)). exact (pl_path_incl_cons p1 a p p0 H5).
reflexivity. apply (pl_tl_propag a p p0 x). apply (H x). intros.
cut (pl_path_length (pl_path_cons a p1) = S x). intros. simpl in H6.
inversion H6. reflexivity. exact (H1 (pl_path_cons a p1) (pl_path_incl_cons p1 a p p0 H5)). apply (H0 (S x)). intros. apply (H1 p1). apply (pl_path_incl_next p1 a p p0 H5). intro. rewrite H6 in H5. elim H4. intros. elim H7. intros. elim H8. intros.
rewrite H9 in H5. inversion H5. exact (H15 (refl_equal _)).
intros. induction  n as [| n Hrecn]. exact pl_tl_O. elim (pl_path_exists prec_empty).
intros. cut (S n = 0). intros. inversion H1. transitivity (pl_path_length x). symmetry  in |- *. exact (H x H0). inversion H0.
reflexivity.
Qed.


(** * EqmR-related laws for the state monad. *)

(* begin hide *)
From Coq Require Import
     Lia
     Setoid
     Morphisms.

From ExtLib Require Import
     Structures.Monad
     Structures.MonadState
     Structures.Functor.

From ITree Require Import
     Basics.Basics
     Basics.CategoryOps
     Basics.HeterogeneousRelations.

From ITree Require Import
     EqmR.EqmRMonad
     Basics.Tacs.

Import ITree.Basics.Basics.Monads.
Import FunctorNotation.
Import CatNotations.
Local Open Scope cat_scope.
Local Open Scope cat.

Import RelNotations.
Local Open Scope relationH_scope.

Existing Class inhabited.
(* end hide *)

Section StateEq.
  Variable S : Type.

  Definition state (s a : Type) : Type :=
    s -> s * a.

  Definition eqmR_state (A B : Type) (R : relationH A B) :=
    fun (x : state S A) (y : state S B) =>
      forall (s : S),
        R (snd (x s)) (snd (y s)) /\ fst (x s) = fst (y s).

  Lemma equal_typ {A} {x : A} : x = x. reflexivity. Qed.

  #[global]
   Instance EqmR_state : EqmR (state S) := {|eqmR := eqmR_state|}.

  (* Couple properties about state [mayRet]. *)
  Definition state_prop {A : Type} (ma : state S A) :=
    (fun a : A => exists s s', ma s = (s', a)).

  Definition const_state {A : Type} (s : S) (a : A) : S -> (S * A) :=
    fun s => (s, a).

  Lemma mayRet_state {A:Type} (ma : state S A) (a : A) :
    (exists s s' : S, (ma s) = (s', a)) <->
    a ∈ ma.
  Proof.
    split. intro.
    - edestruct H as (? & ? & ?); clear H.
      red. red. repeat intro.
      red in EQR; unfold eqmR_state in EQR.
      specialize (EQR x). crunch. subst. rewrite H0 in H; auto.
    - intros EQR. repeat red in EQR.
      epose (state_prop ma : A -> Prop) as Q.
      assert (eqmR (diagonal_prop Q) ma ma).
      { intro. cbn. split.
        - intros.
          unfold state_prop. split. repeat red.
          exists s. destruct (ma s) eqn: Hma. cbn in *. subst. eauto.
          exists s. destruct (ma s) eqn: Hma. cbn in *. subst. eauto.
        - reflexivity.
      }
      specialize (EQR (diagonal_prop Q) (diagonal_prop_PER Q) H).
      unfold diagonal_prop in EQR.
      destruct EQR. clear H1 H.
      edestruct H0 as (? & ? & ?).
      auto.
  Qed.

  (* The [eqmR_state] definition is [EqmR_OK]. *)
  Ltac destruct_hyp :=
    match goal with
    | [H : (_ /\ _) /\ fst (?x ?s0) = fst (?y ?s1) |- _] =>
      destruct H as ((? & ?) & ?); destruct (x s0) eqn: ?HX;
      destruct (y s1) eqn : ?HY; cbn in *; subst
    | [H : (_ /\ _) /\ _ = _ |- _] =>
      destruct H as ((? & ?) & <-)
    end.

  Ltac rewrite_eq :=
    do 2 match goal with
    | [H : forall _, ?x = _ -> _ |- _] => destruct (H x) as (? & ? & <-); try reflexivity; clear H
    end; eauto.

  Ltac ok_crush :=
    cbn in *;
    match goal with
    | [ x : S , H : eqmR_state _ _ _ _ _ |- _ ] => specialize (H x)
    end;
    destruct_hyp; split; [ split | ]; auto; intros * <-; rewrite_eq.

  Instance eqmR_conj_state: RelConj (state S).
  Proof.
    intros A B R1 R2 ma mb H H0.
    cbn in *. unfold eqmR_state in *.
    intros. split; cycle 1.
    specialize (H s); specialize (H0 s). crunch.
    auto.
    specialize (H s). crunch. subst.
    specialize (H0 s). crunch. subst. eauto.
    specialize (H0 s). crunch. subst. eauto.
  Qed.

  Lemma eqmR_transport_refl_St:
    forall (A : Type) (R : relationH A A), Reflexive R -> Reflexive (eqmR R).
  Proof.
    repeat intro.  split; eauto.
  Qed.

  Instance eqmR_Proper_eq_St:
    forall A B : Type, Proper (eq_rel ==> eqmR (@eq A) ==> eqmR (@eq B) ==> Basics.flip Basics.impl) eqmR.
  Proof.
    repeat intro. split; eauto; repeat red in H0, H1, H2; edestruct H0, H1, H2.
    - apply H. rewrite H3, H5. eauto.
    - edestruct H0, H1, H2. rewrite H4, H6. eauto.
      Unshelve. all: eauto.
  Qed.

  (* State monad is a monad. *)
  Definition ret_state (A : Type) (x : A) := fun s : S => (s, x).

  Definition bind_state (A B : Type) (sa : state S A) (f : A -> state S B) :=
    (fun s : S => (f (snd (sa s)) (fst (sa s)))).

  Global Instance Monad_state : Monad (state S) :=
    {|
      ret := ret_state;
      bind := bind_state
    |}.

  Global Instance MonadState_state : MonadState S (state S) :=
    {|
      get := (fun x => (x, x));
      put := (fun v => (fun _ => (v, tt)))
    |}.

  Ltac unfold_state := unfold fmap, bind, Monad_state, bind_state, ret, ret_state; cbn in *.

  Instance eqmR_prod_fst_inv_state : FmapFst (state S).
  Proof.
    repeat intro.
    repeat red in H. unfold_state.
    specialize (H s); crunch;
      destruct (m1 s) eqn: Hma; destruct (m2 s) eqn: Hma';
        cbn in *; subst; auto.
    destruct p, p0; inv H; eauto.
  Defined.

  Instance eqmR_prod_snd_inv_state : FmapSnd (state S).
  Proof.
    repeat intro.
    repeat red in H. unfold_state.
    specialize (H s); crunch;
      destruct (m1 s) eqn: Hma; destruct (m2 s) eqn: Hma';
        cbn in *; subst; auto.
    destruct p, p0; inv H; eauto.
  Defined.

  Instance eqmR_prod_rel_state : RelProd (state S).
  Proof.
    intros. red. split; eauto. red in H, H0.
    unfold eqmR_state in *.
    destruct (snd (m1 s)) eqn: Hm1.
    destruct (snd (m2 s)) eqn: Hm2.
    cbn in *. constructor; eauto.
    specialize (H s); specialize (H0 s).
    rewrite Hm1 in H, H0.
    rewrite Hm2 in H, H0.
    crunch. cbn in *; eauto.
    specialize (H s); specialize (H0 s).
    rewrite Hm1 in H, H0.
    rewrite Hm2 in H, H0.
    crunch. eauto. cbn in *; eauto.
    cbn in *; unfold eqmR_state in *; crunch; eauto.
    specialize (H s); specialize (H0 s). crunch.
    unfold bind_state, ret_state in *. cbn in *. eauto.
  Defined.

  Instance eqmR_sum_inl_state : FmapInl (state S).
  Proof.
    repeat intro.
    repeat red in H. unfold_state.
    specialize (H s); crunch;
      destruct (m1 s) eqn: Hma; destruct (m2 s) eqn: Hma';
        cbn in *; subst; auto.
  Defined.

  Instance eqmR_sum_inr_state : FmapInr (state S).
  Proof.
    repeat intro.
    repeat red in H. unfold_state.
    specialize (H s); crunch;
      destruct (m1 s) eqn: Hma; destruct (m2 s) eqn: Hma';
        cbn in *; subst; auto.
  Defined.

  Instance eqmR_sum_rel_state : RelSum (state S).
  Proof.
    repeat intro.
    repeat red in H. unfold_state.
    split; repeat intro.
    - specialize (H s); crunch;
      destruct (m1 s) eqn: Hma; destruct (m2 s) eqn: Hma';
        cbn in *; subst; auto.
      destruct s1, s3; inv H.
      apply H0. auto. apply H1; auto.
    - specialize (H (A1 + B1)%type (A2 + B2)%type inl inl inr inr (RA ⊕ RB)).
      assert (inl_P :ProperH (respectfulH A1 A2 (A1 + B1) (A2 + B2) RA (RA ⊕ RB)) inl inl) by
        (repeat intro; constructor; eauto).
      assert (inr_P: ProperH (respectfulH B1 B2 (A1 + B1) (A2 + B2) RB (RA ⊕ RB)) inr inr) by
        (repeat intro; constructor; eauto).
      destruct (m1 s) eqn: Hma; destruct (m2 s) eqn: Hma'.
      cbn.
      specialize (H inl_P inr_P s). cbn in *.
      rewrite Hma, Hma' in H; cbn in *.
      crunch; eauto.
      destruct s1, s3; crunch; eauto.
  Defined.

  Lemma eqmR_prod_sum_rel_state :
    forall (A B C : Type) (ma ma' : state S (C + A * B)%type)
      (RA : relationH A A) (RB : relationH B B) (RC : relationH C C),
      (fst_sum <$> ma) ≈{ RC ⊕ RA } (fst_sum <$> ma') ->
      (snd_sum <$> ma) ≈{ RC ⊕ RB } (snd_sum <$> ma') -> ma ≈{ RC ⊕ RA ⊗ RB } ma'.
  Proof.
    intros. repeat red in H. repeat red in H0.
    intro. specialize (H s); specialize (H0 s). crunch.
    all : unfold fmap, fst_sum, snd_sum in *.
    all : inv H0; inv H; inv H1; inv H2;
      destruct (ma s) eqn: Hma; destruct (ma' s) eqn: Hma'; cbn in *; destruct s1 eqn: Hs1; destruct s3 eqn: Hs3.
    all : eauto.
    all : repeat match goal with
          | [H : inl _ = _ |- _] => inv H
          | [H : inr _ = _ |- _] => inv H
          end; eauto.
    constructor. destruct p, p0. eauto.
  Qed.

  Instance eqmR_transport_PER_state : TransportPER (state S).
  Proof.
    split.
    - repeat intro; crunch. repeat red in H0.  symmetry. eauto.
      symmetry. edestruct H0. symmetry. eauto.
      edestruct H0. symmetry. eauto.
    - repeat intro. intros. repeat intro. unfold TransitiveH in H.
      cbn in *. unfold eqmR_state in *.
      destruct (x s) eqn: HX.
      specialize (H0 s).
      specialize (H1 s).
      crunch. subst. etransitivity; eauto.  rewrite <- HX. auto.
      cbn. rewrite HX in *. cbn in *. subst. auto.
  Defined.

  Instance eqmR_rel_comp_state : RelComp (state S).
  Proof.
    repeat intro. cbn in *. unfold eqmR_state in *.
    intros. specialize (H s). specialize (H0 s).
    destruct H. destruct H0. split; eauto. esplit; split; eauto.
    rewrite H1, H2. auto.
  Defined.

  Instance eqmR_lift_transpose_state : LiftTranspose (state S).
  Proof.
    intros.
    split; repeat intro; repeat red in H; specialize (H s) ;
      crunch; eauto.
  Defined.

  Instance eqmR_Proper_state :
    forall A B : Type, Proper (eq_rel (A:=A) (B:=B) ==> eq_rel) eqmR.
  Proof.
    repeat intro; split; repeat intro; crunch; repeat red in H0;
      specialize (H0 s); crunch; subst; try eexists; try split;
        eauto; apply H; auto.
  Defined.

  Instance eqmR_Proper_mono_state:
    forall A B : Type,
      Proper (subrelationH (A:=A) (B:=B) ==> subrelationH (B:=state S B)) eqmR.
  Proof.
    repeat intro; crunch; repeat red in H0; specialize (H0 s);
      crunch; subst; eauto.
  Defined.

  Instance eqmR_transport_Equiv_state: TransportEquiv (state S).
  Proof.
    repeat intro; destruct H; split; try typeclasses eauto.
    repeat intro; eauto.
    eapply eqmR_transport_PER_state; split; eauto.
    apply eqmR_transport_PER_state; split; eauto.
  Qed.

  Instance transport_refl : TransportReflexive (state S).
  repeat intro; eauto.
  Qed.

  Instance transport_symm : TransportSymmetric (state S).
  repeat intro; eauto. repeat red in H0. edestruct H0; eauto.
  Qed.

  Instance transport_trans : TransportTransitive (state S).
  repeat intro; eauto. repeat red in H0. edestruct H0, H1; split; subst; eauto.
  rewrite H3. auto.
  Qed.

  Global Instance EqmR_OK_state : EqmR_OK (state S).
  Proof.
    constructor; try typeclasses eauto.
  Defined.

  Opaque mayRet.

  (* EqmRMonad properties for state monad. *)
  Lemma mayRet_image :
    forall A (a: A) ma, (a ∈ ma -> image ma a a).
  Proof.
    intros. apply H.
  Qed.

  Lemma image_eqmR_state :
    forall (A : Type) (ma : state S A), ma ≈{ image ma } ma.
  Proof.
    intros. cbn. unfold eqmR_state. intros. cbn.
    destruct (ma s) eqn: Hma.
    cbn in *. split.
    - intros. repeat red. intros. repeat red in EQR.
      edestruct EQR. rewrite Hma in *. cbn in *; auto.
    - reflexivity.
  Qed.

  Instance eqmR_mayRet_l_state : MayRetL (state S).
  Proof.
    red;intros.
    rewrite <- mayRet_state in H. edestruct H as (? & ? & ?); clear H.
    cbn in *.
    destruct (ma1 x) eqn: Hma. cbn in *.
    inv H0. rename EQH into H.
    unfold eqmR_state in H. cbn in H.
    specialize (H x). setoid_rewrite Hma in H.
    cbn in *. setoid_rewrite <- mayRet_state.
    destruct (ma2 x) eqn: Hma2. cbn in *.
    crunch. eauto.
  Defined.

  Instance eqmR_mayRet_r_state : MayRetR (state S).
  Proof.
    red;intros.
    rewrite <- mayRet_state in H. edestruct H as (? & ? & ?); clear H.
    cbn in *.
    destruct (ma1 x) eqn: Hma. cbn in *.
    inv H0. rename EQH into H.
    unfold eqmR_state in H. cbn in H.
    specialize (H x). setoid_rewrite Hma in H. crunch.
    cbn in *. setoid_rewrite <- mayRet_state.
    exists a. split; eauto. rewrite H1 in H. auto.
  Defined.

  Instance eqmR_ret_state : RetFinal (state S).
  Proof.
    red; intros. cbn. unfold eqmR_state. cbn. intros.
    split.
    - eauto.
    - reflexivity.
  Defined.

  Instance eqmR_bind_ProperH_state : ProperBind (state S).
  Proof.
    red;intros.
    cbn in *. unfold eqmR_state in *. cbn in *. intro.
    specialize (H s).
    destruct (ma1 s) eqn: Hma1. destruct (ma2 s) eqn: Hma2. cbn in *. subst.

    destruct H.
    specialize (H0 _ _ H). subst.
    edestruct H0; eauto. constructor; eauto.

    unfold bind_state. rewrite Hma1, Hma2. cbn. eauto.
    unfold bind_state. rewrite Hma1, Hma2. cbn. eauto.
  Qed.

  Instance eqmR_bind_ret_l_state : BindRetL (state S).
  Proof.
    red;intros. repeat red. cbn. intros.
    unfold bind_state, ret_state. cbn in *. split; auto.
  Defined.

  Instance eqmR_bind_ret_r_state : BindRetR (state S).
  Proof.
    repeat intro. cbn. split; try split; try reflexivity.
  Defined.

  Instance eqmR_bind_bind_state : BindBind (state S).
  Proof.
    repeat intro. cbn.
    unfold bind_state.
    split; try split; try reflexivity;
      intros; subst.
  Defined.

  Global Instance EqmRMonad_state : EqmRMonadLaws (state S).
  Proof.
    constructor; try typeclasses eauto.
    repeat intro. eapply image_eqmR_state.
  Qed.

  (* [EqmRMonadInverses] for state monad. *)

  Lemma are_continuations_functions:
    forall {A B : Type} (a : A) (k : A -> state S B) (mb mb' : state S B),
      k a = mb /\ k a = mb' -> mb = mb'.
  Proof.
    intros. destruct H. rewrite <- H, <- H0. reflexivity.
  Qed.

  Context {IS: inhabited S}.

  Instance ret_inv_St : RetInv (state S).
  Proof.
    inv IS.
    repeat intro. repeat red in H.
    edestruct H. crunch; eauto. Unshelve. eauto.
  Defined.

  Definition imageA {A : Type} : relationH A A :=
    fun a a' =>
      forall (R : relationH A A) (PH : PER R), R a a'.

  Definition mayRetA {A : Type} : A -> Prop :=
    (fun (a : A) => imageA a a).

  Instance state_mayRet_bind_inv : MayRetBindInv (state S).
  Proof.
    red; intros.
    apply mayRet_state in H.
    setoid_rewrite <- mayRet_state.
    crunch.
    unfold bind, Monad_state, bind_state in H.
    destruct (ma x) eqn:Hma1.
    exists a. split; eauto; eauto.
  Defined.

  Lemma fmap_inv_state_hetero :
    forall (A B : Type) (ma ma' : state S A) (f f' : A -> B) (R : relationH B B),
      (f <$> ma) ≈{ R } (f' <$> ma') ->
      forall a : A, a ∈ ma -> exists a', a' ∈ ma' /\ ret (f a) ≈{ R } ret (f' a').
  Proof.
    repeat intro.
    repeat red in H.
    unfold fmap, bind, ret, Monad_state, bind_state, ret_state in H.
    eapply mayRet_state in H0.
    setoid_rewrite <- mayRet_state. crunch.
    destruct (ma' x) eqn: Hma.
    exists a0. specialize (H x). crunch. cbn in *; rewrite H0, Hma in H, H1.
    crunch; eauto.
    eapply eqmR_ret. typeclasses eauto.
    cbn in *.
    rewrite Hma, H0 in H. eauto.
  Qed.

  Definition state_prop_ {A : Type} (ma ma': state S A) :=
    (fun a a' : A => exists s s' s'' : S, (ma s) = (s', a) /\ (ma' s) = (s'', a')).

  Lemma image_state {A:Type} (ma ma': state S A) (a a': A) :
    (exists s s' s'': S, (ma s) = (s', a) /\ (ma' s) = (s'', a')) ->
    image_ _ ma ma' a a'.
  Proof.
    intro.
    - edestruct H as (? & ? & ?); clear H.
      red. repeat intro.
      red in EQR; unfold eqmR_state in EQR.
      specialize (EQR x). crunch. subst.
      rewrite H, H2 in H0. auto.
  Qed.

  Instance fmap_inv_mayRet_state : FmapInvRet (state S).
  Proof.
    repeat intro.
    repeat red in H.
    unfold fmap, bind, ret, Monad_state, bind_state, ret_state in H.
    eapply mayRet_state in H0.
    crunch.
    specialize (H x). crunch. cbn in *. rewrite H0 in H, H1.
    crunch; eauto. cbn in *; constructor.
  Defined.

  Instance fmap_inv_state_ : FmapInv_mayRet (state S).
  Proof.
    repeat intro.
    Ltac sunfold := unfold fmap, bind, ret, Monad_state, bind_state, ret_state in *; cbn in *; unfold eqmR_state in *.
    sunfold.
    specialize (H s). crunch; destruct (ma1 s) eqn: Hma, (ma2 s) eqn: Hma'; cbn in *; subst; eauto.
    red. rewrite<- !mayRet_state; split; eauto.
  Defined.

  Instance eqmR_inv_state : EqmRInv (state S).
  Proof.
    repeat intro. rewrite <- mayRet_state in H0. destruct H0 as (?&?&?).
    repeat red in H. specialize (H x). rewrite H0 in H.
    destruct H; eauto.
  Qed.

  Global Instance EqmRMonadInverses_state : EqmRInversionProperties (state S).
  Proof.
    constructor; try typeclasses eauto.
  Defined.

  Global Instance EQM_state : EQM (state S) _.
  Proof.
    econstructor; typeclasses eauto.
  Defined.

End StateEq.

Example bind_ret_inv_counterexample:
  forall A B (a:A) (b:B) (x y : nat),
    bind (m := state nat) (fun x => (x+1, a)) (fun x => (fun y => (y-1, b))) ≈{eq} ret b.
Proof.
  intros.
  repeat red. unfold bind, ret, Monad_state, bind_state, ret_state; cbn.
  intros. split; eauto. lia.
Qed.

Definition ma : state nat nat := (fun s => if Nat.eqb s 2 then (s, 0) else (s + 1, 1)).

Definition k : nat -> state nat nat := (fun s => if Nat.eqb s 0 then (fun s => (s, s)) else (fun s => (s, 1))).

Lemma ma_mayRet :
  0 ∈ ma.
Proof. apply mayRet_state. exists 2. cbn. exists 2; eauto. Qed.

Lemma k_mayRet :
  0 ∈ k 0.
Proof. apply mayRet_state. cbn. eauto. Qed.

Lemma bind_mayRet:
  ~ (0 ∈ bind ma k).
Proof.
  intro. apply mayRet_state in H. destruct H as (? & ? & ?).
  cbn in *. unfold bind_state in H.
  unfold ma in H.
  destruct (Nat.eqb x 2) eqn: Hx. cbn in *.
  apply EqNat.beq_nat_true in Hx. subst. inv H. cbn in *. inv H.
Qed.


From Undecidability Require StringRewriting.SR.
From Undecidability Require StringRewriting.Util.Definitions.
Module SR_facts := StringRewriting.Util.Definitions.
From Undecidability Require Import TM.SBTM TM.Util.SBTM_facts.
From Undecidability Require Import StringRewriting.Reductions.SBTM_HALT_to_SR.

Require Import PeanoNat Lia.

Require Import List ssreflect ssrbool ssrfun.
Import ListNotations SBTMNotations.

Set Default Goal Selector "!".

Section Construction.
  (* input SBTM *)
  Context (M : SBTM).

  #[local] Notation "⦇" := 0.
  #[local] Notation "⦈" := 1.
  #[local] Notation "# a" := (encode_symbol a) (at level 1).
  #[local] Notation encode_state q := (encode_state M q).
  #[local] Notation encode_config q t := (encode_config M q t).
  #[local] Notation encode_rule qa := (encode_rule M qa).

  #[local] Notation srs := (srs M).

  Lemma simulation q t k :
    steps M k (q, t) = None ->
    SR.rewt (srs ++ map SR.swap srs) (encode_config q t) [⦈; ⦇].
  Proof.
    elim: k q t; first done.
    move=> k IH q t.
    rewrite (steps_plus 1 k). case E: (steps M 1 _) => [[q' t']|].
    - move: E => /simulation_step ?.
      move=> /IH. apply: SR.rewS. apply /SR_facts.rew_app_inv.
      by left.
    - move: E => /simulation_halt /SR_facts.rewt_subset + _. apply.
      apply: incl_appl. by apply: incl_refl.
  Qed.

  Lemma rew_swap {X} {R : SR.SRS X} {x y} : SR.rew (map SR.swap R) x y -> SR.rew R y x.
  Proof.
    move ER': (map _ _) => R' H.
    case: H ER' => > + ?. subst R'.
    by move=> /in_map_iff [[??]] [[]] <- <- /SR.rewB.
  Qed.

  Lemma app_left_marker u ls : u ++ [⦇] = ⦇ :: rev (map encode_symbol ls) -> u = [] /\ ls = [].
  Proof.
    move: u ls => [|c u] [|l ls].
    - done.
    - by move=> /(@app_inj_tail nat _ (_ :: _)) [].
    - by case: u.
    - move=> /(@app_inj_tail nat _ (_ :: _)) []. by case: l.
  Qed.

  Lemma left_marker_nth q t n : not (nth_error (encode_config q t) (S n) = Some ⦇).
  Proof.
    move: t => [[ls a] rs] /=. elim /rev_ind: ls n.
    - move=> [|[|n]] /=; [by case: a|done|].
      elim: rs n. { by move=> [|[|?]]. }
      move=> r rs IH [|n]; first by case: r.
      by apply: IH.
    - move=> l ls IH [|n]; rewrite map_app rev_app_distr; first by case: l.
      by apply: IH.
  Qed.

  Lemma inverse_simulation_back_step q t x q' t' :
    SR.rew (map SR.swap srs) (encode_config q t) x ->
    step M (q, t) = Some (q', t') ->
    exists q'' t'', x = encode_config q'' t'' /\ step M (q'', t'') = Some (q, t).
  Proof.
    have reassoc (n m : nat) (u v : list nat) : u ++ (n :: m :: v) = (u ++ [n]) ++ m :: v.
    { by rewrite -app_assoc. }
    move=> /rew_swap. move Ey: (encode_config q t) => y Hxy.
    case: Hxy Ey => u v > /In_srsI [].
    - move=> > _ H. exfalso. apply: (left_marker_nth q t (length u)).
      rewrite H. rewrite nth_error_app2; first by lia.
      by have ->: S (length u) - length u = 1 by lia.
    - move: t => [[??]?] > E b /encode_config_eq_app [->] [->] [-> ->].
      by rewrite /step E.
    - move: t => [[??]?] > E b /encode_config_eq_app [->] [->] [-> ->].
      by rewrite /step E.
    - move: t => [[ls ?] rs] q'' a ? a' E H _. move: H E. rewrite !(reassoc ⦇).
      move=> /encode_config_eq_app [->] [->] [/app_left_marker] [-> ->].
      move: rs => [|r rs]. { by case: a'. }
      move=> [] /encode_symbol_inj -> -> E.
      exists q'', ([], a, rs). split; first done.
      by rewrite /step E.
    - move: t => [[ls ?] rs] q'' a ? a' E b H _. move: H E.
      move=> /encode_config_eq_app [->] [->] [->].
      move: rs => [|r rs]. { by case: a'. }
      move=> [] /encode_symbol_inj -> -> E.
      exists q'', (b :: ls, a, rs). split; first by rewrite /= -!app_assoc.
      by rewrite /step E.
    - move: t => [[ls ?] rs] q'' a ? a' E H _. move: H E. rewrite !(reassoc #a').
      move=> /encode_config_eq_app [->] [->] [].
      move: ls => [|l ls]. { move=> /(@app_inj_tail nat _ []) []. by case: a'. }
      move=> /= /(@app_inj_tail nat _ (_ :: _)) [-> /encode_symbol_inj ->].
      move: rs => [|r rs]; last by case: r.
      move=> [->] E.
      exists q'', (ls, a, []). split; first done.
      by rewrite /step E.
    - move: t => [[ls ?] rs] q'' a ? a' E b H _. move: H E. rewrite !(reassoc #a').
      move=> /encode_config_eq_app [->] [->] [+ ->].
      move: ls => [|l ls]. { move=> /(@app_inj_tail nat _ []) []. by case: a'. } cbn.
      move=> /(@app_inj_tail nat _ (_ :: _)) [-> /encode_symbol_inj ->] E.
      exists q'', (ls, a, b :: rs). split; first done.
      by rewrite /step E.
  Qed.

  Lemma inverse_simulation q t :
    SR.rewt (srs ++ map SR.swap srs) (encode_config q t) [⦈; ⦇] ->
    exists k, steps M k (q, t) = None.
  Proof.
    move Eu: (encode_config q t) => u.
    move Ev: ([⦈; ⦇]) => v Huv.
    elim: Huv q t Eu Ev. { by move=> ?? [[??]?] <-. }
    move=> x y z + _ + q t ??. subst x z.
    case E: (step M (q, t)) => [[q' t']|]; first last.
    { move=> *. by exists 1. }
    move=> /SR_facts.rew_app_inv [].
    { move: (E) => /inverse_simulation_step /[apply] ->.
      move=> /(_ _ _ erefl erefl) [k Hk].
      exists (1+k). by rewrite steps_plus /= E. }
    move: (E) => /inverse_simulation_back_step /[apply] [[q'']] [t''] [-> H''].
    move=> /(_ _ _ erefl erefl) [[|k] Hk]; first done.
    exists k. move: Hk. by rewrite (steps_plus 1 k) /= H''.
  Qed.

End Construction.

Require Import Undecidability.Synthetic.Definitions.

Theorem reduction :
  SBTM_HALT ⪯ SR.TSR.
Proof.
  exists ((fun '(existT _ M (q, t)) => (srs M, encode_config M q t, [1; 0]))).
  move=> [M [q t]] /=. split.
  - by move=> [?] /simulation.
  - by move=> /inverse_simulation.
Qed.


(******************************************************************************)
(* Mtac plugin.                                                               *)
(* Copyright (c) 2015 Beta Ziliani <beta@mpi-sws.org>                         *)
(*                    et al.                                                  *)
(******************************************************************************)
Require Import Lists.List.

Require Import Mtac.Mtac.

Import MtacNotations.

Module AFewBasicExamples.

Goal True.
  run (ret I) as H.
  run (hypotheses) as Hs.
  run (mtry @raise nat exception with _ => ret 0 end) as H'.
  rrun (ret I).
Qed.

Definition test_of_definition : nat := ltac:( rrun (ret 0) ).

Definition test_of_definition_evar  : 0 = 0 := ltac:( rrun (ret (eq_refl _)) ).

Definition MyException (x:nat) : Exception. exact exception. Qed.
Program Definition test_exception_with_evar : M nat :=
  mtry
    e <- evar nat;
    raise (MyException e) : M nat
  with [? e] MyException e => ret e
  end.

Check (Mrun test_exception_with_evar).

Definition ex_test : M nat :=
  mtry raise (MyException 0) : M nat
  with exception => ret 1 end.
Definition double_trouble := mtry ex_test with [? n] MyException n => ret 0 end.

Check (Mrun double_trouble).
End AFewBasicExamples.

Module Abs.
Definition abs_evar (A : Type) :=
  e <- evar A;
  f <- @abs Type (fun A'=>A') A e  : M (forall A : Type, A);
  ret (f nat, f bool).

Check (fun A : Type => ltac:( rrun (abs_evar A) ) ).

Definition abs_val2 (A : Type) :=
  e <- evar A;
  f <- @abs Type (fun A'=>A) A e;
  ret (f bool, f A).

Fail Check (fun A : Type => Mrun (abs_val2 A)).
(* variable appearing in the returning type *)

Definition abs_dep (A : Type) (x : A) :=
  e <- evar nat;
  @abs Type (fun _ => nat) A e : M (Type -> nat).

(* 1. e := ?u[A, x] : nat[A, x : A]
   2. f := fun A' => ?u[A', x]
*)

Fail Check fun A x => Mrun (@abs_dep A x).
(* Cannot abstract variable in a context depending on it *)

Definition test := nu n : nat, e <- evar nat; abs n e.
Check (fun x y => let f:= Mrun test in Mrun (mmatch f x with x => ret true | _ => ret false end)).

End Abs.

Section Misc.
Set Printing Universes.

Program Definition test_ho {A} B (t : A) :=
  mmatch t with
  | [? f (x:B)] f x => ret f
  | _ => raise exception
  end.

Check (Mrun (test_ho nat (id 0))).

Example exret : 1 = 1.
set (H := Mrun (ret True)).
Abort.

Example exbind : 1 = 1.
set (H := Mrun (bind (ret 8) (fun n=>ret (n+1)))).
Abort.

Example exbind2 : 1 = 1.
set (H := Mrun (bind (bind (ret 8) (fun n=>ret (n+1))) (fun n=>ret (n+3)))).
Abort.

Example bla : 1 = 1.
set (H := Mrun ((fun x => bind x (fun n=>ret n)) (ret 8))).
Abort.

Example excomp : 1 = 1.
set (T := (fun x=>ret x) 8).
set (H := Mrun T).
Abort.

Example excomp2 : 1 = 1.
set (T := let x:=ret 8 in x).
set (H := Mrun T).
Abort.

Example exfix2 : 1 = 1.
set (iszero n := match n with 0 => true | _ => false end).
set (plus := mfix1 f (a : nat*nat) : M _ :=
    match a with
    | (n, m) =>
      if iszero n then
        ret m
      else
        f (n-1, S m)
    end)
  .
Time set (H := Mrun (plus (10, 52))).
idtac.
Abort.

Example exmatch : 1 = 1.
set (H1 := Mrun (mmatch 0 return M nat with
     | 0 => ret 8
     end)).
set (H2 := Mrun (mmatch 0 return M nat with
     | 1 => ret 8
     | 0 => ret 2
     end)).
Abort.

Definition madd : nat -> nat -> M nat :=
  mfix2 f (m : _) (n : nat) : M _ :=
    mmatch m return M nat with
    | 0 => ret n
    | [? m'] (S m') => x <- f m' n; ret (S x)
    end.

Time Definition mresult1: nat := Mrun (madd 100 5000).
Time Definition mresult2: nat := Mrun (madd 1000 1000).
Time Definition mresult3: nat := Mrun (madd 1000 10).
Time Definition mresult4: nat := Mrun (madd 10 10000).
(*
100+5000 takes 3s
1000+1000 takes 18s
1000+10 takes 56s
10+10000 takes 1s
 *)

Ltac ladd m n :=
  match m with
  | 0 => constr:n
  | S ?m' => let x := ladd m' n in constr:(S x)
  end.

Definition lresult1: nat.
  Time let x := ladd 100 5000 in exact x.
Defined.
Definition lresult2: nat.
  Time let x := ladd 1000 1000 in exact x.
Defined.
Definition lresult3: nat.
  Time let x := ladd 1000 10 in exact x.
Defined.
Definition lresult4: nat.
  Time let x := ladd 10 10000 in exact x.
Defined.
(*
100+5000 takes .3s
1000+1000 takes .6s
1000+10 takes .3s
10+10000 takes .2s
 *)

Definition ElementNotFound : Exception.  exact exception. Qed.

Definition inlist A (x : A) :=
  mfix1 f (s : _) : M (In x s) :=
  mmatch s as s' return M (In x s') with
  | [? s] x::s => ret (in_eq x s)
  | [? y s] y :: s =>
    t <- f s : M (In x s);
    ret (in_cons y x s t)
  | _ => raise ElementNotFound
  end.

Implicit Arguments inlist [A].

Set Printing Existential Instances.

Example x_en_zyx_u : forall A (x y z : A),
  In x (z :: y :: x :: nil).
Proof.
  intros A x y z.
  rrun (inlist _ _).
Qed.

Example exinlist (x1 x2 x3 : nat) : In x2 (x1 :: x2 :: nil).
  rrun (inlist x2 (x1:: x2:: nil)).
Qed.

Example exinlist' (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10: nat) :
  let l := (x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: x9 :: x10 :: nil) in
  In x10 l.
intro l.
unfold l.
rrun (inlist _ _).
Qed.

Require Import Strings.String.

Definition MyException (s : string) : Exception.
  exact exception.
Qed.

Definition AnotherException : Exception.
  exact exception.
Qed.

Definition test_ex (e : Exception) : M string :=
  mtry raise e : M string
  with
  | AnotherException => ret ""%string
  | MyException "hello"%string => ret "world"%string
  | [? s] MyException s => ret s
  | [? e'] e' => raise e'
  end.

Check (Mrun (test_ex (MyException "hello"%string))).
Check (Mrun (test_ex AnotherException)).
Check (Mrun (test_ex (MyException "dummy"%string))).
Fail Check (Mrun (test_ex exception)).

Import ListNotations.

Definition inlist'' {A} (x : A) :=
  mfix1 f (s : list A) : M _ :=
    mmatch s as s' return M (In x s') with
    | [? l r] l ++ r =>
      mtry
        il <- f l;
        ret (in_or_app l r x (or_introl il))
      with _ =>
        ir <- f r;
        ret (in_or_app l r x (or_intror ir))
      end
    | [? s'] (x :: s') => ret (in_eq _ _)
    | [? y s'] (y :: s') =>
      r <- f s';
      ret (in_cons y _ _ r)
    | _ => raise AnotherException
    end.

Definition remove {A} (x : A) :=
  mfix1 f (s : list A) : M (list A) :=
    mmatch s with
    | [? s'] (x :: s') => f s'
    | [? y s'] (y :: s') =>
      r <- f s';
      ret (y :: r)
    | _ => ret s
    end.

Definition inlistS {A} (x : A) :=
  mfix1 f (s : list A) : M (In x s) :=
    mmatch s with
    | [? s'] (x :: s') => ret (in_eq _ _)
    | [? y s'] (y :: s') =>
      r <- f s';
      ret (in_cons y _ _ r)
    | [? l r] l ++ r =>
      mtry
        il <- f l;
        ret (in_or_app l r x (or_introl il))
      with _ =>
        ir <- f r;
        ret (in_or_app l r x (or_intror ir))
      end
    | _ => raise AnotherException
    end.

Example exinlist'' (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11: nat) :
  let l := (x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: x9 :: x10 :: nil) in
  In x11 (
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ [x11]).
intro l.
(* repeat rewrite <- app_assoc_reverse. *)
Time rrun (inlist'' _ _).
Time Qed.

Example exinlistS (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11: nat) :
  let l := (x1 :: x2 :: x3 :: x4 :: x5 :: x6 :: x7 :: x8 :: x9 :: x10 :: nil) in
  In x11 (
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++
    l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ l ++ [x11]).
intro l.
(* repeat rewrite <- app_assoc_reverse. *)
Time rrun (inlistS _ _).
Time Qed.

End Misc.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************)
(*           The Calculus of Inductive Constructions            *)
(*                       COQ v5.10                              *)
(*                                                              *)
(* Laurent Arditi.  Laboratoire I3S. CNRS ura 1376.             *)
(* Universite de Nice - Sophia Antipolis                        *)
(* arditi@unice.fr, http://wwwi3s.unice.fr/~arditi/lolo.html    *)
(*                                                              *)
(* date: july 1995                                              *)
(* file: Definitions.v                                          *)
(* contents: PROOF OF A SEQUENTIAL MULTIPLIER. Definitions of   *)
(* auxilliary functions, axioms and the register-functions.     *)
(****************************************************************)

(****************************************************************)
(* Definitions des operateurs utilises (lowbit et highs)
   des registres (R1 et R2)
   et des lemmes sur les longueurs des registres
*)

Require Export BV.
Require Export Adder.
Require Import Gt.

Definition Mux := If BV.
Hint Unfold Mux.

Definition lowbit (l : list bool) :=
  match l with
  | nil => false
  | b :: _ => b
  end.

Definition highs (l : list bool) :=
  match l with
  | nil => nil (A:=bool)
  | _ :: v => v
  end.

Lemma lowbit_is_trunc :
 forall v : BV, v <> nilbv -> consbv (lowbit v) nilbv = truncbv v 1.
simple induction v. intro. absurd (nil <> nilbv); unfold not in |- *; auto with arith.
intros. simpl in |- *. rewrite (trunc_O bool). trivial with arith.
Qed.

Lemma lowbit_is_abit :
 forall v : BV, v <> nilbv -> consbv (lowbit v) nilbv = abit v 0.
intros. unfold abit in |- *. unfold elemlist in |- *. rewrite strip_O.
apply lowbit_is_trunc. exact H.
Qed.

Lemma highs_is_strip : forall v : BV, highs v = stripbv v 1.
simple induction v. simpl in |- *. auto with arith.
intros. simpl in |- *. rewrite (strip_cons_S bool). rewrite strip_O. trivial with arith.
Qed.

Lemma app_lowbit_highs :
 forall v : BV, v <> nilbv -> appbv (consbv (lowbit v) nilbv) (highs v) = v.
intros. rewrite lowbit_is_trunc. rewrite highs_is_strip.
rewrite (app_trunc_strip bool). trivial with arith. exact H.
Qed.

Lemma length_highs :
 forall v : BV, v <> nilbv -> lengthbv (highs v) = pred (lengthbv v).
intros. rewrite highs_is_strip.
rewrite (length_strip bool). apply minus_n_SO.
apply (v_not_nil_length bool). exact H.
Qed.

Lemma length_abit :
 forall (v : BV) (i : nat), i < lengthbv v -> lengthbv (abit v i) = 1.
unfold abit in |- *. exact (length_elemlist bool).
Qed.
(****************************************************************)
(* Defintitions des variables et leurs contraintes *)

Parameter size : nat. (* La taille des mots *)
Parameter V1 : BV. (* Les deux entrees *)
Parameter V2 : BV.

Axiom size_not_O : size <> 0. Hint Resolve size_not_O.
Axiom length_V1_size : lengthbv V1 = size. Hint Resolve length_V1_size.
Axiom length_V2_size : lengthbv V2 = size. Hint Resolve length_V2_size.

Lemma le_SO_size : 1 <= size.
       generalize size_not_O. elim size. intro. absurd (0 <> 0); unfold not in |- *; auto with arith.
       intros. apply le_n_S. auto with arith. Qed. Hint Resolve le_SO_size.

Lemma length_V1 : lengthbv V1 <> 0.
	rewrite length_V1_size. auto with arith. Qed. Hint Resolve length_V1.
Lemma length_V2 : lengthbv V2 <> 0.
	rewrite length_V2_size. auto with arith. Qed. Hint Resolve length_V2.
Lemma length_V2_V1 : lengthbv V2 = lengthbv V1.
	transitivity size; auto with arith. Qed.
Lemma V1_not_nil : V1 <> nilbv.
	apply (not_nil bool). auto with arith. Qed. Hint Resolve V1_not_nil.
Lemma V2_not_nil : V2 <> nilbv.
	apply (not_nil bool). auto with arith. Qed. Hint Resolve V2_not_nil.
Lemma le_SO_length_V1 : 1 <= lengthbv V1.
	apply (le_SO_length_v bool). auto with arith. Qed. Hint Resolve le_SO_length_V1.

(****************************************************************)
(* Les registres: *)

Fixpoint R1 (st : nat) : BV :=
  match st return BV with
  | O => V1
  | S t =>
      appbv (highs (R1 t))
        (Mux (lowbit (R1 t))
           (consbv (lowbit (BV_full_adder_sum (R2 t) V2 false)) nilbv)
           (consbv (lowbit (R2 t)) nilbv))
  end

 with R2 (st : nat) : BV :=
  match st return BV with
  | O => BV_null size
  | S t =>
      appbv
        (highs
           (Mux (lowbit (R1 t)) (BV_full_adder_sum (R2 t) V2 false) (R2 t)))
        (Mux (lowbit (R1 t))
           (consbv (BV_full_adder_carry (R2 t) V2 false) nilbv)
           (consbv false nilbv))
  end.

Lemma R1_eq1 : R1 0 = V1. auto with arith. Qed.
Lemma R1_eq2 :
 forall t : nat,
 R1 (S t) =
 appbv (highs (R1 t))
   (Mux (lowbit (R1 t))
      (consbv (lowbit (BV_full_adder_sum (R2 t) V2 false)) nilbv)
      (consbv (lowbit (R2 t)) nilbv)).
auto with arith. Qed.

Lemma R2_eq1 : R2 0 = BV_null size. auto with arith. Qed.
Lemma R2_eq2 :
 forall t : nat,
 R2 (S t) =
 appbv
   (highs (Mux (lowbit (R1 t)) (BV_full_adder_sum (R2 t) V2 false) (R2 t)))
   (Mux (lowbit (R1 t)) (consbv (BV_full_adder_carry (R2 t) V2 false) nilbv)
      (consbv false nilbv)).
auto with arith. Qed.

(****************************************************************)
Lemma length_R1 : forall t : nat, t <= size -> lengthbv (R1 t) = size.
simple induction t. auto with arith.
intros. rewrite R1_eq2. rewrite (length_app bool).
unfold Mux in |- *. rewrite (F_If BV nat _ _ _ (@length bool)). simpl in |- *. rewrite If_eq.
rewrite highs_is_strip. rewrite (length_strip bool). unfold lengthbv in H.
rewrite H. symmetry  in |- *. rewrite plus_comm. apply le_plus_minus. auto with arith.
apply le_Sn_le; auto with arith.
unfold lengthbv in H. rewrite H. auto with arith.
apply le_Sn_le. exact H0.
Qed. Hint Resolve length_R1.

Lemma length_R2 : forall t : nat, t <= size -> lengthbv (R2 t) = size.
simple induction t. simpl in |- *.
unfold lengthbv, BV_null in |- *. rewrite (length_list_const bool). trivial with arith.
unfold lengthbv in |- *. intros. rewrite R2_eq2.
rewrite (length_app bool). unfold Mux, consbv.
rewrite (F_If BV BV _ _ _ highs).
rewrite (F_If BV nat _ _ _ (@length bool)).
rewrite highs_is_strip. rewrite (length_strip bool).
rewrite length_BV_full_adder_sum. unfold lengthbv in |- *.
rewrite H. rewrite highs_is_strip. rewrite (length_strip bool).
rewrite H. rewrite If_eq. rewrite (F_If BV nat _ _ _ (@length bool)). simpl in |- *.
rewrite If_eq. symmetry  in |- *. rewrite plus_comm. apply le_plus_minus. auto with arith.
auto with arith. rewrite H. auto with arith.
apply le_Sn_le; exact H0. apply le_Sn_le; exact H0.
unfold lengthbv in |- *. rewrite H. auto with arith. apply le_Sn_le; exact H0.
rewrite length_BV_full_adder_sum.
unfold lengthbv in |- *. rewrite H. auto with arith. apply le_Sn_le; exact H0.
unfold lengthbv in |- *. rewrite H. auto with arith. apply le_Sn_le; exact H0.
Qed. Hint Resolve length_R2.

Lemma R1_never_nil : forall t : nat, t <= size -> R1 t <> nilbv.
intros. apply (not_nil bool). rewrite length_R1. auto with arith. exact H.
Qed.