Require Import Bedrock.Platform.AutoSep Bedrock.Platform.Malloc Bedrock.Platform.Bags Bedrock.Platform.Arrays8 Bedrock.Platform.MoreArrays.
Import Bags.W_Bag.

Local Hint Extern 1 (@eq W _ _) => words.

Inductive shape :=
| Leaf : shape
| Node : shape -> shape -> shape.

Module Type TREE.
  Parameter tree : bag -> W -> HProp.
  Parameter tree' : bag -> shape -> W -> HProp.
  Parameter tree'' : bag -> shape -> W -> W -> HProp.

  Axiom tree_fwd : forall b p, tree b p ===> Ex t, Ex p', Ex junk, (p ==*> p', junk) * tree' b t p'.
  Axiom tree_bwd : forall b p, (Ex t, Ex p', Ex junk, (p ==*> p', junk) * tree' b t p') ===> tree b p.

  Axiom tree'_nil_fwd : forall b t (p : W), p = 0
    -> tree' b t p ===> [| t = Leaf |].
  Axiom tree'_nil_bwd : forall b t (p : W), p = 0
    -> [| t = Leaf |] ===> tree' b t p.

  Axiom tree'_cons_fwd : forall b t (p : W), p <> 0
    -> tree' b t p ===> Ex t1, Ex t2, Ex i, Ex c, Ex p1, Ex p2, [| t = Node t1 t2 |] * (p ==*> i, c, p1, p2)
        * tree'' b t1 p1 c * tree' b t2 p2.
  Axiom tree'_cons_bwd : forall b t (p : W), p <> 0
    -> (Ex t1, Ex t2, Ex i, Ex c, Ex p1, Ex p2, [| t = Node t1 t2 |] * (p ==*> i, c, p1, p2)
        * tree'' b t1 p1 c * tree' b t2 p2) ===> tree' b t p.

  Axiom tree'_weaken : forall b b', b %<= b'
    -> forall t p, tree' b t p ===> tree' b' t p.

  Axiom tree''_zero_fwd : forall b t p (c : W), c = 0
    -> tree'' b t p c ===> [| p %in b |] * [| t = Leaf |].
  Axiom tree''_zero_bwd : forall b t p (c : W), c = 0
    -> [| p %in b |] * [| t = Leaf |] ===> tree'' b t p c.

  Axiom tree''_nonzero_fwd : forall b t p (c : W), c <> 0
    -> tree'' b t p c ===> tree' b t p.
  Axiom tree''_nonzero_bwd : forall b t p (c : W), c <> 0
    -> tree' b t p ===> tree'' b t p c.
End TREE.

Module Tree : TREE.
  Open Scope Sep_scope.

  Fixpoint tree' (b : bag) (t : shape) (p : W) : HProp :=
    match t with
      | Leaf => [| p = 0 |]
      | Node t1 t2 => [| p <> 0 |] * Ex i, Ex c, Ex p1, Ex p2, (p ==*> i, c, p1, p2)
        * (if weq c $0 then [| p1 %in b |] * [| t1 = Leaf |] else tree' b t1 p1) * tree' b t2 p2
    end.

  Definition tree'' (b : bag) (t : shape) (p c : W) : HProp :=
    if weq c $0
      then [| p %in b |] * [| t = Leaf |]
      else tree' b t p.

  Definition tree (b : bag) (p : W) : HProp := Ex t, Ex p', Ex junk, (p ==*> p', junk) * tree' b t p'.

  Theorem tree_fwd : forall b p, tree b p ===> Ex t, Ex p', Ex junk, (p ==*> p', junk) * tree' b t p'.
    unfold tree; sepLemma.
  Qed.

  Theorem tree_bwd : forall b p, (Ex t, Ex p', Ex junk, (p ==*> p', junk) * tree' b t p') ===> tree b p.
    unfold tree; sepLemma.
  Qed.

  Ltac normalize :=
    match goal with
      | [ |- context C[(Ex i : W, Ex c : W, Ex p1 : W, Ex p2 : W,
        ?p =*> i * ((?p ^+ $4) =*> c * ((?p ^+ $8) =*> p1 * (?p ^+ $12) =*> p2))
        * (if weq c $0 then [| p1 %in ?b |] * [| ?t1 = Leaf |] else tree' ?b ?t1 p1) * tree' ?b ?t2 p2)%Sep] ] =>
      let G := context C[(Ex i : W, Ex c : W, Ex p1 : W, Ex p2 : W,
        p =*> i * ((p ^+ $4) =*> c * ((p ^+ $8) =*> p1 * (p ^+ $12) =*> p2))
        * tree'' b t1 p1 c * tree' b t2 p2)%Sep] in
      change G
    end.

  Theorem tree'_nil_fwd : forall b t (p : W), p = 0
    -> tree' b t p ===> [| t = Leaf |].
    destruct t; simpl; intros; try normalize; sepLemma.
  Qed.

  Theorem tree'_nil_bwd : forall b t (p : W), p = 0
    -> [| t = Leaf |] ===> tree' b t p.
    destruct t; simpl; intros; try normalize; sepLemma.
  Qed.

  Theorem tree'_cons_fwd : forall b t (p : W), p <> 0
    -> tree' b t p ===> Ex t1, Ex t2, Ex i, Ex c, Ex p1, Ex p2, [| t = Node t1 t2 |] * (p ==*> i, c, p1, p2)
        * tree'' b t1 p1 c * tree' b t2 p2.
    destruct t; simpl; intros; try normalize; sepLemma.
  Qed.

  Theorem tree'_cons_bwd : forall b t (p : W), p <> 0
    -> (Ex t1, Ex t2, Ex i, Ex c, Ex p1, Ex p2, [| t = Node t1 t2 |] * (p ==*> i, c, p1, p2)
        * tree'' b t1 p1 c * tree' b t2 p2) ===> tree' b t p.
    destruct t; simpl; intros; try normalize; sepLemma;
      match goal with
        | [ H : Node _ _ = Node _ _ |- _ ] => injection H0; intros; subst; sepLemma
      end.
  Qed.

  Theorem tree'_weaken : forall b b', b %<= b'
    -> forall t p, tree' b t p ===> tree' b' t p.
    induction t; simpl; intros; repeat normalize; sepLemma;
      apply himp_star_frame; auto;
        unfold tree''; destruct (weq x1 $0); auto; sepLemma; eauto using incl_mem.
  Qed.

  Transparent natToWord.

  Theorem tree''_zero_fwd : forall b t p (c : W), c = 0
    -> tree'' b t p c ===> [| p %in b |] * [| t = Leaf |].
    unfold tree''; intros; subst; sepLemma.
  Qed.

  Theorem tree''_zero_bwd : forall b t p (c : W), c = 0
    -> [| p %in b |] * [| t = Leaf |] ===> tree'' b t p c.
    unfold tree''; intros; subst; sepLemma.
  Qed.

  Theorem tree''_nonzero_fwd : forall b t p (c : W), c <> 0
    -> tree'' b t p c ===> tree' b t p.
    unfold tree''; intros; destruct (weq c $0); sepLemma.
  Qed.

  Theorem tree''_nonzero_bwd : forall b t p (c : W), c <> 0
    -> tree' b t p ===> tree'' b t p c.
    unfold tree''; intros; destruct (weq c $0); sepLemma.
  Qed.

End Tree.

Import Tree.
Export Tree.

Inductive debufferize := Debufferize.
Hint Constructors debufferize.

Definition hints : TacPackage.
  prepare (tree_fwd, tree'_nil_fwd, tree'_cons_fwd, tree''_zero_fwd, tree''_nonzero_fwd)
  (tree_bwd, tree'_nil_bwd, tree'_cons_bwd, tree''_zero_bwd, tree''_nonzero_bwd).
Defined.

Import Bags.W_Bag.

Definition newS := SPEC reserving 8
  PRE[_] mallocHeap 0
  POST[R] tree empty R * mallocHeap 0.

Definition lookupS := SPEC("t", "key", "keyLen") reserving 2
  Al b,
  PRE[V] tree b (V "t") * V "key" =?>8 wordToNat (V "keyLen")
  POST[R] [| R = 0 \/ R %in b |] * tree b (V "t") * V "key" =?>8 wordToNat (V "keyLen").

Definition insertS := SPEC("t", "key", "keyLen", "value") reserving 13
  Al b,
  PRE[V] tree b (V "t") * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0
  POST[_] tree (b %+ V "value") (V "t") * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS], "sys"!"abort" @ [abortS] ]]
  bmodule "stringdb" {{
    bfunction "new"("r") [newS]
      "r" <-- Call "malloc"!"malloc"(0, 2)
      [PRE[_, R] R =?> 2
       POST[R'] tree empty R'];;

      "r" *<- 0;;
      Return "r"
    end with bfunction "lookup"("t", "key", "keyLen", "i", "c") [lookupS]
      "t" <-* "t";;

      [Al b, Al t,
        PRE[V] tree' b t (V "t") * V "key" =?>8 wordToNat (V "keyLen")
        POST[R] [| R = 0 \/ R %in b |] * tree' b t (V "t") * V "key" =?>8 wordToNat (V "keyLen")]
      While ("t" <> 0) {
        "i" <-* "t";;
        "c" <-* "t" + 4;;

        If ("c" = 0) {
          (* Search might be done, leaving just a test on the length of key. *)
          If ("i" = "keyLen") {
            "t" <-* "t" + 8;;
            Return "t"
          } else {
            "t" <-* "t" + 12
          }
        } else {
          (* Regular internal node, with an equality test on a particular character of key. *)
          If ("i" < "keyLen") {
            Note [debufferize];;

            Assert [Al b, Al t1, Al t2, Al p1, Al p2, Al bs,
              PRE[V] (V "t" ==*> V "i", V "c", p1, p2) * tree' b t1 p1 * tree' b t2 p2
                * array8 bs (V "key") * [| (V "i" < natToW (length bs))%word |]
                * [| length bs = wordToNat (V "keyLen") |]
              POST[R] [| R = 0 \/ R %in b |] * (V "t" ==*> V "i", V "c", p1, p2) * tree' b t1 p1 * tree' b t2 p2
                * V "key" =?>8 wordToNat (V "keyLen")];;

            "i" <-*8 "key" + "i";;

            Note [debufferize];;

            Assert [Al i, Al b, Al t1, Al t2, Al p1, Al p2,
              PRE[V] (V "t" ==*> i, V "c", p1, p2) * tree' b t1 p1 * tree' b t2 p2
                * V "key" =?>8 wordToNat (V "keyLen")
              POST[R] [| R = 0 \/ R %in b |] * (V "t" ==*> i, V "c", p1, p2) * tree' b t1 p1 * tree' b t2 p2
                * V "key" =?>8 wordToNat (V "keyLen")];;

            If ("i" = "c") {
              "t" <-* "t" + 8
            } else {
              "t" <-* "t" + 12
            }
          } else {
            "t" <-* "t" + 12
          }
        }
      };;

      Return 0
    end with bfunction "insert"("t", "key", "keyLen", "value", "p", "pos", "i", "c", "c2", "matched") [insertS]
      "p" <-* "t";;
      "pos" <- 0;;

      [Al b, Al t,
        PRE[V] V "t" =*> V "p" * tree' b t (V "p") * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0
        POST[_] Ex p, Ex t', V "t" =*> p * tree' (b %+ V "value") t' p * V "key" =?>8 wordToNat (V "keyLen")
          * mallocHeap 0]
      While (0 = 0) {
        If ("pos" < "keyLen") {
          (* We are in the phase of matching characters in key. *)

          (* Read current character from key. *)
          Note [debufferize];;

          Assert [Al b, Al t, Al bs,
            PRE[V] V "t" =*> V "p" * tree' b t (V "p") * array8 bs (V "key") * mallocHeap 0
              * [| length bs = wordToNat (V "keyLen") |] * [| (V "pos" < natToW (length bs))%word |]
            POST[_] Ex p, Ex t', V "t" =*> p * tree' (b %+ V "value") t' p
              * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0];;

          "c2" <- "key" + "pos";;
          "c2" <-*8 "c2";;

          Note [debufferize];;

          Assert [Al b, Al t,
            PRE[V] V "t" =*> V "p" * tree' b t (V "p")
              * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0
            POST[_] Ex p, Ex t', V "t" =*> p * tree' (b %+ V "value") t' p
              * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0];;

          If ("p" = 0) {
            "matched" <- 0
          } else {
            "i" <-* "p";;
            If ("i" = "pos") {
              "matched" <- 1
            } else {
              "matched" <- 0
            }
          };;

          If ("matched" = 1) {
            Assert [Al b, Al i, Al c, Al p1, Al p2, Al t1, Al t2,
              PRE[V] [| V "p" <> 0 |] * V "t" =*> V "p" * (V "p" ==*> i, c, p1, p2)
                * tree'' b t1 p1 c * tree' b t2 p2
                * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0
              POST[_] Ex p, Ex t', V "t" =*> p * tree' (b %+ V "value") t' p
                * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0];;

            (* The next test in the tree matches the character we are focusing on. *)
            "c" <-* "p"+4;;

            If ("c" = 0) {
              (* This is a length test that fails for us. *)
              "t" <- "p"+12
            } else {
              If ("c2" = "c") {
                (* Character match.  Continue along the "true" path. *)
                "t" <- "p"+8;;
                "pos" <- "pos" + 1
              } else {
                (* Character non-match.  Continue along the "false" path. *)
                "t" <- "p"+12
              }
            };;

            "p" <-* "t"
          } else {
            Assert [Al b, Al t,
              PRE[V] V "t" =*> V "p" * tree' b t (V "p")
                * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0
              POST[_] Ex p, Ex t', V "t" =*> p * tree' (b %+ V "value") t' p
                * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0];;

            (* The current position-character pair is not represented in the tree.  Let's add it here. *)
            "c" <-- Call "malloc"!"malloc"(0, 4)
            [Al b, Al t,
              PRE[V, R] R =?> 4 * [| R <> 0 |] * V "t" =*> V "p" * tree' b t (V "p")
                * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0
              POST[_] Ex p, Ex t', V "t" =*> p * tree' (b %+ V "value") t' p
                * V "key" =?>8 wordToNat (V "keyLen") * mallocHeap 0];;

            If ("c2" = 0) {
              (* Informal invariant violated!  Key contains an internal '0' character. *)
              Call "sys"!"abort"()
              [PREonly[_] [| False |] ];;
              Fail
            } else {
              Skip
            };;

            "c" *<- "pos";;
            "c"+4 *<- "c2";;
            "c"+8 *<- 0;;
            "c"+12 *<- "p";;

            "t" *<- "c";;
            "t" <- "c"+8;;
            "p" <- 0;;
            "pos" <- "pos" + 1
          }
        } else {
          (* We are ready to insert the final check, on string length. *)

          "pos" <-- Call "malloc"!"malloc"(0, 4)
          [Al b, Al t,
            PRE[V, R] R =?> 4 * [| R <> 0 |] * V "t" =*> V "p" * tree' b t (V "p")
            POST[_] Ex p, Ex t', V "t" =*> p * tree' (b %+ V "value") t' p];;

          "pos" *<- "keyLen";;
          "pos"+4 *<- 0;;
          "pos"+8 *<- "value";;
          "pos"+12 *<- "p";;

          "t" *<- "pos";;
          Return 0
        }
      }
    end
  }}.

Hint Extern 1 (@eq W _ _) => words.

Ltac finish :=
  repeat match goal with
           | [ H : _ = _ |- _ ] => rewrite H
         end; try rewrite natToW_wordToNat;
  try apply tree'_weaken; auto.

Ltac t :=
  match goal with
    | [ |- forall stn_st specs, interp specs (Ex st', _ /\ [| evalInstrs _ _ (Assign (LvMem (Sp + natToW 0)%loc) (RvLval (LvReg Rp)) :: nil) = _ |])%PropX -> interp specs _ ] => solve [ sep hints ]
    | _ =>
      try match goal with
            | [ |- context[debufferize] ] => unfold buffer
          end;
      post; evaluate hints; try (discriminate || tauto); descend; try match_locals; sep hints; finish
  end.

Theorem ok : moduleOk m.
  vcgen; abstract t.
Qed.


Require Import MapProofs.Common.
Set Bullet Behavior "Strict Subproofs".
Require Import MapProofs.Bounds.
Require Import MapProofs.Tactics.
Require Export MapProofs.PairTypeclass.

Section WF_1.
Context {e : Type} {a b : Type} {HEq : Eq_ e} {HOrd : Ord e} {HEqLaws : EqLaws e}  {HOrdLaws : OrdLaws e}.

(** ** Verification of [foldrWithKey] *)

Lemma fold_right_toList_go:
  forall f (n : b) map (xs : list (e * a)),
  fold_right f n (foldrWithKey (fun x y t  => (x,y) :: t) xs map) =
  foldrWithKey (fun x y t => f (x,y) t) (fold_right f n xs) map.
Proof.
  intros. generalize dependent xs. induction map.
  - intros. simpl. rewrite IHmap1. simpl. rewrite IHmap2. reflexivity.
  - simpl. intros. reflexivity.
Qed.

End WF_1.

Section WF_2.

Context {e : Type} {a b : Type} {HEq : Eq_ e} {HOrd : Ord e} {HEqLaws : EqLaws e}  {HOrdLaws : OrdLaws e}.

Lemma foldrWithKey_spec:
  forall f (n : b) map,
  foldrWithKey f n map = fold_right (fun (x : e * a) t => let (a0, b0) := x in f a0 b0 t) n (toList map).
Proof.
  intros. unfold toList. unfold toAscList.
  rewrite fold_right_toList_go. simpl. reflexivity.
Qed.

(** ** Verification of [foldr] *)
Lemma foldr_spec:
  forall f (n: b) (map : Map e a),
  foldr f n map = foldrWithKey (fun x y t => f y t) n map.
Proof.
  intros. generalize dependent n. induction map.
  - intros. simpl. rewrite IHmap1. rewrite IHmap2. reflexivity.
  - intros. simpl. reflexivity.
Qed.

(** ** Verification of [foldr'] *)
Lemma foldr'_spec:
  forall {k : Type} (f : a -> k -> k) (n : k) (m : Map e a),
  foldr' f n m = foldr f n m.
Proof. reflexivity. Qed.

(** ** Verification of [toList] *)

Lemma foldrWithKey_const_append:
  forall xs (map : Map e a),
  foldrWithKey (fun x y t => (x,y) :: t) xs map = toList map ++ xs.
Proof.
  intros. generalize dependent xs. induction map; intros.
  - unfold toList, toAscList in *. simpl. rewrite IHmap1. rewrite IHmap2.
    rewrite (IHmap1 ((k, a0) :: foldrWithKey (fun (k0 : e) (x : a) (xs0 : list (e * a)) => (k0, x) :: xs0) nil map2)).
    rewrite <- app_assoc. reflexivity.
  - simpl. reflexivity.
Qed.

(*Allows us to decompose toList*)
Lemma toList_Bin:
  forall sz key value (m1 m2 : Map e a),
  toList (Bin sz key value m1 m2) = toList m1 ++ (key, value) :: nil ++ toList m2.
Proof.
  intros.
  unfold toList. unfold toAscList. simpl.
  rewrite foldrWithKey_const_append. rewrite foldrWithKey_const_append.
  rewrite foldrWithKey_const_append. rewrite app_nil_r. rewrite app_nil_r.
  reflexivity.
Qed.

(*We have two different versions of toList_sem for use in proving [Eq], preceded by several helper lemmas*)

(*This function imposes a stronger condition than List.elem - the values must be equal according to Coq.
This is used in proving strong equality*)
Fixpoint Key_In {e} {a} `{EqLaws e} (key : e) (value : a) (l : list (e * a)) : Prop :=
  match l with
  | nil => False
  | a :: tl => (let (x,y):= a in x == key = true /\ y = value) \/ Key_In key value tl
  end.

(*Helper methods for logic*)

Lemma or_assoc: forall b1 b2 b3,
  (b1 \/ b2) \/ b3 <-> b1 \/ ( b2 \/ b3).
Proof.
  intros. split; intros.
  - destruct H. destruct H. left. assumption. right. left. assumption. right.
    right. assumption.
  - destruct H. left. left. assumption. destruct H. left. right. assumption. right.
    assumption.
Qed.

Lemma false_or: forall (P : Prop),
  False \/ P <-> P.
Proof.
  intros. split; intros.
  - destruct H. destruct H. apply H.
  - right. apply H.
Qed.

(*Key property of Key_In for lists - if we append to 2 lists, an item is in the whole list
iff it is in one of them*)
Lemma elem_or : forall {e} {a} `{EqLaws e} (key : e) (value : a) l1 l2,
  Key_In key value (l1 ++ l2) <-> Key_In key value l1 \/ Key_In key value l2.
Proof.
  intros. generalize dependent l2. induction l1.
  - intros. simpl. split; intros.
    + right. assumption.
    + destruct H1. destruct H1. assumption.
  - intros. simpl. rewrite IHl1. rewrite or_assoc. apply iff_refl.
Qed.

(*The first toList_sem:
This says that sem m key returns a Value iff that key, value pair appears in the
resulting toList of the map (according to Coq equality for values)*)

Lemma toList_sem :
  forall  (m: Map e a) lb ub, Bounded m lb ub ->
  forall key value, sem m key = Some value <-> Key_In key value (toList m).
Proof.
  intros. generalize dependent value. induction H.
  - simpl. intros. split; intros. discriminate H. destruct H.
  - intros. simpl. rewrite toList_Bin. rewrite elem_or.
    assert (((x, v) :: nil ++ toList s2) = (((x, v) :: nil) ++ toList s2)).
    simpl. reflexivity. rewrite H5. rewrite elem_or. split; intros.
      + destruct (sem s1 key) eqn : ?; simpl in H6.
      * apply IHBounded1 in H6. left. apply H6.
      * destruct (key == x) eqn : ?; simpl in H6.
        { right. left. simpl. left. apply Eq_Symmetric in Heqb0.
          split. apply Heqb0. inversion H6. reflexivity. }
        { apply IHBounded2 in H6. right. right. assumption. }
     + destruct H6.
      * apply IHBounded1 in H6. rewrite H6. simpl. reflexivity.
      * destruct H6. simpl in H6. destruct H6. destruct H6.
        assert (sem s1 key = None). { eapply sem_outside_above.
        apply H. order_Bounds e. }
        rewrite H8. simpl. apply Eq_Symmetric in H6. rewrite H6. simpl.
        rewrite H7. reflexivity. destruct H6. apply IHBounded2 in H6.
        assert (key > x = true ) by (solve_Bounds e).
        assert (sem s1 key = None). eapply sem_outside_above. eassumption.
        solve_Bounds e. rewrite H8. replace (key == x) with false by (order e).
        rewrite H6. reflexivity.
Qed.

(*Helper lemmas for [toList_sem']*)
(*Analogue of [elem_or] for List.elem*)
Lemma list_elem_or : forall `{Eq_ a} `{EqLaws a} l1 l2 (x : e * a),
  List.elem x (l1 ++ l2) = List.elem x l1 || List.elem x l2.
Proof.
  intros. generalize dependent l2. induction l1; intros.
  - destruct l2. simpl. reflexivity. simpl. reflexivity.
  - destruct l2. simpl. rewrite app_nil_r. rewrite orb_false_r .
    reflexivity. simpl. rewrite IHl1. rewrite orb_assoc. simpl. reflexivity.
Qed.

(*Weaker version of [toList_sem], using Haskell equality instead of Coq's. sem m key == Some value
iff the (key, value) pair appears in toList*)
Lemma toList_sem' :
  forall `{Eq_ a} `{EqLaws a}  m lb ub, Bounded m lb ub ->
  forall key value, sem m key == Some value = true <->
     List.elem (key, value) (toList m) = true.
Proof.
  intros. generalize dependent value. induction H2.
  - simpl. intros. split; intros.
    + discriminate H2.
    + discriminate H2.
  - intros; split; intros; simpl.
    + rewrite toList_Bin. simpl. rewrite list_elem_or. simpl.
      simpl in H6. destruct (List.elem (key, value) (toList s1)) eqn : ?.
      * simpl. reflexivity.
      * simpl. specialize (IHBounded1 value). destruct IHBounded1.
        apply contrapositive in H7. destruct (sem s1 key) eqn : ?.
        { simpl in H6. contradiction. }
        { simpl in H6. destruct (_GHC.Base.==_ (key, value) (x, v)) eqn : ?.
          { simpl. reflexivity. }
          { simpl. rewrite eq_tuple_eq in Heqb1.
            rewrite andb_false_iff in Heqb1. destruct Heqb1.
            { rewrite H9 in H6. simpl in H6. apply IHBounded2. apply H6. }
            { destruct (_GHC.Base.==_ key x) eqn : ?.
              { simpl in H6. rewrite simpl_option_some_eq in H6.
                apply Eq_Symmetric in H6. unfold is_true in H6.
                rewrite H9 in H6. discriminate H6. }
              { simpl in H6. apply IHBounded2. assumption. }
            }
          }
        }
        { destruct (List.elem (key, value) (toList s1)). discriminate Heqb0.
          intro. discriminate H9. }
    + rewrite toList_Bin in H6. simpl in H6. rewrite list_elem_or in H6.
      rewrite orb_true_iff in H6. destruct H6.
      * apply IHBounded1 in H6. destruct (sem s1 key) eqn : ?.
        { simpl. assumption. }
        { discriminate H6. }
      * simpl in H6. rewrite orb_true_iff in H6. destruct H6.
        { assert (forall i, sem s1 key <> Some i). { rewrite eq_tuple_prop in H6.
          destruct H6. intros. intro. solve_Bounds e. }
          assert (sem s1 key = None). { destruct (sem s1 key). specialize (H7 a0).
          contradiction. reflexivity. }
          rewrite H8. simpl. rewrite eq_tuple_prop in H6. destruct H6.
          rewrite H6. simpl. rewrite simpl_option_some_eq. apply Eq_Symmetric.
          apply H9. }
        { apply IHBounded2 in H6. destruct (sem s2 key) eqn : ?.
          assert (sem s1 key = None). { apply (sem_inside H2_0) in Heqo.
          destruct Heqo. eapply sem_outside_above. apply H2_. order_Bounds e. }
          rewrite H7. simpl. assert (key == x = false) by solve_Bounds e. rewrite H8.
          simpl. assumption. discriminate H6. }
Qed.

(*Equality based (rather than prop based) version of the above*)
Lemma toList_sem'_eq :
  forall `{Eq_ a} `{EqLaws a}  m lb ub, Bounded m lb ub ->
  forall key value, sem m key == Some value = List.elem (key, value) (toList m).
Proof.
  intros. rewrite prop_bool.  eapply toList_sem'. apply H2.
Qed.

(*The next two lemmas say that every key in toList m is between the bounds of the map*)
Lemma toList_lb : forall m lb ub,
  Bounded m lb ub ->
  Forall (fun (i : e * a) => let (x, _) := i in isLB lb x = true) (toList m).
Proof.
  intros. induction H.
  - apply Forall_nil.
  - rewrite toList_Bin. rewrite Forall_forall in *.
    intros. simpl in H5. rewrite in_app_iff in *.
    destruct H5.
    + apply IHBounded1. assumption.
    +  simpl in H5.  destruct H5.
      *  subst.  assumption.
      * apply IHBounded2 in H5. simpl in H5. rename x0 into x2.
        destruct x2. order_Bounds e.
Qed.

Lemma toList_ub : forall m lb ub,
  Bounded m lb ub ->
  Forall (fun (i : e * a) => let (x, _) := i in isUB ub x = true) (toList m).
Proof.
  intros. induction H.
  - apply Forall_nil.
  - rewrite toList_Bin. rewrite Forall_forall in *. intros.
    simpl in H5. rewrite in_app_iff in *. destruct H5.
    + apply IHBounded1 in H5. destruct x0. order_Bounds e.
    + simpl in H5. destruct H5. subst. assumption. apply IHBounded2. assumption.
Qed.

(*The list of the empty tree is empty*)
Lemma toList_Tip: toList (@Tip e a) = nil.
Proof. reflexivity. Qed.

(*The list contains the left subtree, then the current value, then the right subtree
(crucial in showing that the list is sorted)*)
Lemma toList_bin:
  forall key value n (m1 m2 : Map e a),
  toList (Bin n key value m1 m2) = toList m1 ++ ((key, value) :: nil) ++ toList m2.
Proof. intros. apply toList_Bin. Qed.

(*The next two lemmas prove that the list from toList is in the same order even if we balance the tree. The
proofs are very similar to setProofs, only 1 more case at the end*)
Lemma toList_balanceR :
  forall x y (m1: Map e a) m2 lb ub,
  Bounded m1 lb (Some x) ->
  Bounded m2 (Some x) ub ->
  balance_prop (size m1) (size m2) \/
  balance_prop_inserted (size m2 - 1) (size m1) /\ (1 <= size m2)%Z  \/
  balance_prop (size m1 + 1) (size m2) ->
  toList (balanceR x y m1 m2) = toList m1 ++ ((x,y) :: nil) ++ toList m2.
Proof.
  intros.
  unfold balanceR.
  unfold op_zg__, op_zl__, Ord_Integer___, op_zg____, op_zl____.

  repeat lazymatch goal with [ H : Bounded ?s _ _ |- context [match ?s with _ => _ end] ] => inversion H; subst; clear H end;
  repeat lazymatch goal with [ |- context [if (?x <? ?y)%Z then _ else _] ] => destruct (Z.ltb_spec x y) end;
  rewrite ?size_Bin in *; simpl (size Tip) in *; simpl sem;
  simpl isLB in *;
  simpl isUB in *.
  all: try solve [exfalso; lia_sizes]. (* Some are simply impossible *)
  all: repeat find_Tip.
  all: rewrite ?toList_Bin, <- ?app_assoc; try reflexivity.
  simpl. rewrite <- app_assoc. simpl. reflexivity. simpl. rewrite <-app_assoc. simpl.
  reflexivity.
Qed.

Lemma toList_balanceL:
  forall x y (m1: Map e a) m2 lb ub,
  Bounded m1 lb (Some x) ->
  Bounded m2 (Some x) ub  ->
  balance_prop (size m1) (size m2) \/
  balance_prop_inserted (size m1 - 1) (size m2) /\ (1 <= size m1)%Z \/
  balance_prop (size m1) (size m2 + 1) ->
  toList (balanceL x y m1 m2) = toList m1 ++ ((x, y) :: nil) ++ toList m2.
Proof.
  intros.
  unfold balanceL.
  unfold op_zg__, op_zl__, Ord_Integer___, op_zg____, op_zl____.

  repeat lazymatch goal with [ H : Bounded ?s _ _ |- context [match ?s with _ => _ end] ] => inversion H; subst; clear H end;
  repeat lazymatch goal with [ |- context [if (?x <? ?y)%Z then _ else _] ] => destruct (Z.ltb_spec x y) end;
  rewrite ?size_Bin in *; simpl (size Tip) in *; simpl sem;
  simpl isLB in *;
  simpl isUB in *.
  all: try solve [exfalso; lia_sizes]. (* Some are simply impossible *)
  all: repeat find_Tip.
  all: rewrite ?toList_Bin, <- ?app_assoc; try reflexivity.
  all: simpl; rewrite <- app_assoc; reflexivity.
Qed.

(*If we insertMax into a tree, that value is at the end of the list*)
Lemma toList_insertMax:
   forall x y (m: Map e a) lb,
   Bounded m lb (Some x) ->
   toList (insertMax x y m) = toList m ++ (x,y) :: nil.
Proof.
  intros. remember (Some x) as ub'. generalize dependent x.
  induction H; intros.
  - simpl. reflexivity.
  - simpl. subst. specialize(IHBounded2 x0 eq_refl). revert IHBounded2.
    assert (isUB None x0 = true) by reflexivity. applyDesc e (@insertMax_Desc e a).
    intro. erewrite toList_balanceR. rewrite IHBounded2. rewrite toList_bin.
    rewrite <- app_assoc. simpl. reflexivity. apply H. apply HB.
    solve_size.
Qed.

(*If we insertMin into a tree, that value is at the beginning of the list*)
Lemma toList_insertMin:
   forall x y (m: Map e a) ub,
   Bounded m (Some x) ub ->
   toList (insertMin x y m) = (x,y) :: nil ++ toList m.
Proof.
  intros. remember (Some x) as ub'. generalize dependent x.
  induction H; intros.
  - simpl. reflexivity.
  - simpl. subst. specialize(IHBounded1 x0 eq_refl). revert IHBounded1.
    assert (isLB None x0 = true) by reflexivity. applyDesc e (@insertMin_Desc e a).
    intro. erewrite toList_balanceL. rewrite IHBounded1. rewrite toList_bin.
    simpl. reflexivity. apply HB. apply H0. solve_size.
Qed.

(*States that if we link 2 maps together, then the list is in the same order. These
past few lemmas together mean that when balancing the tree, the list does not change*)
Program Fixpoint toList_link (x : e) (y : a) (m1: Map e a)  (m2: Map e a)
  {measure (map_size m1 + map_size m2)} :
    forall lb ub,
    Bounded m1 lb (Some x) ->
    Bounded m2 (Some x) ub  ->
    isLB lb x = true ->
    isUB ub x = true->
    toList (link x y m1 m2) = toList m1 ++ (x,y) :: nil ++ toList m2 := _.
Next Obligation.
  intros.
  rewrite link_eq.
  inversion H; subst; clear H;
  inversion H0; subst; clear H0.
  * reflexivity.
  * erewrite toList_insertMin by solve_Bounded e.
    rewrite toList_Bin.
    reflexivity.
  * erewrite toList_insertMax by solve_Bounded e.
    rewrite toList_Bin.
    reflexivity.
  * destruct (Sumbool.sumbool_of_bool _);
    only 2: destruct (Sumbool.sumbool_of_bool _);
    rewrite ?Z.ltb_lt, ?Z.ltb_ge in *.
    - erewrite toList_balanceL; only 3: solve_Precondition e.
      erewrite toList_link by solve_Precondition e.
      rewrite ?toList_Bin, <- ?app_assoc. reflexivity.
      applyDesc e (@link_Desc e a); eassumption.
      applyDesc e (@link_Desc e a); solve_size.
    - erewrite toList_balanceR; only 2: solve_Precondition e.
      erewrite toList_link by solve_Precondition e.
      rewrite ?toList_Bin, <- ?app_assoc. reflexivity.
      applyDesc e (@link_Desc e a); eassumption.
      applyDesc e (@link_Desc e a); solve_size.
    - rewrite ?toList_bin, ?toList_Bin, <- ?app_assoc.
      unfold bin. rewrite toList_bin. rewrite toList_bin.
      rewrite toList_bin. simpl. rewrite <- app_assoc. simpl.
      reflexivity.
Qed.

(** *** Sortedness of [toList] *)

Require Import Coq.Sorting.Sorted.
Close Scope Z.

(*Maps are sorted only by keys*)
Local Definition lt : e * a -> e * a -> Prop
  := fun x1 x2 => let (e1, a1) := x1 in let (e2, a2) := x2 in (e1 < e2) = true.

(* States that if two lists are sorted and all values in the first are smaller
than all values in the second, then appending the two lists gives a sorted list. *)
Lemma sorted_append:
  forall (l1 : list (e * a)) (l2 : list (e * a)) (x : e),
  StronglySorted lt l1 ->
  StronglySorted lt l2 ->
  (forall (y : e) (z : a), List.In (y, z) l1 -> (y < x) = true) ->
  (forall y z, List.In (y, z) l2 -> (x <= y) = true) ->
  StronglySorted lt (l1 ++ l2).
Proof.
  intros ??? Hsorted1 Hsorted2 Hlt Hge.
  induction Hsorted1.
  * apply Hsorted2.
  * simpl. apply SSorted_cons.
    + apply IHHsorted1.
      intros y z Hy.
      eapply Hlt.
      right. apply Hy.
    + rewrite Forall_forall.
      intros z Hz.
      rewrite in_app_iff in Hz.
      destruct Hz.
      - rewrite Forall_forall in H.
        apply H; auto.
      - destruct a0.  assert (e0 < x = true). eapply Hlt. left. reflexivity.
        unfold lt. destruct z. apply Hge in H0. order e.
Qed.

(*Similar to List.elem, but does not require that a be in the Eq typeclass (because it doesn't actually
matter; the a's are not ever compared)*)
Fixpoint list_elem_tuple (x : e * a) (l : list (e * a)) :=
  match l with
  | nil => false
  | h :: t => let (a, b) := h in let (x1, x2) := x in (a == x1) || list_elem_tuple x t
  end.

(*This states that if x is a lower bound for a list and the tuple i is in the list, then x is less than i.
Note: this required a change from toList (using lt rather than < in the conclusion), though this
is needed because there is no definition of ordering on all tuples*)
Lemma All_lt_elem:
  forall x i xs,
  Forall (lt x) xs ->
  list_elem_tuple i xs = true ->
  lt x i.
Proof.
  intros.
  induction H.
  * simpl in H0. inversion H0.
  * simpl in *. destruct x0. destruct i.
    rewrite orb_true_iff in H0.
    destruct H0.
    - unfold lt in *. destruct x. order e.
    - intuition.
Qed.

(*toList is sorted by key*)
Lemma to_List_sorted:
  forall m lb ub,
  Bounded m lb ub ->
  StronglySorted lt (toList m).
Proof.
  intros. induction H.
  - apply SSorted_nil.
  - rewrite toList_bin. eapply sorted_append. assumption.
    apply SSorted_cons. assumption. apply toList_lb in H0.
    apply H0. apply toList_ub in H.  intros.
    rewrite Forall_forall in H.
    remember (y,z) as t.
    apply H in H5. destruct t. inversion Heqt. rewrite <- H7. unfold isUB in H5. apply H5.
    intros. simpl in H5. destruct H5.
    + inversion H5. order e.
    + apply toList_lb in H0.
      rewrite Forall_forall in H0. apply H0 in H5. order_Bounds e.
Qed.

(** ** Verification of [toAscList] *)

Lemma toAscList_spec: @toAscList = @toList. Proof. reflexivity. Qed.

(** ** Verification of [elems] *)

Lemma fold_right_with_assoc:
  forall l1 l2,
    fold_right (fun (x : e * a) acc => let (a,b) := x in b :: acc) l1 l2  =
  fold_right (fun (x : e * a) acc => let (a,b) := x in b :: acc) nil l2 ++ l1.
Proof.
  intros. generalize dependent l1. induction l2.
  - intros. simpl. reflexivity.
  - intros. simpl. destruct a0. rewrite IHl2. simpl. reflexivity.
Qed.

Lemma foldr_const_append:
  forall xs (map : Map e a),
  foldr cons xs map = elems map ++ xs.
Proof.
  intros. generalize dependent xs. induction map; intros.
  - simpl. unfold elems. simpl. rewrite IHmap1. rewrite IHmap2. rewrite IHmap1.
    rewrite IHmap2. rewrite <- app_assoc. simpl. rewrite <- app_assoc. reflexivity.
  - simpl. reflexivity.
Qed.

Lemma elems_Bin:
  forall sz key value (m1 m2 : Map e a),
  elems (Bin sz key value m1 m2) = elems m1 ++ (value :: nil) ++ elems m2.
Proof.
  intros.
  unfold elems at 1. simpl. rewrite foldr_const_append. rewrite foldr_const_append.
  rewrite app_nil_r. reflexivity.
Qed.

(*For a map, elems means we take the 2nd element of each tuple in toList*)
Lemma elems_spec: forall map,
  elems map = fold_right (fun (x : e * a) acc => let (a,b) := x in  b :: acc) nil (toList map).
Proof.
  intros. induction map.
  - rewrite elems_Bin.  rewrite IHmap1. simpl. rewrite IHmap2. rewrite toList_bin.
    rewrite fold_right_app. simpl. rewrite <- fold_right_with_assoc. reflexivity.
  - simpl. unfold elems. simpl. reflexivity.
Qed.

(** ** Verification of [keys] *)

Lemma fold_right_with_assoc':
  forall l1 l2,
    fold_right (fun (x : e * a) acc => let (a,b) := x in a :: acc) l1 l2  =
  fold_right (fun (x : e * a) acc => let (a,b) := x in a :: acc) nil l2 ++ l1.
Proof.
  intros. generalize dependent l1. induction l2.
  - intros. simpl. reflexivity.
  - intros. simpl. destruct a0. rewrite IHl2. simpl. reflexivity.
Qed.

Lemma foldrWithKey_const_append':
  forall xs (map : Map e a),
  foldrWithKey (fun x y t => x :: t) xs map = keys map ++ xs.
Proof.
  intros. generalize dependent xs. induction map; intros.
  - unfold keys in *.  simpl. rewrite IHmap1. rewrite IHmap2.
    rewrite (IHmap1 (k :: foldrWithKey (fun (arg_0__ : e) (_ : a) (arg_2__ : list e) => arg_0__ :: arg_2__) nil map2) ).
    rewrite <- app_assoc. reflexivity.
  - simpl. reflexivity.
Qed.

Lemma keys_Bin:
  forall sz key value (m1 m2 : Map e a),
  keys (Bin sz key value m1 m2) = keys m1 ++ (key :: nil) ++ keys m2.
Proof.
  intros.
  unfold keys at 1. simpl. rewrite foldrWithKey_const_append'. rewrite foldrWithKey_const_append'.
  rewrite app_nil_r. reflexivity.
Qed.

Lemma keys_spec: forall map,
  keys map = fold_right (fun (x : e * a) acc => let (a,b) := x in  a :: acc) nil (toList map).
Proof.
  intros. induction map.
  - rewrite keys_Bin.  rewrite IHmap1. simpl. rewrite IHmap2. rewrite toList_bin.
    rewrite fold_right_app. simpl. rewrite <- fold_right_with_assoc'. reflexivity.
  - simpl. unfold keys. simpl. reflexivity.
Qed.

(** ** Verification of [assocs] *)
Lemma assocs_spec: forall (map: Map e a),
  assocs map = toList map.
Proof.
  intros. unfold assocs. unfold toList. reflexivity.
Qed.

(** ** Verification of [toDescList] *)

(*The reverse of a list is empty iff the original list was empty*)
Lemma rev_nil : forall {A : Type} (x : list A),
  rev x = nil <-> x = nil.
Proof.
  intros. split; intros.
  - destruct x.
    + reflexivity.
    + simpl in H. assert (nil <> rev x ++ a0 :: nil ) by apply app_cons_not_nil.
      rewrite H in H0. contradiction.
  - rewrite H. reflexivity.
Qed.

(*Reversing a list is injective*)
Lemma rev_inj {A} (x y : list A) :
  rev x = rev y -> x = y.
Proof.
  intros. generalize dependent y. induction x using rev_ind; intros.
  - simpl in H.  symmetry. apply rev_nil. symmetry. assumption.
  - rewrite rev_app_distr in H. simpl in H. destruct y using rev_ind.
    + simpl in H. discriminate H.
    + rewrite rev_app_distr in H. simpl in H. inversion H. subst.
    apply IHx in H2. subst. reflexivity.
Qed.

(*from SetProofs, not actually useful*)
Lemma foldl_acc_app: forall l (m : Map e a),
  foldl (flip cons) l m = foldl (flip cons) nil m ++ l.
Proof.
  intros. generalize dependent l. induction m; intros.
  - simpl. rewrite IHm2. rewrite  IHm1. symmetry. rewrite IHm2. rewrite <- app_assoc.
    simpl. unfold flip. reflexivity.
  - simpl. reflexivity.
Qed.

(*The version we want for toDescList_spec*)
Lemma foldlWithKey_acc_app: forall l (m : Map e a),
  foldlWithKey (fun acc x y => (x, y) :: acc) l m = foldlWithKey (fun acc x y => (x,y) :: acc) nil m ++ l.
Proof.
  intros. generalize dependent l. induction m; intros.
  - simpl. rewrite IHm2. rewrite IHm1. symmetry. rewrite IHm2. rewrite <- app_assoc.
    reflexivity.
  - simpl. reflexivity.
Qed.

(*reversing a list takes the last element and puts it at the front*)
Lemma rev_cons: forall {A: Type} (l : list A) (x : A),
  rev (l ++ x :: nil) = x :: rev l.
Proof.
  intros. induction l.
  - simpl. reflexivity.
  - simpl. rewrite IHl. simpl. reflexivity.
Qed.

(*toDescList returns the reverse of toAscList on a map*)
Lemma toDescList_spec (map : Map e a) :
  toDescList map = rev (toAscList map).
Proof.
  unfold toDescList. unfold toAscList.
  induction map.
  - simpl. rewrite IHmap1. rewrite foldlWithKey_acc_app. rewrite IHmap2.
    assert ((k, a0) :: rev (foldrWithKey (fun (k0 : e) (x : a) (xs : list (e * a)) => (k0, x) :: xs) nil map1)=
      rev (foldrWithKey (fun (k0 : e) (x : a) (xs : list (e * a)) => (k0, x) :: xs) nil map1 ++ (k, a0) :: nil))
      by (symmetry; apply rev_cons).
    rewrite H. rewrite <- rev_app_distr.
    rewrite foldrWithKey_const_append. rewrite app_nil_r. rewrite foldrWithKey_const_append. rewrite app_nil_r.
    rewrite foldrWithKey_const_append. rewrite <- app_assoc. simpl. reflexivity.
  - simpl. reflexivity.
Qed.

(** ** Verification of [foldl] and [foldlWithKey *)

(** This relates [foldl] and [elems]. *)
Lemma foldl_spec:
  forall k (n : a) (m: Map e a),
  foldl k n m = fold_left k (elems m) n.
Proof.
  intros. generalize dependent n. induction m; intros.
  - simpl. rewrite (elems_Bin s k0 a0 m1 m2) . rewrite IHm1. rewrite IHm2.
    rewrite fold_left_app. simpl. reflexivity.
  - simpl. reflexivity.
Qed.

(*TODO: REPLACE WITH UPDATED SPEC FROM MAPFUNCTIONPROOFS*)
(** This relates [foldlWithKey] and [toList]. *)
Lemma foldlWithKey_spec:
  forall f (n : e * a) (m: Map e a),
  foldlWithKey f n m = fold_left (fun xs (x : e * a) => let (a,b) := x in f xs a b)  (toList m) n.
Proof.
  intros. generalize dependent n. induction m; intros.
  - simpl. rewrite toList_Bin. rewrite IHm1. rewrite IHm2.
    rewrite fold_left_app. simpl. reflexivity.
  - reflexivity.
Qed.

(** ** Verification of [foldl'] *)

Lemma foldl'_spec:
  forall k (n : a) (m : Map e a),
  foldl' k n m = foldl k n m.
Proof. reflexivity. Qed.

(** ** Verification of [foldlWithKey'] *)
Lemma foldlWithKey'_spec:
  forall k (n : a) (m : Map e a),
  foldlWithKey' k n m = foldlWithKey k n m.
Proof. reflexivity. Qed.

(** ** Verification of [size] *)

Lemma size_spec:
  forall (s: Map e a) lb ub,
  Bounded s lb ub ->
  size s = Z.of_nat (length (toList s)).
Proof.
  intros. induction H.
  - simpl. reflexivity.
  - simpl. rewrite toList_Bin. simpl. rewrite app_length. simpl.
    rewrite Nat2Z.inj_add. rewrite <- IHBounded1.
    rewrite Nat2Z.inj_succ. rewrite <- IHBounded2.
    omega.
Qed.

(** ** Verification of [Eq] *)

(*Note: This is substantially different from SetProofs because the values' equality may differ between
Coq and Haskell. Instead of a single spec, we will prove 3 different specifications of [Eq]
1. [weak_equals_spec]: This states that m1 == m2 iff for every key, sem m1 key == sem m2 key
 (all according to Haskell notions of equality)
2. [strong_eq1]: If sem m1 key = sem m2 key for all keys, then m1 == m2 (the other direction is not true
in general)
3. [strong_eq2]: If Haskell equality is equivalent to Coq equality for the values (for example, if the
values are integers), then m1 == m2 iff for every key, sem m1 key = sem m2 key

The benefit of this is that the stronger notions of equality are much easier to work with in Coq proofs,
and means that if Coq and Haskell equality agree, we have a very strong specification of the equality of the
corresponding maps.
*)

(*START NEW*)
(*I'm still not quite sure how to organize this, as there is a ton of duplication, but this additional
specification gives a specification that is actually useful in Coq, allowing us to prove all the
properties we want even without an {eqLaws a} assumption*)
Fixpoint eqlist_key {e a} `{EqLaws e} (l1 l2 : list (e * a)) :=
  match l1, l2 with
  | nil, nil => True
  | x:: t1 , y :: t2 => let (a,b) := x in let (c,d) := y in (a == c = true /\ b = d /\ eqlist_key t1 t2)
  | _, _ => False
  end.

Lemma eqlist_key_sym:
  forall {e a} `{EqLaws e} (xs ys: list (e * a)),
  eqlist_key xs ys <-> eqlist_key ys xs.
Proof.
  intros. generalize dependent ys. induction xs; intros; destruct ys; try (reflexivity).
  simpl. destruct a1. destruct p. split; intros.
  - destruct H1. destruct H2. split. apply Eq_Symmetric. assumption. split. subst. reflexivity.
    rewrite <- IHxs. assumption.
  - destruct H1. destruct H2. split. apply Eq_Symmetric. assumption. split. subst. reflexivity.
    rewrite IHxs. assumption.
Qed.

Lemma eqlist_key_trans:
  forall {e a} `{EqLaws e} (xs ys zs: list (e * a)),
  eqlist_key xs ys ->
  eqlist_key ys zs ->
  eqlist_key xs zs.
Proof.
  intros. generalize dependent ys. revert zs. induction xs; intros; destruct ys; try (reflexivity);
  destruct (zs); try (reflexivity); try (inversion H1); try (inversion H2).
  simpl in H1. simpl in H2. destruct a1. destruct p. destruct p0. simpl.
  repeat match goal with
  | [H: _ /\ _  |- _] => destruct H
  end; subst. split. eapply Eq_Transitive. apply H1. apply H2. split. reflexivity.
  eapply IHxs. apply H6. apply H4.
Qed.

Lemma eqlist_key_refl:
  forall {e a} `{EqLaws e} (xs: list (e * a)),
  eqlist_key xs xs.
Proof.
  intros. induction xs. reflexivity. simpl.
  destruct a1. split. apply Eq_Reflexive. split. reflexivity. apply IHxs.
Qed.

Lemma eqlist_key_length:
  forall {e a} `{EqLaws e} (xs ys : list (e * a)),
  eqlist_key xs ys ->
  length xs = length ys.
Proof.
  intros. generalize dependent ys. induction xs; intros; destruct ys; try (reflexivity);
  try (inversion H1).
  simpl. simpl in H1. destruct a1. destruct p. destruct H1. destruct H2. erewrite IHxs.
  reflexivity. assumption.
Qed.

Lemma eqlist_Key_In:
  forall {e a}  `{EqLaws e} (xs ys : list (e * a)) x y,
  eqlist_key xs ys ->
  Key_In x y xs <-> Key_In x y ys.
Proof.
  intros. generalize dependent ys. induction xs; intros; destruct ys; simpl in *; try (reflexivity);
  try(destruct H1).
  destruct a1. destruct p. destruct H1. destruct H2. subst. split; intros.
  + destruct H2. destruct H2. left. split. eapply Eq_Transitive. apply Eq_Symmetric.
    apply H1. apply H2. assumption. right. apply IHxs. assumption. assumption.
  + destruct H2. destruct H2. left. split. eapply Eq_Transitive. apply H1. apply H2. assumption.
    right. rewrite  IHxs. apply H2. assumption.
Qed.

Lemma sem_false_nil:
  forall (m: Map e a),
  (forall i, sem m i = None) <-> m = Tip.
Proof.
  intros. destruct m.
  - simpl. split; intros.
    + specialize (H e0). rewrite Eq_Reflexive in H. simpl in H.
       destruct (sem m1 e0); inversion H.
    + inversion H.
  - simpl. split; intros; reflexivity.
Qed.

Lemma Forall_lt: forall (l : list (e * a)) t,
  Forall (lt t) l <-> (forall x y, Key_In x y l -> lt t (x,y)).
Proof.
  intros. split; induction l; intros.
  - inversion H0.
  - inversion H. inversion H0. subst. destruct a0. unfold lt. destruct t.
    unfold lt in H3. order e. apply IHl. apply H4. apply H5.
  - constructor.
  - simpl in H. destruct a0. constructor. specialize (H e0 a0). apply H.
    left. split. order e. reflexivity. apply IHl. intros. apply H.
    right. assumption.
Qed.

Lemma list_Key_In_eq : forall (x1 x2 : e) (y : a) l,
  x1 == x2 = true ->
  Key_In x1 y l <-> Key_In x2 y l.
Proof.
  intros. induction l; split; intros; try (inversion H0); simpl; destruct a0.
  - left. split. order e. destruct H1. assumption.
  - right. apply IHl. assumption.
  - left. split. order e. destruct H1. assumption.
  - right. apply IHl. assumption.
Qed.

Lemma strongly_sorted_unique:
  forall (xs ys : list (e * a)),
  StronglySorted lt xs ->
  StronglySorted lt ys ->
  (forall x y, Key_In x y xs <-> Key_In x y ys) ->
  eqlist_key xs ys.
Proof.
  intros. generalize dependent ys. induction xs; intros; destruct ys; try (reflexivity).
  - simpl in H1. destruct p. specialize (H1 e0 a0). destruct H1. apply H2. left.
    split. order e. reflexivity.
  - simpl in H1. destruct a0. specialize (H1 e0 a0). destruct H1. apply H1. left.
    split. order e. reflexivity.
  - simpl. destruct a0. destruct p. simpl in H1. inversion H; subst. inversion H0; subst.
    rewrite Forall_lt in H7. rewrite Forall_lt in H5. assert (A:=H1).
    specialize (H1 e1 a1). destruct H1.
    assert (_GHC.Base.==_ e0 e1 = true /\ a0 = a1 \/ Key_In e1 a1 xs). apply H2. left.
    split. order e. reflexivity. destruct H3. split. order e. split. destruct H3. subst.
    reflexivity. apply IHxs. assumption. assumption. intros.
    assert (A1:=A). specialize (A x y). split; intros.
    destruct A.
    assert (_GHC.Base.==_ e1 x = true /\ a1 = y \/ Key_In x y ys). apply H9. right.
    apply H8. destruct H11. apply H5 in H8. unfold lt in H8. order e. assumption.
    destruct A. assert (_GHC.Base.==_ e0 x = true /\ a0 = y \/ Key_In x y xs). apply H10.
    right. apply H8. destruct H11. apply H7 in H8. unfold lt in H8. order e. assumption.
    assert (A1:=A). specialize (A e0 a0). destruct A.
    assert ( _GHC.Base.==_ e1 e0 = true /\ a1 = a0 \/ Key_In e0 a0 ys). apply H8.
    left. split. order e. reflexivity. destruct H10.
    apply H5 in H3. unfold lt in H3. order e.
    apply H5 in H3. apply H7 in H10. unfold lt in H3. unfold lt in H10. order e.
Qed.

Lemma Key_In_unique: forall k (m: Map e a) lb ub v1 v2,
  Bounded m lb ub ->
  Key_In k v1 (toList m) /\ Key_In k v2 (toList m) -> v1 = v2.
Proof.
  intros. destruct H0. rewrite <- toList_sem in H0. rewrite <- toList_sem in H1.
  rewrite H1 in H0. inversion H0; subst; reflexivity. all: apply H.
Qed.

Lemma Key_In_not_in_list : forall key (map: Map e a) lb ub,
  Bounded map lb ub ->
  (forall value, (~Key_In key value (toList map))) <-> sem map key = None.
Proof.
  intros; split; intros.
  - destruct (sem map key) eqn : ?.
    + rewrite toList_sem in Heqo. specialize (H0 a0). contradiction. apply H.
    + reflexivity.
  - intro. rewrite <- toList_sem in H1. rewrite H1 in H0. inversion H0. apply H.
Qed.

Lemma eq_size : forall (m1: Map e a) m2 lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  eqlist_key (toList m1) (toList m2)  ->
  Internal.size m1 = Internal.size m2.
Proof.
  intros. rewrite size_size. erewrite size_spec. erewrite size_spec.
  apply eqlist_key_length in H1. rewrite H1. reflexivity. all : eassumption.
Qed.

(*The real lemma we want for Coq purposes. This does not require any information about
{EqLaws a} and gives us a very useful specification of equivalent maps*)
Lemma coq_equals_spec: forall (m1: Map e a) m2 lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  (forall i, sem m1 i = sem m2 i) <-> eqlist_key (toList m1) (toList m2).
Proof.
  intros. split; intros.
  - apply strongly_sorted_unique. eapply to_List_sorted. eassumption.
    eapply to_List_sorted. eassumption. intros. split; intros.
    + rewrite <- toList_sem in *. rewrite <- H1. assumption. all: eassumption.
    + rewrite <- toList_sem in *. rewrite H1. assumption. all: eassumption.
  - assert (forall x y, Key_In x y (toList m1) <-> Key_In x y (toList m2)). intros.
    apply eqlist_Key_In. assumption. specialize (H2 i).
    destruct (sem m1 i) eqn : ?. specialize (H2 a0). rewrite toList_sem in Heqo.
    apply H2 in Heqo. rewrite <- toList_sem in Heqo. symmetry. assumption.
    eassumption. eassumption. destruct (sem m2 i) eqn : ?.
    rewrite toList_sem in Heqo0. rewrite <- Key_In_not_in_list in Heqo.
    specialize (Heqo a0). specialize (H2 a0). apply H2 in Heqo0. contradiction.
    eassumption. eassumption. reflexivity.
Qed.

(*A useful corollary*)
Lemma size_sem: forall (m1: Map e a) m2 lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  (forall i, sem m1 i = sem m2 i) ->
  size m1 = size m2.
Proof.
  intros. pose proof (coq_equals_spec m1 m2 lb ub H H0). destruct H2.
  apply H2 in H1. repeat(erewrite size_spec).
  assert (length (toList m1) = length (toList m2)). apply eqlist_key_length. assumption.
  rewrite H4. reflexivity. all: eassumption.
Qed.

(*END NEW*)

(*[eqlist] is symmetric*)
Lemma eqlist_sym:
  forall {a} `{EqLaws a} (xs ys : list a),
  eqlist xs ys = eqlist ys xs.
Proof.
  intros. generalize dependent ys. induction xs; intros.
  - destruct ys. reflexivity. simpl. reflexivity.
  - destruct ys. simpl. reflexivity. simpl.
    destruct (a1 == a2) eqn : ?.
    + simpl. rewrite Eq_Symmetric. simpl. apply IHxs. apply Heqb0.
    + simpl. assert (a2 == a1 = false). apply Lemmas.Eq_neq_sym. assumption.
      rewrite H1. simpl. reflexivity.
Qed.

(*Equal lists have the same length*)
Lemma eqlist_length:
  forall {a} `{Eq_ a} (xs ys : list a),
  eqlist xs ys = true ->
  length xs = length ys.
Proof.
  intros. generalize dependent ys. induction xs; intros.
  - destruct ys. reflexivity. simpl in H0. discriminate H0.
  - destruct ys. simpl in H0. discriminate H0. simpl in H0.
    simpl. rewrite (IHxs ys). reflexivity. apply andb_true_iff in H0.
    destruct H0. assumption.
Qed.

(*Equal lists have the same elements in them*)
Lemma eqlist_elem:
  forall `{Eq_ a}  `{EqLaws a} (xs ys : list (e * a)) x y,
  eqlist xs ys = true ->
  List.elem (x, y) xs = true <-> List.elem (x, y) ys = true.
Proof.
  intros. generalize dependent ys. induction xs; intros.
  - simpl. destruct ys. simpl. reflexivity. simpl in H2. discriminate H2.
  - destruct ys. simpl in H2. discriminate H2. simpl. simpl in H2. split; intros.
    + destruct p. rewrite andb_true_iff in H2. destruct H2. rewrite orb_true_iff.
      rewrite orb_true_iff in H3. destruct H3. left. destruct a0.  eapply Eq_Tuple_Trans.
      apply H3. apply H2. right. apply IHxs. assumption. assumption.
    + rewrite orb_true_iff. rewrite orb_true_iff in H3. rewrite andb_true_iff in H2.
      destruct H2. destruct H3. left. destruct a0. destruct p. eapply Eq_Tuple_Trans.
      apply H3. eapply Eq_Tuple_Sym. assumption. right. rewrite (IHxs ys). assumption. assumption.
Qed.
(*
(*States that a map is empty iff sem key map returns None for every key*)
Lemma sem_false_nil:
  forall (m: Map e a),
  (forall i, sem m i = None) <-> m = Tip.
Proof.
  intros. remember m as m1. split; intros.
  - destruct m.
    + assert (sem m1 e0 <> None). { subst.
      simpl. destruct (sem m2 e0).
      * simpl. intro. discriminate H0.
      * simpl. rewrite Eq_Reflexive. simpl. intro. discriminate H0. }
        specialize (H e0). rewrite H in H0. contradiction.
    + assumption.
  - rewrite H. simpl. reflexivity.
Qed.
*)
(*We don't want to use Forall_forall because all we know is that List.elem is true,
which is much weaker than List.In*)
Lemma Forall_lt': forall `{Eq_ a} `{EqLaws a} (l : list (e * a)) t,
  Forall (lt t) l <-> (forall x y, List.elem (x, y) l = true -> lt t (x,y)).
Proof.
  intros. split; induction l; intros.
  - simpl in H3. discriminate H3.
  - inversion H2. subst. simpl in H3. rewrite orb_true_iff in H3. destruct H3.
    destruct t. destruct a0. unfold lt in H6. unfold lt. rewrite eq_tuple_prop in H3.
    order e. apply IHl. apply H7. apply H3.
  - apply Forall_nil.
  - apply Forall_cons. destruct a0. specialize (H2 e0 a0). apply H2. simpl.
    apply orb_true_iff. left. apply Eq_Tuple_Refl. apply IHl. intros. apply H2.
    simpl. apply orb_true_iff. right. apply H3.
Qed.

(*If two tuples are equal according to Haskell, List.elem returns the same result for either on a list*)
Lemma list_elem_eq : forall `{Eq_ a} `{EqLaws a} (x1 x2 : e) (y1 y2 : a) l,
  (x1, y1) == (x2, y2) = true ->
  List.elem (x1, y1) l = true <-> List.elem (x2, y2) l = true.
Proof.
  intros. induction l.
  - simpl. split; intros; discriminate H3.
  - split; intros; simpl in *; rewrite orb_true_iff in *.
    + destruct H3.
      * left. destruct a0. eapply Eq_Tuple_Trans. eapply Eq_Tuple_Sym. apply H2. apply H3.
      * right. apply IHl. apply H3.
    + destruct H3.
      * left. destruct a0. eapply Eq_Tuple_Trans. apply H2. apply H3.
      * right. apply IHl. apply H3.
Qed.

(*Strongly sorted lists with the same elements are the same.*)
(*TODO: Clean up the proof*)
Lemma strongly_sorted_unique':
  forall `{Eq_ a} `{EqLaws a} (xs ys : list (e * a)),
  StronglySorted lt xs ->
  StronglySorted lt ys ->
  (forall x y, List.elem (x, y) xs = true <-> List.elem (x,y) ys = true) ->
  eqlist xs ys = true.
Proof.
  intros. generalize dependent ys. induction xs; intros.
  - simpl in H4. destruct ys. reflexivity.
    assert (forall x y, List.elem (x,y) (p :: ys) = false). { intros. specialize (H4 x y).
   destruct H4. apply contrapositive in H5. destruct (List.elem (x, y) (p :: ys)). contradiction.
    reflexivity. intro. discriminate H6. }
    assert (List.elem p (p :: ys) = true). { simpl. rewrite orb_true_iff. left. destruct p.
    apply Eq_Tuple_Refl. } destruct p. specialize (H5 e0 a0). rewrite H6 in H5. discriminate H5.
  - destruct ys.
    + assert (forall x y, List.elem (x,y) (a0 :: xs) = false). { intros x y.
      specialize (H4 x y). destruct H4. apply contrapositive in H4. destruct (List.elem (x, y) (a0 :: xs)).
      contradiction. reflexivity. intro. simpl in H6. discriminate H6. }
      destruct a0. assert (List.elem (e0, a0) ((e0, a0) :: xs) = true). { simpl. rewrite orb_true_iff.
      left. apply Eq_Tuple_Refl. }
      specialize (H5 e0 a0). rewrite H6 in H5. discriminate H5.
    + simpl. rewrite andb_true_iff. inversion H2; subst. inversion H3; subst. split.
      assert (A:=H4). destruct a0. destruct p. specialize (H4 e0 a0). specialize (A e1 a1).
      destruct H4. destruct A.
      assert (List.elem (e0, a0) ((e1, a1) :: ys) = true). { apply H4. simpl. rewrite orb_true_iff.
      left. apply Eq_Tuple_Refl. }
      assert (List.elem (e1, a1) ((e0, a0) :: xs) = true). { apply H11. simpl. rewrite orb_true_iff.
      left. apply Eq_Tuple_Refl. }
      rewrite Forall_lt' in H8. rewrite Forall_lt' in H10. simpl in H12. simpl in H13.
      rewrite orb_true_iff in *. destruct H12. destruct H13. apply H12. apply H12.
      destruct H13. apply Eq_Tuple_Sym. apply H13. apply H8 in H13. apply H10 in H12.
      unfold lt in H12. unfold lt in H13. order e.
      apply IHxs. assumption. assumption. intros. split; intros.
      * assert (A1:=H4). specialize (H4 x y). destruct H4. rewrite Forall_lt' in H8. rewrite Forall_lt' in H10.
        assert (A:=H5).  assert (List.elem (x,y) (a0 :: xs) = true). {
        simpl. rewrite orb_true_iff. right. assumption. }
        apply H4 in H11. simpl in H11.  rewrite orb_true_iff in H11. destruct H11.
        { apply H8 in H5. destruct p. assert (List.elem (e0, a1) (a0 :: xs) = true). {
          apply A1. simpl. rewrite orb_true_iff. left. apply Eq_Tuple_Refl. }
          simpl in H12. rewrite orb_true_iff in H12. destruct H12.
          { destruct a0. unfold lt in H5. rewrite eq_tuple_prop in H11. rewrite eq_tuple_prop in H12.
            order e. }
          { destruct a0. assert (List.elem (e1, a0) ((e0, a1) :: ys) = true). { apply A1.
            simpl. rewrite orb_true_iff. left. apply Eq_Tuple_Refl. }
           simpl in H13. rewrite orb_true_iff in H13. destruct H13.
            { rewrite eq_tuple_prop in H11. rewrite eq_tuple_prop in H13.
              apply H8 in A. apply H8 in H12. unfold lt in *. order e. }
            { assert (A2:=H13). assert (A3:=H12). apply H10 in H13. apply H8 in H12.
              unfold lt in *. order e. }
            }
          }
          { apply H11. }
          (*Basically the same proof - try to clean up*)
        * assert (A1:=H4). specialize (H4 x y). destruct H4. rewrite Forall_lt' in H8. rewrite Forall_lt' in H10.
        assert (A:=H5).  assert (List.elem (x,y) (p :: ys) = true). {
        simpl. rewrite orb_true_iff. right. assumption. }
        apply H6 in H11. simpl in H11.  rewrite orb_true_iff in H11. destruct H11.
        { apply H10 in H5. destruct p. assert (List.elem (e0, a1) (a0 :: xs) = true). {
          apply A1. simpl. rewrite orb_true_iff. left. apply Eq_Tuple_Refl. }
          simpl in H12. rewrite orb_true_iff in H12. destruct H12.
          { destruct a0. unfold lt in H5. rewrite eq_tuple_prop in H11. rewrite eq_tuple_prop in H12.
            order e. }
          { destruct a0. assert (List.elem (e1, a0) ((e0, a1) :: ys) = true). { apply A1.
            simpl. rewrite orb_true_iff. left. apply Eq_Tuple_Refl. }
           simpl in H13. rewrite orb_true_iff in H13. destruct H13.
            { rewrite eq_tuple_prop in H11. rewrite eq_tuple_prop in H13.
              apply H10 in A. apply H8 in H12. unfold lt in *. order e. }
            { assert (A2:=H13). assert (A3:=H12). apply H10 in H13. apply H8 in H12.
              unfold lt in *. order e. }
            }
          }
          { apply H11. }
Qed.

(*A few final lemmas before the [Eq] specs. The first states that if a key is not in [toList],
  then sem returns false, and vice versa. *)

Lemma elem_not_in_list : forall `{Eq_ a} `{EqLaws a} key map lb ub,
  Bounded map lb ub ->
  (forall value, List.elem (key, value) (toList map) = false) <-> sem map key = None.
Proof.
  intros; split; intros.
  - destruct (sem map key) eqn : ?.
    + assert (sem map key == Some a0 = true). { rewrite Heqo. apply Eq_Reflexive. } eapply toList_sem' in H4.
      specialize (H3 a0). rewrite H4 in H3. discriminate H3. apply H2.
    + reflexivity.
  - destruct (List.elem (key, value) (toList map)) eqn : ?.
    + rewrite <- toList_sem' in Heqb0. rewrite H3 in Heqb0. discriminate Heqb0. apply H2.
    + reflexivity.
Qed.

(*If two maps have equal lists, their size is equal*)
Lemma eq_size' : forall `{Eq_ a} `{EqLaws a} m1 m2 lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  toList m1 == toList m2 = true ->
  Internal.size m1 = Internal.size m2.
Proof.
  intros. rewrite size_size. erewrite size_spec. erewrite size_spec.
  unfold op_zeze__ in H4. unfold Eq_list in H4. unfold op_zeze____ in H4. apply eqlist_length in H4.
  rewrite H4. reflexivity. apply H3. apply H2.
Qed.

(*Map equality is defined by checking both [length] and [toList], but [length] does not matter.
This makes the next proofs a bit easier.*)
Lemma eq_toList : forall `{Eq_ a} `{EqLaws a} m1 m2 lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  m1 == m2 = true <-> (toList m1 == toList m2) = true.
Proof.
  intros. split; intros.
  - unfold op_zeze__ in H4. unfold Eq___Map in H4. unfold op_zeze____ in H4.
    unfold Internal.Eq___Map_op_zeze__ in H4. rewrite andb_true_iff in H4. destruct H4.
    unfold toList. assumption.
  - unfold_zeze. unfold  Eq___Map. unfold Internal.Eq___Map_op_zeze__. rewrite andb_true_iff.
    split. assert (Internal.size m1 = Internal.size m2). eapply eq_size'. apply H2. apply H3.
    assumption. rewrite H5. apply Eq_Reflexive. unfold toList in *. assumption.
Qed.

Lemma weak_equals_spec:
  forall `{Eq_ a} `{EqLaws a} m1 m2 lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  m1 == m2 = true <-> (forall i, sem m1 i == sem m2 i = true).
Proof.
  intros. split; intros. unfold op_zeze__ in H4. unfold Eq___Map in H4.
      unfold op_zeze____ in H4. unfold Internal.Eq___Map_op_zeze__ in H4.  rewrite andb_true_iff in H4.
      destruct H4. unfold op_zeze__ in H5. unfold Eq_list in H5. unfold op_zeze____ in H5.
  - destruct (sem m1 i) eqn : ?.
    + eapply eqlist_elem in H5. assert (sem m1 i == Some a0 = true). { rewrite Heqo. apply Eq_Reflexive. }
      rewrite toList_sem' in H6. unfold toList in H6. apply H5 in H6. rewrite <- toList_sem' in H6.
      apply Eq_Symmetric. apply H6. apply H3. apply H2.
    + rewrite <- elem_not_in_list in Heqo. pose proof (toList_sem') as H7. specialize (H7 m2 lb ub H3 i).
      assert (forall value, List.elem (i, value) (toList m2) = false). { intros.
      specialize (H7 value). destruct H7. apply contrapositive in H7.
      destruct (List.elem (i, value) (toList m2)). contradiction. reflexivity.
      assert (forall value, List.elem (i, value) (toAscList m2) = false). { intros.
      apply (eqlist_elem _ _ i value0) in H5. destruct H5. apply contrapositive in H8.
      destruct (List.elem (i, value0) (toAscList m2)). contradiction. reflexivity.
      destruct (List.elem (i, value0) (toAscList m1)) eqn : ?. specialize (Heqo value0).
      unfold toList in Heqo. rewrite Heqo in Heqb0. discriminate Heqb0. intro. discriminate H9. }
      eapply elem_not_in_list in H8. rewrite H8. intro. discriminate H9. apply H3. }
      eapply elem_not_in_list in H6. rewrite H6. order e. apply H3. apply H2.
  - eapply eq_toList. apply H2. apply H3. apply strongly_sorted_unique'. eapply to_List_sorted.
    apply H2. eapply to_List_sorted. apply H3. intros. split; intros.
    + rewrite <- toList_sem' in H5. specialize (H4 x). assert (sem m2 x == Some y = true).
      { eapply Eq_Transitive. apply Eq_Symmetric. apply H4. apply H5. }
      rewrite toList_sem' in H6. assumption. apply H3. apply H2.
    + rewrite <-toList_sem' in H5. specialize (H4 x). assert (sem m1 x == Some y = true).
      { eapply Eq_Transitive. apply H4. apply H5. } rewrite toList_sem' in H6. assumption.
      apply H2. apply H3.
Qed.

Lemma strong_eq1 : forall `{Eq_ a} `{EqLaws a} m1 m2 lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  (forall i, sem m1 i = sem m2 i) -> m1 == m2 = true.
Proof. intros.
  assert (forall i, (sem m1 i == sem m2 i = true)). { intros. specialize (H4 i).
  rewrite H4. apply Eq_Reflexive. } eapply weak_equals_spec in H5. assumption.
  apply H2. apply H3.
Qed.

Lemma strong_eq2 : forall `{Eq_ a} `{EqLaws a} m1 m2 lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  (forall (y1 : a) (y2 : a), y1 == y2 = true <-> y1 = y2) ->
  (forall i, sem m1 i =  sem m2 i) <-> m1 == m2 = true.
Proof.
  intros. split; intros.
  - eapply strong_eq1; eassumption.
  - rewrite weak_equals_spec in H5; try eassumption.
    specialize (H5 i).
    destruct (sem m1 i). destruct (sem m2 i).
    rewrite simpl_option_some_eq in H5. rewrite H4 in H5. subst. reflexivity.
    discriminate H5. destruct (sem m2 i). discriminate H5. reflexivity.
Qed.

End WF_2.


Add LoadPath "src".
Require Import Maps.
Require Import Context.

Import Context.Context.
Require Import Coq.Lists.List.
Require Import LibTactics.
Require Import SmallCore.
Require Import Coq.ZArith.ZArith.

Import SmallCore.SmallCore.

Import Context.Context.

Module SmallCoreORFU.

Inductive orfu : ty -> Prop :=
    | orfu_tvar : forall i, orfu (TVar i)
    | orfu_tnone : orfu TNone
    | orfu_trcons :
        forall i t T,
            orfu t ->
            orfu T ->
            rcd_field_ty' T i = None ->
            orfu (TRcons i t T)
    | orfu_tfun :
        forall i o,
            orfu i ->
            orfu o ->
            orfu (TFun i o)
    | orfu_tsum :
        forall x y,
            orfu x ->
            orfu y ->
            orfu (TSum x y).
Hint Constructors orfu.

Theorem orfu_ORFU:
    forall T,
        orfu T ->
        ORFU T.

    intros T h.
    induction T; intros; subst; eauto;
    try (
        match goal with
        | h : only_rcd (_ _) |- _ => inversion h; subst; eauto
        end
    );
    try (match goal with
        | h : orfu _ |- _ => inversion h; subst; eauto
        end
    ).
Qed.

(* Theorem subty_orfu_trans:
    forall x y,
        subty x y ->
        orfu x ->
        orfu y.

    intros x y h.
    induction h; intros; subst; eauto;
    try (
        match goal with
        | h : orfu _ |- _ => inversion h; subst; eauto
        end
    ).
    Abort. *)

Theorem subty_defined_well_strong_orfu:
    forall x y,
        subty x y ->
        orfu x ->
        forall T fid,
            rcd_field_ty' y fid = Some T ->
            exists T', rcd_field_ty' x fid = Some T' /\ subty T' T.

    intros.
    assert (ORFU x).
    eapply orfu_ORFU; eauto.
    eapply subty_defined_well_strong_ORFU; eauto.
Qed.

Lemma not_only_rcd_orfu:
    forall T,
        ~only_rcd T ->
        orfu T.
    intros T;
    induction T;intros; subst; eauto; try discriminate; try contradiction.
Abort.

Theorem RFU_orfu:
    forall T,
        RFU T ->
        orfu T.
    intros T;
    induction T; intros; subst; eauto;
    try (
        match goal with
        | h : RFU _ |- _ => inversion h; subst; eauto
        end
    ).
    eapply orfu_trcons; eauto.
Abort.

Theorem rcd_field_ty'_orfu_is_orfu:
    forall T i x,
        rcd_field_ty' T i = Some x ->
        orfu T ->
        orfu x.

    intros T i x h0 h.
    generalize dependent x.
    generalize dependent i.
    induction h; intros; cbn in *; subst; eauto; try discriminate.
    destruct (eq_id_dec i i0); subst ; eauto.
    inversion h0; subst; eauto.
Qed.

Theorem orfu_dec:
    forall x,
        {orfu x} + {~orfu x}.
    induction x; intros; subst; eauto;
    destructALL;
    try (
        left;
        match goal with
        | h : orfu _ |- _ => inversion h; subst; eauto
        end; fail
    );
    try (
        right;
        intro;
        match goal with
        | h : orfu _ |- _ => inversion h; subst; eauto; try discriminate; try contradiction
        end; fail
    ).

    (* case TRcons *)
    destruct (rcd_field_ty' x2 f) eqn:H;
    try (
        left;
        match goal with
        | h : orfu _ |- _ => inversion h; subst; eauto
        end; fail
    ).
    right; intro. inversion H0; subst; eauto. rewrite H6 in *; try discriminate.
Qed.

End SmallCoreORFU.


Require Import Util LengthEq Map Envs Exp IL AllInRel Computable Annotation.
Require Import Rename RenamedApart Alpha ILDB SetOperations Status Position.
Require Import Take Drop.
Import F.

Set Implicit Arguments.
Unset Printing Records.

(** * Properties of Alpha Equivalence and Renamed Apart Programs *)

(** ** Given an renamedApart program, every alpha-equivalent program
       can be obtained as a renaming according to some [rho] *)

Definition alpha_rho_F (alpha_rho:env var -> stmt -> stmt -> env var) :=
  fix f (rho: env var) (F F':list (params*stmt)) : env var :=
    match F, F' with
    | (Z,s)::F, (Z',s')::F' => f (alpha_rho (rho [Z <-- Z']) s s') F F'
    | _, _ => rho
    end.

Fixpoint alpha_rho (rho:env var) (s t:stmt) : env var :=
  match s, t with
  | stmtLet x _ s, stmtLet y _ t => alpha_rho (rho [x <- y]) s t
  | stmtIf _ s1 s2, stmtIf _ t1 t2 => alpha_rho (alpha_rho rho s1 t1) s2 t2
  | stmtApp _ _, stmtApp _ _ => rho
  | stmtReturn _, stmtReturn _ => rho
  | stmtFun F1 s, stmtFun F2 t => alpha_rho (alpha_rho_F alpha_rho rho F1 F2) s t
  | _, _ => rho
  end.

Lemma alpha_rho_agrees_snd_F F F' ans ϱ ϱ' D
  : ( forall (n : nat) (Zs : params * stmt) (a : ann (set var * set var)),
       get F n Zs ->
       get ans n a ->
       forall (u : stmt) (ϱ ϱ' : var -> var) (D0 : set var),
       agree_on eq D0 ϱ ϱ' ->
       agree_on eq D0 (alpha_rho ϱ (snd Zs) u) (alpha_rho ϱ' (snd Zs) u))
    -> (forall (n : nat) (Zs : params * stmt) (a : ann (set var * set var)),
          get F n Zs -> get ans n a -> renamedApart (snd Zs) a)
    -> length F = length ans
    -> agree_on eq D ϱ ϱ'
    -> agree_on eq D (alpha_rho_F alpha_rho ϱ F F') (alpha_rho_F alpha_rho ϱ' F F').
Proof.
  intros AR RA LEN AGR. length_equify.
  general induction LEN; simpl; eauto.
  - destruct x as [Z u], F' as [|[Z' u'] F']; eauto.
    eapply IHLEN; eauto using get.
    + eapply AR with (Zs:=(Z,u)); eauto using get.
      eapply update_with_list_agree_preserve; eauto.
Qed.

Lemma alpha_rho_agrees_snd s u ang ϱ ϱ' D
  : renamedApart s ang
    -> agree_on eq D ϱ ϱ'
    -> agree_on eq D (alpha_rho ϱ s u) (alpha_rho ϱ' s u).
Proof.
  intros RA.
  general induction RA; destruct u; simpl in *; eauto.
  - eapply IHRA. eapply agree_on_update_same; eauto.
    eapply agree_on_incl; eauto.
  - eapply IHRA. eapply alpha_rho_agrees_snd_F; eauto.
Qed.

Lemma alpha_rho_agree_F F F' ans ϱ ϱ' D
  : (forall (n : nat) (Zs : params * stmt) (a : ann (set var * set var)),
       get F n Zs ->
       get ans n a ->
       forall (D0 : set var) (u : stmt) (ϱ ϱ' : var -> var),
       agree_on eq (D0 \ snd (getAnn a)) ϱ ϱ' ->
       agree_on eq (D0 \ snd (getAnn a)) ϱ (alpha_rho ϱ' (snd Zs) u))
    -> (forall (n : nat) (Zs : params * stmt) (a : ann (set var * set var)),
          get F n Zs -> get ans n a -> renamedApart (snd Zs) a)
    -> length F = length ans
    -> agree_on eq (D \ list_union zip defVars F ans) ϱ ϱ'
    -> agree_on eq (D \ list_union zip defVars F ans)
               ϱ (alpha_rho_F alpha_rho ϱ' F F').

Proof.
  intros AR RA LEN AGR. length_equify.
  general induction LEN; simpl.
  + eauto.
  + destruct x as [Z s1], F' as [|[Z' s2] F']; simpl in *; eauto.
    eapply agree_on_incl. eapply IHLEN; eauto using get.
    instantiate (1:=D \ defVars (Z, s1) y).
    eapply agree_on_incl. eapply AR with (Zs:=(Z,s1)); eauto using get.
    symmetry. eapply agree_on_incl. eapply update_with_list_agree_minus; eauto.
    symmetry; eauto.
    instantiate (1:=D \ fold_left union (zip defVars XL YL) ({} ∪ defVars (Z, s1) y) \ of_list Z).
    cset_tac; intuition. unfold defVars at 1. simpl.
    setoid_rewrite list_union_start_swap at 2. unfold defVars at 2.
    simpl.
    * clear_all; cset_tac.
    * rewrite list_union_start_swap. clear_all; cset_tac.
Qed.

Lemma alpha_rho_agree D s u ang ϱ ϱ'
  : renamedApart s ang
    -> agree_on eq (D \ snd (getAnn ang)) ϱ ϱ'
    -> agree_on eq (D \ snd (getAnn ang)) ϱ (alpha_rho ϱ' s u).
Proof.
  intros RA.
  general induction RA; destruct u; simpl; eauto;
    set_simpl; pe_rewrite.
  - eapply agree_on_incl.
    + eapply IHRA.
      symmetry. instantiate (1:=D0 \ singleton x).
      eapply agree_on_update_dead; [ clear; cset_tac | ].
      symmetry. eapply agree_on_incl; eauto.
      clear_all; cset_tac.
    + clear. cset_tac.
  - eapply agree_on_incl. eapply (IHRA2 (D0 \ Ds)).
    eapply agree_on_incl. eapply (IHRA1 (D0 \ Dt)).
    eapply agree_on_incl; eauto with cset.
    eauto with cset. eauto with cset.
  - eapply agree_on_incl. eapply IHRA.
    eapply agree_on_incl. eapply alpha_rho_agree_F; eauto.
    eapply agree_on_incl; eauto.
    + instantiate (1:=D0 \ Dt); eauto with cset.
    + instantiate (1:=D0 \ list_union zip defVars F ans).
      eauto with cset.
    + eauto with cset.
Qed.

Lemma alpha_rho_agrees_snd2_F F F' ans ϱ ϱ' D
  : (forall (n : nat) (Zs Zs': params * stmt)  (a : ann (set var * set var)),
       get F n Zs ->
       get ans n a ->
       get F' n Zs' ->
       forall (ϱ ϱ' : var -> var) (D0 : set var),
       agree_on eq (D0 \ definedVars (snd Zs)) ϱ ϱ' ->
       agree_on eq (D0) (alpha_rho ϱ (snd Zs) (snd Zs')) (alpha_rho ϱ' (snd Zs) (snd Zs')))
    ->  (forall (n : nat) (Zs Zs' : params * stmt),
           get F n Zs ->
           get F' n Zs' -> length (fst Zs) = length (fst Zs'))
    -> (forall (n : nat) (Zs : params * stmt) (a : ann (set var * set var)),
          get F n Zs -> get ans n a -> renamedApart (snd Zs) a)
    -> length F = length ans
    -> length F = length F'
    -> agree_on eq (D \ list_union zip defVars F ans) ϱ ϱ'
    -> agree_on eq D (alpha_rho_F alpha_rho ϱ F F') (alpha_rho_F alpha_rho ϱ' F F').
Proof.
  intros AR LENF RA LEN1 LEN2 AGR. length_equify.
  general induction LEN1; simpl in *; eauto using agree_on_incl with cset.
  - destruct x as [Z u], y0 as [Z' u']; eauto.
    eapply IHLEN1; eauto using get.
    + rewrite list_union_start_swap in AGR.
      exploit (AR 0); eauto using get.
      eapply update_with_list_agree with (XL:=Z) (YL:=Z'); eauto.
      eapply agree_on_incl. eapply AGR.
      unfold defVars at 2. simpl.
      exploit (RA 0); eauto using get.
      rewrite renamedApart_occurVars; eauto.
      clear_all. cset_tac.
      exploit LENF; eauto using get.
Qed.

Lemma list_union_incl {X} `{OrderedType X} (L L':list (set X)) (s s':set X)
: length L = length L'
  -> (forall n s t, get L n s -> get L' n t -> s [<=] t)
  -> s [<=] s'
  -> fold_left union L s [<=] fold_left union L' s'.
Proof.
  intros. length_equify.
  general induction H0; simpl; eauto.
  exploit H1; eauto using get. rewrite H2, H3; eauto using get.
Qed.

Lemma alpha_rho_agrees_snd2 s u ang ϱ ϱ' D ρ ρ'
  : renamedApart s ang
    -> alpha ρ ρ' s u
    -> agree_on eq (D \ definedVars s) ϱ ϱ'
    -> agree_on eq D (alpha_rho ϱ s u) (alpha_rho ϱ' s u).
Proof.
  intros RA ALPHA.
  general induction RA; invt alpha; simpl in *;
  only 1-4: eauto using agree_on_incl, agree_on_update_same with cset.
  - eapply IHRA; eauto.
    eapply alpha_rho_agrees_snd2_F; eauto.
    + eapply agree_on_incl; eauto.
      unfold defVars.
      rewrite renamedApart_occurVars; eauto.
      pe_rewrite. rewrite union_comm. rewrite <- minus_union.
      eapply incl_minus_lr; eauto.
      eapply list_union_incl; eauto with len.
      * intros; inv_get.
        rewrite <- renamedApart_occurVars; eauto.
        eauto with cset.
Qed.

Lemma funConstr_disjoint_defVars F ans D Dt
  : length F = length ans
    -> Indexwise.indexwise_R (funConstr D Dt) F ans
    -> disj (list_union (defVars ⊜ F ans)) Dt.
Proof.
  intros.
  rewrite <- list_union_disjunct; intros; inv_get.
  edestruct H0; dcr; eauto.
Qed.

Lemma alpha_rho_agree_F_get D F F' ans ϱ ϱ' n Z Z' u u'
  : (forall (n : nat) (Zs : params * stmt) (a : ann (set var * set var)),
        get F n Zs -> get ans n a -> renamedApart (snd Zs) a)
    -> (forall (n : nat) (Zs Zs' : params * stmt),
                 get F n Zs -> get F' n Zs' -> ❬fst Zs❭ = ❬fst Zs'❭)
    -> length F = length ans
    -> length F = length F'
    -> agree_on eq (D \ list_union (take n (zip defVars F ans))) ϱ ϱ'
    -> get F n (Z, u)
    -> get F' n (Z', u')
    -> agree_on eq (D \ list_union (take n (zip defVars F ans))
                     \ list_union (drop (S n) (zip defVars F ans)))
               (alpha_rho (ϱ [Z <-- Z']) u u') (alpha_rho_F alpha_rho ϱ' F F').

Proof.
  intros RA ZLEN LEN1 LEN2 AGR GetF GetF'. length_equify.
  general induction LEN1; simpl; inv GetF; inv GetF'.
  - simpl in *.
    + exploit RA; eauto using get; simpl in *.
      eapply alpha_rho_agree_F; eauto using get, alpha_rho_agree with len.
      eapply alpha_rho_agrees_snd; eauto.
      eapply update_with_list_agree; eauto.
      eapply agree_on_incl; eauto. clear; cset_tac.
      exploit ZLEN; eauto.
  - destruct x as [Z1 s1], y0 as [Z2 s2]; simpl.
    exploit RA; try econstructor. simpl in *.
    eapply agree_on_incl.
    eapply (IHLEN1 (D \ (of_list Z1 ∪ snd (getAnn y)))) ; eauto using get.
    + eapply agree_on_incl.
      eapply alpha_rho_agree; eauto.
      eapply agree_on_incl.
      symmetry. eapply update_with_list_agree_minus; eauto. symmetry; eauto.
      norm_lunion. unfold defVars at 1. simpl.
      instantiate (1:=D \ of_list Z1 \ list_union take n0 (defVars ⊜ XL YL)).
      clear; cset_tac.
      clear; cset_tac.
    + norm_lunion. unfold defVars at 1. simpl.
      clear; cset_tac.
Qed.

Lemma rename_renamedApart_all_alpha s t ang ϱ ϱ'
: renamedApart s ang
  -> alpha ϱ ϱ' s t
  -> rename (alpha_rho ϱ s t) s = t.
Proof.
  intros RA ALPHA.
  intros. general induction ALPHA; invt renamedApart; pe_rewrite; simpl.
  - erewrite op_rename_renamedApart_all_alpha; eauto.
  - f_equal. length_equify.
    revert H H0; clear_all; intros. general induction H; simpl; eauto.
    f_equal.
    + eapply op_rename_renamedApart_all_alpha; eauto using get.
    + eapply IHlength_eq; eauto using get, list_union_cons.
  - exploit IHALPHA; eauto; dcr; pe_rewrite.
    f_equal; eauto.
    + erewrite <- alpha_rho_agree; eauto. instantiate (1:=ra [x <- y]).
      lud; try congruence.
      reflexivity.
      pe_rewrite. eapply renamedApart_disj in H5. pe_rewrite.
      instantiate (1:={x}). specialize (H5 x).
      cset_tac; intuition.
    + eapply exp_rename_renamedApart_all_alpha.
      eapply alpha_exp_agree_on_morph; eauto.
      instantiate (1:=ira). eauto.
      etransitivity. symmetry. eapply agree_on_incl.
      eapply alpha_rho_agree; eauto. reflexivity.
      instantiate (1:=D). pe_rewrite.
      eapply renamedApart_disj in H5. pe_rewrite. eauto with cset.
      eapply agree_on_update_dead; eauto.
  - f_equal.
    + erewrite rename_op_agree. eapply op_rename_renamedApart_all_alpha; eauto.
      symmetry. etransitivity. Focus 2.
      eapply agree_on_incl. eapply alpha_rho_agree; eauto. reflexivity.
      instantiate (1:=D). eapply renamedApart_disj in H7; pe_rewrite.
      eauto with cset.
      eapply agree_on_incl. eapply alpha_rho_agree; eauto.
      instantiate (1:=D). eapply renamedApart_disj in H6; pe_rewrite.
      eauto with cset.
    + erewrite rename_agree; eauto.
      rewrite occurVars_freeVars_definedVars.
      rewrite renamedApart_freeVars; eauto.
      rewrite renamedApart_occurVars; eauto.
      pe_rewrite. symmetry.
      eapply agree_on_incl. eapply alpha_rho_agree; eauto.
      instantiate (1:=D ∪ Ds). pe_rewrite.
      eapply renamedApart_disj in H7. pe_rewrite.
      eauto with cset.
    + erewrite rename_agree; eauto.
      rewrite occurVars_freeVars_definedVars.
      rewrite renamedApart_freeVars; eauto.
      rewrite renamedApart_occurVars; eauto.
      pe_rewrite. symmetry. eapply agree_on_union.
      * eapply agree_on_incl. eapply alpha_rho_agree. eauto.
        instantiate (1:=D \ Ds). pe_rewrite.
        etransitivity. symmetry.
        eapply agree_on_incl. eapply alpha_rho_agree. eauto. reflexivity.
        pe_rewrite. reflexivity.
        eapply agree_on_incl. eapply alpha_rho_agree. eauto. reflexivity.
        pe_rewrite. instantiate (1:=D\Dt). cset_tac; intuition. pe_rewrite.
        eapply renamedApart_disj in H7.
        eapply renamedApart_disj in H6.
        pe_rewrite. eauto with cset.
      * eapply agree_on_incl. eapply alpha_rho_agrees_snd. eauto.
        eapply alpha_rho_agree; eauto. pe_rewrite.
        instantiate (1:=Dt). cset_tac; intuition.
  - exploit IHALPHA; eauto; dcr; pe_rewrite.
    f_equal.
    + eapply map_ext_get_eq; eauto.
      intros. destruct x as [Z u]. inv_get.
      exploit H6; eauto.
      exploit H2; eauto. simpl in *.
      destruct y as [Z' u']; simpl in *. f_equal.
      * erewrite lookup_list_agree.
        instantiate (1:=ra[Z <-- Z']).
        eapply lookup_list_nodup; eauto.
        exploit H0; eauto. edestruct H7; eauto.
        symmetry.
        etransitivity.
        Focus 2.
        eapply agree_on_incl. eapply alpha_rho_agree; eauto.
        eapply agree_on_incl.
        eapply alpha_rho_agree_F_get; eauto. reflexivity.
        instantiate (1:=of_list Z).
        instantiate (1:=of_list Z).
        rewrite minus_union.
        repeat rewrite disj_minus_eq; eauto.
        eapply disj_app; split.
        symmetry. rewrite <- list_union_disjunct; intros; inv_get.
        exploit (H8 n0 n); eauto using zip_get. omega.
        eapply disj_2_incl; eauto. unfold defVars; simpl; eauto with cset.
        symmetry. rewrite <- list_union_disjunct; intros; inv_get.
        exploit (H8 (S n + n0) n); eauto using zip_get. omega.
        eapply disj_2_incl; eauto. unfold defVars; simpl; eauto with cset.

        pe_rewrite. edestruct H7; dcr; eauto with cset.

        pe_rewrite. rewrite disj_minus_eq; eauto.
        edestruct H7; dcr; eauto; simpl in *.
        eapply disj_1_incl; eauto with cset.

        eapply agree_on_incl.
        eapply alpha_rho_agree; eauto.
        instantiate (1:=of_list Z).
        edestruct H7; eauto; dcr; simpl in *.
        eapply renamedApart_disj in H14.
        rewrite H16 in H14.
        rewrite disj_minus_eq; eauto with cset.
      * erewrite rename_agree; eauto.
        symmetry.
        exploit renamedApart_occurVars as OC; eauto.
        exploit renamedApart_freeVars as FV; eauto.
        assert (DISJ:disj (occurVars u) Dt). {
          pe_rewrite. rewrite occurVars_freeVars_definedVars.
          edestruct H7; dcr; eauto; simpl in *.
          symmetry; eapply disj_app; split; symmetry.
          rewrite FV. rewrite H16.
          symmetry; eapply disj_app; split; symmetry. eauto with cset.
          eapply renamedApart_disj in RA. simpl in *.
          eapply disj_2_incl; eauto. rewrite <- H12. eauto with cset.
          rewrite OC. eauto with cset.
        }

        eapply agree_on_incl.
        eapply alpha_rho_agree; eauto.
        eapply agree_on_incl.
        eapply alpha_rho_agree_F_get; eauto.
        instantiate (2:=occurVars u).
        instantiate (1:=occurVars u).

        rewrite minus_union.
        repeat rewrite disj_minus_eq; eauto.
        rewrite occurVars_freeVars_definedVars.
        eapply disj_app; split.
        symmetry. rewrite <- list_union_disjunct; intros; inv_get.
        rewrite (@incl_minus_union2 _ _ (freeVars u) (of_list Z)).
        rewrite union_assoc.
        exploit (H8 n0 n); eauto using zip_get. omega.
        eapply disj_app; split.

        exploit renamedApart_freeVars; try eapply RA; eauto. simpl in *.
        exploit renamedApart_disj; try eapply RA; eauto. simpl in *.
        symmetry. eapply (disj_incl H22).
        rewrite <- H21. eapply incl_union_left, incl_list_union.
        eapply map_get_1; try eapply H4. simpl. reflexivity.
        rewrite <- H12. eapply incl_union_left, incl_list_union; eauto using zip_get.

        rewrite OC. unfold defVars in H20 at 2. simpl in *. eauto.

        symmetry. rewrite <- list_union_disjunct; intros; inv_get.
        rewrite (@incl_minus_union2 _ _ (freeVars u) (of_list Z)).
        rewrite union_assoc.
        eapply disj_app; split.

        exploit renamedApart_freeVars; try eapply RA; eauto. simpl in *.
        exploit renamedApart_disj; try eapply RA; eauto. simpl in *.
        symmetry. eapply (disj_incl H20).
        rewrite <- H19. eapply incl_union_left, incl_list_union.
        eapply map_get_1; try eapply H4. simpl. reflexivity.
        rewrite <- H12. eapply incl_union_left, incl_list_union; eauto using zip_get.

        exploit (H8 (S n + n0) n); eauto using zip_get. omega.
        eapply disj_2_incl; eauto.  unfold defVars. simpl.
        rewrite OC. eauto with cset.

        pe_rewrite; eauto.

        pe_rewrite. rewrite disj_minus_eq; eauto.

    + erewrite rename_agree; eauto.
      eapply alpha_rho_agrees_snd2; eauto.
      eapply agree_on_incl. symmetry.
      eapply alpha_rho_agree_F; eauto using alpha_rho_agree.
      setoid_rewrite disj_minus_eq at 2; [ reflexivity | ].
      eapply disj_incl.
      eapply (renamedApart_disj RA).
      simpl. rewrite occurVars_freeVars_definedVars.
      eapply renamedApart_freeVars in RA. simpl in *.
      rewrite <- RA. clear_all; cset_tac.
      simpl. rewrite <- H12. eauto with cset.
Qed.

(** ** Alpha Equivalent programs map to identical De-Bruijn terms *)

Lemma op_alpha_real ϱ ϱ' e e' symb symb'
: alpha_op ϱ ϱ' e e'
  -> (forall x y, ϱ x = y -> ϱ' y = x -> pos symb x 0 = pos symb' y 0)
  -> exp_idx symb e = exp_idx symb' e'.
Proof.
  intros. general induction H; simpl in * |- *; eauto.
  - erewrite H1; eauto.
  - erewrite IHalpha_op; intros; eauto.
  - erewrite IHalpha_op1; eauto with cset.
    erewrite IHalpha_op2; eauto with cset.
Qed.

Lemma alpha_real ϱ ϱ' s t symb symb'
: alpha ϱ ϱ' s t
  -> (forall x y, ϱ x = y -> ϱ' y = x -> pos symb x 0 = pos symb' y 0)
  -> stmt_idx symb s = stmt_idx symb' t.
Proof.
  intros. general induction H; simpl in * |- *.
  - erewrite op_alpha_real; eauto.
  - erewrite smap_agree_2; eauto.
    intros; erewrite op_alpha_real; eauto.
  - inv H.
    + erewrite op_alpha_real; eauto with cset.
      case_eq (exp_idx symb' e'0); intros; simpl; eauto.
      erewrite IHalpha; eauto with cset.
      simpl; intros.
      lud; repeat cases; try congruence.
      exploit H1; try eapply H5; eauto. eapply pos_inc with (k':=1); eauto.
    + erewrite smap_agree_2; eauto; [| intros; erewrite op_alpha_real; eauto].
      erewrite IHalpha; eauto.
      simpl; intros.
      lud; repeat cases; try congruence.
      exploit H1; try eapply H5; eauto. eapply pos_inc with (k':=1); eauto.
  - erewrite op_alpha_real; eauto with cset.
    erewrite IHalpha1; eauto with cset.
    erewrite IHalpha2; eauto with cset.
  - erewrite IHalpha; eauto with cset.
    erewrite smap_agree_2; eauto.
    intros m [Z u] [Z' u'] ? ?. erewrite H0; eauto.
    erewrite H2; eauto.
    intros.
    exploit H0; eauto. simpl in *.
    decide (x ∈ of_list Z).
    + edestruct (of_list_get_first _ i) as [n]; eauto; dcr.
      hnf in H11. subst x0.
      rewrite pos_app_in; eauto.
      exploit (update_with_list_lookup_in_list_first ra _ H9 H12 H14); eauto; dcr.
      assert (x0 = y) by congruence. subst x0. clear_dup.
      rewrite H7 in H13.
      edestruct (list_lookup_in_list_first _ _ Z (eq_sym H9) H8) as [n'];
        eauto using get_in_of_list; dcr.
      hnf in H11; subst x0.
      rewrite pos_app_in; eauto.
      decide (n < n'). now exfalso; exploit H17; eauto.
      decide (n' < n). now exfalso; exploit H14; eauto.
      assert (n = n') by omega. subst n'.
      repeat erewrite get_first_pos; eauto.
      eapply get_in_of_list; eauto.
    + exploit (update_with_list_lookup_not_in ra Z Z' y n); eauto.
      assert ((ira [Z' <-- Z]) y ∉ of_list Z). rewrite H8; eauto.
      eapply lookup_set_update_not_in_Z'_not_in_Z in H11; eauto.
      repeat rewrite pos_app_not_in; eauto.
      exploit (update_with_list_lookup_not_in ira Z' Z x H11); eauto.
      rewrite H9. eapply pos_inc; eauto.
Qed.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

Require Recdef.

Function occ_ (a:Type) (a_WT:WhyType a) (v:a) (m: map.Map.map Z a)
  (l: Z) (delta: Z) {measure Zabs_nat delta } : Z :=
  if Z_le_gt_dec delta 0%Z then 0%Z else
  ((if why_decidable_eq (map.Map.get m (l + delta - 1)%Z) v then 1 else 0) +
   occ_ a a_WT v m l (delta-1))%Z.
intros a a_WT _ _ _ delta h.
destruct (Z_le_gt_dec delta 0); intros.
now omega.
now apply Zabs_nat_lt; omega.
Defined.

(* Why3 goal *)
Definition occ: forall {a:Type} {a_WT:WhyType a}, a -> (map.Map.map Z a) ->
  Z -> Z -> Z.
intros a a_WT v m l u.
exact (occ_ a a_WT v m l (u-l)%Z).
Defined.

(* Why3 goal *)
Lemma occ_empty : forall {a:Type} {a_WT:WhyType a}, forall (v:a)
  (m:(map.Map.map Z a)) (l:Z) (u:Z), (u <= l)%Z -> ((occ v m l u) = 0%Z).
intros a a_WT v m l u h1.
unfold occ. rewrite occ__equation.
destruct (Z_le_gt_dec (u - l) 0)%Z; intros.
now trivial.
omega.
Qed.

(* Why3 goal *)
Lemma occ_right_no_add : forall {a:Type} {a_WT:WhyType a}, forall (v:a)
  (m:(map.Map.map Z a)) (l:Z) (u:Z), (l < u)%Z -> ((~ ((map.Map.get m
  (u - 1%Z)%Z) = v)) -> ((occ v m l u) = (occ v m l (u - 1%Z)%Z))).
intros a a_WT v m l u h1 h2.
unfold occ. rewrite occ__equation.
destruct (Z_le_gt_dec (u - l) 0)%Z; intros.
rewrite occ__equation.
destruct (Z_le_gt_dec (u - 1 - l) 0)%Z; intros.
now trivial.
omega.
destruct (why_decidable_eq (Map.get m (l + (u - l) - 1)%Z) v).
replace (l + (u - l) - 1)%Z with (u-1)%Z in e by omega.
intuition.
replace (u - 1 - l)%Z with (u - l - 1)%Z by omega.
ring.
Qed.

(* Why3 goal *)
Lemma occ_right_add : forall {a:Type} {a_WT:WhyType a}, forall (v:a)
  (m:(map.Map.map Z a)) (l:Z) (u:Z), (l < u)%Z -> (((map.Map.get m
  (u - 1%Z)%Z) = v) -> ((occ v m l u) = (1%Z + (occ v m l (u - 1%Z)%Z))%Z)).
intros a a_WT v m l u h1 h2.
unfold occ. rewrite occ__equation.
destruct (Z_le_gt_dec (u - l) 0)%Z; intros.
rewrite occ__equation.
destruct (Z_le_gt_dec (u - 1 - l) 0)%Z; intros.
omega.
omega.
destruct (why_decidable_eq (Map.get m (l + (u - l) - 1)%Z) v).
replace (u - 1 - l)%Z with (u - l - 1)%Z by omega.
ring.
replace (l + (u - l) - 1)%Z with (u-1)%Z in n by omega.
intuition.
Qed.

(* Why3 goal *)
Lemma occ_bounds : forall {a:Type} {a_WT:WhyType a}, forall (v:a)
  (m:(map.Map.map Z a)) (l:Z) (u:Z), (l <= u)%Z -> ((0%Z <= (occ v m l
  u))%Z /\ ((occ v m l u) <= (u - l)%Z)%Z).
intros a a_WT v m l u h1.
cut (0 <= u - l)%Z. 2: omega.
replace (occ v m l u) with (occ v m l (l + (u - l)))%Z.
pattern (u - l)%Z; apply Z_lt_induction. 2: omega.
intros.
assert (h: (x = 0 \/ x <> 0)%Z) by omega. destruct h.
now rewrite occ_empty; omega.
destruct (why_decidable_eq (Map.get m (l + (x-1))%Z) v).
rewrite occ_right_add.
generalize (H (x-1)%Z); clear H; intros.
assert (0 <= occ v m l (l + (x - 1)) <= x-1)%Z.
apply H; omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
omega.
omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
trivial.
rewrite occ_right_no_add.
assert (0 <= occ v m l (l + (x - 1)) <= x-1)%Z.
apply H; omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
omega.
omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
trivial.
replace (l + (u-l))%Z with u by ring. trivial.
Qed.

(* Why3 goal *)
Lemma occ_append : forall {a:Type} {a_WT:WhyType a}, forall (v:a)
  (m:(map.Map.map Z a)) (l:Z) (mid:Z) (u:Z), ((l <= mid)%Z /\
  (mid <= u)%Z) -> ((occ v m l u) = ((occ v m l mid) + (occ v m mid u))%Z).
intros a a_WT v m l mid u (h1,h2).
cut (0 <= u - mid)%Z. 2: omega.
replace (occ v m l u) with (occ v m l (mid + (u - mid)))%Z.
replace (occ v m mid u) with (occ v m mid (mid + (u - mid)))%Z.
pattern (u - mid)%Z; apply Z_lt_induction. 2: omega.
intros.
assert (h: (x = 0 \/ x <> 0)%Z) by omega. destruct h.
rewrite (occ_empty _ _ mid (mid+x)%Z).
subst x. ring_simplify ((mid+0)%Z). ring.
omega.
destruct (why_decidable_eq (Map.get m (mid + (x-1))%Z) v).
rewrite (occ_right_add _ _ l (mid+x))%Z.
rewrite (occ_right_add _ _ mid (mid+x))%Z.
generalize (H (x-1)%Z); clear H; intros.
assert ((occ v m l (mid+(x-1)) = (occ v m l mid) + occ v m mid (mid + (x - 1)))%Z).
apply H; omega.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring.
omega. omega.
trivial.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring. trivial.
omega.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring. trivial.

rewrite (occ_right_no_add _ _ l (mid+x))%Z.
rewrite (occ_right_no_add _ _ mid (mid+x))%Z.
generalize (H (x-1)%Z); clear H; intros.
assert ((occ v m l (mid+(x-1)) = (occ v m l mid) + occ v m mid (mid + (x - 1)))%Z).
apply H; omega.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring.
omega. omega.
trivial.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring. trivial.
omega.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring. trivial.

replace (mid + (u-mid))%Z with u by ring. trivial.
replace (mid + (u-mid))%Z with u by ring. trivial.
Qed.

(* Why3 goal *)
Lemma occ_neq : forall {a:Type} {a_WT:WhyType a}, forall (v:a)
  (m:(map.Map.map Z a)) (l:Z) (u:Z), (forall (i:Z), ((l <= i)%Z /\
  (i < u)%Z) -> ~ ((map.Map.get m i) = v)) -> ((occ v m l u) = 0%Z).
intros a a_WT v m l u.
assert (h: (u < l \/ 0 <= u - l)%Z) by omega. destruct h.
rewrite occ_empty. trivial. omega.
replace u with (l + (u - l))%Z. 2:ring.
generalize H.
pattern (u - l)%Z; apply Z_lt_induction. 2: omega.
clear H; intros.
assert (h: (x = 0 \/ x <> 0)%Z) by omega. destruct h.
now rewrite occ_empty; omega.
destruct (why_decidable_eq (Map.get m (l + (x-1))%Z) v).
assert (Map.get m (l + (x - 1)) <> v)%Z.
  apply H1; omega.
intuition.
rewrite occ_right_no_add.
replace (l+x-1)%Z with (l+(x-1))%Z by ring.
apply H; intuition.
apply (H1 i). omega. assumption.
omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
trivial.
Qed.

(* Why3 goal *)
Lemma occ_exists : forall {a:Type} {a_WT:WhyType a}, forall (v:a)
  (m:(map.Map.map Z a)) (l:Z) (u:Z), (0%Z < (occ v m l u))%Z -> exists i:Z,
  ((l <= i)%Z /\ (i < u)%Z) /\ ((map.Map.get m i) = v).
intros a a_WT v m l u h1.
assert (h: (u < l \/ 0 <= u - l)%Z) by omega. destruct h.
rewrite occ_empty in h1. elimtype False; omega. omega.
generalize h1.
replace u with (l + (u - l))%Z. 2:ring.
generalize H.
pattern (u - l)%Z; apply Z_lt_induction. 2: omega.
clear H; intros.
assert (h: (x = 0 \/ x <> 0)%Z) by omega. destruct h.
rewrite occ_empty in h0. elimtype False; omega. omega.
destruct (why_decidable_eq (Map.get m (l + (x-1))%Z) v).
exists (l+(x-1))%Z. split. omega. now trivial.
destruct (H (x-1))%Z as (i,(hi1,hi2)). omega. omega.
rewrite occ_right_no_add in h0.
replace (l + (x - 1))%Z with (l+x-1)%Z by ring. trivial.
omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring. trivial.
exists i. split. omega. assumption.
Qed.

(* Why3 goal *)
Lemma occ_pos : forall {a:Type} {a_WT:WhyType a}, forall (m:(map.Map.map Z
  a)) (l:Z) (u:Z) (i:Z), ((l <= i)%Z /\ (i < u)%Z) ->
  (0%Z < (occ (map.Map.get m i) m l u))%Z.
intros a a_WT m l u i (h1,h2).
pose (v := (Map.get m i)). fold v.
assert (occ v m l u = occ v m l i + occ v m i u)%Z.
  apply occ_append. omega.
assert (occ v m i u = occ v m i (i+1) + occ v m (i+1) u)%Z.
  apply occ_append. omega.
assert (occ v m i (i + 1) = 1)%Z.
rewrite occ_right_add.
  ring_simplify (i+1-1)%Z. rewrite occ_empty. ring. omega. omega.
ring_simplify (i+1-1)%Z. auto.
assert (0 <= occ v m l i <= i -l)%Z. apply occ_bounds. omega.
assert (0 <= occ v m i (i+1) <= (i+1)-i)%Z. apply occ_bounds. omega.
assert (0 <= occ v m (i+1) u <= u - (i+1))%Z. apply occ_bounds. omega.
omega.
Qed.

(* Why3 goal *)
Lemma occ_eq : forall {a:Type} {a_WT:WhyType a}, forall (v:a)
  (m1:(map.Map.map Z a)) (m2:(map.Map.map Z a)) (l:Z) (u:Z), (forall (i:Z),
  ((l <= i)%Z /\ (i < u)%Z) -> ((map.Map.get m1 i) = (map.Map.get m2 i))) ->
  ((occ v m1 l u) = (occ v m2 l u)).
intros a a_WT v m1 m2 l u h1.
assert (h: (u < l \/ 0 <= u - l)%Z) by omega. destruct h.
rewrite occ_empty.
rewrite occ_empty. trivial.
omega. omega.
generalize h1.
replace u with (l + (u - l))%Z. 2:ring.
generalize H.
pattern (u - l)%Z; apply Z_lt_induction. 2: omega.
clear H; intros.
assert (h: (x = 0 \/ x <> 0)%Z) by omega. destruct h.
rewrite occ_empty. rewrite occ_empty. trivial. omega. omega.
destruct (why_decidable_eq (Map.get m1 (l + (x-1))%Z) v).
rewrite occ_right_add.
rewrite (occ_right_add v m2).
apply f_equal.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
apply H. omega. omega. intros. apply h0. omega. omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
rewrite <- h0. trivial. omega. omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring. assumption.

rewrite occ_right_no_add.
rewrite (occ_right_no_add v m2).
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
apply H. omega. omega. intros. apply h0. omega. omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
rewrite <- h0. trivial. omega. omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring. assumption.
Qed.


From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
From Coq Require Import ssrfun.
Require Import AutosubstSsr ARS Context.
Require Import Program.Equality.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import ast.
Require Import smallstep.
Require Import typing.
Require Import typing_bi.
Require Import astCast.
Require Import smallstepCast.
Require Import confluenceCast.
Require Import typingCast.

Inductive ElabInf : list astCast.term -> ast.term ->
  astCast.term -> astCast.term -> Prop :=
  | ElabInfVar ctx x : ElabInf ctx (ast.Var x) (astCast.Var x) (dget ctx x)
  | ElabInfTT ctx : ElabInf ctx ast.TT astCast.TT astCast.TT
    (* on paper this would require a well formed ctx *)
  | ElabInfPi ctx A A' B B':
    ElabCheck ctx A A' astCast.TT ->
    ElabCheck (A' :: ctx) B B' astCast.TT ->
    ElabInf ctx (ast.Pi A B) (astCast.Pi A' B') astCast.TT
  | ElabInfCast ctx e e' t t' :
    ElabCheck ctx t t' astCast.TT ->
    ElabCheck ctx e e' t' ->
    ElabInf ctx (ast.Cast e t) e' t'
    (* insert the cast at a discrepency *)
  | ElabInfapp ctx f f' fty a a' A B :
    (* ElabInf ctx f f' (astCast.Pi A B) -> (* minimally *) *)
    ElabInf ctx f f' fty -> astCast.Pi A B === fty ->
    ElabCheck ctx a a' A ->
    ElabInf ctx (ast.App f a) (astCast.App f' a') (B.[a' /])
with ElabCheck : list astCast.term -> ast.term ->
  astCast.term -> astCast.term -> Prop :=
  | ElabCheckTT ctx : ElabCheck ctx ast.TT astCast.TT astCast.TT
    (* TODO: this can be removed*)

  | ElabCheckFun ctx A B b b' :
    ElabCheck ((astCast.Pi A B).[ren (+1)]  :: A :: ctx) b b' B ->
    ElabCheck ctx (ast.Fun b) (astCast.Fun b') (astCast.Pi A B)
  | ElabCheckinf ctx a a' A A' :
    ElabInf ctx a a' A' ->
    ElabCheck ctx a (astCast.Cast a' A' A astCast.Here) A
.

(* TODO that mutually inductive scheme thing *)

(* CTX elaborations *)
Inductive ElabCtx : list ast.term -> list astCast.term -> Prop :=
| ElabCtx_Emp : ElabCtx nil nil
| ElabCtx_cons ctx ctx' e e' : ElabCtx ctx ctx' ->
  ElabCheck ctx' e e' astCast.TT -> ElabCtx (e :: ctx) (e' :: ctx')
.

Fixpoint erase (e : ast.term) : astCast.term :=
  match e with
  | ast.Var x    => astCast.Var x
  | ast.TT       => astCast.TT
  | ast.App f a  => astCast.App (erase f) (erase a)
  | ast.Fun b    => astCast.Fun (erase b)
  | ast.Pi a b => astCast.Pi (erase a) (erase b)
  | ast.Cast e t => erase e
  end.

(* TODO: elab (unique enough) *)

(* gragual garentee like conditions, review this with robin *)

Theorem well_typed_terms_elaborate e t :
  [ nil |- e :-> t ] ->
  exists e' t' ,
  ElabInf nil e e' t'.
Proof.
Admitted.

(* TODO a cast varient? *)

(* this is a weak theorem about syntax, it would be nicer to have a stronger theorem about semantics *)
(* can this be strengthend against the TAS? *)
Theorem blameable_terms_were_not_well_typed e e' t :
  (star smallstepCast.step) e e' ->
  smallstepCast.Stuck e' ->
  not (exists ee tt,
    typing.has_type nil ee tt /\
    ElabCheck nil ee e t)
  .
Admitted.
(* follows directly from type soundenss and the corespondece with elaborated terms *)

Theorem elab_corresponds_TT e e' :
  typingCast.has_type nil e' astCast.TT ->
  ElabCheck nil e e' astCast.TT ->
  (star smallstepCast.step) e' astCast.TT ->
  (star smallstep.step) e ast.TT
  .
Admitted.

Theorem elab_corresponds_Pi e e' a' b' :
  ElabCheck nil e e' astCast.TT ->
  (star smallstepCast.step) e' (astCast.Pi a' b') ->
  exists a b,
  (star smallstep.step) e (ast.Pi a b)
  .
Admitted.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D I P X Y : Universe, ((wd_ C D /\ (wd_ A B /\ (wd_ B P /\ (wd_ A P /\ (wd_ B C /\ (wd_ A C /\ (col_ A B I /\ (col_ C D I /\ (col_ C D X /\ col_ C D Y))))))))) -> col_ C X I)).
Proof.
  time tac.
Qed.

End FOFProblem.