Require Export GeoCoq.Elements.OriginalProofs.proposition_03.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NCorder.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NCdistinct.
Require Export GeoCoq.Elements.OriginalProofs.lemma_ABCequalsCBA.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglestransitive.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_angleorderrespectscongruence :
   forall A B C D E F P Q R,
   LtA A B C D E F -> CongA P Q R D E F ->
   LtA A B C P Q R.
Proof.
intros.
rename_H H;let Tf:=fresh in
assert (Tf:exists G H J, (BetS G H J /\ Out E D G /\ Out E F J /\ CongA A B C D E H)) by (conclude_def LtA );destruct Tf as [G[H[J]]];spliter.
assert ((neq P Q /\ neq Q R /\ neq P R /\ neq D E /\ neq E F /\ neq D F)) by (forward_using lemma_angledistinct).
assert (neq Q P) by (conclude lemma_inequalitysymmetric).
assert ((neq A B /\ neq B C /\ neq A C /\ neq D E /\ neq E H /\ neq D H)) by (forward_using lemma_angledistinct).
assert (neq E G) by (conclude lemma_raystrict).
let Tf:=fresh in
assert (Tf:exists U, (Out Q P U /\ Cong Q U E G)) by (conclude lemma_layoff);destruct Tf as [U];spliter.
assert (neq E J) by (conclude lemma_raystrict).
let Tf:=fresh in
assert (Tf:exists V, (Out Q R V /\ Cong Q V E J)) by (conclude lemma_layoff);destruct Tf as [V];spliter.
assert (Cong G H G H) by (conclude cn_congruencereflexive).
assert (Lt G H G J) by (conclude_def Lt ).
assert (CongA D E F P Q R) by (conclude lemma_equalanglessymmetric).
assert (CongA D E F U Q V) by (conclude lemma_equalangleshelper).
assert (CongA U Q V D E F) by (conclude lemma_equalanglessymmetric).
assert (CongA U Q V G E J) by (conclude lemma_equalangleshelper).
assert (CongA G E J U Q V) by (conclude lemma_equalanglessymmetric).
assert (Cong E G Q U) by (conclude lemma_congruencesymmetric).
assert (Cong E J Q V) by (conclude lemma_congruencesymmetric).
assert ((Cong G J U V /\ CongA E G J Q U V /\ CongA E J G Q V U)) by (conclude proposition_04).
assert (Cong U V G J) by (conclude lemma_congruencesymmetric).
assert (neq G J) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists W, (BetS U W V /\ Cong U W G H)) by (conclude proposition_03);destruct Tf as [W];spliter.
assert (eq H H) by (conclude cn_equalityreflexive).
assert (Out E H H) by (conclude lemma_ray4).
assert (CongA A B C G E H) by (conclude lemma_equalangleshelper).
assert (nCol G E H) by (conclude lemma_equalanglesNC).
assert (nCol G H E) by (forward_using lemma_NCorder).
assert (neq U V) by (forward_using lemma_betweennotequal).
assert (Out U V W) by (conclude lemma_ray4).
assert (eq Q Q) by (conclude cn_equalityreflexive).
assert (eq E E) by (conclude cn_equalityreflexive).
assert (nCol U Q V) by (conclude lemma_equalanglesNC).
assert (neq U Q) by (forward_using lemma_NCdistinct).
assert (Out U Q Q) by (conclude lemma_ray4).
assert (~ eq G E).
 {
 intro.
 assert (Col G H E) by (conclude_def Col ).
 contradict.
 }
assert (Out G E E) by (conclude lemma_ray4).
assert (CongA E G J Q U W) by (conclude lemma_equalangleshelper).
assert (CongA Q U W E G J) by (conclude lemma_equalanglessymmetric).
assert (Out G J H) by (conclude lemma_ray4).
assert (CongA Q U W E G H) by (conclude lemma_equalangleshelper).
assert (CongA E G H Q U W) by (conclude lemma_equalanglessymmetric).
assert (nCol Q U W) by (conclude lemma_equalanglesNC).
assert (nCol U W Q) by (forward_using lemma_NCorder).
assert (nCol H G E) by (forward_using lemma_NCorder).
assert (~ Col W U Q).
 {
 intro.
 assert (Col U W Q) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (Cong G H U W) by (conclude lemma_congruencesymmetric).
assert (Cong G E U Q) by (forward_using lemma_congruenceflip).
assert (CongA E G H Q U W) by (conclude lemma_equalanglessymmetric).
assert (CongA Q U W W U Q) by (conclude lemma_ABCequalsCBA).
assert (CongA E G H W U Q) by (conclude lemma_equalanglestransitive).
assert (CongA H G E E G H) by (conclude lemma_ABCequalsCBA).
assert (CongA H G E W U Q) by (conclude lemma_equalanglestransitive).
assert ((Cong H E W Q /\ CongA G H E U W Q /\ CongA G E H U Q W)) by (conclude proposition_04).
assert (CongA A B C U Q W) by (conclude lemma_equalanglestransitive).
assert (eq W W) by (conclude cn_equalityreflexive).
assert (~ eq Q W).
 {
 intro.
 assert (Col Q U W) by (conclude_def Col ).
 assert (Col W U Q) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (Out Q W W) by (conclude lemma_ray4).
assert (Out Q U P) by (conclude lemma_ray5).
assert (CongA A B C P Q W) by (conclude lemma_equalangleshelper).
assert (LtA A B C P Q R) by (conclude_def LtA ).
close.
Qed.

End Euclid.


Require Export Classes.EquivDec.

From CoqAlgs Require Import Base.
From CoqAlgs Require Import Ord.
From CoqAlgs Require Export Data.ListLemmas.
From CoqAlgs Require Import Sorting.Sort.

Inductive BTree (A : Type) : Type :=
    | empty : BTree A
    | node : A -> BTree A -> BTree A -> BTree A.

Arguments empty {A}.
Arguments node {A} _ _ _.

Inductive Elem {A : Type} (a : A) : BTree A -> Prop :=
    | Elem_root : forall l r : BTree A, Elem a (node a l r)
    | Elem_left : forall (v : A) (l r : BTree A),
        Elem a l -> Elem a (node v l r)
    | Elem_right : forall (v : A) (l r : BTree A),
        Elem a r -> Elem a (node v l r).

#[global] Hint Constructors Elem : core.

Lemma Elem_node :
  forall {A : Type} (x v : A) (l r : BTree A),
    Elem x (node v l r) <-> x = v \/ Elem x l \/ Elem x r.
Proof.
  split; inv 1; firstorder.
Qed.

Definition singleton {A : Type} (x : A) : BTree A :=
  node x empty empty.

Fixpoint Elem_decb
  {A : Ord} (x : A) (t : BTree A) : bool :=
match t with
    | empty => false
    | node v l r =>
        (x =? v) || Elem_decb x l || Elem_decb x r
end.

Definition root {A : Type} (bt : BTree A) : option A :=
match bt with
    | empty => None
    | node v l r => Some v
end.

Definition isEmpty {A : Type} (t : BTree A) : bool :=
match t with
    | empty => true
    | _ => false
end.

(** [size] and counting. *)
Fixpoint size {A : Type} (bt : BTree A) : nat :=
match bt with
    | empty => 0
    | node _ l r => S (size l + size r)
end.

Fixpoint countBT {A : Type} (p : A -> bool) (t : BTree A) : nat :=
match t with
    | empty => 0
    | node v l r =>
        (if p v then 1 else 0) + countBT p l + countBT p r
end.

(* Tree traversals. *)

Fixpoint inorder {A : Type} (t : BTree A) : list A :=
match t with
    | empty => []
    | node v l r => inorder l ++ v :: inorder r
end.

Fixpoint preorder {A : Type} (t : BTree A) : list A :=
match t with
    | empty => []
    | node v l r => v :: (preorder l ++ preorder r)
end.

Fixpoint postorder {A : Type} (t : BTree A) : list A :=
match t with
    | empty => []
    | node v l r => postorder l ++ postorder r ++ [v]
end.

(* TODO *) Definition leaf {A : Type} (x : A) : BTree A :=
  node x empty empty.

Fixpoint wut {A : Type} (t : BTree A) : nat :=
match t with
    | empty => 1
    | node v l r => 2 + wut l + wut r
end.

Fixpoint sumOfWuts {A : Type} (l : list (BTree A)) : nat :=
match l with
    | [] => 0
    | t :: ts => 1 + wut t + sumOfWuts ts
end.

Lemma sumOfWuts_app :
  forall (A : Type) (l1 l2 : list (BTree A)),
    sumOfWuts (l1 ++ l2) = sumOfWuts l1 + sumOfWuts l2.
Proof.
  induction l1 as [| h t]; cbn; intros.
    reflexivity.
    rewrite IHt. rewrite Nat.add_assoc. reflexivity.
Qed.

Fixpoint sumOfSizes {A : Type} (l : list (BTree A)) : nat :=
match l with
    | [] => 0
    | h :: t => size h + sumOfSizes t
end.

Lemma sumOfSizes_app :
  forall (A : Type) (l1 l2 : list (BTree A)),
    sumOfSizes (l1 ++ l2) = sumOfSizes l1 + sumOfSizes l2.
Proof.
  induction l1 as [| h1 t1]; cbn; intros.
    reflexivity.
    rewrite IHt1. apply Nat.add_assoc.
Qed.

Function bfs_aux
  {A : Type} (ts : list (BTree A)) (acc : list A) {measure sumOfWuts ts}
  : list A :=
match ts with
    | [] => acc
    | empty :: ts' => bfs_aux ts' acc
    | node v l r :: ts' =>
        bfs_aux (ts' ++ [l; r]) (v :: acc)
end.
Proof.
  intros. subst. cbn. apply le_S, le_n.
  intros. subst. cbn. rewrite sumOfWuts_app. cbn. lia.
Defined.

Definition bfs {A : Type} (t : BTree A) : list A :=
  rev (bfs_aux A [t] []).

(*

Definition test :=
  node 1
    (node 2 (leaf 4) (leaf 5))
    (leaf 3).

Compute inorder test.
Compute preorder test.
Compute postorder test.
Compute bfs test.
Compute bfs (mirror test).
*)

Function inorder'_aux
  {A : Ord} (t : BTree A) (acc : list A) : list A :=
match t with
    | empty => acc
    | node v l r => inorder'_aux l (v :: inorder'_aux r acc)
end.

Definition inorder' {A : Ord} (t : BTree A) : list A :=
  inorder'_aux t [].

(** * Tactics *)

Ltac Elem :=
  intros; unfold singleton in *; cbn in *; subst; repeat
match goal with
    | H : Elem _ empty |- _ => inv H
    | H : Elem _ (node _ empty empty) |- _ => inv H
    | H : Elem _ _ /\ Elem _ _ |- _ => destruct H
    | H : Elem _ _ \/ Elem _ _ |- _ => destruct H
    | |- ~ Elem _ _ => intro
    | |- Elem ?x (node ?x _ _) => constructor
end; auto.

Ltac Elem' :=
  repeat (intros; subst;
match goal with
    | H : Elem _ empty |- _ => inv H
    | H : Elem _ (node _ _ _) |- _ => inv H
    | H : _ /\ _ |- _ => destruct H
    | H : _ \/ _ |- _ => destruct H
    | |- ~ Elem _ _ => intro
    | |- Elem _ (node _ _ _) => try (constructor; auto; fail)
end; auto).

(** * Theorems *)

(** Properties of [Elem] and [Elem_decb]. *)

Lemma Elem_decb_reflect :
  forall (A : Ord) (x : A) (t : BTree A),
    BoolSpec (Elem x t) (~ Elem x t) (Elem_decb x t).
Proof.
  induction t as [| v l IHl r IHr]; cbn.
    constructor. inv 1.
    unfold orb. trich. destruct IHl, IHr; auto.
      constructor. inv 1.
Qed.

(** Properties of casts to/from list. *)

Lemma inorder'_aux_spec :
  forall (A : Ord) (t : BTree A) (acc : list A),
    inorder'_aux t acc = inorder t ++ acc.
Proof.
  intros. functional induction @inorder'_aux A t acc; cbn.
    trivial.
    rewrite <- app_assoc. cbn. rewrite <- IHl, <- IHl0. trivial.
Qed.

Theorem inorder'_spec : @inorder' = @inorder.
Proof.
  ext A. extensionality t. unfold inorder'.
  rewrite inorder'_aux_spec, app_nil_r. trivial.
Qed.

Lemma toList_In_Elem :
  forall (A : Type) (x : A) (t : BTree A),
    In x (inorder t) <-> Elem x t.
Proof.
  split.
    induction t; cbn; intros; try apply in_app_or in H; firstorder.
      subst. firstorder.
    induction 1; cbn; apply in_or_app; firstorder.
Qed.

(** Properties of [size]. *)

Lemma size_swap :
  forall (A : Type) (v : A) (l r : BTree A),
    size (node v l r) = size (node v r l).
Proof.
  intros. cbn. rewrite Nat.add_comm. trivial.
Qed.

Lemma size_length :
  forall (A : Type) (t : BTree A),
    length (inorder t) = size t.
Proof.
  induction t; cbn.
    reflexivity.
    rewrite !app_length. cbn. rewrite IHt1, IHt2. lia.
Qed.

Lemma count_toList :
  forall (A : Type) (p : A -> bool) (t : BTree A),
    count p (inorder t) = countBT p t.
Proof.
  induction t; cbn; rewrite ?count_app.
    reflexivity.
    cbn. rewrite IHt1, IHt2. destruct (p a); cbn.
      rewrite plus_n_Sm. reflexivity.
      reflexivity.
Qed.

(** Properties of [empty]. *)
Lemma Elem_empty :
  forall (A : Ord) (x : A), ~ Elem x empty.
Proof. inv 1. Qed.

Lemma size_empty :
  forall A : Ord, size (@empty A) = 0.
Proof. reflexivity. Qed.

Lemma countBT_empty :
  forall (A : Type) (p : A -> bool),
    countBT p empty = 0.
Proof. reflexivity. Qed.

(** Properties of [singleton]. *)

Lemma Elem_singleton :
  forall (A : Ord) (x y : A),
    Elem x (singleton y) <-> x = y.
Proof.
  split; Elem.
Qed.

Lemma size_singleton :
  forall (A : Ord) (x : A),
    size (singleton x) = 1.
Proof. reflexivity. Qed.

Lemma countBT_singleton :
  forall (A : Type) (p : A -> bool) (x : A),
    countBT p (singleton x) = if p x then 1 else 0.
Proof.
  intros. unfold singleton. cbn. destruct (p x); reflexivity.
Qed.

(** Properties of [isEmpty]. *)

Lemma isEmpty_Elem_false :
  forall (A : Ord) (t : BTree A),
    isEmpty t = false <-> exists x : A, Elem x t.
Proof.
  split; destruct t; cbn; intros.
    congruence.
    eauto.
    inv H. inv H0.
    reflexivity.
Qed.

Lemma isEmpty_Elem_true :
  forall (A : Ord) (t : BTree A),
    isEmpty t = true <-> forall x : A, ~ Elem x t.
Proof.
  split; destruct t; cbn; firstorder.
    inv 1.
    congruence.
    contradiction (H c). constructor.
Qed.

Lemma isEmpty_empty :
  forall (A : Type) (t : BTree A),
    isEmpty t = true <-> t = empty.
Proof.
  destruct t; cbn; firstorder congruence.
Qed.

Lemma isEmpty_singleton :
  forall (A : Type) (x : A),
    isEmpty (singleton x) = false.
Proof. reflexivity. Qed.

Lemma isEmpty_size_false :
  forall (A : Type) (t : BTree A),
    isEmpty t = false <-> size t <> 0.
Proof.
  split; destruct t; cbn; firstorder congruence.
Qed.

Lemma isEmpty_size_true :
  forall (A : Type) (t : BTree A),
    isEmpty t = true <-> size t = 0.
Proof.
  split; destruct t; cbn; congruence.
Qed.

Lemma isEmpty_countBT :
  forall (A : Type) (t : BTree A),
    isEmpty t = true <-> forall p : A -> bool, countBT p t = 0.
Proof.
  split; destruct t; cbn; try congruence.
    intro. specialize (H (fun _ => true)). cbn in H. inversion H.
Qed.

(** [mirror] *)

Fixpoint mirror {A : Type} (t : BTree A) : BTree A :=
match t with
    | empty => empty
    | node v l r => node v (mirror r) (mirror l)
end.

Lemma mirror_inv :
  forall (A : Type) (t : BTree A),
    mirror (mirror t) = t.
Proof.
  induction t; cbn; rewrite ?IHt1, ?IHt2; reflexivity.
Qed.

Lemma preorder_mirror :
  forall (A : Type) (t : BTree A),
    preorder (mirror t) = rev (postorder t).
Proof.
  induction t; cbn.
    reflexivity.
    rewrite ?rev_app_distr, IHt1, IHt2. cbn. reflexivity.
Qed.

Lemma postorder_mirror :
  forall (A : Type) (t : BTree A),
    postorder (mirror t) = rev (preorder t).
Proof.
  intros. rewrite <- rev_involutive at 1. rewrite <- preorder_mirror.
  rewrite mirror_inv. reflexivity.
Qed.

Lemma inorder_mirror :
  forall (A : Type) (t : BTree A),
    inorder (mirror t) = rev (inorder t).
Proof.
  induction t; cbn.
    reflexivity.
    rewrite ?rev_app_distr, IHt1, IHt2. cbn.
      rewrite <- app_assoc. cbn. reflexivity.
Qed.

Lemma Elem_mirror :
  forall (A : Type) (x : A) (t : BTree A),
    Elem x (mirror t) <-> Elem x t.
Proof.
  assert (forall (A : Type) (x : A) (t : BTree A),
            Elem x t -> Elem x (mirror t)).
    induction 1; cbn; auto.
    split; intro.
      rewrite <- mirror_inv. apply H, H0.
      apply H, H0.
Qed.

Lemma size_mirror :
  forall (A : Type) (t : BTree A),
    size (mirror t) = size t.
Proof.
  induction t; cbn; rewrite ?IHt1, ?IHt2, 1?Nat.add_comm; reflexivity.
Qed.

Lemma mirror_singleton :
  forall (A : Type) (x : A),
    mirror (singleton x) = singleton x.
Proof. reflexivity. Qed.

(** [complete] *)

Fixpoint complete {A : Type} (n : nat) (x : A) : BTree A :=
match n with
    | 0 => empty
    | S n' => node x (complete n' x) (complete n' x)
end.

Function pow2 (n : nat) : nat :=
match n with
    | 0 => 1
    | S n' => 2 * pow2 n'
end.

Lemma pow2_1plus :
  forall (A : Type) (n : nat),
    exists m : nat, pow2 n = 1 + m.
Proof.
  induction n as [| n']; cbn.
    exists 0. reflexivity.
    destruct IHn' as [m IH]. rewrite !IH. exists (1 + 2 * m). cbn.
      rewrite <- plus_n_Sm, Nat.add_0_r. reflexivity.
Qed.

Lemma size_complete :
  forall (A : Type) (n : nat) (x : A),
    size (complete n x) = pow2 n - 1.
Proof.
  induction n as [| n']; cbn; intros.
    reflexivity.
    rewrite !IHn', Nat.add_0_r. destruct (pow2_1plus A n').
      rewrite !H. cbn. rewrite !Nat.sub_0_r, plus_n_Sm. reflexivity.
Qed.

Lemma mirror_complete :
  forall (A : Type) (n : nat) (x : A),
    mirror (complete n x) = complete n x.
Proof.
  induction n as [| n']; cbn; intros.
    reflexivity.
    rewrite IHn'. reflexivity.
Qed.

(** [takeWhileBT] *)

Function takeWhileBT {A : Type} (p : A -> bool) (t : BTree A) : BTree A :=
match t with
    | empty => empty
    | node v l r =>
        if p v
        then node v (takeWhileBT p l) (takeWhileBT p r)
        else empty
end.

Lemma Elem_takeWhileBT :
  forall {A : Type} (p : A -> bool) (t : BTree A) (x : A),
    Elem x (takeWhileBT p t) -> Elem x t /\ p x = true.
Proof.
  intros until t.
  functional induction takeWhileBT p t;
  inv 1; firstorder.
Qed.

Lemma size_takeWhileBT :
  forall (A : Type) (p : A -> bool) (t : BTree A),
    size (takeWhileBT p t) <= size t.
Proof.
  induction t; cbn.
    apply Nat.le_0_l.
    destruct (p a); cbn.
      apply le_n_S. lia.
      apply Nat.le_0_l.
Qed.

Lemma mirror_takeWhileBT :
  forall (A : Type) (p : A -> bool) (t : BTree A),
    takeWhileBT p (mirror t) = mirror (takeWhileBT p t).
Proof.
  induction t; cbn; intros.
    reflexivity.
    destruct (p a).
      rewrite IHt1, IHt2. cbn. reflexivity.
      reflexivity.
Qed.

Lemma length_bfs_aux :
  forall (A : Type) (l : list (BTree A)) (acc : list A),
    length (bfs_aux A l acc) = sumOfSizes l + length acc.
Proof.
  intros. functional induction bfs_aux A l acc; cbn.
    reflexivity.
    apply IHl0.
    rewrite IHl0, sumOfSizes_app. cbn. lia.
Qed.

Lemma length_bfs :
  forall (A : Type) (t : BTree A),
    length (bfs t) = size t.
Proof.
  intros. unfold bfs.
  rewrite rev_length, length_bfs_aux.
  cbn. rewrite ?Nat.add_0_r. reflexivity.
Qed.

Fixpoint intersperse {A : Type} (x : A) (t : BTree A) : BTree A :=
match t with
    | empty => empty
    | node v l r =>
        node v
          (node x (intersperse x l) (intersperse x l))
          (node x (intersperse x r) (intersperse x r))
end.

Fixpoint height {A : Type} (t : BTree A) : nat :=
match t with
    | empty => 0
    | node _ l r => 1 + max (height l) (height r)
end.

Lemma height_complete :
  forall (A : Type) (n : nat) (x : A),
    height (complete n x) = n.
Proof.
  induction n as [| n']; cbn; intros.
    reflexivity.
    rewrite IHn', Nat.max_id. reflexivity.
Qed.

Lemma max_height_intersperse :
  forall (A : Type) (x : A) (t1 t2 : BTree A),
    height t1 <= height t2 ->
      height (intersperse x t1) <= height (intersperse x t2).
Proof.
  induction t1; cbn; intros.
    apply Nat.le_0_l.
    destruct t2; cbn in *.
      inv H.
      repeat apply le_n_S; repeat apply le_S_n in H.
        rewrite !Nat.max_id. apply Nat.max_lub.
          destruct (Nat.max_dec (height t2_1) (height t2_2)).
            apply Nat.max_lub_l in H. rewrite e in H. apply IHt1_1 in H.
              rewrite H. apply Nat.le_max_l.
            apply Nat.max_lub_l in H. rewrite e in H. apply IHt1_1 in H.
              rewrite H. apply Nat.le_max_r.
          destruct (Nat.max_dec (height t2_1) (height t2_2)).
            apply Nat.max_lub_r in H. rewrite e in H. apply IHt1_2 in H.
              rewrite H. apply Nat.le_max_l.
            apply Nat.max_lub_r in H. rewrite e in H. apply IHt1_2 in H.
              rewrite H. apply Nat.le_max_r.
Qed.

Lemma height_intersperse :
  forall (A : Type) (x : A) (t : BTree A),
    height (intersperse x t) = 2 * height t.
Proof.
  induction t; cbn.
    reflexivity.
    repeat match goal with
        | |- context [max ?n ?m] =>
            let H := fresh "H" in
              destruct (Nat.max_dec n m) as [H | H]; rewrite ?H
    end;
    rewrite ?IHt1, ?IHt2, ?Nat.add_0_r, ?Nat.mul_max_distr_l,
            ?Nat.mul_cancel_l, ?Nat.max_id in *;
    lia.
Qed.

Lemma S_pow_minus_1 :
  forall n : nat,
    S (2 ^ n - 1) = 2 ^ n.
Proof.
  induction n as [| n']; cbn.
    reflexivity.
    rewrite Nat.add_0_r, Nat.add_sub_swap.
      rewrite <- Nat.add_succ_l, IHn'. reflexivity.
      lia.
Qed.

Lemma size_intersperse_complete :
  forall (A : Type) (x y : A) (n : nat),
    size (intersperse x (complete n y)) = pow 2 (2 * n) - 1.
Proof.
  induction n as [| n']; cbn.
    reflexivity.
    rewrite IHn'. cbn. rewrite !(Nat.add_comm _ (S _)). cbn.
      rewrite !Nat.add_0_r, <- 4!Nat.add_succ_l.
      rewrite S_pow_minus_1, plus_n_Sm, S_pow_minus_1.
      rewrite Nat.add_succ_l, plus_n_Sm, <- Nat.add_succ_l, S_pow_minus_1.
        lia.
Qed.

Lemma mirror_intersperse :
  forall (A : Type) (x : A) (t : BTree A),
    mirror (intersperse x t) = intersperse x (mirror t).
Proof.
  induction t; cbn; rewrite ?IHt1, ?IHt2; reflexivity.
Qed.

Fixpoint take {A : Type} (n : nat) (t : BTree A) : BTree A :=
match n, t with
    | 0, _ => empty
    | _, empty => empty
    | S n', node v l r =>
        node v (take n' l) (take n' r)
end.

Lemma height_take :
  forall (A : Type) (n : nat) (t : BTree A),
    height (take n t) <= n.
Proof.
  induction n as [| n']; cbn.
    trivial.
    destruct t; cbn.
      apply Nat.le_0_l.
      apply le_n_S, Nat.max_lub; auto.
Qed.

Lemma take_mirror :
  forall (A : Type) (n : nat) (t : BTree A),
    take n (mirror t) = mirror (take n t).
Proof.
  induction n as [| n']; cbn; intros.
    reflexivity.
    destruct t; cbn; rewrite ?IHn'; reflexivity.
Qed.

Function drop {A : Type} (n : nat) (t : BTree A) : list (BTree A) :=
match n, t with
    | 0, _ => [t]
    | _, empty => []
    | S n', node _ l r =>
        drop n' l ++ drop n' r
end.

Lemma height_drop :
  forall (A : Type) (h : nat) (t : BTree A),
    height t < h -> drop h t = [].
Proof.
  intros. functional induction @drop A h t.
    destruct _x; inv H.
    reflexivity.
    cbn in *. rewrite <- Nat.succ_lt_mono in H. rewrite IHl, IHl0. reflexivity.
      eapply Nat.le_lt_trans.
        apply Nat.le_max_r.
        eexact H.
      eapply Nat.le_lt_trans.
        apply Nat.le_max_l.
        eassumption.
Qed.

Lemma drop_mirror :
  forall (A : Type) (n : nat) (t : BTree A),
    drop n (mirror t) = rev (map mirror (drop n t)).
Proof.
  induction n as [| n']; cbn; intros.
    reflexivity.
    destruct t; cbn.
      reflexivity.
      rewrite ?IHn'. rewrite map_app, rev_app_distr. reflexivity.
Qed.

Fixpoint zipWith
  {A B C : Type} (f : A -> B -> C)
  (ta : BTree A) (tb : BTree B) : BTree C :=
match ta, tb with
    | empty, _ => empty
    | _, empty => empty
    | node a la ra, node b lb rb =>
        node (f a b) (zipWith f la lb) (zipWith f ra rb)
end.

Lemma height_zipWith :
  forall
    (A B C : Type) (f : A -> B -> C)
    (ta : BTree A) (tb : BTree B),
      height (zipWith f ta tb) <= height ta /\
      height (zipWith f ta tb) <= height tb.
Proof.
  induction ta; cbn.
    intros. split; apply Nat.le_0_l.
    destruct tb; cbn.
      split; apply Nat.le_0_l.
      edestruct IHta1, IHta2. split; apply le_n_S.
        apply Nat.max_le_compat; eauto.
        apply Nat.max_le_compat; eauto.
Qed.

Lemma zipWith_mirror :
  forall (A B C : Type) (f : A -> B -> C) (ta : BTree A) (tb : BTree B),
    zipWith f (mirror ta) (mirror tb) =
    mirror (zipWith f ta tb).
Proof.
  induction ta; cbn; intros.
    reflexivity.
    destruct tb; cbn.
      reflexivity.
      rewrite IHta1, IHta2. reflexivity.
Qed.

Function find {A : Type} (p : A -> bool) (t : BTree A) : option A :=
match t with
    | empty => None
    | node v l r =>
        if p v
        then Some v
        else
          match find p l, find p r with
              | Some x, _ => Some x
              | _, Some x => Some x
              | _, _ => None
          end
end.

Inductive Any {A : Type} (P : A -> Prop) : BTree A -> Prop :=
    | Any_root :
        forall (v : A) (l r : BTree A),
          P v -> Any P (node v l r)
    | Any_child_l :
        forall (v : A) (l r : BTree A),
          Any P l -> Any P (node v l r)
    | Any_child_r :
        forall (v : A) (l r : BTree A),
          Any P r -> Any P (node v l r).

#[global] Hint Constructors Any : core.

Lemma Any_find :
  forall (A : Type) (P : A -> Prop) (p : A -> bool) (t : BTree A),
    (forall x : A, reflect (P x) (p x)) ->
      reflect (Any P t) (match find p t with
                             | None => false
                             | _ => true
                         end).
Proof.
  intros. induction t; cbn.
    constructor. inv 1.
    destruct (p a) eqn: Hpa.
      do 2 constructor. specialize (X a). inv X.
      destruct (find p t1).
        inv IHt1.
        destruct (find p t2).
          inv IHt2.
          constructor. inv IHt1; inv IHt2. inv 1.
            specialize (X a). inv X.
Qed.

Inductive Dup {A : Type} : BTree A -> Prop :=
    | Dup_root_l :
        forall (v : A) (l r : BTree A),
          Elem v l -> Dup (node v l r)
    | Dup_root_r :
        forall (v : A) (l r : BTree A),
          Elem v r -> Dup (node v l r)
    | Dup_l :
        forall (v : A) (l r : BTree A),
          Dup l -> Dup (node v l r)
    | Dup_r :
        forall (v : A) (l r : BTree A),
          Dup r -> Dup (node v l r).

Inductive Exactly {A : Type} (P : A -> Prop) : nat -> BTree A -> Prop :=
    | Exactly_empty : Exactly P 0 empty
    | Exactly_node_yes :
        forall (n m : nat) (v : A) (l r : BTree A),
          P v -> Exactly P n l -> Exactly P m r ->
            Exactly P (1 + n + m) (node v l r)
    | Exactly_node_no :
        forall (n m : nat) (v : A) (l r : BTree A),
          ~ P v -> Exactly P n l -> Exactly P m r ->
            Exactly P (n + m) (node v l r).

Lemma Exactly_0_False :
  forall (A : Type) (t : BTree A),
    Exactly (fun _ => False) 0 t.
Proof.
  induction t.
    constructor.
    change 0 with (0 + 0). constructor; try intro; assumption.
Qed.

Lemma Exactly_count :
  forall
    (A : Type) (P : A -> Prop) (p : A -> bool) (n : nat) (t : BTree A),
      (forall x : A, reflect (P x) (p x)) ->
        Exactly P n t <-> countBT p t = n.
Proof.
  split.
    induction 1; cbn.
      reflexivity.
      destruct (p v) eqn: Hpv; rewrite ?IHExactly1, ?IHExactly2.
        reflexivity.
        specialize (X v). inv X.
      destruct (p v) eqn: Hpv; rewrite ?IHExactly1, ?IHExactly2.
        specialize (X v). inv X.
        reflexivity.
    gen n. induction t; cbn; intros; subst.
      constructor.
      destruct (p a) eqn: Hpa; constructor; auto.
        1-2: specialize (X a); inv X.
Qed.

Inductive All {A : Type} (P : A -> Prop) : BTree A -> Prop :=
    | All_empty : All P empty
    | All_node :
        forall (v : A) (l r : BTree A),
          P v -> All P l -> All P r -> All P (node v l r).

#[global] Hint Constructors All : core.

Lemma All_node' :
  forall {A : Type} {P : A -> Prop} {v : A} {l r : BTree A},
    All P (node v l r) <-> P v /\ All P l /\ All P r.
Proof.
  split; inv 1. inv H1.
Qed.

Lemma All_spec :
  forall {A : Type} {P : A -> Prop} {t : BTree A},
    All P t <-> forall x : A, Elem x t -> P x.
Proof.
  split.
    induction 1; inv 1.
    intro H. induction t; auto.
Qed.

Lemma All_Elem :
  forall {A : Type} {P : A -> Prop} {x : A} {t : BTree A},
    All P t -> Elem x t -> P x.
Proof.
  induction 1; inv 1.
Qed.

Lemma count_size :
  forall (A : Type) (p : A -> bool) (t : BTree A),
    countBT p t <= size t.
Proof.
  induction t; cbn.
    reflexivity.
    destruct (p a).
      apply le_n_S. apply Nat.add_le_mono; assumption.
      unfold id. apply le_S. apply Nat.add_le_mono; assumption.
Qed.

Lemma count_size_aux :
  forall (A : Type) (p : A -> bool) (t1 t2 : BTree A),
    countBT p t1 + countBT p t2 = size t1 + size t2 ->
      countBT p t1 = size t1 /\ countBT p t2 = size t2.
Proof.
  induction t1; cbn; intros.
    split; [reflexivity | assumption].
    destruct (p a) eqn: Hpa.
      inv H. specialize (IHt1_1 (node a t1_2 t2)). cbn in *.
        rewrite Hpa in *. destruct (IHt1_1 ltac:(lia)). inv H0.
        destruct (IHt1_2 _ H3). lia.
      assert (S (size t1_1 + size t1_2 + size t2) <=
                (size t1_1 + size t1_2 + size t2)).
        rewrite <- H. unfold id.
          repeat apply Nat.add_le_mono; apply count_size.
        lia.
Qed.

Lemma All_count :
  forall (A : Type) (P : A -> Prop) (p : A -> bool) (t : BTree A),
    (forall x : A, reflect (P x) (p x)) ->
      All P t <-> countBT p t = size t.
Proof.
  split.
    induction 1; cbn.
      reflexivity.
      destruct (p v) eqn: Hpv.
        rewrite ?IHAll1, ?IHAll2. reflexivity.
        specialize (X v). inv X.
    induction t; cbn; intros.
      constructor.
      destruct (p a) eqn: Hpa; inv H.
        apply count_size_aux in H1.
          destruct H1. constructor; auto. specialize (X a). inv X.
        assert (S (size t1 + size t2) <=
                  (size t1 + size t2)).
          rewrite <- H1. unfold id.
            apply Nat.add_le_mono; apply count_size.
          lia.
Qed.

Inductive SameStructure {A B : Type} : BTree A -> BTree B -> Prop :=
    | SS_empty : SameStructure empty empty
    | SS_node :
        forall (v1 : A) (l1 r1 : BTree A) (v2 : B) (l2 r2 : BTree B),
          SameStructure l1 l2 ->
          SameStructure r1 r2 ->
            SameStructure (node v1 l1 r1) (node v2 l2 r2).

Lemma zipWith_swap :
  forall (A B C : Type) (f : A -> B -> C) (ta : BTree A) (tb : BTree B),
    zipWith f ta tb = zipWith (fun b a => f a b) tb ta.
Proof.
  induction ta; destruct tb; cbn; intros; f_equal; auto.
Qed.

Inductive subtree {A : Type} : BTree A -> BTree A -> Prop :=
    | subtree_l :
        forall (v : A) (l r : BTree A),
          subtree l (node v l r)
    | subtree_r :
        forall (v : A) (l r : BTree A),
          subtree r (node v l r)
    | subtree_trans :
        forall t1 t2 t3 : BTree A,
          subtree t1 t2 -> subtree t2 t3 -> subtree t1 t3.

Lemma size_subtree :
  forall (A : Type) (t1 t2 : BTree A),
    subtree t1 t2 -> size t1 < size t2.
Proof.
  induction 1; cbn.
    apply le_n_S, Nat.le_add_r.
    apply le_n_S, Nat.le_add_l.
    apply Nat.lt_trans with (size t2); assumption.
Qed.

Lemma height_subtree :
  forall (A : Type) (t1 t2 : BTree A),
    subtree t1 t2 -> height t1 < height t2.
Proof.
  induction 1; cbn.
    apply le_n_S, Nat.le_max_l.
    apply le_n_S, Nat.le_max_r.
    apply Nat.lt_trans with (height t2); assumption.
Qed.

(** [removeMin] *)

Function removeMin
  {A : Type} (t : BTree A) : option (A * BTree A) :=
match t with
    | empty => None
    | node x l r =>
        match removeMin l with
            | None => Some (x, r)
            | Some (m, l') => Some (m, node x l' r)
        end
end.

Lemma Elem_removeMin :
  forall
    {A : Type} {t t' : BTree A} {m : A},
      removeMin t = Some (m, t') ->
        forall x : A, Elem x t <-> x = m \/ Elem x t'.
Proof.
  intros A t.
  functional induction removeMin t;
  inv 1; intro; rewrite ?Elem_node;
  firstorder.
    functional inversion e0. subst. inv H.
Qed.

(** * [filterBT] *)

Function filterBT
  {A : Type} (p : A -> bool) (t : BTree A) : BTree A :=
match t with
    | empty => empty
    | node v l r =>
        let l' := filterBT p l in
        let r' := filterBT p r in
          if p v
          then node v l' r'
          else
            match removeMin r' with
                | None => l'
                | Some (m, r'') => node m l' r''
            end
end.

Lemma Elem_filterBT :
  forall (A : Type) (p : A -> bool) (t : BTree A) (x : A),
    Elem x (filterBT p t) <-> Elem x t /\ p x = true.
Proof.
  intros until t.
  functional induction filterBT p t;
  intros;
    rewrite ?Elem_node, ?IHb, ?IHb0.
    firstorder. inv H.
    firstorder. congruence.
    firstorder.
      congruence.
      functional inversion e1; subst.
        assert (Elem x empty).
          rewrite H1, IHb0. split; assumption.
          inv H2.
    pose (Elem_removeMin e1). firstorder.
      congruence.
Qed.

(* TODO: drop using cmp *)

(* TODO: nth, modify, splitAt, insert, replace, modify *)

Inductive All2 {A B : Type} (R : A -> B -> Prop) : BTree A -> BTree B -> Prop :=
    | All2_empty : All2 R empty empty
    | All2_node  :
        forall
          (va : A) (la ra : BTree A)
          (vb : B) (lb rb : BTree B),
            R va vb -> All2 R la lb -> All2 R ra rb ->
              All2 R (node va la ra) (node vb lb rb).

Inductive Ex2 {A B : Type} (R : A -> B -> Prop) : BTree A -> BTree B -> Prop :=
    | Ex2_node  :
        forall
          (va : A) (la ra : BTree A)
          (vb : B) (lb rb : BTree B),
            R va vb \/ Ex2 R la lb \/ Ex2 R ra rb ->
              Ex2 R (node va la ra) (node vb lb rb).

Inductive PermutationBT {A : Type} : BTree A -> BTree A -> Prop :=
    | PermutationBT_empty : PermutationBT empty empty
    | PermutationBT_skip  :
        forall (v : A) (l1 l2 r1 r2 : BTree A),
          PermutationBT l1 l2 -> PermutationBT r1 r2 ->
            PermutationBT (node v l1 r1) (node v l2 r2)
    | PermutationBT_swapl :
        forall (x y : A) (yl yr xr : BTree A),
          PermutationBT (node y (node x yl yr) xr) (node x (node y yl yr) xr)
    | PermutationBT_swapr :
        forall (x y : A) (xl yl yr : BTree A),
          PermutationBT (node y xl (node x yl yr)) (node x xl (node y yl yr))
    | PermutationBT_trans :
        forall t1 t2 t3 : BTree A,
          PermutationBT t1 t2 -> PermutationBT t2 t3 -> PermutationBT t1 t3.

Lemma PermutationBT_refl :
  forall {A : Type} (t : BTree A),
    PermutationBT t t.
Proof.
  induction t; constructor; assumption.
Qed.

Lemma PermutationBT_sym :
  forall {A : Type} {t1 t2 : BTree A},
    PermutationBT t1 t2 -> PermutationBT t2 t1.
Proof.
  induction 1; econstructor; eassumption.
Qed.

Lemma count_PermutationBT :
  forall {A : Type} {t1 t2 : BTree A},
    PermutationBT t1 t2 ->
      forall p : A -> bool, countBT p t1 = countBT p t2.
Proof.
  induction 1; cbn; intro;
  rewrite ?IHPermutationBT1, ?IHPermutationBT2;
  try reflexivity;
  destruct (p x), (p y); unfold id; lia.
Qed.

Inductive AtLeast {A : Type} (P : A -> Prop) : BTree A -> nat -> Prop :=
    | AtLeast_empty :
        forall t : BTree A, AtLeast P t 0
    | AtLeast_node_yes  :
        forall (v : A) (l r : BTree A) (n m : nat),
          P v -> AtLeast P l n -> AtLeast P r m -> AtLeast P (node v l r) (S (n + m))
    | AtLeast_node_skip :
        forall (v : A) (l r : BTree A) (n m : nat),
          AtLeast P l n -> AtLeast P r m -> AtLeast P (node v l r) (n + m).

#[global] Hint Constructors AtLeast : core.

Fixpoint toList {A : Type} (t : BTree A) : list A :=
match t with
    | empty => []
    | node v l r => toList l ++ v :: toList r
end.

Lemma PermutationBT_toList :
  forall {A : Type} {t1 t2 : BTree A},
    PermutationBT t1 t2 -> Permutation (toList t1) (toList t2).
Proof.
  induction 1; cbn.
    constructor.
    apply Permutation_app; auto.
    rewrite <- ?app_assoc. apply Permutation_app.
      reflexivity.
      {
        rewrite Permutation_app_comm.
        cbn. constructor.
        rewrite Permutation_app_comm, (Permutation_app_comm (toList yr)).
        cbn. constructor.
        apply Permutation_app_comm.
      }
    apply Permutation_app.
      reflexivity.
      rewrite 2!Permutation_middle. apply Permutation_app.
        reflexivity.
        constructor.
    rewrite IHPermutationBT1, IHPermutationBT2. reflexivity.
Qed.

Lemma PermutationBT_toList_conv :
  forall {A : Type} {t1 t2 : BTree A},
    Permutation (toList t1) (toList t2) -> PermutationBT t1 t2.
Proof.
  induction t1 as [| h1 t1].
    destruct t2 as [| h2 t2]; cbn.
      constructor.
      intro. apply Permutation_length in H.
        rewrite app_length in H. cbn in H. lia.
    destruct t2 as [| h2 t2]; cbn.
      intro. apply Permutation_length in H.
        rewrite app_length in H. cbn in H. lia.
      intro.
Abort.

Definition PermutationBT' {A : Type} (t1 t2 : BTree A) : Prop :=
  forall (P : A -> Prop) (n : nat),
    Exactly P n t1 <-> Exactly P n t2.

Lemma Permutation_PermutationBT' :
  forall {A : Type} {t1 t2 : BTree A},
    PermutationBT t1 t2 -> PermutationBT' t1 t2.
Proof.
  unfold PermutationBT'.
  induction 1; split; inv 1; try constructor; firstorder.
Abort.

Definition PermutationBT'' {A : Type} (t1 t2 : BTree A) : Prop :=
  forall (P : A -> Prop) (n : nat),
    AtLeast P t1 n <-> AtLeast P t2 n.

Lemma Permutation_PermutationBT'' :
  forall {A : Type} {t1 t2 : BTree A},
    PermutationBT t1 t2 -> PermutationBT'' t1 t2.
Proof.
  unfold PermutationBT''.
  induction 1; split; inv 1;
  try (constructor 2; firstorder; fail);
  try (constructor 3; firstorder; fail).
    inv H5. cbn. change (S m) with (1 + m). constructor 3.
      change 1 with (1 + 0). constructor; auto. auto.
Abort.

(* Various versions of [removeMin], moved from SplayTree.v *)

Function leftmost {A : Type} (t : BTree A) : option A :=
match t with
    | empty => None
    | node v empty _ => Some v
    | node _ l _ => leftmost l
end.

Function leftmost'
  {A : Type} (h : BTree A) : option A :=
match h with
    | empty => None
    | node v l r =>
        match leftmost' l with
            | None => Some v
            | Some m => Some m
        end
end.

Function removeLeftmost
  {A : Type} (h : BTree A) : BTree A :=
match h with
    | empty => empty
    | node _ empty r => r
    | node v l r => node v (removeLeftmost l) r
end.

(** Properties of [leftmost'] *)

Lemma Elem_leftmost' :
  forall {A : Type} {t : BTree A} {x : A},
    leftmost' t = Some x -> Elem x t.
Proof.
  intros A t.
  functional induction leftmost' t;
  inv 1.
Qed.

(** Properties of [leftmost]. *)

Lemma Elem_leftmost :
  forall {A : Type} {t : BTree A} {x : A},
    leftmost t = Some x -> Elem x t.
Proof.
  intros A t.
  functional induction leftmost t; inv 1.
Qed.

(** Properties of [removeMin]. *)

Lemma size_removeMin :
  forall {A : Type} {t t' : BTree A} {m : A},
    removeMin t = Some (m, t') ->
        size t = 1 + size t'.
Proof.
  intros until t.
  functional induction removeMin t;
  cbn; inv 1.
    functional inversion e0; subst. cbn. reflexivity.
    rewrite (IHo _ _ e0). cbn. reflexivity.
Qed.

Lemma removeMin_isEmpty_None :
  forall (A : Type) (h : BTree A),
    removeMin h = None -> isEmpty h = true.
Proof.
  intros. functional induction @removeMin A h; cbn; inv H.
Qed.

Lemma removeMin_isEmpty_Some :
  forall (A : Type) (m : A) (h h' : BTree A),
    removeMin h = Some (m, h') -> isEmpty h = false.
Proof.
  intros. functional induction @removeMin A h; cbn; inv H.
Qed.

Lemma countBT_removeMin :
  forall {A : Type} {t t' : BTree A} {x : A},
    removeMin t = Some (x, t') ->
      forall p : A -> bool,
        countBT p t = (if p x then 1 else 0) + countBT p t'.
Proof.
  intros A t.
  functional induction removeMin t;
  inv 1; cbn; intro.
    functional inversion e0; subst. cbn. lia.
    rewrite (IHo _ _ e0). lia.
Qed.

Lemma size_removeLeftmost :
  forall {A : Type} (t : BTree A),
    size (removeLeftmost t) = pred (size t).
Proof.
  intros.
  functional induction removeLeftmost t;
  cbn; try reflexivity.
    rewrite IHb. destruct l; cbn; lia.
Qed.


Set Implicit Arguments.
Require Import MyTactics.
Require Import DeBruijn.
Require Import Environments.
Require Import Syntax.

(* ---------------------------------------------------------------------------- *)

(* Well-kindedness. *)

Inductive wk : env kind -> syntax -> kind -> Prop :=

(* The case of variables is special, as a variable can have an arbitrary kind. *)

(* Variable: [x]. *)

| WkVar:
    forall K x kappa,
    lookup x K = Some kappa ->
    wk K (SVar x) kappa

(* The following constructs have kind [ADDR]. *)

(* The value [SAddr a] represents the address [a] in the heap. *)

| WkAddr:
    forall K a,
    wk K (SAddr a) ADDR

(* The following constructs have kind [VALUE]. *)

(* An address is also a value. In other words, [ADDR] is a subkind of [VALUE]. *)

| WkAddrAsValue:
    forall K av,
    wk K av ADDR ->
    wk K av VALUE

(* The value [garbage] is used to fill newly-allocated, uninitialized
   areas of memory. *)

| WkGarbage:
    forall K,
    wk K SGarbage VALUE

(* The following constructs have kind [STATEMENT]. *)

(* [skip] is a no-op. *)

| WkSkip:
    forall K,
    wk K SSkip STATEMENT

(* Sequence: [st; st]. *)

| WkSequence:
    forall K st1 st2,
    wk K st1 STATEMENT ->
    wk K st2 STATEMENT ->
    wk K (SSequence st1 st2) STATEMENT

(* Assignment: [lv = rv]. *)

| WkAssignment:
    forall K lv rv,
    wk K lv ADDR ->
    wk K rv RVALUE ->
    wk K (SAssignment lv rv) STATEMENT

(* Local variable definition: [let x = lv in st]. The variable [x] is the de
   Bruijn index 0, so it does not explicitly appear. The lvalue [lv] is
   evaluated, yielding (if successful) a memory location [l]. The variable [x]
   is bound to this address. [x] may be used in the statement [st]. No memory
   allocation (on the stack or on the heap) takes place. *)

| WkLetLValue:
    forall K lv st,
    wk K lv LVALUE ->
    wk (insert 0 ADDR K) st STATEMENT ->
    wk K (SLetLValue lv st) STATEMENT

(* Memory de-allocation: [delete lv]. The size of the block that must be
   freed is known by the runtime system. *)

| WkDelete:
    forall K lv,
    wk K lv ADDR ->
    wk K (SDelete lv) STATEMENT

(* The following constructs have kind [LVALUE]. *)

(* We allow a syntactic element of kind [ADDR] to also have kind [LVALUE]. This
   allows variables (and memory locations) to appear as lvalues, i.e., it
   allows writing [let x = y in st], where [x] and [y] are temporaries of kind
   [ADDR]. This is useful as an intermediate step in the reduction of more
   elaborate expressions of the form [let x = lv in st]. *)

| WkAddrAsLValue:
    forall K lv,
    wk K lv ADDR ->
    wk K lv LVALUE

(* Field projection: [lv.f]. (Note that [z] must be nonnegative.) *)

| WkFieldProj:
    forall K lv z,
    wk K lv ADDR ->
    wk K (SFieldProj lv z) LVALUE

(* Dereferencing: [*lv]. *)

| WkDeref:
    forall K lv,
    wk K lv ADDR ->
    wk K (SDeref lv) LVALUE

(* Memory allocation: [new z]. The parameter [z] is a size. *)

| WkNew:
    forall K z,
    wk K (SNew z) LVALUE

(* The following constructs have kind [RVALUE]. *)

(* Copying: [z lv]. This means that an lvalue can be supplied where an rvalue
   is expected. We annotate with a size [z], so that we know how many words
   of memory must be copied. *)

| WkCopy:
    forall K z lv,
    wk K lv ADDR ->
    wk K (SCopy z lv) RVALUE

(* Every address also has kind [RVALUE]. It is a one-word rvalue. *)

| WkAddress:
    forall K lv,
    wk K lv ADDR ->
    wk K lv RVALUE

(* Nothing is an rvalue, which occupies zero words. *)

| WkNothing:
    forall K,
    wk K SNothing RVALUE

(* The concatenation of two rvalues forms an rvalue: [rv; rv]. This
   allows us to emulate struct constants, without relying on actual
   struct definitions. *)

| WkConsecutive:
    forall K rv1 rv2,
    wk K rv1 RVALUE ->
    wk K rv2 RVALUE ->
    wk K (SConsecutive rv1 rv2) RVALUE

.


Fixpoint inList {A: Set} (x: A) (l: list A): Prop :=
  match l with
  | nil => False
  | cons h t => x = h \/ inList x t
  end.

Inductive UList (A: Type) : list A -> Type :=
  | UNil : UList A []
  | UCons : forall i: list A, forall l : UList A i, forall a : A, (inList a i -> False) -> UList A []


(* begin hide *)
From Vellvm Require Import
     Utilities
     Syntax
     Semantics.
(* end hide *)

(** * Utilities to build predicates and relations over VIR's state *)

Definition pred T : Type := T -> Prop.
Definition rel  T : Type := T -> T -> Prop.

Definition conj_pred {T} (P1 P2: pred T) : pred T :=
  fun x => P1 x /\ P2 x.

Definition conj_rel {T} (R1 R2: rel T) : rel T :=
  fun x y => R1 x y /\ R2 x y.

Infix "×" := conj_rel (at level 30, right associativity).

Section CFG_LEVEL.

  Definition state_cfg : Type := memory_stack * (local_env * global_env).

  Definition state_cfg_T (T:Type): Type
    := memory_stack * (local_env * (global_env * T)).

  Definition state_cfgP := pred state_cfg.
  Definition state_cfg_TP {T : Type} := pred (state_cfg_T T).
  Definition state_cfgR := rel state_cfg.
  Definition state_cfg_TR {T : Type} := rel (state_cfg_T T).

  Definition lift_pure_cfgP {T : Type} (P : pred T) : @state_cfg_TP T :=
    fun '(_,(_,(_,v))) => P v.
  Definition lift_pure_cfgR {T : Type} (P : rel T) : @state_cfg_TR T :=
    fun '(_,(_,(_,v))) '(_,(_,(_,v'))) => P v v'.

  Definition lift_state_cfgP {T : Type} (P : state_cfgP) : @state_cfg_TP T :=
    fun '(m,(l,(g,_))) => P (m,(l,g)).
  Definition lift_state_cfgR {T : Type} (P : state_cfgR) : @state_cfg_TR T :=
    fun '(m,(l,(g,_))) '(m',(l',(g',_))) => P (m,(l,g)) (m',(l',g')).

End CFG_LEVEL.

Notation "↑" :=  lift_state_cfgP.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import definition.
Require Import Reals.
Require Import Zind_complements.
Require Import Tactiques.
Require Import Psatz.
Require Import Lemmes.
Require Import Zsqrt_complements.
Require Import Rbase_inegalites.
Require Import Lemmes_generaux.
Require Import Rbase_doubles_inegalites.
Require Import Zarith_inegalites.
Require Import Zarith_operations.
Require Import powerRZ_complements.
Require Import Inverse.

Lemma contraposesg_Zsgn_2 :
 forall (x : R) (xc : Reelc) (n : Z),
 encadrement xc x -> x >= 0 ->  ( xc n >= 0)%Z .
Proof.
intros x xc n H.
assert (implique : forall A B : Prop, (~A -> ~B) -> (B -> A)).
intros A B H2. apply Classical_Prop.or_to_imply.
apply Classical_Prop.imply_to_or in H2.
apply or_comm. apply Classical_Prop.imply_and_or2 with (~~A).
apply Classical_Prop.NNPP. assumption.
apply implique. assert (implique2 :  (x < 0) -> (~ x >= 0)).
apply Classical_Prop.or_to_imply.
apply Classical_Prop.imply_and_or2 with (x >= 0).
intros H2. apply RIneq.Rle_not_lt. apply Rge_le.
assumption. apply Classical_Prop.classic.
intros H8. apply implique2.
 assert (implique3 : (~ (xc n >= 0)%Z) -> ((xc n < 0)%Z)).
apply Znot_ge_lt.
apply sg_Zsgn_2 with xc n. assumption.
apply Z.lt_gt. apply implique3. assumption.
Qed.

Lemma geqZ : forall z : Z,
(z >= 0)%Z -> ((0=z)%Z)\/((0 < z)%Z).
Proof.
intros z H. apply Z.ge_le in H.
apply Zle_lt_or_eq in H.
apply or_comm in H.
assumption.
Qed.

Lemma existcarre : forall z : Z,
(exists z2 : Z, (z2*z2 = z)%Z)\/(forall z2 : Z, (z2* z2 <> z)%Z).
Proof.
intros z.
assert (H :(~(forall z2 : Z, (z2* z2 <> z)%Z)) ->
           (exists z2 : Z, (z2*z2 = z)%Z)).
intros H. apply Classical_Pred_Type.not_all_ex_not in H.
inversion H. assert ((~ (x * x)%Z <> z) -> (x * x)%Z = z).
intros H2. apply Z.eq_dne. assumption.
assert (H2 : (x * x)%Z = z).  apply H1.
assumption.
  apply ex_intro with (x). assumption.
apply Classical_Prop.imply_and_or2 with (~ (forall z2 : Z, (z2 * z2)%Z <> z)).
assumption. apply or_comm. apply Classical_Prop.classic.
Qed.

Lemma racineineq : forall a b : R,
a >= 0 -> b >= 0 -> a * a >= b * b -> a >= b.
Proof. intros a b H1 H2 H3.
replace (a) with (sqrt (a * a)).
replace (b) with (sqrt (b * b)).
apply Rle_ge. apply sqrt_le_1_alt. apply Rge_le. assumption.
rewrite sqrt_square. reflexivity. apply Rge_le. assumption.
rewrite sqrt_square. reflexivity. apply Rge_le. assumption.
Qed.

Lemma plusracine : forall r : R,
r >= 0 -> sqrt r >= sqrt(r + 1) - 1.
Proof. intros r H.
replace (sqrt (r + 1) - 1) with (sqrt (r + 1) + (- 1)).
replace (sqrt r) with (sqrt r + 1 + (-1)).
apply Rplus_ge_compat_r. apply racineineq.
apply Rge_trans with (1). replace (1) with (0 + 1).
replace (sqrt r + (0 + 1)) with (sqrt r + 1).
apply Rplus_ge_compat_r. apply Rle_ge. apply sqrt_positivity.
apply Rge_le. assumption. ring. ring. lra.
apply Rle_ge. apply sqrt_positivity. apply Rge_le.
apply Rge_trans with (1). replace (1) with (0 + 1).
replace (r + (0 + 1)) with (r + 1).
apply Rplus_ge_compat_r. assumption. ring. ring. lra.
rewrite sqrt_sqrt. replace ((sqrt r + 1) * (sqrt r + 1)) with
(sqrt r * sqrt r + 1 * 1 + sqrt r + sqrt r). rewrite sqrt_sqrt.
replace (r + 1 * 1 + sqrt r + sqrt r) with (r + (1 * 1 + sqrt r + sqrt r)).
apply Rplus_ge_compat_l. replace (1 * 1) with (1).
replace (1) with (1 + 0). replace (1 + 0 + sqrt r + sqrt r) with
(1  + 2* sqrt r). apply Rplus_ge_compat_l. replace (0) with (2 * 0).
apply Rmult_ge_compat_l. lra. apply Rle_ge. apply sqrt_positivity.
apply Rge_le. assumption. ring. ring. ring. ring. ring.
apply Rge_le. assumption. ring. apply Rge_le.
apply Rge_trans with (1). replace (1) with (0 + 1).
replace (r + (0 + 1)) with (r + 1).
apply Rplus_ge_compat_r. assumption. ring. ring. lra.
ring. ring.
Qed.

Lemma sqrtB2n : forall z : Z,
sqrt (B_powerRZ (2 * z)) = B_powerRZ z.
Proof. intros z. replace (B_powerRZ (2 * z)) with
(B_powerRZ (z) * B_powerRZ (z)).
apply sqrt_square. apply Rlt_le. apply Rgt_lt.
apply Bexpos. rewrite produitB_powerRZ. unfold B_powerRZ.
apply powerRZ_trivial. ring. Qed.

Lemma zetzplusunnoncarre : forall z : Z,
(z >= 0)%Z -> (forall z2 : Z, (z2* z2 <> z)%Z) -> (forall z2 : Z, (z2* z2 <> (z + 1)%Z)%Z) ->
(Z.sqrt z = Z.sqrt (z + 1))%Z.
Proof.
intros z H H1 H2.
assert (H3 : Z.sqrt (Z.succ z) = Z.succ (Z.sqrt z) \/
             Z.sqrt (Z.succ z) = Z.sqrt z).
apply Z.sqrt_succ_or. apply Z.ge_le. assumption.
replace (Z.succ z) with ((z + 1)%Z) in H3. inversion H3.
apply Z.sqrt_eq_succ_iff_square in H0. inversion H0. inversion H4.
replace (Z.succ z) with ((z + 1)%Z) in H6.
rewrite H6 in H2. assert (H7 : (x * x)%Z <> (x * x)%Z).
apply H2. replace ((x * x)%Z <> (x * x)%Z) with (False) in H7.
inversion H7. unfold not. omega. ring. apply Z.ge_le.
assumption. rewrite H0. reflexivity. ring.
Qed.

Lemma sqrtZ : forall z : Z,
(z > 0)%Z -> (Z.sqrt (z * z - 1) = z - 1)%Z.
Proof. intros z H.
replace ((z - 1)%Z) with (Z.pred (z)). rewrite <- Z.sqrt_pred_square.
replace ((z * z - 1)%Z) with (Z.pred(z * z)).
reflexivity. unfold Z.pred. ring. apply Z.gt_lt. assumption.
unfold Z.pred. ring. Qed.

Lemma plusracineZ : forall z : Z,
(z >= 0)%Z -> sqrt (IZR z + 1) <= IZR (Z.sqrt z) + 1.
Proof. intros z H.
assert (H1 : sqrt (IZR (z + 1%Z)) < IZR (Z.sqrt (z + 1%Z)) + 1).
apply Zsqrt_sqrt_bis. apply le_IZR.
apply Rle_trans with (1).
lra. replace (1) with (0 + 1). rewrite plus_IZR.
apply Rplus_le_compat_r. apply IZR_le. apply Z.ge_le.
assumption. ring.
rewrite plus_IZR in H1.
assert (H2 : (exists z2 : Z, (z2*z2 = z)%Z)\/(forall z2 : Z, (z2* z2 <> z)%Z)).
apply existcarre. inversion H2.
inversion H0. inversion H3. clear H3.
assert (K : (x >=0)%Z \/ (x<=0)%Z).
apply Classical_Prop.imply_and_or2 with ((0 <= x)%Z).
intros H5. apply Z.le_ge. assumption.
apply Z.le_ge_cases.
 inversion K.
rewrite Z.sqrt_square.
replace (IZR x) with (sqrt (IZR (x * x))).
replace (sqrt (IZR (x * x) + 1)) with (sqrt (IZR (x * x) + 1) - 1 + 1).
apply Rplus_le_compat_r. apply Rge_le.
apply plusracine. rewrite mult_IZR. replace (0) with
(0 * IZR x). apply Rmult_ge_compat_r. apply Rle_ge. apply IZR_le.
apply Z.ge_le. assumption.
apply Rle_ge. apply IZR_le. apply Z.ge_le. assumption.
ring. ring. rewrite mult_IZR. rewrite sqrt_square.
reflexivity. apply IZR_le. apply Z.ge_le. assumption.
apply Z.ge_le. assumption.
assert (K2 : ((-x) * (-x)= z)%Z).
replace ((- x * - x)%Z) with ((x * x)%Z).
assumption. ring.
assert (K3 : ((-x) >= 0)%Z).
apply Z.le_ge. apply le_IZR.
replace (0) with (0 + IZR (x) + (- IZR (x))). replace (IZR (- x)) with
(0 + (-IZR ( x))). apply Rplus_le_compat_r.
replace (0 + IZR x) with ( IZR x). apply IZR_le. assumption.
ring. replace (0 + - IZR x) with (0 - IZR x). rewrite <- minus_IZR.
apply IZR_trivial. ring. ring. ring.
assert (K4 : (x * x)%Z = (-x * -x)%Z). ring.
rewrite K4.
rewrite Z.sqrt_square.
replace (IZR (-x)) with (sqrt (IZR (-x * -x))).
replace (sqrt (IZR (-x * -x) + 1)) with (sqrt (IZR (-x * -x) + 1) - 1 + 1).
apply Rplus_le_compat_r. apply Rge_le.
apply plusracine. rewrite mult_IZR. replace (0) with
(0 * IZR (-x)). apply Rmult_ge_compat_r. apply Rle_ge. apply IZR_le.
apply Z.ge_le. assumption.
apply Rle_ge. apply IZR_le. apply Z.ge_le. assumption.
ring. ring. rewrite mult_IZR. rewrite sqrt_square.
reflexivity. apply IZR_le. apply Z.ge_le. assumption.
apply Z.ge_le. assumption.
assert (H3 : (exists z2 : Z, (z2 * z2)%Z = (z + 1)%Z) \/
(forall z2 : Z, (z2 * z2)%Z <> (z + 1)%Z)).
apply existcarre. inversion H3. inversion H4. inversion H5.
assert (K : (x >=0)%Z \/ (x<=0)%Z).
apply Classical_Prop.imply_and_or2 with ((0 <= x)%Z).
intros H6. apply Z.le_ge. assumption.
apply Z.le_ge_cases. inversion K.

assert (M : ((0=x)%Z)\/((0 < x)%Z)). apply geqZ. assumption.
inversion M. rewrite <- H8 in H7.
rewrite <- plus_IZR. rewrite <- H7.
replace (IZR (0 * 0)) with (0). apply Rle_trans with (IZR (Z.sqrt z)).
rewrite sqrt_0. apply IZR_le. apply Zsqrt_pos.
replace (IZR (Z.sqrt z)) with (IZR (Z.sqrt z) + 0).
replace (IZR (Z.sqrt z) + 0 + 1) with (IZR (Z.sqrt z) + 1).
apply Rplus_le_compat_l. lra. ring. ring. rewrite mult_IZR.
ring. clear H5. rewrite <- plus_IZR. rewrite <- H7. rewrite mult_IZR.
rewrite sqrt_square. assert (H9 : (x * x - 1)%Z = z%Z).
apply eq_IZR. rewrite minus_IZR.
replace (IZR (x * x) - 1) with (IZR (x * x) + (- 1)).
replace (IZR z) with (IZR z + 1 + (-1)).
apply Rplus_eq_compat_r. rewrite <- plus_IZR. apply IZR_trivial.
assumption. ring. ring.
rewrite <- H9. rewrite sqrtZ. rewrite minus_IZR.
replace (IZR x - 1 + 1) with (IZR x). lra.
ring. apply Z.lt_gt. assumption. apply IZR_le. apply Z.ge_le.
apply Z.le_ge. apply le_IZR.
apply Rlt_le. apply IZR_lt. assumption.

assert (M : ((0=x)%Z)\/((0 > x)%Z)).
apply Classical_Prop.imply_and_or2 with ((x = 0)%Z).
intros H8. symmetry in H8. assumption. apply or_comm.
apply Classical_Prop.imply_and_or2 with ((x < 0)%Z).
intros H8. apply Z.lt_gt. assumption.
apply  Zle_lt_or_eq. assumption.
inversion M. rewrite <- H8 in H7.
rewrite <- plus_IZR. rewrite <- H7.
replace (IZR (0 * 0)) with (0). apply Rle_trans with (IZR (Z.sqrt z)).
rewrite sqrt_0. apply IZR_le. apply Zsqrt_pos.
replace (IZR (Z.sqrt z)) with (IZR (Z.sqrt z) + 0).
replace (IZR (Z.sqrt z) + 0 + 1) with (IZR (Z.sqrt z) + 1).
apply Rplus_le_compat_l. lra. ring. ring. rewrite mult_IZR.
ring. clear H5. rewrite <- plus_IZR. rewrite <- H7. rewrite mult_IZR.
replace (IZR x * IZR x) with (IZR (-x) * IZR (-x)).
rewrite sqrt_square. assert (H9 : (-x * -x - 1)%Z = z%Z).
apply eq_IZR. rewrite minus_IZR. replace (IZR (- x * - x))
with (IZR ( x *  x)).
replace (IZR (x * x) - 1) with (IZR (x * x) + (- 1)).
replace (IZR z) with (IZR z + 1 + (-1)).
apply Rplus_eq_compat_r. rewrite <- plus_IZR. apply IZR_trivial.
assumption. ring. ring.
apply IZR_trivial. ring.
rewrite <- H9. rewrite sqrtZ. rewrite minus_IZR.
replace (IZR (-x) - 1 + 1) with (IZR (-x)). lra.
ring. replace ((-x)%Z) with ((0 + (-x))%Z).
apply Z.lt_gt. apply lt_IZR. replace (0) with (IZR x + IZR(-x)).
rewrite plus_IZR. apply Rplus_lt_compat_r. apply IZR_lt.
apply Z.gt_lt. assumption. rewrite <- plus_IZR. apply IZR_trivial. ring. ring.
replace (IZR (- x)) with (IZR (0 + (-x))).
replace (0) with (IZR x + IZR (-x)). rewrite plus_IZR.
apply Rplus_le_compat_r. apply IZR_le. assumption.
rewrite <- plus_IZR. apply IZR_trivial. ring.
rewrite plus_IZR. ring. rewrite <- !mult_IZR. apply f_equal.
ring.
assert (H8 : (Z.sqrt z = Z.sqrt (z + 1))%Z).
apply zetzplusunnoncarre. assumption.
 assumption.  assumption.
rewrite H8. apply Rlt_le. assumption.
Qed.

Lemma racine_correct :
 forall (x : R) (xc : Reelc),
 0 <= x -> encadrement xc x -> encadrement (racine_reelc xc) (sqrt x).

Proof.
intros x xc H0. intro H.
unfold encadrement. intros n.
assert (H2 : (xc (2*n) >= 0)%Z). apply contraposesg_Zsgn_2 with x.
assumption. apply Rle_ge. assumption.
assert (H3 : ((0=xc (2*n))%Z)\/((0 <xc (2*n))%Z)).
apply geqZ.  assumption. inversion H3.
unfold racine_reelc. replace (Z.succ (Z.succ 0)) with (2%Z).
rewrite <- H1. rewrite Zsqrt_0. replace (0 - 1) with (-1).
replace (0 + 1) with (1).
unfold encadrement in H.
assert (H4 : IZR (xc (2*n)%Z) - 1 < x * B_powerRZ ((2*n)%Z) < IZR (xc (2*n)%Z) + 1).
apply H. rewrite <- H1 in H4. replace (0 - 1) with (-1) in H4.
replace (0 + 1) with (1) in H4.
split. apply Rlt_le_trans with (0). lra.
replace (0) with (0 * 0). apply Rmult_le_compat. lra.
lra. apply sqrt_pos. apply Rlt_le. apply Rgt_lt.
apply Bexpos. ring.
inversion H4. clear H4. clear H5. apply Rgt_lt.
assert (H7 : x < 1 * / B_powerRZ (2 * n)).
replace (x) with (x * B_powerRZ (2 * n) * / B_powerRZ (2 * n)).
apply Rmult_lt_compat_r. apply Rinv_0_lt_compat. apply Rgt_lt.
apply Bexpos. assumption. rewrite Rinv_r_simpl_l. reflexivity.
apply Rgt_not_eq. apply Bexpos.
replace (1 * / B_powerRZ (2 * n)) with (B_powerRZ (-2 * n)) in H7.
replace (1) with (/ B_powerRZ n * B_powerRZ n).
apply Rmult_gt_compat_r. apply Bexpos.
replace (/ B_powerRZ n) with (B_powerRZ (-n)). apply Rlt_gt.
replace (B_powerRZ (- n)) with (sqrt (B_powerRZ (-2 * n))).
apply sqrt_lt_1_alt. split. assumption. assumption.
replace ((-2 * n)%Z) with ((2 * (-n))%Z).
rewrite sqrtB2n. reflexivity. ring.
 unfold B_powerRZ. rewrite Rinv_powerRZ.
reflexivity. apply Bneq0.  rewrite Rmult_comm.
replace (B_powerRZ n * / B_powerRZ n) with
(1 * B_powerRZ n * / B_powerRZ n). rewrite Rinv_r_simpl_l.
reflexivity. apply Rgt_not_eq. apply Bexpos. ring.
unfold B_powerRZ.  rewrite Rinv_powerRZ. replace
(1 * powerRZ (INR B) (- (2 * n))) with (powerRZ (INR B) (- (2 * n))).
apply powerRZ_trivial. ring. ring. apply Bneq0. ring. ring.
ring. ring. ring.

 - unfold encadrement in H.
assert (H4 : IZR (xc (2*n)%Z) - 1 < x * B_powerRZ (2*n) < IZR (xc (2*n)%Z) + 1).
apply H. unfold racine_reelc.  replace ((Z.succ (Z.succ 0))) with (2%Z).
inversion H4. split.
assert (H7 : IZR (xc (2 * n)%Z) < x * B_powerRZ (2 * n) + 1).
replace (IZR (xc (2 * n)%Z)) with (IZR (xc (2 * n)%Z) - 1 + 1).
apply Rplus_lt_compat_r. assumption. ring.
assert (H8 : sqrt (IZR (xc (2 * n)%Z)) < sqrt(x * B_powerRZ (2 * n) + 1)).
apply sqrt_lt_1_alt. split. apply Rlt_le.
apply IZR_lt. apply Z.gt_lt. apply Z.lt_gt. assumption. assumption.
assert (H9 : sqrt (IZR (xc (2 * n)%Z)) + (-1) < sqrt (x * B_powerRZ (2 * n) + 1) + (-1)).
apply Rplus_lt_compat_r. assumption.
replace (sqrt (IZR (xc (2 * n)%Z)) + -1) with (sqrt (IZR (xc (2 * n)%Z)) -1) in H9.
replace (sqrt (x * B_powerRZ (2 * n) + 1) + -1) with
 (sqrt (x * B_powerRZ (2 * n) + 1) -1) in H9.
apply Rle_lt_trans with (sqrt (IZR (xc (2 * n)%Z)) - 1).
replace (IZR (Z.sqrt (xc (2 * n)%Z)) - 1) with (IZR (Z.sqrt (xc (2 * n)%Z)) + (- 1)).
replace (sqrt (IZR (xc (2 * n)%Z)) - 1) with (sqrt (IZR (xc (2 * n)%Z)) + (- 1)).
apply Rplus_le_compat_r. apply Zsqrt_sqrt. apply le_IZR. apply Rlt_le.
apply IZR_lt. apply Z.gt_lt. apply Z.lt_gt. assumption. ring. ring.
apply Rlt_le_trans with (sqrt (x * B_powerRZ (2 * n) + 1) - 1).
replace (sqrt x * B_powerRZ n) with (sqrt (x * B_powerRZ (2 * n))).
assumption. rewrite sqrt_mult_alt. rewrite sqrtB2n. reflexivity.
assumption. replace (sqrt x * B_powerRZ n) with (sqrt (x * B_powerRZ (2 * n))).
apply Rge_le. apply plusracine.
replace (0) with (0 * B_powerRZ (2 * n)). apply Rmult_ge_compat_r.
apply Rgt_ge. apply Bexpos. apply Rle_ge. assumption.
ring. rewrite sqrt_mult_alt. rewrite sqrtB2n. reflexivity. assumption.
ring. ring.
assert (H7 : sqrt (x * B_powerRZ (2 * n)) < sqrt (IZR (xc (2 * n)%Z) + 1)).
apply sqrt_lt_1_alt. split. replace (0) with (0 * B_powerRZ (2 * n)).
apply Rmult_le_compat_r. apply Rlt_le. apply Rgt_lt. apply Bexpos.
assumption. ring. assumption.
replace (sqrt (x * B_powerRZ (2 * n))) with (sqrt x * B_powerRZ n) in H7.
apply Rlt_le_trans with (sqrt (IZR (xc (2 * n)%Z) + 1)).
assumption. apply plusracineZ. assumption.
rewrite sqrt_mult_alt. rewrite sqrtB2n. reflexivity. assumption. ring.
Qed.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import Logic. Import Decidable.
Require Import
        Definitions
        Lemmas
        Infrastructure
        Soundness.

(* Lemma ptype_uniq: forall mu u A B,
 sto_ok mu ->
 pvalue u -> ptype mu u A -> ptype mu u B -> A = B.
Proof.
  introv ok pval ptyp1 ptyp2.
  inductions pval; try solve[inverts* ptyp1; inverts* ptyp2].
Qed.

Lemma TypedReduce_unique: forall P v mu r1 r2 (A: typ),
    sto_ok mu -> value v -> (exists B, typing nil P v Inf B) -> TypedReduce (v, mu) A r1 -> TypedReduce (v, mu) A r2 -> r1 = r2.
Proof.
  introv ok Val H R1 R2.
  gen r2.
  lets R1': R1.
  inductions R1; introv R2;
    try solve [inverts~ R2].
  -
  inverts~ R2.
  forwards*: ptype_uniq H0 H9. subst*.
  -
  inverts~ R2.
  forwards*: ptype_uniq H0 H9. subst*.
Qed. *)

Lemma fill_eq: forall mu E0 e0 E e1 r1 r2 mu1 mu2,
  fill E0 e0 = fill E e1 ->
  step (e0, mu) (r1,mu1) ->
  step (e1, mu) (r2,mu2) ->
  wellformed E ->
  wellformed E0 ->
  E = E0 /\ e0 = e1.
Proof.
  introv eq red1 red2 wf1 wf2. gen mu mu1 mu2 E e0 e1 r1 r2.
  inductions E0; unfold fill in *;  intros;
  try solve[inductions E; unfold fill in *; inverts* eq;
  inverts wf1;
  forwards*: step_not_value red1];
  try solve[inductions E; unfold fill in *; inverts* eq];
  try solve[inductions E; unfold fill in *; inverts* eq;
  inverts wf2;
  forwards*: step_not_value red2].
Qed.

Lemma typing_chk: forall E e P A,
 typing E P e Inf A ->
 typing E P e Chk A.
Proof.
  introv typ.
  eapply typ_eq; eauto.
Qed.

Lemma fill_chk: forall F e dir P A,
 typing empty P (fill F e) dir A ->
 exists B, typing empty P e Chk B.
Proof.
  introv typ.
  destruct F; unfold fill in *;inverts* typ; try solve[inverts* H].
Qed.

Theorem step_unique: forall P mu A e r1 r2,
   P |== mu -> typing nil P e Chk A -> step (e, mu) r1 -> step (e, mu) r2 -> r1 = r2.
Proof.
  introv well Typ Red1.
  gen P A r2.
  lets Red1' : Red1.
  inductions Red1;
    introv well Typ Red2.
  - (* fill *)
    inverts* Red2;
    try solve[destruct F; unfold fill in H0; inverts* H0];
    try solve[
    forwards*: typing_regular Typ;destructs~ H1;destruct F; unfold fill in H0; inverts* H0;
    inverts* H4;
    inverts* H8;
    forwards: step_not_value Red1; auto; inverts H0];
    try solve[
    forwards*: typing_regular Typ;destructs~ H1;destruct F; unfold fill in H0; inverts* H0;
    inverts* H2;
    inverts* H6;
    forwards: step_not_value Red1; auto; inverts H0];
    try solve[ destruct F; unfold fill in *; inverts* H0;
    forwards: step_not_value Red1; auto; inverts* H0];
    try solve[destruct F; unfold fill in H5; inverts* H5].
    + forwards*: fill_eq H0.
      destruct H1. subst. inverts Typ.
      forwards*: fill_chk H1. inverts* H3.
      forwards*: IHRed1 Red1 H4. congruence.
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H2; inverts* H2;
    forwards: step_not_value H6; auto; inverts H2];
    try solve[inverts H7].
  -
   inverts* Red2;
    try solve[destruct F; unfold fill in H1; inverts* H1;
    forwards: step_not_value H5; auto; inverts H1];
    try solve[inverts H7].
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H0; inverts H0];
    try solve[destruct F; unfold fill in *; inverts H0];
    try solve[inverts* H8];
    try solve[inverts* H8];
    try solve[inverts* H3];
    try solve[
      destruct F; unfold fill in *; inverts H0;
      forwards*: step_not_value H4; auto; inverts H; auto].
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H0; inverts H0];
    try solve[destruct F; unfold fill in *; inverts H0];
    try solve[inverts* H8];
    try solve[inverts* H8];
    try solve[inverts* H3];
    try solve[
      destruct F; unfold fill in *; inverts H1;
      forwards*: step_not_value H5; auto; inverts H; auto].
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H0; inverts H0];
    try solve[destruct F; unfold fill in *; inverts H0];
    try solve[inverts* H4];
    try solve[
      destruct F; unfold fill in *; inverts H1;
      forwards: step_not_value H5; auto; inverts H1].
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H0; inverts H0];
    try solve[destruct F; unfold fill in *; inverts H0];
    try solve[inverts* H3];
    try solve[
      destruct F; unfold fill in *; inverts H0;
      forwards: step_not_value H4; auto; inverts H0].
Qed.


Require Import Eqdep_dec.
From mathcomp Require Import all_ssreflect.
Require Import PArith core_defs.

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

Open Scope positive_scope.

Inductive expr :=
| Var : nat -> expr
| IfThenElse : bool_expr -> expr -> expr -> expr
| Plus : expr -> expr -> expr
| Minus : expr -> expr -> expr
with bool_expr :=
| True : bool_expr
| False : bool_expr
| And : bool_expr -> bool_expr -> bool_expr
| Or : bool_expr -> bool_expr -> bool_expr
| Equal : expr -> expr -> bool_expr
| Lt : expr -> expr -> bool_expr.

Section Ind.

Scheme expr_ind_mut := Induction for expr Sort Prop
  with bool_expr_ind_mut := Induction for bool_expr Sort Prop.

Combined Scheme expr_combined_ind from expr_ind_mut, bool_expr_ind_mut.

End Ind.

Module AUX.

Definition etag (e : expr) :=
  match e with
  | Var _            => 1
  | IfThenElse _ _ _ => 2
  | Plus _ _         => 3
  | Minus _ _        => 4
  end.

Definition btag (b : bool_expr) :=
  match b with
  | True      => 1
  | False     => 2
  | And _ _   => 3
  | Or _ _    => 4
  | Equal _ _ => 5
  | Lt _ _    => 6
  end.

Definition efields_t (p:positive) : Type :=
  match p with
  | 1 => nat
  | 2 => bool_expr * expr * expr
  | 3 | 4 => expr * expr
  | _ => unit
  end.

Definition bfields_t (p:positive) : Type :=
  match p with
  | 3 | 4 => bool_expr * bool_expr
  | 5 | 6 => expr * expr
  | _ => unit
  end.

Definition efields (e:expr) : efields_t (etag e) :=
  match e with
  | Var n => n
  | IfThenElse b e1 e2 => (b, e1, e2)
  | Plus e1 e2 | Minus e1 e2 => (e1, e2)
  end.

Definition bfields (b:bool_expr) : bfields_t (btag b) :=
  match b with
  | True | False => tt
  | And b1 b2 | Or b1 b2 => (b1, b2)
  | Equal e1 e2 | Lt e1 e2 => (e1, e2)
  end.

Definition econstruct (p:positive) : efields_t p -> option expr :=
  match p with
  | 1 => fun n => Some (Var n)
  | 2 => fun '(b, e1, e2) => Some (IfThenElse b e1 e2)
  | 3 => fun '(e1, e2) => Some (Plus e1 e2)
  | 4 => fun '(e1, e2) => Some (Minus e1 e2)
  | _ => fun _ => None
  end.

Lemma econstructP e : econstruct (efields e) = Some e.
Proof. by case: e. Qed.

Definition bconstruct (p:positive) : bfields_t p -> option bool_expr :=
  match p with
  | 1 => fun _ => Some True
  | 2 => fun _ => Some False
  | 3 => fun '(b1, b2) => Some (And b1 b2)
  | 4 => fun '(b1, b2) => Some (Or b1 b2)
  | 5 => fun '(e1, e2) => Some (Equal e1 e2)
  | 6 => fun '(e1, e2) => Some (Lt e1 e2)
  | _ => fun _ => None
  end.

Lemma bconstructP b : bconstruct (bfields b) = Some b.
Proof. by case: b. Qed.

End AUX.

Local Instance expr_obj : @obj expr :=
  {| tag        := AUX.etag
   ; fields_t   := AUX.efields_t
   ; fields     := AUX.efields
   ; construct  := AUX.econstruct
   ; constructP := AUX.econstructP |}.

Local Instance bool_expr_obj : @obj bool_expr :=
  {| tag        := AUX.btag
   ; fields_t   := AUX.bfields_t
   ; fields     := AUX.bfields
   ; construct  := AUX.bconstruct
   ; constructP := AUX.bconstructP |}.

Section Fields.

Context (eqb_e : expr -> expr -> bool) (eqb_b : bool_expr -> bool_expr -> bool).

Definition eqb_fields_e (p:positive) : fields_t (obj:=expr_obj) p -> fields_t (obj:=expr_obj) p -> bool :=
  match p with
  | 2 => fun '(b1, e11, e12) '(b2, e21, e22) => [&& eqb_b b1 b2, eqb_e e11 e21 & eqb_e e12 e22]
  | 3 | 4 => fun '(e11, e12) '(e21, e22) => eqb_e e11 e21 && eqb_e e12 e22
  | _ => eq_op
  end.

Definition eqb_fields_b (p:positive) : fields_t (obj:=bool_expr_obj) p -> fields_t (obj:=bool_expr_obj) p -> bool :=
  match p with
  | 3 | 4 => fun '(b11, b12) '(b21, b22) => eqb_b b11 b21 && eqb_b b12 b22
  | 5 | 6 => fun '(e11, e12) '(e21, e22) => eqb_e e11 e21 && eqb_e e12 e22
  | _ => eq_op
  end.

End Fields.

Fixpoint eqb_e (e1 e2 : expr) :=
  match e1 with
  | Var n => eqb_body (eqb_fields_e eqb_e eqb_b) (t1:=1) n e2
  | IfThenElse b1 e11 e12 => eqb_body (eqb_fields_e eqb_e eqb_b) (t1:=2) (b1,e11,e12) e2
  | Plus e11 e12 => eqb_body (eqb_fields_e eqb_e eqb_b) (t1:=3) (e11,e12) e2
  | Minus e11 e12 => eqb_body (eqb_fields_e eqb_e eqb_b) (t1:=4) (e11,e12) e2
  end
with eqb_b (b1 b2 : bool_expr) :=
  match b1 with
  | True => eqb_body (eqb_fields_b eqb_e eqb_b) (t1:=1) tt b2
  | False => eqb_body (eqb_fields_b eqb_e eqb_b) (t1:=2) tt b2
  | And b11 b12 => eqb_body (eqb_fields_b eqb_e eqb_b) (t1:=3) (b11,b12) b2
  | Or b11 b12 => eqb_body (eqb_fields_b eqb_e eqb_b) (t1:=4) (b11,b12) b2
  | Equal e1 e2 => eqb_body (eqb_fields_b eqb_e eqb_b) (t1:=5) (e1,e2) b2
  | Lt e1 e2 => eqb_body (eqb_fields_b eqb_e eqb_b) (t1:=6) (e1,e2) b2
  end.

Lemma eqb_e_correct_on_Var n : eqb_correct_on eqb_e (Var n).
Proof.
  rewrite /eqb_correct_on /=.
  apply (@eqb_body_correct _ expr_obj (eqb_fields_e eqb_e eqb_b) (Var n)).
  by rewrite /eqb_fields_correct_on /= => ? /eqP <-.
Qed.

Lemma eqb_e_correct_on_IfThenElse b e1 e2 :
  eqb_correct_on eqb_b b ->
  eqb_correct_on eqb_e e1 ->
  eqb_correct_on eqb_e e2 ->
  eqb_correct_on eqb_e (IfThenElse b e1 e2).
Proof.
  rewrite /eqb_correct_on /=.
  move=> hb he1 he2;
    apply (@eqb_body_correct _ expr_obj (eqb_fields_e eqb_e eqb_b) (IfThenElse b e1 e2)).
  by rewrite /eqb_fields_correct_on /= => -[[??]?] /and3P [/hb <- /he1 <- /he2 <-].
Qed.

Lemma eqb_e_correct_on_Plus e1 e2 :
  eqb_correct_on eqb_e e1 ->
  eqb_correct_on eqb_e e2 ->
  eqb_correct_on eqb_e (Plus e1 e2).
Proof.
  rewrite /eqb_correct_on /=.
  move=> he1 he2;
    apply (@eqb_body_correct _ expr_obj (eqb_fields_e eqb_e eqb_b) (Plus e1 e2)).
  by rewrite /eqb_fields_correct_on /= => -[??] /andP [/he1 <- /he2 <-].
Qed.

Lemma eqb_e_correct_on_Minus e1 e2 :
  eqb_correct_on eqb_e e1 ->
  eqb_correct_on eqb_e e2 ->
  eqb_correct_on eqb_e (Minus e1 e2).
Proof.
  rewrite /eqb_correct_on /=.
  move=> he1 he2;
    apply (@eqb_body_correct _ expr_obj (eqb_fields_e eqb_e eqb_b) (Minus e1 e2)).
  by rewrite /eqb_fields_correct_on /= => -[??] /andP [/he1 <- /he2 <-].
Qed.

Lemma eqb_b_correct_on_True :
  eqb_correct_on eqb_b True.
Proof.
  rewrite /eqb_correct_on /=.
  by apply (@eqb_body_correct _ bool_expr_obj (eqb_fields_b eqb_e eqb_b) True).
Qed.

Lemma eqb_b_correct_on_False :
  eqb_correct_on eqb_b False.
Proof.
  rewrite /eqb_correct_on /=.
  by apply (@eqb_body_correct _ bool_expr_obj (eqb_fields_b eqb_e eqb_b) False).
Qed.

Lemma eqb_b_correct_on_And b1 b2 :
  eqb_correct_on eqb_b b1 ->
  eqb_correct_on eqb_b b2 ->
  eqb_correct_on eqb_b (And b1 b2).
Proof.
  rewrite /eqb_correct_on /=.
  move=> hb1 hb2;
    apply (@eqb_body_correct _ bool_expr_obj (eqb_fields_b eqb_e eqb_b) (And b1 b2)).
  by rewrite /eqb_fields_correct_on /= => -[??] /andP [/hb1 <- /hb2 <-].
Qed.

Lemma eqb_b_correct_on_Or b1 b2 :
  eqb_correct_on eqb_b b1 ->
  eqb_correct_on eqb_b b2 ->
  eqb_correct_on eqb_b (Or b1 b2).
Proof.
  rewrite /eqb_correct_on /=.
  move=> hb1 hb2;
    apply (@eqb_body_correct _ bool_expr_obj (eqb_fields_b eqb_e eqb_b) (Or b1 b2)).
  by rewrite /eqb_fields_correct_on /= => -[??] /andP [/hb1 <- /hb2 <-].
Qed.

Lemma eqb_b_correct_on_Equal e1 e2 :
  eqb_correct_on eqb_e e1 ->
  eqb_correct_on eqb_e e2 ->
  eqb_correct_on eqb_b (Equal e1 e2).
Proof.
  rewrite /eqb_correct_on /=.
  move=> he1 he2;
    apply (@eqb_body_correct _ bool_expr_obj (eqb_fields_b eqb_e eqb_b) (Equal e1 e2)).
  by rewrite /eqb_fields_correct_on /= => -[??] /andP [/he1 <- /he2 <-].
Qed.

Lemma eqb_b_correct_on_Lt e1 e2 :
  eqb_correct_on eqb_e e1 ->
  eqb_correct_on eqb_e e2 ->
  eqb_correct_on eqb_b (Lt e1 e2).
Proof.
  rewrite /eqb_correct_on /=.
  move=> he1 he2;
    apply (@eqb_body_correct _ bool_expr_obj (eqb_fields_b eqb_e eqb_b) (Lt e1 e2)).
  by rewrite /eqb_fields_correct_on /= => -[??] /andP [/he1 <- /he2 <-].
Qed.

Lemma eqb_correct :
  (forall e1 e2, eqb_e e1 e2 -> e1 = e2)
  /\
  (forall b1 b2, eqb_b b1 b2 -> b1 = b2).
Proof.
  apply expr_combined_ind => *.
  + by apply eqb_e_correct_on_Var.
  + by apply eqb_e_correct_on_IfThenElse.
  + by apply eqb_e_correct_on_Plus.
  + by apply eqb_e_correct_on_Minus.
  + by apply eqb_b_correct_on_True.
  + by apply eqb_b_correct_on_False.
  + by apply eqb_b_correct_on_And.
  + by apply eqb_b_correct_on_Or.
  + by apply eqb_b_correct_on_Equal.
  + by apply eqb_b_correct_on_Lt.
Qed.

Lemma eqb_e_correct e1 e2 : eqb_e e1 e2 -> e1 = e2.
Proof. by have [h _] := eqb_correct; apply h. Qed.

Lemma eqb_b_correct b1 b2 : eqb_b b1 b2 -> b1 = b2.
Proof. by have [_ h] := eqb_correct; apply h. Qed.

Lemma eqb_e_refl_on_Var n : eqb_refl_on eqb_e (Var n).
Proof.
  apply (@eqb_body_refl _ expr_obj (eqb_fields_e eqb_e eqb_b) (Var n)).
  by apply eqxx.
Qed.

Lemma eqb_e_refl_on_IfThenElse b e1 e2 :
  eqb_refl_on eqb_b b ->
  eqb_refl_on eqb_e e1 ->
  eqb_refl_on eqb_e e2 ->
  eqb_refl_on eqb_e (IfThenElse b e1 e2).
Proof.
  move=> hb he1 he2.
  apply (@eqb_body_refl _ expr_obj (eqb_fields_e eqb_e eqb_b) (IfThenElse b e1 e2)).
  by apply /and3P.
Qed.

Lemma eqb_e_refl_on_Plus e1 e2 :
  eqb_refl_on eqb_e e1 ->
  eqb_refl_on eqb_e e2 ->
  eqb_refl_on eqb_e (Plus e1 e2).
Proof.
  move=> he1 he2.
  apply (@eqb_body_refl _ expr_obj (eqb_fields_e eqb_e eqb_b) (Plus e1 e2)).
  by apply /andP.
Qed.

Lemma eqb_e_refl_on_Minus e1 e2 :
  eqb_refl_on eqb_e e1 ->
  eqb_refl_on eqb_e e2 ->
  eqb_refl_on eqb_e (Minus e1 e2).
Proof.
  move=> he1 he2.
  apply (@eqb_body_refl _ expr_obj (eqb_fields_e eqb_e eqb_b) (Minus e1 e2)).
  by apply /andP.
Qed.

Lemma eqb_b_refl_on_True :
  eqb_refl_on eqb_b True.
Proof. done. Qed.

Lemma eqb_b_refl_on_False :
  eqb_refl_on eqb_b False.
Proof. done. Qed.

Lemma eqb_b_refl_on_And b1 b2 :
  eqb_refl_on eqb_b b1 ->
  eqb_refl_on eqb_b b2 ->
  eqb_refl_on eqb_b (And b1 b2).
Proof.
  move=> hb1 hb2.
  apply (@eqb_body_refl _ bool_expr_obj (eqb_fields_b eqb_e eqb_b) (And b1 b2)).
  by apply /andP.
Qed.

Lemma eqb_b_refl_on_Or b1 b2 :
  eqb_refl_on eqb_b b1 ->
  eqb_refl_on eqb_b b2 ->
  eqb_refl_on eqb_b (Or b1 b2).
Proof.
  move=> hb1 hb2.
  apply (@eqb_body_refl _ bool_expr_obj (eqb_fields_b eqb_e eqb_b) (Or b1 b2)).
  by apply /andP.
Qed.

Lemma eqb_b_refl_on_Equal e1 e2 :
  eqb_refl_on eqb_e e1 ->
  eqb_refl_on eqb_e e2 ->
  eqb_refl_on eqb_b (Equal e1 e2).
Proof.
  move=> he1 he2.
  apply (@eqb_body_refl _ bool_expr_obj (eqb_fields_b eqb_e eqb_b) (Equal e1 e2)).
  by apply /andP.
Qed.

Lemma eqb_b_refl_on_Lt e1 e2 :
  eqb_refl_on eqb_e e1 ->
  eqb_refl_on eqb_e e2 ->
  eqb_refl_on eqb_b (Lt e1 e2).
Proof.
  move=> he1 he2.
  (*
  apply (@eqb_body_refl _ expr_obj (eqb_fields_e eqb_e eqb_b) (Minus e1 e2))
  works ??
  *)
  apply (@eqb_body_refl _ bool_expr_obj (eqb_fields_b eqb_e eqb_b) (Lt e1 e2)).
  by apply /andP.
Qed.

Lemma eqb_refl :
  (forall e, eqb_e e e) /\ (forall b, eqb_b b b).
Proof.
  apply expr_combined_ind; move=> *.
  + by apply eqb_e_refl_on_Var.
  + by apply eqb_e_refl_on_IfThenElse.
  + by apply eqb_e_refl_on_Plus.
  + by apply eqb_e_refl_on_Minus.
  + by apply eqb_b_refl_on_True.
  + by apply eqb_b_refl_on_False.
  + by apply eqb_b_refl_on_And.
  + by apply eqb_b_refl_on_Or.
  + by apply eqb_b_refl_on_Equal.
  + by apply eqb_b_refl_on_Lt.
Qed.

Lemma eqb_e_refl e : eqb_e e e.
Proof. by have [h _] := eqb_refl; apply h. Qed.

Lemma eqb_b_refl b : eqb_b b b.
Proof. by have [_ h] := eqb_refl; apply h. Qed.

Lemma eqb_eP e1 e2 : reflect (e1 = e2) (eqb_e e1 e2).
Proof. apply (iffP idP);[ apply eqb_e_correct | move=> ->; apply eqb_e_refl]. Qed.

Lemma eqb_bP b1 b2 : reflect (b1 = b2) (eqb_b b1 b2).
Proof. apply (iffP idP);[ apply eqb_b_correct | move=> ->; apply eqb_b_refl]. Qed.


Require Import NArith.
Require Import GeoCoq.Utils.sets.
Require Import GeoCoq.Meta_theory.Models.tarski_to_cong_theory.
Require Import GeoCoq.Tactics.Coinc.CongR.

Ltac add_to_distinct_list x xs :=
  match xs with
    | nil     => constr:(x::xs)
    | x::_    => fail 1
    | ?y::?ys => let zs := add_to_distinct_list x ys in constr:(y::zs)
  end.

Ltac collect_points_list Tpoint xs :=
  match goal with
    | N : Tpoint |- _ => let ys := add_to_distinct_list N xs in
                           collect_points_list Tpoint ys
    | _               => xs
  end.

Ltac collect_points Tpoint := collect_points_list Tpoint (@nil Tpoint).

Ltac number_aux Tpoint lvar cpt :=
  match constr:(lvar) with
    | nil          => constr:(@nil (prodT Tpoint positive))
    | cons ?H ?T => let scpt := eval vm_compute in (Pos.succ cpt) in
                    let lvar2 := number_aux Tpoint T scpt in
                      constr:(cons (@pairT  Tpoint positive H cpt) lvar2)
  end.

Ltac number Tpoint lvar := number_aux Tpoint lvar (1%positive).

Ltac build_numbered_points_list Tpoint := let lvar := collect_points Tpoint in number Tpoint lvar.

Ltac List_assoc Tpoint elt lst :=
  match constr:(lst) with
    | nil => fail
    | (cons (@pairT Tpoint positive ?X1 ?X2) ?X3) =>
      match constr:(elt = X1) with
        | (?X1 = ?X1) => constr:(X2)
        | _ => List_assoc Tpoint elt X3
      end
  end.

Definition Tagged P : Prop := P.

Lemma PropToTagged : forall P : Prop, P -> Tagged P.
Proof. trivial. Qed.

Ltac assert_ss_ok Tpoint Cong lvar :=
  repeat
  match goal with
    | HCong : Cong ?A ?B ?C ?D, HOK : ss_ok ?SS ?Interp |- _ =>
        let pa := List_assoc Tpoint A lvar in
        let pb := List_assoc Tpoint B lvar in
        let pc := List_assoc Tpoint C lvar in
        let pd := List_assoc Tpoint D lvar in
         apply PropToTagged in HCong;
         apply (collect_congs A B C D HCong pa pb pc pd SS Interp) in HOK; try reflexivity
  end.

Ltac Cong_refl Tpoint Cong :=
  match goal with
    | Default : Tpoint |- Cong ?A ?B ?C ?D =>
        let lvar := build_numbered_points_list Tpoint in
        let pa := List_assoc Tpoint A lvar in
        let pb := List_assoc Tpoint B lvar in
        let pc := List_assoc Tpoint C lvar in
        let pd := List_assoc Tpoint D lvar in
        let c := ((vm_compute;reflexivity) || fail 2 "Can not be deduced") in
        let HSS := fresh in
          assert (HSS := @ss_ok_empty Tpoint Cong (interp lvar Default)); assert_ss_ok Tpoint Cong lvar;
          match goal with
            | HOKSS : ss_ok ?SS ?Interp |- _ =>
              apply (test_cong_ok SS Interp pa pb pc pd HOKSS); c
          end
  end.


Require Import Coq.Strings.String
        Coq.omega.Omega
        Coq.Lists.List
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Coq.Bool.Bool
        Fiat.Common.ilist2
        Fiat.Computation
        Fiat.ADT
        Fiat.ADTRefinement
        Fiat.ADTNotation
        Fiat.QueryStructure.Specification.Representation.QueryStructureSchema
        Fiat.QueryStructure.Specification.Operations.Query
        Fiat.QueryStructure.Specification.Operations.Insert
        Fiat.QueryStructure.Specification.Representation.QueryStructure
        Fiat.ADTRefinement.BuildADTRefinements
        Fiat.Common.DecideableEnsembles
        Fiat.Common.Ensembles.IndexedEnsembles
        Fiat.Common.Ensembles.EnsembleListEquivalence
        Fiat.QueryStructure.Implementation.Operations.General.QueryRefinements
        Fiat.QueryStructure.Implementation.Operations.General.InsertRefinements
        Fiat.QueryStructure.Implementation.Operations.General.QueryStructureRefinements
        Fiat.QueryStructure.Implementation.Constraints.ConstraintChecksRefinements.

Fixpoint Check_List_Prop {A}
         (cond : A -> bool)
         (l : list A)
: bool :=
  match l with
    | [] => true
    | a :: l' => if (cond a) then
                   Check_List_Prop cond l'
                 else false
  end.

Lemma Check_List_Prop_dec {A} :
  forall (cond : A -> bool)
         (P : Ensemble A)
         (l : list A),
    (forall a, cond a = true <-> P a)
    -> (Check_List_Prop cond l = true <->
        forall a', List.In a' l -> P a').
Proof.
  split; induction l; simpl; intros; intuition; subst.
  generalize (H a'); find_if_inside; intuition; eauto.
  generalize (H a'); find_if_inside; intuition; eauto.
  generalize (H a); find_if_inside; intuition; eauto.
Qed.

Lemma Check_List_Prop_dec' {A} :
  forall (cond : A -> bool)
         (P : Ensemble A)
         (l : list A),
    (forall a, cond a = true <-> P a)
    -> (Check_List_Prop cond l = false <->
        (exists a', List.In a' l /\ ~ P a')).
Proof.
  split; induction l; simpl; intros; intuition; subst.
  generalize (H a); find_if_inside; intuition; eauto.
  destruct_ex; intuition; intuition; eauto.
  eexists; intuition.
  destruct_ex; intuition.
  generalize (H a); find_if_inside; intuition; eauto.
  destruct_ex; subst; intuition; eauto.
  subst; intuition.
Qed.

Definition Check_Attr_Depend
           {h}
           (attrlist attrlist' : list (Attributes h))
           (attr_eq_dec : List_Query_eq (map (Domain h) attrlist))
           (attr_eq_dec' : List_Query_eq (map (Domain h) attrlist'))
           (tup : RawTuple)
           (l : list RawTuple) :=
  Check_List_Prop (fun tup' => orb (negb (Tuple_Agree_eq _ attr_eq_dec' tup tup'))
                                   (Tuple_Agree_eq _ attr_eq_dec tup tup')) l.

Lemma Check_Attr_Depend_dec
: forall (h : RawHeading)
         (attrlist attrlist' : list (Attributes h))
         (attr_eq_dec : List_Query_eq (map (Domain h) attrlist))
         (attr_eq_dec' : List_Query_eq (map (Domain h) attrlist'))
         (tup : RawTuple)
         (l : list RawTuple),
    Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l = true ->
    (forall tup', List.In tup' l
                          -> tupleAgree tup tup' attrlist'
                          -> tupleAgree tup tup' attrlist).
Proof.
  unfold Check_Attr_Depend; intros.
  eapply Check_List_Prop_dec  with
  (P := fun tup' => tupleAgree tup tup' attrlist'
                            -> tupleAgree tup tup' attrlist) in H; eauto.
  intuition.
  let H := match goal with H : tupleAgree _ _ _ |- _ => constr:(H) end in
  apply (proj1 (Tuple_Agree_eq_dec _ _ _ _ _ )) in H;
    rewrite H in * ; simpl in *; eapply Tuple_Agree_eq_dec; eauto.
  destruct (Tuple_Agree_dec _ _ attr_eq_dec tup a); auto;
  [ apply (proj1 (Tuple_Agree_eq_dec _ _ _ _ _ )) in t; rewrite t, orb_true_r
  | apply (proj1 (Tuple_Agree_eq_dec' _ _ _ _ _ )) in n; rewrite n, orb_false_r]; auto.
  destruct (Tuple_Agree_dec _ _ attr_eq_dec' tup a); auto;
  [ apply (proj1 (Tuple_Agree_eq_dec _ _ _ _ _ )) in t; rewrite t
  | apply (proj1 (Tuple_Agree_eq_dec' _ _ _ _ _ )) in n0; rewrite n0]; auto.
  elimtype False; eapply (Tuple_Agree_eq_dec' _ _ attr_eq_dec); eauto.
  match goal with
    | [ H : _ |- _ ]
      => apply H; eapply Tuple_Agree_eq_dec; solve [ eauto ]
  end.
Qed.

Lemma Check_Attr_Depend_dec'
: forall (h : RawHeading)
         (attrlist attrlist' : list (Attributes h))
         (attr_eq_dec : List_Query_eq (map (Domain h) attrlist))
         (attr_eq_dec' : List_Query_eq (map (Domain h) attrlist'))
         (tup : RawTuple)
         (l : list RawTuple),
    Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l = false ->
    ~ (forall tup' : RawTuple, List.In tup' l
                            -> tupleAgree tup tup' attrlist'
                            -> tupleAgree tup tup' attrlist).
Proof.
  unfold Check_Attr_Depend; intros.
  eapply Check_List_Prop_dec' with
  (P := fun tup' : RawTuple =>
          ~ tupleAgree tup tup' attrlist' \/
          tupleAgree tup tup' attrlist) in H; eauto.
  destruct_ex; intuition; eauto.
  intros; destruct (Tuple_Agree_dec _ _ attr_eq_dec' tup a); auto;
  [ apply (proj1 (Tuple_Agree_eq_dec _ _ _ _ _ )) in t; rewrite t |
    apply (proj1 (Tuple_Agree_eq_dec' _ _ _ _ _ )) in n; rewrite n];
  simpl; intuition.
  right;   eapply Tuple_Agree_eq_dec; eauto.
  elimtype False;
    match goal with
      | [ H : _ |- _ ] => apply H; eapply Tuple_Agree_eq_dec; eauto
    end.
  eapply Tuple_Agree_eq_dec; eauto.
  left; eapply Tuple_Agree_eq_dec'; eauto.
Qed.

Lemma refine_unused_key_check
: forall (h : RawHeading)
         (attrlist attrlist' : list (Attributes h))
         (attr_eq_dec : List_Query_eq (map (Domain h) attrlist))
         (attr_eq_dec' : List_Query_eq (map (Domain h) attrlist'))
         (tup : RawTuple)
         (rel : Ensemble IndexedRawTuple)
         (l : list RawTuple),
    EnsembleIndexedListEquivalence  rel l
    -> refine {b | decides b
                           (forall tup' : IndexedRawTuple,
                              rel tup' ->
                              tupleAgree tup (indexedElement tup') attrlist' ->
                              tupleAgree tup (indexedElement tup') attrlist)}
              (ret (Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l)).
Proof.
  intros.
  unfold refine; intros;  computes_to_inv;
  subst; computes_to_econstructor.
  case_eq (Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l); simpl; intros.
  eapply Check_Attr_Depend_dec; try apply H; eauto.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  eapply in_map; eapply equiv_l_l'; eapply H1.
  unfold not; intros.
  eapply (Check_Attr_Depend_dec' attr_eq_dec attr_eq_dec'); eauto.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  intros.
  apply (in_map_iff indexedRawTuple) in H; destruct_ex;
  intuition; subst.
  intros; eapply H1; eauto.
  eapply equiv_l_l'; eauto.
Qed.

Lemma refine_unused_key_check'
: forall (h : RawHeading)
         (attrlist attrlist' : list (Attributes h))
         (attr_eq_dec : List_Query_eq (map (Domain h) attrlist))
         (attr_eq_dec' : List_Query_eq (map (Domain h) attrlist'))
         (tup : RawTuple)
         (rel : Ensemble IndexedRawTuple)
         (l : list RawTuple),
    EnsembleIndexedListEquivalence  rel l
    -> refine {b | decides b
                           (forall tup' : IndexedRawTuple,
                              rel tup' ->
                              tupleAgree (indexedElement tup') tup attrlist' ->
                              tupleAgree (indexedElement tup') tup attrlist)}
              (ret (Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l)).
Proof.
  intros.
  unfold refine; intros;  computes_to_inv;
  subst; computes_to_econstructor.
  case_eq (Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l); simpl; intros.
  unfold tupleAgree in *; intros; apply sym_eq.
  eapply (Check_Attr_Depend_dec _ attr_eq_dec attr_eq_dec'); unfold tupleAgree;
  intros; try apply H; try rewrite H2; eauto.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  eapply in_map; eapply equiv_l_l'; eapply H1.
  unfold not; intros.
  eapply (Check_Attr_Depend_dec' attr_eq_dec attr_eq_dec'); eauto.
  unfold tupleAgree in *; intros.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  apply (in_map_iff indexedRawTuple) in H2; destruct_ex; intuition;
  subst.
  apply sym_eq; apply H1; try eapply H; eauto.
  eapply equiv_l_l'; eauto.
  intros; rewrite H3; eauto.
Qed.

Fixpoint Check_List_Ex_Prop {A}
         (cond : A -> bool)
         (l : list A)
: bool :=
  match l with
    | [] => false
    | a :: l' => if (cond a) then
                   true else
                   Check_List_Ex_Prop cond l'
  end.

Lemma Check_List_Ex_Prop_dec {A} :
  forall (cond : A -> bool)
         (P : Ensemble A)
         (l : list A),
    (forall a, cond a = true <-> P a)
    -> (Check_List_Ex_Prop cond l = true ->
        exists a', List.In a' l /\ P a').
Proof.
  induction l; simpl; intros; intuition; subst.
  generalize (H a); find_if_inside; intuition; eauto.
  destruct_ex; intuition; eauto.
Qed.

Lemma Check_List_Ex_Prop_dec' {A} :
  forall (cond : A -> bool)
         (P : Ensemble A)
         (l : list A),
    (forall a, cond a = true <-> P a)
    -> (Check_List_Ex_Prop cond l = false ->
        ~ exists a', List.In a' l /\ P a').
Proof.
  induction l; simpl; intros; intuition; subst.
  destruct_ex; intuition.
  destruct_ex; intuition; subst; eauto;
  generalize (H x); find_if_inside; intuition; eauto.
Qed.

Lemma refine_foreign_key_check
      (h : RawHeading)
      (rel : Ensemble IndexedRawTuple)
      (l : list RawTuple)
      (P : Ensemble RawTuple)
      (P_dec : DecideableEnsemble P)
: EnsembleIndexedListEquivalence rel l
    -> refine {b  |
               decides b
                       (exists tup' : @IndexedRawTuple h,
                          rel tup' /\
                          P (indexedElement tup'))}
              (ret (Check_List_Ex_Prop (DecideableEnsembles.dec) l)).
Proof.
  intros.
  unfold refine; intros;  computes_to_inv;
  subst; computes_to_econstructor.
  case_eq (Check_List_Ex_Prop DecideableEnsembles.dec l); simpl; intros.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  destruct (Check_List_Ex_Prop_dec DecideableEnsembles.dec P _ dec_decides_P H0);
    intuition.
  apply in_map_iff in H1; destruct_ex; intuition; subst.
  eexists; intuition; eauto; eapply equiv_l_l'; eauto.
  unfold not; intros; eapply Check_List_Ex_Prop_dec';
  eauto using dec_decides_P.
  destruct_ex; intuition; eexists; intuition; try apply H; eauto.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  eapply in_map; eapply equiv_l_l'; unfold In; eauto.
Qed.

Add Parametric Morphism {A: Type} (b : bool):
  (If_Then_Else b)
    with signature (
      @refine A ==> @refine A ==> refine)
      as refine_refine_if.
Proof.
  unfold refine, If_Then_Else; intros.
  destruct b; eauto.
Qed.

Lemma refine_list_insert_in_other_table :
  forall (db_schema : QueryStructureSchema) (qs : UnConstrQueryStructure db_schema)
         index1 index2 (store : list RawTuple),
    EnsembleIndexedListEquivalence (GetUnConstrRelation qs index2) store ->
    index1 <> index2 ->
    forall inserted : @IndexedRawTuple _,
      EnsembleIndexedListEquivalence
        (GetUnConstrRelation
           (UpdateUnConstrRelation qs index1
                                   (EnsembleInsert inserted (GetUnConstrRelation qs index1))) index2)
        (store).
Proof.
  intros; rewrite get_update_unconstr_neq; eauto.
Qed.

Ltac refine_list_insert_in_other_table :=
  match goal with
    | [ |- appcontext [
               EnsembleIndexedListEquivalence
                 (GetUnConstrRelation
                    (UpdateUnConstrRelation ?qs ?index1
                                            (EnsembleInsert ?inserted
                                                            (GetUnConstrRelation ?qs ?index1)))
                    ?index2) ] ] => apply (@refine_list_insert_in_other_table _ qs index1 index2);
                                   [ eauto | intuition discriminate ]
  end.

Lemma ImplementListInsert_eq qsSchema Ridx
      (tup : RawTuple)
      (or : UnConstrQueryStructure qsSchema)
      (nr : list (RawTuple))
      (bound : nat)
:
  EnsembleIndexedListEquivalence (GetUnConstrRelation or Ridx) nr
  -> (UnConstrFreshIdx (GetUnConstrRelation or Ridx) bound)
  -> refine
       {a |
        EnsembleIndexedListEquivalence
          (GetUnConstrRelation
             (@UpdateUnConstrRelation qsSchema or Ridx
                                     (EnsembleInsert {| elementIndex := bound;
                                                        indexedElement := tup|}
                                                     (GetUnConstrRelation or Ridx))) Ridx) a}
       (ret (tup :: nr)).
Proof.
  unfold refine; intros;  computes_to_inv; subst; computes_to_constructor.
  unfold GetUnConstrRelation, UpdateUnConstrRelation in *.
  rewrite ith_replace2_Index_eq.
  unfold EnsembleInsert, In, EnsembleIndexedListEquivalence, UnConstrFreshIdx in *;
    intuition.
  exists (S bound); unfold In in *; destruct_ex; subst; simpl.
  intros; intuition; subst.
  simpl. omega.
  destruct H2 as [l' [l'_eq [equiv_l' NoDup_l'] ] ].
    econstructor 1 with ({| elementIndex := bound;
                            indexedElement := tup|} :: l'); split; eauto.
  simpl; subst; reflexivity.
  unfold EnsembleListEquivalence in *; intuition.
  unfold In in *; subst; intuition.
  subst; simpl; eauto.
  simpl; right; eapply equiv_l'; eauto.
  simpl in *; unfold In; intuition.
  eapply equiv_l' in H2; eauto.
  simpl; econstructor; eauto.
  unfold not; intros.
  rewrite in_map_iff in H; destruct_ex; intuition.
  apply equiv_l' in H3; apply H0 in H3.
  simpl in *; omega.
Qed.

Lemma ImplementListInsert_neq qsSchema Ridx Ridx'
      (tup : RawTuple)
      (or : UnConstrQueryStructure qsSchema)
      (nr : list (RawTuple))
      m
:
  Ridx <> Ridx'
  -> EnsembleIndexedListEquivalence (GetUnConstrRelation or Ridx) nr
  -> refine
       {a |
        EnsembleIndexedListEquivalence
          (GetUnConstrRelation
             (@UpdateUnConstrRelation qsSchema or Ridx'
                                     (EnsembleInsert {| elementIndex := m;
                                                        indexedElement := tup|}
 (GetUnConstrRelation or Ridx'))) Ridx) a}
       (ret nr).
Proof.
  unfold refine; intros;  computes_to_inv; subst; computes_to_constructor.
  unfold GetUnConstrRelation, UpdateUnConstrRelation in *.
  rewrite ith_replace2_Index_neq; eauto using string_dec.
Qed.

Tactic Notation "implement" "insert" "for" "lists" :=
  repeat (progress
            (try (setoid_rewrite ImplementListInsert_eq; eauto;
                  try simplify with monad laws);
             try (match goal with
                      |- context
                           [{a | EnsembleIndexedListEquivalence
                                   ((UpdateUnConstrRelation ?QSSchema ?c ?Ridx
                                                            (EnsembleInsert ?n (?c!?R)))!?R')%QueryImpl a}%comp] =>
                      setoid_rewrite ((@ImplementListInsert_neq QSSchema
                                                                {| bindex := R' |}
                                                                {| bindex := R |} n c))
                  end;
                    eauto; try simplify with monad laws);
             try (match goal with
                    | |- context [ (GetUnConstrRelation _ ?Ridx) ] =>
                      setoid_rewrite (@ImplementListInsert_neq _ Ridx)
                  end; eauto; try simplify with monad laws)));
  try reflexivity.

Ltac implement_foreign_key_check_w_lists H :=
  repeat (match goal with
              |- context [
                     forall tup' : @RawTuple ?h,
                       (?qs ! ?R )%QueryImpl tup' ->
                       tupleAgree ?n tup' ?attrlist2%SchemaConstraints ->
                       tupleAgree ?n tup' ?attrlist1%SchemaConstraints ]
              =>
              setoid_rewrite (@refine_unused_key_check h attrlist1 attrlist2 _ _ n (qs ! R )%QueryImpl);
              [ simplify with monad laws |
                unfold H in *; split_and; eauto ]
              | |- context [
                       forall tup' : @RawTuple ?h,
                         (?qs ! ?R )%QueryImpl tup' ->
                         tupleAgree tup' ?n ?attrlist2%SchemaConstraints ->
                         tupleAgree tup' ?n  ?attrlist1%SchemaConstraints]
                =>
                setoid_rewrite (@refine_unused_key_check' h attrlist1 attrlist2 _ _ n (qs ! R )%QueryImpl);
              [ simplify with monad laws |
                unfold H in *; split_and; eauto ]
          end).


Inductive disj1 (A B : Prop) : Prop :=
| or1 : A -> disj1 A B
| or2 : B -> disj1 A B.


Set Universe Polymorphism.
(** The template-polymorphic 'prod' from the standard
    library just ain't good enough! *)
Inductive prod {A B : Type} : Type :=
  pair : A -> B -> prod.

Arguments prod : clear implicits.

Infix "*" := prod : type_scope.

Definition fst {A B} (p : A * B) := let (x, _) := p in x.
Definition snd {A B} (p : A * B) := let (_, y) := p in y.

Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z)
                      : core_scope.

Inductive sum {A B : Type} : Type :=
  | inl : A -> sum
  | inr : B -> sum.

Arguments sum : clear implicits.

Infix "+" := sum : type_scope.

Hint Resolve pair inl inr : core v62.

(*
(* Universe-polymorphic versions of things from
   CRelationClasses and CMorphisms. *)

Definition iffT (A B : Type) := ((A -> B) * (B -> A))%type.

Typeclasses Opaque iffT.

Require Import CRelationClasses.

Instance iffT_Reflexive : Reflexive iffT.
Proof. firstorder. Qed.

Instance iffT_Symmetric : Symmetric iffT.
Proof. firstorder. Qed.

Instance iffT_Transitive : Transitive iffT.
Proof. firstorder. Qed.

Instance iffT_arrow_subrelation : subrelation iffT arrow | 2.
Proof. firstorder. Qed.

Instance iffT_flip_arrow_subrelation : subrelation iffT (flip arrow) | 2.
Proof. firstorder. Qed.
*)


Set Implicit Arguments.
Require Import TLC.LibTactics.
Require Import TLC.LibListSort.
Require Import TLC.LibListZ.
(* Load the CFML library, with time credits. *)
Require Import CFML.CFLibCredits.
Require Pervasives_ml.
Require Array_ml.
Require Import Pervasives_proof.
Require Import ArrayCredits_proof.
(* Load the big-O library. *)
Require Import Dominated.
Require Import UltimatelyGreater.
Require Import Monotonic.
Require Import LibZExtra.
Require Import DominatedNary.
Require Import LimitNary.
Require Import Generic.
(* Load the custom CFML tactics with support for big-Os *)
Require Import CFMLBigO.
(* Load the CF definitions. *)
Require Import Selection_sort_ml.

Lemma swap_spec :
  specO unit_filterType eq
    (fun cost =>
      forall a (xs: list int) i j,
      index xs i -> index xs j ->
      app swap [a i j]
      PRE (\$ cost tt \* a ~> Array xs)
      POST (fun (_:unit) => a ~> Array (xs[i := xs[j]][j := xs[i]])))
    (fun (_:unit) => 1).
Proof.
  xspecO_refine straight_line. introv Ii Ij. xcf. xpay.
  xapps~. xapps~. xapp~. xapp~. apply~ index_update.
  cleanup_cost. monotonic. dominated.
Qed.

Hint Extern 1 (RegisterSpec swap) => Provide (provide_specO swap_spec).

Ltac auto_tilde ::= try solve [ eauto with maths | false; math ].

(* cumul a b (λi. f (b-i))
   = f(b-a) + f(b-(a+1)) + ... + f(b-(b-1))
   = f(b-a) + f(b-(a+1)) + ... + f(1)
   = cumul 1 (b-a+1) (λi. f i)
*)
Lemma cumul_triangle_renumber : forall lo hi f g,
  (forall i, lo <= i -> i < hi -> g i = f (hi - i)) ->
  cumul lo hi g = cumul 1 (hi-lo+1) f.
Proof.
  intros *. induction_wf: (upto hi) lo. intros Hg.
  unfold cumul. interval_case_l lo hi.
  { intros. cbn. rewrite~ interval_empty. }
  { intros. cbn.
    rewrite~ (@interval_cons_r 1 (hi - lo + 1)).
    rewrite List.map_app, Big.big_app. 2: typeclass. cbn.
    unfold cumul, Big.big in IH. rewrite IH. 2: upto. 2: intros; applys~ Hg.
    cbn. rewrite~ Hg.
    ring_simplify (hi - (lo + 1) + 1) (hi - lo + 1 - 1). unfold Big.big. cbn.
    math. }
Qed.

Lemma selection_sort_spec :
  specZ [cost \in_O (fun n => n ^ 2)]
    (forall a (xs : list int),
      1 <= length xs -> (* TODO: generalize the for-loop reasoning rule *)
      app selection_sort [a]
      PRE (\$ cost (length xs) \* a ~> Array xs)
      POST (fun (_:unit) => Hexists (xs' : list int), a ~> Array xs')).
Proof.
  xspecO_refine straight_line. xcf. xpay. xapps~.
  weaken. xfor_inv (fun (_:int) =>
    Hexists (xs':list int), a ~> Array xs' \* \[ length xs = length xs']
  ).
  { math. }
  { intros i Hi. xpull. intros xs' L.
    xpay. xapp. xseq.
    { weaken. xfor_inv (fun (_:int) =>
        Hexists (xs'':list int) (k:int),
        a ~> Array xs'' \* p ~~> k \*
        \[index xs'' k /\ length xs = length xs'']).
      { math. }
      intros j Hj. xpull. intros xs'' k (Hk & L').
      xpay. xapps. xapps~. xapps~. apply~ int_index_prove.
      xif.
      { xapp. hsimpl. splits~. apply~ int_index_prove. }
      { xret. hsimpl. splits~. }
      hsimpl. splits~. apply~ int_index_prove.

      match goal with |- cumul _ _ (fun _ => ?X) <= _ => ring_simplify X end.
      rewrite Z.max_l, Z.add_0_l; autos~. reflexivity. }

    xpull. intros xs'' k (? & ?). xapps. xapps~. apply~ int_index_prove.
    hsimpl. rewrite !LibListZ.length_update; auto.
  }
  hsimpl~. hsimpl.
  sets len_xs: (length xs). rewrite Z.add_0_l. reflexivity.

  eapply cleanup_cost_tagged, cleanup_cost_eq.
  { intro x. unfold costf.
    rewrite cumul_triangle_renumber
      with (lo := 0) (f := fun i => 3 * i + cost swap_spec tt + 1); auto; cycle 1.
    { intros. rewrite~ cumul_const. }
    ring_simplify (x - 2 + 1 - 0 + 1). reflexivity. }

  cleanup_cost.
  { monotonic. }
  { dominated.
    etransitivity. eapply dominated_big_sum_bound'; swap 1 3.
    { repeat apply_nary dominated_sum_distr_nary; dominated.
      apply dominated_reflexive. all: cbn; dominated. }
    1, 2: now ultimately_greater.
    { monotonic. intros ? ? H. destruct~ H. } now limit. now cbn; dominated. }
Qed.