(************************************************************************)
(* Copyright (c) 2022, Gergei Bana, Qianli Zhang                        *)
(*                                                                      *)
(* This work is licensed under the MIT license. The license is          *)
(* described in the file "LICENSE" available at the root of the source  *)
(* or at https://opensource.org/licenses/MIT                            *)
(*                                                                      *)
(* Special thanks to Dr. Eeralla                                        *)
(************************************************************************)

Require Export H_NonceImplications.

(*  *)
Notation "b0 & b1"    := (If b0 Then b1 Else FAlse)      (at level 21, right associativity).  (* *)
Notation "b0 'or' b1" := (If b0 Then TRue Else b1)       (at level 22, right associativity).  (* *)
Notation "! b "       := (If b Then FAlse Else TRue)     (at level 20, right associativity).  (* *)
Notation "b0 ⨀ b1"   := (If b0 Then b1 Else (!b1))      (at level 22, right associativity).  (* Gives TRue iff both b0 or b1 are TRue or both are FAlse *)

(*  *)
Proposition AndComm :
  forall A B,
    bppt A ->
    bppt B ->
    A & B = B & A.
Proof.
  intros.
  rewrite (@If_tf B) at 1.
  rewrite (@If_morph (fun x => If A Then x Else FAlse) B).
  rewrite If_same.
  rewrite <- (If_tf).
  reflexivity.
  all: ProveboolandContext.
Qed.

Proposition AndAssoc :
  forall A B C,
    (A & B) & C = A & B & C.
Proof.
  intros.
  rewrite (@If_morph (fun x => If x Then C Else FAlse) A).
  rewrite If_false.
  reflexivity.
  ProveContext.
Qed.

Proposition OrComm:
  forall A B,
    bppt A ->
    bppt B ->
    A or B = B or A.
Proof.
  intros.
  rewrite (@If_tf B) at 1.
  rewrite (@If_morph (fun x => A or x)).
  rewrite If_same.
  rewrite <- If_tf.
  reflexivity.
  all: ProveboolandContext.
Qed.

Proposition OrAssoc:
  forall A B C,
    (A or B) or C = A or B or C.
Proof.
  intros.
  rewrite (@If_morph (fun x => x or C)).
  rewrite If_true.
  reflexivity.
  ProveContext.
Qed.

Proposition NotElim :
  forall b x y,
    If ! b Then x Else y = If b Then y Else x.
Proof.
  intros.
  rewrite (@If_morph (fun z => If z Then x Else y) _ _ _ ).
  rewrite If_false.
  rewrite If_true.
  reflexivity.
  ProveContext.
Qed.

(**)
Proposition DeMorganNotOr : forall b1 b2,
    ! (b1 or b2) = !b1 & !b2.
Proof.
  intros.
  rewrite (@If_morph (fun x => If x Then FAlse Else TRue)). rewrite If_true.
  rewrite (@If_morph (fun x => x & ! b2)). rewrite If_false, If_true.
  reflexivity.
  all : ProveContext.
Qed.

Proposition XnorComm : forall b0 b1, bppt b0 -> bppt b1 -> b0 ⨀ b1 = b1 ⨀ b0.
Proof.
{ intros. rewrite (@If_morph (fun x => If b0 Then b1 Else x)). rewrite (@If_eval (fun b1 => b0 & b1) (fun b1 => If b0 Then b1 Else TRue)). rewrite <- If_tf.
  reflexivity.
  all : ProveboolandContext. }
Qed.

(**)(* Further useful propositions *)

Proposition OrComp : forall b1 b2 b3 x y,
    If b1 or b2 or b3 Then x Else y
    =
    If b1 Then x Else If b2 Then x Else If b3 Then x Else y.
Proof.
  intros.
  rewrite (@If_morph (fun b => If b Then x Else y)). rewrite If_true.
  rewrite (@If_morph (fun b => If b Then x Else y)). rewrite If_true.
  reflexivity.
  all : ProveContext.
Qed.

(**)
Proposition DeMorganNot2Or : forall b1 b2 b3,
    ! (b1 or b2 or b3) = !b1 & !b2 & !b3.
Proof.
  intros.
  rewrite (@If_morph (fun x => If x Then FAlse Else TRue)). rewrite If_true.
  rewrite (@If_morph (fun x => If x Then FAlse Else TRue)). rewrite If_true.
  rewrite (@If_morph (fun x => x & ! b2 & ! b3)). rewrite If_false, If_true.
  rewrite (@If_morph (fun x => x & ! b3)). rewrite If_false, If_true.
  reflexivity.
  all : ProveContext.
Qed.

Proposition CNF_IfThenElse : forall b1 b2 b3,
    ! (b1 or b2 or b3) =
      If b1 Then FAlse Else If b2 Then FAlse Else If b3 Then FAlse Else TRue.
Proof.
  intros.
  rewrite DeMorganNot2Or.
  rewrite NotElim. rewrite NotElim.
  reflexivity.
Qed.


Require Import String.

(* System F with pairs *)

Inductive STyp A :=
  | STTVar : A -> STyp A
  | STForall : (A -> STyp A) -> STyp A
  | STInt : STyp A
  | STFun : STyp A -> STyp A -> STyp A
  | STTuple : STyp A -> STyp A -> STyp A.

Inductive SExp (A T : Type) :=
  | STVar   : A -> SExp A T
  | STLit   : nat -> SExp A T
  | STLam   : STyp T -> (A -> SExp A T) -> SExp A T
  | STApp   : SExp A T -> SExp A T-> SExp A T
  | STBLam  : (T -> SExp A T) -> SExp A T
  | STTApp  : SExp A T -> STyp T -> SExp A T
  | STPair  : SExp A T -> SExp A T-> SExp A T
  | STProj1 : SExp A T -> SExp A T
  | STProj2 : SExp A T -> SExp A T.

Definition Exp := forall A T, SExp A T.

(* System I (no polymorphism yet) *)

Inductive PTyp A : Type :=
  | TVar : A -> PTyp A
  | TForall : (A -> PTyp A) -> PTyp A
  | PInt : PTyp A
  | Fun : PTyp A -> PTyp A -> PTyp A
  | And : PTyp A -> PTyp A -> PTyp A.

Fixpoint ptyp2styp A (t : PTyp (STyp A)) : STyp A :=
  match t with
    | TVar x => x
    | TForall f => STForall _ (fun a => ptyp2styp _ (f (STTVar _ a)))
    | PInt => STInt _
    | Fun t1 t2 => STFun _ (ptyp2styp A t1) (ptyp2styp A t2)
    | And t1 t2 => STTuple _ (ptyp2styp A t1) (ptyp2styp A t2)
  end.

Require Import Arith.
Require Import Setoid.

(* Subtyping relation *)

Inductive Atomic : forall A, PTyp A -> Prop :=
  | AInt : forall A, Atomic A (PInt _)
  | AFun : forall A (t1 t2 : PTyp A), Atomic A (Fun _ t1 t2).

Inductive sub : PTyp nat -> PTyp nat -> (forall A, SExp A nat) -> Prop :=
  | SInt : sub (PInt _) (PInt _) (fun A => STLam _ _ (STInt _) (fun x => STVar _ _ x))
  | SFun : forall o1 o2 o3 o4 c1 c2, sub o3 o1 c1 -> sub o2 o4 c2 ->
     sub (Fun _ o1 o2) (Fun _ o3 o4) (fun A => STLam _ _ (ptyp2styp _ (Fun _ o1 o2)) (fun f =>
       STLam _ _ (ptyp2styp o3 _) (fun x => STApp _ _ (c2 A) (STApp _ _ (STVar _ _ f) (STApp _ _ (c1 A) (STVar _ _ x)))))).
  | SAnd1 : forall t t1 t2 c1 c2, sub t t1 c1 -> sub t t2 c2 ->
     sub t (And  t1 t2) (fun A T => STLam _ _ (ptyp2styp t1 _) (fun x =>
       STPair _ _ (STApp _ _ (c1 A _) (STVar _ _ x)) (STApp _ _ (c2 A _) (STVar _ _ x))))
  | SAnd2 : forall t t1 t2 c, sub t1 t c -> Atomic t ->
     sub (And  t1 t2) t (fun A T => STLam _ _ (ptyp2styp (And t1 t2) _) (fun x =>
       (STApp _ _ (c A _) (STProj1 _ _ (STVar _ _ x)))))
  | SAnd3 : forall t t1 t2 c, sub t2 t c -> Atomic t ->
     sub (And  t1 t2) t (fun A T => STLam _ _ (ptyp2styp (And t1 t2) _) (fun x =>
       (STApp _ _ (c A _) (STProj2 _ _ (STVar _ _ x))))).

Definition Sub (t1 t2 : PTyp) : Prop := exists (e:Exp), sub t1 t2 e.

(* Smart constructors for Sub *)

Definition sint : Sub PInt PInt.
unfold Sub. exists (fun A T => STLam _ _ (STInt _) (fun x => STVar _ _ x)).
exact SInt.
Defined.

Definition sfun : forall o1 o2 o3 o4, Sub o3 o1 -> Sub o2 o4 -> Sub (Fun o1 o2) (Fun  o3 o4).
unfold Sub; intros. destruct H. destruct H0.
exists (fun A T=> STLam _ _ (ptyp2styp (Fun o1 o2) _) (fun f =>
       STLam _ _ (ptyp2styp o3 _) (fun x1 => STApp _ _ (x0 A _) (STApp _ _ (STVar _ _ f) (STApp _ _ (x A _) (STVar _ _ x1)))))).
apply SFun. auto. auto.
Defined.

Definition sand1 : forall t t1 t2, Sub t t1 -> Sub t t2 -> Sub t (And t1 t2).
unfold Sub. intros. destruct H. destruct H0.
exists (fun A T => STLam _ _ (ptyp2styp t1 _) (fun x1 =>
       STPair _ _ (STApp _ _ (x A _) (STVar _ _ x1)) (STApp _ _ (x0 A _) (STVar _ _ x1)))).
apply SAnd1. auto. auto.
Defined.

Definition sand2_atomic : forall t t1 t2, Sub t1 t -> Atomic t -> Sub (And  t1 t2) t.
unfold Sub. intros. destruct t. destruct H.
exists (fun A T => STLam _ _ (ptyp2styp (And t1 t2) _) (fun x1 =>
       (STApp _ _ (x A _) (STProj1 _ _ (STVar _ _ x1))))).
apply SAnd2. auto. auto. destruct H.
exists (fun A T => STLam _ _ (ptyp2styp (And t1 t2) _) (fun x1 =>
       (STApp _ _ (x A _) (STProj1 _ _ (STVar _ _ x1))))).
apply SAnd2. auto. auto.
inversion H0.
Defined.

Definition sand2 : forall t t1 t2, Sub t1 t -> Sub (And t1 t2) t.
induction t; intros.
(* Case PInt *)
apply sand2_atomic. auto. exact AInt.
(* Case Fun *)
apply sand2_atomic. auto. apply AFun.
(* Case And *)
unfold Sub. unfold Sub in H. destruct H. inversion H.
assert (Sub (And t0 t3) t1). apply IHt1.
unfold Sub. exists c1. auto.
assert (Sub (And t0 t3) t2). apply IHt2.
unfold Sub. exists c2. auto.
unfold Sub in H6. destruct H6.
unfold Sub in H7. destruct H7.
exists (fun A T => STLam _ _ (ptyp2styp t1 _) (fun x =>
       STPair _ _ (STApp _ _ (x0 A _) (STVar _ _ x)) (STApp _ _ (x1 A _) (STVar _ _ x)))).
apply SAnd1. auto. auto.
inversion H1.
inversion H1.
Defined.

Definition sand3_atomic : forall t t1 t2, Sub t2 t -> Atomic t -> Sub (And  t1 t2) t.
unfold Sub. intros. destruct t. destruct H.
exists (fun A T => STLam _ _ (ptyp2styp (And t1 t2) _) (fun x1 =>
       (STApp _ _ (x A _) (STProj2 _ _ (STVar _ _ x1))))).
apply SAnd3. auto. auto. destruct H.
exists (fun A T => STLam _ _ (ptyp2styp (And t1 t2) _) (fun x1 =>
       (STApp _ _ (x A _) (STProj2 _ _ (STVar _ _ x1))))).
apply SAnd3. auto. auto.
inversion H0.
Defined.

Definition sand3 : forall t t1 t2, Sub t2 t -> Sub (And  t1 t2) t.
induction t; intros.
(* Case PInt *)
apply sand3_atomic. auto. exact AInt.
(* Case Fun *)
apply sand3_atomic. auto. apply AFun.
(* Case And *)
unfold Sub. unfold Sub in H. destruct H. inversion H.
assert (Sub (And t0 t3) t1). apply IHt1.
unfold Sub. exists c1. auto.
assert (Sub (And t0 t3) t2). apply IHt2.
unfold Sub. exists c2. auto.
unfold Sub in H6. destruct H6.
unfold Sub in H7. destruct H7.
exists (fun A T => STLam _ _ (ptyp2styp t1 _) (fun x =>
       STPair _ _ (STApp _ _ (x0 A _) (STVar _ _ x)) (STApp _ _ (x1 A _) (STVar _ _ x)))).
apply SAnd1. auto. auto.
inversion H1.
inversion H1.
Defined.

(* Orthogonality: Implementation *)

Inductive Ortho : PTyp -> PTyp -> Prop :=
  | OAnd1 : forall t1 t2 t3, Ortho t1 t3 -> Ortho t2 t3 -> Ortho (And t1 t2) t3
  | OAnd2 : forall t1 t2 t3, Ortho t1 t2 -> Ortho t1 t3 -> Ortho t1 (And t2 t3)
  | OFun  : forall t1 t2 t3 t4, Ortho t2 t4 -> Ortho (Fun t1 t2) (Fun t3 t4)
  | OIntFun : forall t1 t2, Ortho PInt (Fun t1 t2)
  | OFunInt : forall t1 t2, Ortho (Fun t1 t2) PInt.

(*  | OLift : forall t1 t2, not (sub t1 t2) -> not (sub t2 t1) -> Atomic t1 -> Atomic t2 -> Ortho t1 t2. *)

(* Orthogonality: Specification *)

Definition OrthoS (A B : PTyp) := not (exists C, Sub A C /\ Sub B C).

(* Well-formed types *)

Inductive WFTyp : PTyp -> Prop :=
  | WFInt : WFTyp PInt
  | WFFun : forall t1 t2, WFTyp t1 -> WFTyp t2 -> WFTyp (Fun t1 t2)
  | WFAnd : forall t1 t2, WFTyp t1 -> WFTyp t2 -> OrthoS t1 t2 -> WFTyp (And t1 t2).

(* Reflexivity *)
Hint Resolve sint sfun sand1 sand2 sand3.

Lemma reflex : forall (t1 : PTyp), Sub t1 t1.
Proof.
induction t1; intros; auto.
Defined.

(* Orthogonality algorithm is complete *)

Lemma ortho_completness : forall (t1 t2 : PTyp), OrthoS t1 t2 -> Ortho t1 t2.
Proof.
induction t1; intros; unfold OrthoS in H.
(* Case PInt *)
induction t2.
destruct H. exists PInt. split; apply reflex.
apply OIntFun.
apply OAnd2.
apply IHt2_1. unfold not. unfold not in H. intros; apply H.
destruct H0. destruct H0.
exists x. split. exact H0. apply sand2. exact H1.
apply IHt2_2. unfold not. unfold not in H. intros. apply H.
destruct H0. destruct H0. exists x.
split. auto. apply sand3.
auto.
(* Case Fun t1 t2 *)
induction t2.
apply OFunInt.
apply OFun.
apply IHt1_2. unfold OrthoS. unfold not. intros.
unfold not in H. apply H.
destruct H0. destruct H0.
exists (Fun (And t1_1 t2_1) x).
split.
apply sfun.
apply sand2.
apply reflex.
auto.
apply sfun.
apply sand3. apply reflex.
auto.
(* Case t11 -> t12 _|_ t21 & t22 *)
apply OAnd2.
apply IHt2_1.
unfold not. unfold not in H. intros. apply H.
destruct H0. destruct H0.
exists x. split. auto. apply sand2. exact H1.
apply IHt2_2.
unfold not. unfold not in H. intros. apply H.
destruct H0. destruct H0.
exists x. split. auto. apply sand3. exact H1.
(* Case (t11 & t12) _|_ t2 *)
apply OAnd1.
apply IHt1_1.
unfold OrthoS.
unfold not. unfold not in H.
intro.
apply H.
clear H. destruct H0. destruct H.
exists x.
split.
apply sand2. exact H.
exact H0.
apply IHt1_2.
unfold OrthoS; unfold not; intro. unfold not in H.
apply H. clear H.
destruct H0.
destruct H.
exists x.
split.
apply sand3.
exact H.
exact H0.
Defined.

Lemma nosub : forall t1 t2, OrthoS t1 t2 -> not (Sub t1 t2) /\ not (Sub t2 t1).
Proof.
intros; split; unfold not.
unfold OrthoS in H. unfold not in H. intros.
apply H.
exists t2.
split. auto. apply reflex.
unfold OrthoS in H. unfold not in H. intros.
apply H.
exists t1. split. apply reflex. auto.
Defined.

Lemma invAndS1 : forall t t1 t2, Sub t (And t1 t2) -> Sub t t1 /\ Sub t t2.
Proof.
induction t; intros.
(* Case Int *)
inversion H. inversion H0. split; unfold Sub. exists c1. auto. exists c2. auto.
(* Case Fun *)
inversion H. inversion H0. split; unfold Sub. exists c1. auto. exists c2. auto.
(* Case And *)
inversion H. inversion H0. split; unfold Sub. exists c1. auto. exists c2. auto.
assert (Sub t1 t0 /\ Sub t1 t3).
apply IHt1.
auto. unfold Sub. exists c. auto.
destruct H7.
split.
apply sand2.
auto.
apply sand2.
auto.
assert (Sub t2 t0 /\ Sub t2 t3).
apply IHt2.
unfold Sub. exists c. auto.
destruct H7.
split.
apply sand3.
auto.
apply sand3.
auto.
Defined.

Lemma uniquesub : forall A B C,
  OrthoS A B -> Sub (And A B) C -> not (Sub A C /\ Sub B C).
Proof.
intros. unfold OrthoS in H. unfold not. intros. apply H. exists C. auto.
Defined.

(* Lemmas needed to prove soundness of the orthogonality algorithm *)

Lemma ortho_sym : forall A B, OrthoS A B -> OrthoS B A.
Proof.
unfold OrthoS. unfold not.
intros. apply H.
destruct H0. destruct H0.
exists x.
split; auto.
Defined.

Lemma ortho_and : forall A B C, OrthoS A C -> OrthoS B C -> OrthoS (And A B) C.
Proof.
intros. unfold OrthoS.
unfold not. intros.
destruct H1. destruct H1.
induction x.
inversion H1. inversion H3. unfold OrthoS in H. apply H. exists (PInt). split.
unfold Sub. exists c. auto. unfold Sub.  unfold Sub in H2. destruct H2. exists x0. auto.
unfold OrthoS in H0. apply H0. exists (PInt). split.
unfold Sub. exists c. auto. unfold Sub.  unfold Sub in H2. destruct H2. exists x0. auto.
inversion H1. inversion H3. unfold OrthoS in H. apply H. exists (Fun x1 x2). split.
unfold Sub. exists c. auto. unfold Sub.  unfold Sub in H2. destruct H2. exists x0. auto.
unfold OrthoS in H0. apply H0. exists (Fun x1 x2). split.
unfold Sub. exists c. auto. unfold Sub.  unfold Sub in H2. destruct H2. exists x0. auto.
assert (Sub C x1 /\ Sub C x2). apply invAndS1. auto. destruct H3.
inversion H1. inversion H5. apply IHx1.
unfold Sub. exists c1. auto. unfold Sub.  unfold Sub in H3. destruct H3. exists x0. auto.
unfold OrthoS in H. apply H. exists (And x1 x2). split.
unfold Sub. exists c. auto. unfold Sub.  unfold Sub in H2. destruct H2. exists x0. auto.
unfold OrthoS in H0. apply H0. exists (And x1 x2). split.
unfold Sub. exists c. auto. unfold Sub.  unfold Sub in H2. destruct H2. exists x0. auto.
Defined.

Lemma ortho_soundness : forall (t1 t2 : PTyp), Ortho t1 t2 -> OrthoS t1 t2.
intros.
induction H.
(* Hard case *)
assert (OrthoS t1 t3). apply IHOrtho1; auto.
assert (OrthoS t2 t3). apply IHOrtho2; auto.
apply ortho_and; auto.
assert (OrthoS t2 t1). apply ortho_sym. apply IHOrtho1; auto.
assert (OrthoS t3 t1). apply ortho_sym. apply IHOrtho2; auto.
apply ortho_sym.
apply ortho_and; auto.
(* Case FunFun *)
unfold OrthoS. unfold not. intros.
unfold OrthoS in IHOrtho. apply IHOrtho.
destruct H0. destruct H0. generalize H0. generalize H1. clear H0. clear H1.
induction x; intros. inversion H1. inversion H2. exists x2.
split. inversion H0. inversion H2. unfold Sub. exists c2. auto. unfold Sub. inversion H1. inversion H2. exists c2. auto.
apply IHx1.
inversion H1. inversion H2. unfold Sub. exists c1. auto.
inversion H0. inversion H2. exists c1. auto.
(* Case IntFun *)
unfold OrthoS. unfold not. intros.
destruct H. destruct H. induction x. inversion H0. inversion H1. inversion H. inversion H1.
apply IHx1.
inversion H. inversion H1. unfold Sub. exists c1. auto.
inversion H0. inversion H1. unfold Sub. exists c1. auto.
(* Case FunInt *)
unfold OrthoS. unfold not. intros.
destruct H. destruct H. induction x. inversion H. inversion H1. inversion H0. inversion H1.
apply IHx1. inversion H. inversion H1. unfold Sub. exists c1. auto.
inversion H0. inversion H1. unfold Sub. exists c1. auto.
Defined.

(* coercive subtyping is coeherent *)

Lemma sub_coherent : forall A, WFTyp A -> forall B, WFTyp B -> forall C1, sub A B C1 -> forall C2, sub A B C2 -> C1 = C2.
Proof.
intro. intro. intro. intro. intro. intro.
(* Case: Int <: Int *)
induction H1; intros.
inversion H1.
reflexivity.
(* Case: Fun t1 t2 <: Fun t3 t4 *)
inversion H1; inversion H; inversion H0.
assert (c2 = c3). apply IHsub2; auto.
assert (c1 = c0). apply IHsub1; auto.
rewrite H17. rewrite H18.
reflexivity.
(* Case: t <: And t1 t2 *)
inversion H1; inversion H0.
assert (c1 = c0). apply IHsub1; auto.
assert (c2 = c3). apply IHsub2; auto.
rewrite H13. rewrite H14.
reflexivity.
(* different coercion case*)
inversion H3.
(* different coercion case*)
inversion H3.
(* Case: And t1 t2 <: t (first) *)
inversion H3; inversion H.
(* different coercion *)
rewrite <- H7 in H2. inversion H2.
(* same coercion *)
assert (c = c0). apply IHsub; auto. rewrite H15.
reflexivity.
(* contradiction: not orthogonal! *)
destruct H14. exists t. unfold Sub.
split. exists c; auto. exists c0. auto.
(* Case: And t1 t2 <: t (second) *)
inversion H3; inversion H.
rewrite <- H7 in H2. inversion H2.
(* contradiction: not orthogonal! *)
destruct H14. exists t. unfold Sub.
split. exists c0; auto. exists c. auto.
(* same coercion; no contradiction *)
assert (c = c0). apply IHsub; auto. rewrite H15.
reflexivity.
Defined.

(* Old theorems *)

Lemma invAndS1 : forall t t1 t2 i, sub i t (And nat t1 t2) -> sub i t t1 /\ sub i t t2.
Proof.
(*
induction t; intros; split; try (inversion H); auto.
*)
induction t; intros.
(* Case Var *)
inversion H.
split.
exact H4.
exact H5.
(* Case Int *)
inversion H.
split.
exact H4.
exact H5.
(* Case Forall *)
inversion H0.
split.
exact H5.
exact H6.
(* Case Fun *)
inversion H.
split.
exact H4.
exact H5.
(* Case And *)
inversion H.
split.
exact H4.
exact H5.
assert (sub i t1 t0 /\ sub i t1 t3).
apply IHt1.
exact H4.
destruct H5.
split.
apply SAnd2.
exact H5.
apply SAnd2.
exact H6.
assert (sub i t2 t0 /\ sub i t2 t3).
apply IHt2.
exact H4.
destruct H5.
split.
apply SAnd3.
exact H5.
apply SAnd3.
exact H6.
Defined.

Definition transitivity_sub S Q T := forall i, sub i S Q -> sub i Q T -> sub i S T.

Lemma trans : forall Q T S, transitivity_sub S Q T.
induction Q.
unfold transitivity_sub; intros.
induction T; try (inversion H0); auto.
rewrite H4 in H. auto.
unfold transitivity_sub; intros.
induction T; try (inversion H0); auto.
(* Case Forall *)
unfold transitivity_sub. intros.
generalize H1 H0. clear H0. clear H1.
generalize S. clear S.
induction T; intro; intro; try (inversion H1); auto.
induction S; intro; try (inversion H6); intros; auto.
apply SForall.
inversion H7.
apply (H i); auto.
(* Case Fun *)
unfold transitivity_sub; intros.
generalize H0 H. clear H0. clear H.
generalize S. clear S.
induction T; intro; intro; try (inversion H0); auto.
induction S; intro; try (inversion H7); auto.
inversion H8.
apply SFun.
apply IHQ1; auto.
apply IHQ2; auto.
(* Case And *)
unfold transitivity_sub; intros.
assert (sub i S Q1 /\ sub i S Q2).
apply invAndS1; auto.
destruct H1.
generalize H1 H2.
induction T; intros.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply SAnd1.
apply IHT1; auto.
apply IHT2; auto.
apply IHQ1; auto.
apply IHQ2; auto.
Defined.

Definition Ortho A B := forall n, not (exists C, sub n A C /\ sub n B C).

Lemma p1 : forall (A B C : Prop), (A \/ B -> C) -> ((A -> C) /\ (B -> C)).
Proof.
intros.
split; intros.
apply H.
left.
exact H0.
apply H.
right.
exact H0.
Defined.

Definition equiv i t1 t2 := sub i t1 t2 /\ sub i t2 t1.

Definition contextEq i t1 t2 := (forall t, sub i t1 t -> sub i t2 t) /\ (forall t, sub i t t1 -> sub i t t2).

Definition narrowing_sub P Q X S T := forall i, sub i P Q -> (sub i X Q -> sub i S T) -> sub i X P -> sub i S T.

Lemma narrowing : forall X P Q S T, transitivity_sub X P Q -> narrowing_sub P Q X S T.
unfold narrowing_sub; intros.
apply H1.
apply H.
exact H2.
exact H0.
Defined.

Definition substitutability :
  forall t1 t2 i, equiv i t2 t1 -> contextEq i t2 t1 /\ contextEq i t1 t2.
intro. intro. intro. intro.
destruct H.
induction H; split; try split; intros.
(* Case Int *)
exact H.
exact H.
exact H.
exact H.
(* Case Var *)
exact H.
exact H.
exact H.
exact H.
(* Case Forall *)
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd1.
apply IHt1.
apply H6.
apply IHt2.
apply H7.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd2.
apply IHt1.
apply H6.
apply SAnd3.
apply IHt2.
apply H6.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd1.
apply IHt1.
apply H6.
apply IHt2.
apply H7.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd2.
apply IHt1.
apply H6.
apply SAnd3.
apply IHt2.
apply H6.
(* Case Fun *)
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd1.
apply IHt1.
exact H7.
apply IHt2.
exact H8.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd2.
apply IHt1.
exact H7.
apply SAnd3.
apply IHt2.
exact H7.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd1.
apply IHt1.
exact H7.
apply IHt2.
exact H8.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd2.
apply IHt1.
exact H7.
apply SAnd3.
apply IHt2.
exact H7.
(* Case And1 *)
(*
generalize i, t1, t2, H, H1, H0, IHsub1, IHsub2, t0, H2.
clear H2. clear t0. clear IHsub2. clear IHsub1. clear H0. clear H1. clear H. clear t2. clear t1. clear i. *)
induction t; intros.
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
inversion H0. (*H2*)
apply SAnd2.
apply IHsub1.
exact H8.
exact H2. (*H3*)
apply SAnd3.
apply IHsub2.
exact H8.
exact H2. (*H3*)
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
Defined.

Lemma ForallInv : forall t p g i, (forall t : PTyp nat, sub i (Forall nat p) t -> sub i (Forall nat g) t) ->
                  sub (i + 1) (p i) t -> sub (i + 1) (g i) t.
intros.
assert (sub i (Forall nat g) (Forall nat (fun i => t))).
apply H.
apply SForall.
exact H0.
inversion H1.
exact H5.
Defined.

Lemma FunInv1 : forall o t t1 t2 t3 t4 i, (forall t : PTyp nat, sub i (Fun nat t1 t2) t -> sub i (Fun nat t3 t4) t) ->
               sub i t1 t -> sub i o t.
intros.
(* assert (sub i (Fun nat t3 t4) (Fun )). *)
admit.
Defined.

Lemma FunInv2 : forall t t1 t2 t3 t4 i, (forall t : PTyp nat, sub i (Fun nat t1 t2) t -> sub i (Fun nat t3 t4) t) ->
               sub i t2 t -> sub i t4 t.
intros.
assert (exists t10, sub i (Fun nat t3 t4) (Fun nat t10 t)).
exists t1.
apply H.
apply SFun.
apply reflex.
exact H0.
destruct H1.
inversion H1.
exact H8.
Defined.

Lemma funnyLemma : forall t1 t3 i (s : sub i t1 t3) t2, (forall t, sub i t2 t -> sub i t3 t) -> sub i t1 t2.
intro. intro. intro. intro.
induction s; intros.
(* Case PInt *)
apply H.
apply reflex.
(* Case Var *)
apply H.
apply reflex.
(* Case Forall *)
assert (sub i (Forall nat g) t2).
apply H.
apply reflex.
induction t2; try (inversion H0).
assert (sub (i+1) (f i) (p i)).
apply IHs. intro.
apply (ForallInv _ _ _ _ H).
apply SForall.
exact H6.
apply SAnd1.
apply IHt2_1.
intros.
apply H.
apply SAnd2.
exact H7.
exact H5.
apply IHt2_2.
intros.
apply H.
apply SAnd3.
exact H7.
exact H6.
(* Case Fun *)
(*
generalize i, o1, o2, o3, o4 , s1, s2, IHs1, IHs2, H.
clear H. clear IHs2. clear IHs1. clear s2. clear s1. clear o4. clear o3. clear o2. clear o1. clear i.
induction t2; intros.
assert (sub i (Fun nat o3 o4) (Var nat a)).
apply H. apply reflex.
inversion H0.
admit.
admit.
apply SFun.
*)

assert (sub i (Fun nat o3 o4) t2).
apply H.
apply reflex.
induction t2; try (inversion H0).
apply SFun.
assert (sub i o3 t2_1).
apply IHs1.
intros.
assert (sub i (Fun nat o3 o4) (Fun nat (Fun nat o1 o2) t2_1)).
apply H.
apply SFun.
apply IHt2_1.
intros.
apply H.

(* Using H! *)
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
Defined.

(* A functional definition : algorithm *)

Fixpoint size (t : PTyp nat) (i : nat) : nat :=
  match t with
      | PInt => 1
      | Var x => 1
      | Forall f => 1 + size (f i) (i+1)
      | And o1 o2 => 1 + max (size o1 i) (size o2 i)
      | Fun o1 o2 => 1 + max (size o1 i) (size o2 i)
  end.

Fixpoint subTyp (n : nat) (t1 : PTyp nat) (t2 : PTyp nat) (i : nat) : Prop  :=
  match n with
      | 0 => False
      | S m =>
          match (t1,t2) with
            | (PInt,PInt) => True
            | (Var x, Var y) => if (eq_nat_dec x y) then True else False
            | (Forall f, Forall g) => subTyp m (f i) (g i) (i+1)
            | (And o1 o2, And o3 o4) => and (subTyp m o1 o3 i) (subTyp m o2 o4 i)
            | (Fun o1 o2, Fun o3 o4) => and (subTyp m o3 o1 i) (subTyp m o2 o4 i)
            | (_,_) => False
          end
  end.

Lemma implements : forall t1 t2 n i, subTyp (size t1 n) t1 t2 i -> sub i t1 t2.
Proof.
induction t1; intros.
simpl in H.
destruct t2; try destruct H.
destruct (eq_nat_dec a n0).
rewrite e.
apply SVar. reflexivity.
destruct H.
destruct t2; try destruct H.


Require Import Equations.Equations.

Inductive vec (A:Type) : nat -> Type :=
  | nil : vec A 0
  | cons : forall n, A -> vec A n -> vec A (S n).

Arguments nil {A}.
Arguments cons {A n}.

Derive Signature for vec.

Notation "x :: v" := (cons x v).
Notation "[ ]" := nil.
Notation "[ x ]" := (cons x nil).
Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) .. )).

Equations head {A n} (v : vec A (S n)) : A :=
head (x :: _) := x.

Equations tail {A n} (v : vec A (S n)) : vec A n :=
tail (_ :: v) := v.

Equations vec_vec {A:Type} {n} (v : vec  A n) : vec A n :=
vec_vec _ (n:=0) := [];
vec_vec v := (head v) :: (tail v).


(** * SearchTree: Binary Search Trees *)

(** Binary search trees are an efficient data structure for
   lookup tables, that is, mappings from keys to values.
   The [total_map] type from Maps.v is an _inefficient_
   implementation: if you add N items to your total_map,
   then looking them up takes N comparisons in the worst case,
   and N/2 comparisons in the average case.

   In contrast, if your [key] type is a total order -- that is,
   if it has a less-than comparison that's transitive and
   antisymmetric [ a<b <->  ~(b<a) ] -- then one can implement
   binary search trees (BSTs).   We will assume you know how BSTs
   work; you can learn this from:
   - Section 3.2 of  _Algorithms, Fourth Edition_,
       by Sedgewick and Wayne, Addison Wesley 2011;  or
   - Chapter 12 of _Introduction to Algorithms, 3rd Edition_,
       by Cormen, Leiserson, and Rivest, MIT Press 2009.

   Our focus here is to _prove the correctness of an implementation_
   of binary search trees. *)

Require Import Perm.
Require Import FunctionalExtensionality.

(* ################################################################# *)
(** * Total and Partial Maps *)

(** Recall the [Maps] chapter of Volume 1 (Logical Foundations),
    describing functions from identifiers to some arbitrary type [A].
    VFA's [Maps] module is almost exactly the same, except that it
    implements functions from [nat] to some arbitrary type [A]. *)

Require Import Maps.

(* ################################################################# *)
(** * Sections *)

(** We will use Coq's [Section] feature to structure this development,
     so first a brief introduction to Sections.  We'll use the example
     of lookup tables implemented by lists. *)

Module SectionExample1.
  Definition mymap (V: Type) := list (nat*V).
  Definition empty (V: Type) : mymap V := nil.
  Fixpoint lookup (V: Type) (default: V) (x: nat) (m: mymap V) : V :=
    match m with
    | (a,v)::al => if x =? a then v else lookup V default x al
    | nil => default
    end.
  Theorem lookup_empty (V: Type) (default: V):
       forall x, lookup V default x (empty V) = default.
   Proof. reflexivity. Qed.
End SectionExample1.

(** It sure is tedious to repeat the [V] and [default] parameters
     in every definition and every theorem.  The [Section] feature
     allows us to declare them as parameters to every definition
     and theorem in the entire section: *)

Module SectionExample2.
  Section MAPS.
  Variable V : Type.
  Variable default: V.

  Definition mymap  := list (nat*V).
  Definition empty : mymap := nil.
  Fixpoint lookup (x: nat) (m: mymap) : V :=
    match m with
    | (a,v)::al => if x =? a then v else lookup x al
    | nil => default
    end.
  Theorem lookup_empty:
       forall x, lookup x empty = default.
   Proof. reflexivity. Qed.
  End MAPS.
End SectionExample2.

(** At the close of the section, this produces exactly the same
     result:  the functions that "need" to be parametrized by
     [V] or [default] are given extra parameters.  We can test
     this claim, as follows: *)

Goal SectionExample1.empty = SectionExample2.empty.
Proof. reflexivity.
Qed.

Goal SectionExample1.lookup = SectionExample2.lookup.
Proof.
  unfold SectionExample1.lookup, SectionExample2.lookup.
  try reflexivity. (* doesn't do anything. *)

  (** Well, not exactly the same; but certainly equivalent.
   Functions [f] and [g] are "extensionally equal" if, for every
   argument [x], [f x = g x].  The Axiom of Extensionality
   says that if two functions are "extensionally equal" then they
   are _equal_.  The [extensionality] tactic is just a convenient
   way of applying the axiom of extensionality. *)

  extensionality V; extensionality default; extensionality x.
  extensionality m; simpl.
  induction m as [| [? ?] ]; auto.
  destruct (x=?n); auto.
Qed.

(* ################################################################# *)
(** * Program for Binary Search Trees *)

Section TREES.
Variable V : Type.
Variable default: V.

Definition key := nat.

Inductive tree : Type :=
 | E : tree
 | T: tree -> key -> V -> tree -> tree.

Definition empty_tree : tree := E.

Fixpoint lookup (x: key) (t : tree) : V :=
  match t with
  | E => default
  | T tl k v tr => if x <? k then lookup x tl
                         else if k <? x then lookup x tr
                         else v
  end.

Fixpoint insert (x: key) (v: V) (s: tree) : tree :=
 match s with
 | E => T E x v E
 | T a y v' b => if  x <? y then T (insert x v a) y v' b
                        else if y <? x then T a y v' (insert x v b)
                        else T a x v b
 end.

Fixpoint elements' (s: tree) (base: list (key*V)) : list (key * V) :=
 match s with
 | E => base
 | T a k v b => elements' a ((k,v) :: elements' b base)
 end.

Definition elements (s: tree) : list (key * V) := elements' s nil.

(* ################################################################# *)
(** * Search Tree Examples *)

Section EXAMPLES.
Variables v2 v4 v5 : V.
Eval compute in insert 5 v5 (insert 2 v2 (insert 4 v5 empty_tree)).
  (*      = T (T E 2 v2 E) 4 v5 (T E 5 v5 E) *)
Eval compute in lookup 5 (T (T E 2 v2 E) 4 v5 (T E 5 v5 E)).
  (*      = v5 *)
Eval compute in lookup 3 (T (T E 2 v2 E) 4 v5 (T E 5 v5 E)).
  (*      = default *)
Eval compute in elements (T (T E 2 v2 E) 4 v5 (T E 5 v5 E)).
  (*      = [(2, v2); (4, v5); (5, v5)] *)
End EXAMPLES.

(* ################################################################# *)
(** * What Should We Prove About Search trees? *)

(** Search trees are meant to be an implementation of maps.
   That is, they have an [insert] function that corresponds to the
   [update] function of a map, and a [lookup] function that
   corresponds to applying the map to an argument.  To prove the
   correctness of a search-tree algorithm, we can prove:
   - Any search tree corresponds to some map, using a function or
         relation that we demonstrate.
   - The lookup function gives the same result as applying the map
   - The insert function returns a corresponding map.
   - Maps have the properties we actually wanted.  It would do no
     good to prove that searchtrees correspond to some abstract
     type X, if X didn't have useful properties!

  What properties do we want searchtrees to have?  If I insert
  the binding [(k,v)] into a searchtree [t], then look up [k], I
  should get [v]. If I look up [k'] in [insert (k,v) t], where [k'<>k],
  then I should get the same result as [lookup k t].  There are several
  more properties. Fortunately, all these properties are already proved
  about [total_map] in the [Maps] module: *)

Check t_update_eq. (*  : forall (A : Type) (m : total_map A) (x : id) (v : A),
       t_update m x v x = v   *)
Check t_update_neq.  (* : forall (X : Type) (v : X) (x1 x2 : id) (m : total_map X),
       x1 <> x2 -> t_update m x1 v x2 = m x2    *)
Check t_update_shadow.  (* : forall (A : Type) (m : total_map A) (v1 v2 : A) (x : id),
       t_update (t_update m x v1) x v2 = t_update m x v2    *)
Check t_update_same.  (* : forall (X : Type) (x : id) (m : total_map X),
        t_update m x (m x) = m    *)
Check t_update_permute. (* forall (X : Type) (v1 v2 : X) (x1 x2 : id) (m : total_map X),
       x2 <> x1 ->
       t_update (t_update m x2 v2) x1 v1 =
         t_update (t_update m x1 v1) x2 v2    *)
Check t_apply_empty. (* : forall (A : Type) (x : id) (v : A),
       t_empty v x = v *)

(** So, if we like those properties that [total_map] is proved to have,
   and we can prove that searchtrees behave like maps, then we don't
   have to reprove each individual property about searchtrees.

   More generally:  a job worth doing is worth doing well.
   It does no good to prove the "correctness" of a program, if you
   prove that it satisfies a wrong or useless specification. *)

(* ################################################################# *)
(** * Efficiency of Search Trees *)

(** We use binary search trees because they are efficient.  That is,
     if there are [N] elements in a (reasonably well balanced) BST,
     each insertion or lookup takes about logN time.

     What could go wrong?

     1.  The search tree might not be balanced.  In that case, each
           insertion or lookup will take as much as linear time.

	   - SOLUTION: use an algorithm, such as "red-black trees",
	   that ensures the trees stay balanced.  We'll do that in
           Chapter [RedBlack].

     2.  Our keys are natural numbers, and Coq's [nat] type takes
           linear time _per comparison_.  That is, computing (j <? k)
           takes time proportional to the _value_ of [k-j].

	   - SOLUTION: represent keys by a data type that has a more
           efficient comparison operator.  We just use [nat] in this
           chapter because it's something you're already familiar with.

     3.  There's no notion of "run time" in Coq.  That is, we can't
          say what it means that a Coq function "takes N steps to
          evaluate."  Therefore, we can't prove that binary search
          trees are efficient.

	  - SOLUTION 1: Don't prove (in Coq) that they're efficient;
          just prove that they are correct.  Prove things about their
          efficiency the old-fashioned way, on pencil and paper.

	  - SOLUTION 2: Prove in Coq some facts about the height of
          the trees, which have direct bearing on their efficiency.
          We'll explore that in later chapters.

      4.  Our functions in Coq aren't real implementations; they are
          just pretend models of real implementations.  What if there
          are bugs in the correspondence between the Coq function and
          the real implementation?

          - SOLUTION: Use Coq's [extraction] feature to derive the
	    real implementation (in Ocaml or Haskell) automatically
	    from the Coq function.  Or, use Coq's [vm_compute] or
	    [native_compute] feature to compile and run the programs
	    efficiently inside Coq.  We'll explore [extraction] in a
	    later chapter. *)

(* ################################################################# *)
(** * Proof of Correctness *)

(** We claim that a [tree] "corresponds" to a [total_map].
     So we must exhibit an "abstraction relation"
     [Abs: tree -> total_map V -> Prop].

    The idea is that [Abs t m] says that tree [t]
    is a representation of map [m]; or that map [m]
    is an abstraction of tree [t].  How should we
    define this abstraction relation?

    The empty tree is easy:   [Abs E (fun x => default)].

    Now, what about this tree?: *)

Definition example_tree (v2 v4 v5 : V) :=
   T (T E 2 v2 E) 4 v4 (T E 5 v5 E).

(** **** Exercise: 2 stars (example_map)  *)
(* Fill in the definition of example_map with a total_map that
  you think example_tree should correspond to.  Use
  [t_update] and [(t_empty default)]. *)

Definition example_map (v2 v4 v5: V) : total_map V
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
(** [] *)

(** To build the [Abs] relation, we'll use these two auxiliary
     functions that construct maps: *)

Definition combine {A} (pivot: key) (m1 m2: total_map A) : total_map A :=
  fun x => if x <? pivot  then m1 x else m2 x.

(** [combine pivot a b] uses the map [a] on any input less than
   [pivot], and uses map [b] on any input [ >= pivot]. *)

Inductive Abs:  tree -> total_map V -> Prop :=
| Abs_E: Abs E (t_empty default)
| Abs_T: forall a b l k v r,
      Abs l a ->
      Abs r b ->
      Abs (T l k v r)  (t_update (combine k a b) k v).

(** **** Exercise: 3 stars (check_example_map)  *)
(** Prove that your [example_map] is the right one.
     If it isn't, go back and fix your definition of [example_map].
     You will probably need the [bdestruct] tactic, and [omega]. *)

Lemma check_example_map:
  forall v2 v4 v5, Abs (example_tree v2 v4 v5) (example_map v2 v4 v5).
Proof.
intros.
unfold example_tree.
evar (m: total_map V).
replace (example_map v2 v4 v5) with m; subst m.
repeat constructor.
extensionality x.
(* HINT:
  First,    [unfold example_map, t_update, combine, t_empty, beq_id.]
  Then, repeat the following procedure:  If you see something like
  [if 4 =? x then ... else ...],    use the tactic [bdestruct (4 =? x)].
  If the arithmetic facts above the line can't all be true, use [omega].
  If you're too lazy to check for yourself whether they are true,
   use [bdestruct (4 =? x); try omega].
*)
(* FILL IN HERE *) Admitted.
(** [] *)

(** You can ignore this lemma, unless it fails. *)
Lemma check_too_clever: forall v2 v4 v5: V, True.
Proof.
intros.
evar (m: total_map V).
assert (Abs (example_tree v2 v4 v5) m).
repeat constructor.
(change m with (example_map v2 v4 v5) in H || auto);
(* auto; *)
fail "Did you use copy-and-paste, from your check_example_map proof,
       into your example_map definition?  If so, very clever.
       Please try it again with an example_map definition that
       you make up from first principles.  Or, to skip that,
       uncomment the (* auto; *) above.".
Qed.

Theorem empty_tree_relate: Abs empty_tree (t_empty default).
Proof.
constructor.
Qed.

(** **** Exercise: 3 stars (lookup_relate)  *)
Theorem lookup_relate:
  forall k t cts ,
    Abs t cts -> lookup k t =  cts k.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars (insert_relate)  *)
Theorem insert_relate:
 forall k v t cts,
    Abs t cts ->
    Abs (insert k v t) (t_update cts k v).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Correctness Proof of the [elements] Function *)

(** How should we specify what [elements] is supposed to do?
     Well, [elements t] returns a list of pairs
     [(k1,v1);(k2;v2);...;(kn,vn)] that ought to correspond to
     the total_map, [t_update ... (t_update (t_update (t_empty default)
                     (Id k1) v1) (Id k2) v2) ... (Id kn) vn].

    We can formalize this quite easily.  *)

Fixpoint list2map (el: list (key*V)) : total_map V :=
 match el with
 | nil => t_empty default
 | (i,v)::el' => t_update (list2map el') i v
 end.

(** **** Exercise: 3 stars (elements_relate_informal)  *)
Theorem elements_relate:
  forall t cts,  Abs t cts -> list2map (elements t) = cts.
Proof.
(** Don't prove this yet.  Instead, explain in your own words, with
   examples, why this must be true.  It's OK if your explanation is
   not a formal proof; it's even OK if your explanation is subtly
   wrong!  Just make it convincing. *)

  (* FILL IN YOUR EXPLANATION HERE *)
Abort.
(** [] *)

(** Instead of doing a _formal_ proof that [elements_relate] is true,
     prove that it's false!  That is, as long as type [V] contains at
     least two distinct values. *)

(** **** Exercise: 4 stars (not_elements_relate)  *)
Theorem not_elements_relate:
  forall v, v <> default ->
  ~ (forall t cts,  Abs t cts -> list2map (elements t) = cts).
Proof.
intros.
intro.
pose (bogus := T (T E 3 v E) 2 v E).
pose (m := t_update (t_empty default) 2 v).
pose (m' := t_update
        (combine 2
           (t_update (combine 3 (t_empty default) (t_empty default)) 3 v)
           (t_empty default)) 2 v).
assert (Paradox: list2map (elements bogus) = m /\ list2map (elements bogus) <> m).
split.
(** To prove the first subgoal, prove that [m=m'] (by [extensionality]) and
      then use [H].

     To prove the second subgoal, do an [intro] so that you can assume
      [update_list (t_empty default) (elements bogus) = m], then show that
      [update_list (t_empty default) (elements bogus) (Id 3) <> m (Id 3)].
      That's a contradiction.

      To prove the third subgoal, just destruct [Paradox] and use the
      contradiction.

      In all 3 goals, when you need to unfold local definitions such
      as [bogus] you can use [unfold bogus] or [subst bogus].  *)

(* FILL IN HERE *) Admitted.
(** [] *)

(** What went wrong?  Clearly, [elements_relate] is true; you just
    explained why.  And clearly, it's not true, because
    [not_elements_relate] is provable in Coq.  The problem is that the
    tree [(T (T E 3 v E) 2 v E)] is bogus: it's not a well-formed
    binary search tree, because there's a 3 in the left subtree of the
    2 node, and 3 is not less than 2.

    If you wrote a good answer to the [elements_relate_informal]
    exercise, (that is, an answer that is only subtly wrong), then the
    subtlety is that you assumed that the search tree is well formed.
    That's a reasonable assumption; but we will have to prove that all
    the trees we operate on will be well formed.  *)

(* ################################################################# *)
(** * Representation Invariants *)

(** A [tree] has the [SearchTree] property if, at any node with key
     [k], all the keys in the left subtree are less than [k], and all
     the keys in the right subtree are greater than [k].  It's not
     completely obvious how to formalize that!  Here's one way: it's
     correct, but not very practical. *)

Fixpoint forall_nodes (t: tree) (P: tree->key->V->tree->Prop) : Prop :=
 match t with
 | E => True
 | T l k v r => P l k v r /\ forall_nodes l P /\ forall_nodes r P
 end.

Definition SearchTreeX (t: tree) :=
 forall_nodes t
   (fun l k v r =>
      forall_nodes l (fun _ j _ _ => j<k) /\
      forall_nodes r (fun _ j _ _ => j>k)).

Lemma example_SearchTree_good:
   forall v2 v4 v5, SearchTreeX (example_tree v2 v4 v5).
Proof.
intros.
hnf. simpl.
repeat split; auto.
Qed.

Lemma example_SearchTree_bad:
   forall v, ~SearchTreeX (T (T E 3 v E) 2 v E).
Proof.
intros.
intro.
hnf in H; simpl in H.
do 3 destruct H.
omega.
Qed.

Theorem elements_relate_second_attempt:
  forall t cts,
  SearchTreeX t ->
  Abs t cts ->
  list2map (elements t) = cts.
Proof.

(** This is probably provable.  But the [SearchTreeX] property is
   quite unwieldy, with its two Fixpoints nested inside a Fixpoint.
   Instead of using [SearchTreeX], let's reformulate the searchtree
   property as an inductive proposition without any nested
   induction. *)

Abort.

Inductive SearchTree' : key -> tree -> key -> Prop :=
| ST_E : forall lo hi, lo <= hi -> SearchTree' lo E hi
| ST_T: forall lo l k v r hi,
    SearchTree' lo l k ->
    SearchTree' (S k) r hi ->
    SearchTree' lo (T l k v r) hi.

Inductive SearchTree: tree -> Prop :=
| ST_intro: forall t hi, SearchTree' 0 t hi -> SearchTree t.

Lemma SearchTree'_le:
  forall lo t hi, @SearchTree' lo t hi -> lo <= hi.
Proof.
induction 1; omega.
Qed.

(** Before we prove that [elements] is correct, let's consider a simpler version. *)

Fixpoint slow_elements (s: tree) : list (key * V) :=
 match s with
 | E => nil
 | T a k v b => slow_elements a ++ [(k,v)] ++ slow_elements b
 end.

(** This one is easier to understand than the [elements] function,
    because it doesn't carry the [base] list around in its recursion.
    Unfortunately, its running time is quadratic, because at each of
    the [T] nodes it does a linear-time list-concatentation.  The
    original [elements] function takes linear time overall; that's
    much more efficient.

   To prove correctness of [elements], it's actually easier to first
   prove that it's equivalent to [slow_elements], then prove the
   correctness of [slow_elements].  We don't care that [slow_elements]
   is quadratic, because we're never going to really run it; it's just
   there to support the proof. *)

(** **** Exercise: 3 stars, optional (elements_slow_elements)  *)
Theorem elements_slow_elements: elements = slow_elements.
Proof.
extensionality s.
unfold elements.
assert (forall base, elements' s base = slow_elements s ++ base).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (slow_elements_range)  *)
Lemma slow_elements_range:
 forall k v lo t hi,
  SearchTree' lo t hi ->
  In (k,v) (slow_elements t) ->
  lo <= k < hi.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Auxiliary Lemmas About [In] and [list2map] *)

Lemma In_decidable:
  forall (al: list (key*V)) (i: key),
  (exists v, In (i,v) al) \/ (~exists v, In (i,v) al).
Proof.
intros.
induction al as [ | [k v]].
right; intros [w H]; inv H.
destruct IHal as [[w H] | H].
left; exists w; right; auto.
bdestruct (k =? i).
subst k.
left; eauto.
exists v; left; auto.
right. intros [w H1].
destruct H1. inv H1. omega.
apply H; eauto.
Qed.

Lemma list2map_app_left:
  forall (al bl: list (key*V)) (i: key) v,
     In (i,v) al -> list2map (al++bl) i = list2map al i.
Proof.
intros.
revert H; induction al as [| [j w] al]; intro; simpl; auto.
inv H.
destruct H. inv H.
unfold t_update.
bdestruct (i=?i); [ | omega].
auto.
unfold t_update.
bdestruct (j=?i); auto.
Qed.

Lemma list2map_app_right:
  forall (al bl: list (key*V)) (i: key),
     ~(exists v, In (i,v) al) -> list2map (al++bl) i = list2map bl i.
Proof.
intros.
revert H; induction al as [| [j w] al]; intro; simpl; auto.
unfold t_update.
bdestruct (j=?i).
subst j.
contradiction H.
exists w; left; auto.
apply IHal.
contradict H.
destruct H as [u ?].
exists u; right; auto.
Qed.

Lemma list2map_not_in_default:
 forall (al: list (key*V)) (i: key),
   ~(exists v, In (i,v) al) -> list2map al i = default.
Proof.
intros.
induction al as [| [j w] al].
reflexivity.
simpl.
unfold t_update.
bdestruct (j=?i).
subst.
contradiction H.
exists w; left; auto.
apply IHal.
intros [v ?].
apply H. exists v; right; auto.
Qed.

(** **** Exercise: 3 stars, optional (elements_relate)  *)
Theorem elements_relate:
  forall t cts,
  SearchTree t ->
  Abs t cts ->
  list2map (elements t) = cts.
Proof.
rewrite elements_slow_elements.
intros until 1. inv H.
revert cts; induction H0; intros.
* (* ST_E case *)
inv H0.
reflexivity.
* (* ST_T case *)
inv H.
specialize (IHSearchTree'1 _ H5). clear H5.
specialize (IHSearchTree'2 _ H6). clear H6.
unfold slow_elements; fold slow_elements.
subst.
extensionality i.
destruct (In_decidable (slow_elements l) i)  as [[w H] | Hleft].
rewrite list2map_app_left with (v:=w); auto.
pose proof (slow_elements_range _ _ _ _ _ H0_ H).
unfold combine, t_update.
bdestruct (k=?i); [ omega | ].
bdestruct (i<?k); [ | omega].
auto.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Preservation of Representation Invariant *)

(** How do we know that all the trees we will encounter (particularly,
  that the [elements] function will encounter), have the [SearchTree]
  property?  Well, the empty tree is a [SearchTree]; and if you insert
  into a tree that's a [SearchTree], then the result is a
  [SearchTree]; and these are the only ways that you're supposed to
  build trees.  So we need to prove those two theorems. *)

(** **** Exercise: 1 star (empty_tree_SearchTree)  *)
Theorem empty_tree_SearchTree:  SearchTree empty_tree.
Proof.
clear default.  (* This is here to avoid a nasty interaction between Admitted
   and Section/Variable.  It's also a hint that the [default] value
   is not needed in this theorem. *)
(* FILL IN HERE *) Admitted.
(** [] *)

Remark omega_on_keys:
   forall i j : key, ~ (i > j) -> ~ (i < j) -> i=j.
Proof.
intros.
try omega.  (* Oops! [omega] cannot solve this one.
    The problem is that [i] and [j] have type [key] instead of type [nat].
    The solution is easy enough: *)

(** So, if you get stuck on an [omega] that ought to work,
   try unfolding the types from [key] to [nat] *)

Qed.

(** **** Exercise: 3 stars (insert_SearchTree)  *)
Theorem insert_SearchTree:
  forall k v t,
   SearchTree t -> SearchTree (insert k v t).
Proof.
clear default. (* This is here to avoid a nasty interaction between Admitted and Section/Variable *)
(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * We Got Lucky *)

(** Recall the statement of [lookup_relate]: *)

Check lookup_relate.
(*  forall (k : key) (t : tree) (cts : total_map V),
       Abs t cts -> lookup k t = cts (Id k)  *)

(** In general, to prove that a function satisfies the abstraction relation,
   one also needs to use the representation invariant.  That was certainly
   the case with [elements_relate]: *)

Check elements_relate.
(*  : forall (t : tree) (cts : total_map V),
       SearchTree t -> Abs t cts -> elements_property t cts   *)

(** To put that another way, the general form of [lookup_relate] should be: *)

Lemma lookup_relate':
  forall (k : key) (t : tree) (cts : total_map V),
     SearchTree t -> Abs t cts -> lookup k t = cts k.

(** That is certainly provable, since it's a weaker statement than what we proved: *)

Proof.
intros.
apply lookup_relate.
apply H0.
Qed.

Theorem insert_relate':
 forall k v t cts,
    SearchTree t ->
    Abs t cts ->
    Abs (insert k v t) (t_update cts k v).
Proof. intros. apply insert_relate; auto.
Qed.

(** The question is, why did we not need the representation invariant in
   the proof of [lookup_relate]?  The answer is that our particular Abs
   relation is much more clever than necessary:  *)

Print Abs.
(* Inductive Abs : tree -> total_map V -> Prop :=
    Abs_E : Abs E (t_empty default)
  | Abs_T : forall (a b: total_map V) (l: tree) (k: key) (v: V) (r: tree),
            Abs l a ->
            Abs r b ->
	    Abs (T l k v r) (t_update (combine k a b) (Id k) v)
*)
(** Because the [combine] function is chosen very carefully, it turns out
  that this abstraction relation even works on bogus trees! *)

Remark abstraction_of_bogus_tree:
 forall v2 v3,
   Abs (T (T E 3 v3 E) 2 v2 E) (t_update (t_empty default) 2 v2).
Proof.
intros.
evar (m: total_map V).
replace  (t_update (t_empty default) 2 v2) with m; subst m.
repeat constructor.
extensionality x.
unfold t_update, combine, t_empty.
bdestruct (2 =? x).
auto.
bdestruct (x <? 2).
bdestruct (3 =? x).
(* LOOK HERE! *)
omega.
bdestruct (x <? 3).
auto.
auto.
auto.
Qed.

(** Step through the proof to [LOOK HERE], and notice what's going on.
   Just when it seems that [(T (T E 3 v3 E) 2 v2 E)] is about to produce [v3]
  while [(t_update (t_empty default) (Id 2) v2)] is about to produce [default],
  [omega] finds a contradiction.  What's happening is that [combine 2]
  is careful to ignore any keys >= 2 in the left-hand subtree.

  For that reason, [Abs] matches the _actual_ behavior of [lookup],
  even on bogus trees.  But that's a really strong condition!  We should
  not have to care about the behavior of [lookup] (and [insert]) on
  bogus trees.  We should not need to prove anything about it, either.

  Sure, it's convenient in this case that the abstraction relation is able to
  cope with ill-formed trees.  But in general, when proving correctness of
  abstract-data-type (ADT) implementations, it may be a lot of extra
  effort to make the abstraction relation as heavy-duty as that.
  It's often much easier for the abstraction relation to assume that the
  representation is well formed.  Thus, the general statement of our
  correctness theorems will be more like [lookup_relate'] than like
  [lookup_relate].  *)

(* ################################################################# *)
(** * Every Well-Formed Tree Does Actually Relate to an Abstraction *)

(** We're not quite done yet.  We would like to know that
    _every tree that satisfies the representation invariant, means something_.

   So as a general sanity check, we need the following theorem: *)

(** **** Exercise: 2 stars (can_relate)  *)
Lemma can_relate:
 forall t,  SearchTree t -> exists cts, Abs t cts.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** Now, because we happen to have a super-strong abstraction relation, that
   even works on bogus trees, we can prove a super-strong can_relate function: *)

(** **** Exercise: 2 stars (unrealistically_strong_can_relate)  *)
Lemma unrealistically_strong_can_relate:
 forall t,  exists cts, Abs t cts.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * It Wasn't Really Luck, Actually *)

(** In the previous section, I said, "we got lucky that the abstraction
    relation that I happened to choose had this super-strong property."

    But actually, the first time I tried to prove correctness of search trees,
    I did _not_ get lucky.  I chose a different abstraction relation: *)

Definition AbsX (t: tree) (m: total_map V) : Prop :=
    list2map (elements t) = m.

(** It's easy to prove that [elements] respects this abstraction relation: *)

Theorem elements_relateX:
  forall t cts,
  SearchTree t ->
  AbsX t cts ->
  list2map (elements t) = cts.
Proof.
intros.
apply H0.
Qed.

(** But it's not so easy to prove that [lookup] and [insert] respect this
    relation.  For example, the following claim is not true. *)

Theorem naive_lookup_relateX:
  forall k t cts ,
    AbsX t cts -> lookup k t =  cts k.
Abort.  (* Not true *)

(** In fact, [naive_lookup_relateX] is provably false,
     as long as the type [V] contains at least two different values. *)

Theorem not_naive_lookup_relateX:
   forall v, default <> v ->
    ~ (forall k t cts , AbsX t cts -> lookup k t =  cts k).
Proof.
unfold AbsX.
intros v H.
intros H0.
pose (bogus := T (T E 3 v E) 2 v E).
pose (m := t_update (t_update (t_empty default) 2 v) 3 v).
assert (list2map (elements bogus) = m).
  reflexivity.
assert (~ lookup 3 bogus = m 3). {
  unfold bogus, m, t_update, t_empty.
  simpl.
  apply H.
}
(** Right here you see how it is proved.  [bogus] is our old friend,
    the bogus tree that does not satisfy the [SearchTree] property.
    [m] is the [total_map] that corresponds to the elements of [bogus].
    The [lookup] function returns [default] at key [3],
    but the map [m] returns [v] at key [3].  And yet, assumption [H0]
    claims that they should return the same thing. *)
apply H2.
apply H0.
apply H1.
Qed.

(** **** Exercise: 4 stars, optional (lookup_relateX)  *)
Theorem lookup_relateX:
  forall k t cts ,
    SearchTree t -> AbsX t cts -> lookup k t =  cts k.
Proof.
intros.
unfold AbsX in H0. subst cts.
inv H. remember 0 as lo in H0.
clear - H0.
rewrite elements_slow_elements.
(** To prove this, you'll need to use this collection of facts:
   [In_decidable], [list2map_app_left], [list2map_app_right],
   [list2map_not_in_default], [slow_elements_range].  The point is,
   it's not very pretty. *)

(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Coherence With [elements] Instead of [lookup] *)
(** The first definition of the abstraction relation, [Abs], is "coherent"
     with the [lookup] operation, but not very coherent with the [elements]
     operation.  That is, [Abs] treats all trees, including ill-formed ones,
     much the way [lookup] does, so it was easy to prove [lookup_relate].
     But it was harder to prove [elements_relate].

    The alternate abstraction relation, [AbsX], is coherent with [elements],
    but not very coherent with [lookup].  So proving [elements_relateX] is
    trivial, but proving [lookup_relate] is difficult.

    This kind of thing comes up frequently.  The important thing to remember
    is that you often have choices in formulating the abstraction relation,
    and the choice you make will affect the simplicity and elegance of your
    proofs.   If you find things getting too difficult, step back and reconsider
    your abstraction relation. *)

End TREES.


Require Import List.
Require Import Tactics.
Require Import Arith.
Import ListNotations.

Require Import Logic.ClassicalFacts.

Axiom excluded_middle: excluded_middle.
Lemma rewrite_not_conj P Q: not (P /\ Q) <-> (not P) \/ (not Q).
Proof.
  split; intros; auto.
  - destruct (excluded_middle P).
    + right. intro. auto.
    + left. auto.
  - intro. destruct H0. destruct H; auto.
Qed.
Lemma rewrite_not_not P: not (not P) <-> P.
Proof.
  split; intros; auto.
  - destruct (excluded_middle P); auto.
    exfalso. auto.
Qed.

Inductive list_head : list nat -> nat -> Prop :=
| lhd1: forall u u', u = u' -> list_head [u] u'
| lhd2: forall l u u', u = u' ->  list_head (u :: l) u'.

Inductive list_member: list nat -> nat -> Prop :=
| lmem1: forall l u u', u = u' -> list_member (u :: l) u'
| lmem2: forall l u v, list_member l u -> list_member (v :: l) u.

Inductive list_order: list nat -> nat -> nat -> Prop :=
| lord1: forall l u u' v, u = u' -> list_member l v -> list_order (u :: l) u' v
| lord2: forall l u v w, list_order l u v -> list_order (w :: l) u v.

Inductive list_once: list nat -> nat -> Prop :=
| lonce1: forall l u u', u = u' -> not (list_member l u) -> list_once (u :: l) u'
| lonce2: forall l u u', u <> u' -> list_once l u' -> list_once (u :: l) u'.

Hint Constructors list_head: core.
Hint Constructors list_member: core.
Hint Constructors list_order: core.
Hint Constructors list_once: core.

Ltac invsub H := inversion H; subst.

Lemma lord_one_elem: forall (u: nat) (v: nat) (w: nat), not (list_order [w] u v).
Proof.
  unfold not. intros. invsub H.
  - inversion H5.
  - inversion H4.
Qed.

Hint Resolve lord_one_elem: core.

Lemma lmem_one_elem: forall (u: nat) (v: nat) , list_member [u] v -> u = v.
Proof.
  intros. invsub H; auto. inversion H3.
Qed.

Hint Resolve lord_one_elem: core.

Lemma lhd_lmem1: forall (l: list nat) (u: nat), list_head l u -> list_member l u.
Proof.
  intros.
  destruct H; auto with core.
Qed.

Hint Resolve lhd_lmem1: core.

Lemma lhd: forall (l: list nat) (u: nat) (v: nat), list_head l u -> list_head l v -> u = v.
Proof.
  intros. destruct l.
  - inversion H.
  - inversion H; inversion H0; subst; auto.
Qed.

Hint Resolve lhd: core.

Lemma lord_lmem1: forall (l: list nat) (u: nat) (v: nat), list_order l u v -> list_member l u.
Proof.
  intros. induction H; subst; auto.
Qed.

Lemma lord_lmem2: forall (l: list nat) (u: nat) (v: nat), list_order l u v -> list_member l v.
Proof.
intros.
  induction H; subst; auto.
Qed.

Hint Resolve lord_lmem1: core.
Hint Resolve lord_lmem2: core.

Lemma lord_lhd3: forall (l: list nat) (u: nat) (v: nat), list_head l u -> not (list_order l u v) -> not (u = v) -> not (list_member l v).
Proof.
  intros. destruct H.
  - intro. apply lmem_one_elem in H2. subst. auto.
  - intro. invsub H2.
    + auto.
    + auto.
Qed.

Lemma lord_lhd4: forall (l: list nat) (u: nat) (v: nat), list_member l u -> list_member l v -> not (u = v) -> not (list_order l u v) -> list_order l v u.
Proof.
  intros. induction l.
  - inversion H.
  - destruct (Nat.eqb_spec a v); subst.
    + invsub H. exfalso; auto. auto.
    + apply lord2. invsub H0. exfalso; auto.
      destruct (Nat.eqb_spec a u); subst.
      exfalso. auto.
      invsub H. exfalso; auto.
      auto.
Qed.

Lemma lord_lhd5: forall (l: list nat) (u: nat) (v: nat), list_member l u -> list_member l v -> not (u = v) -> not (list_order l v u) -> list_order l u v.
Proof.
  intros. apply lord_lhd4; auto.
Qed.

Lemma lord_lhd6: forall (l: list nat) (u: nat) (v: nat), list_member l u -> list_member l v -> not (list_order l v u) -> not (list_order l u v) -> (u = v).
Proof.
  intros.
  destruct (Nat.eqb_spec u v); subst; auto.
  exfalso. apply H2. apply (lord_lhd4 l); auto.
Qed.

Hint Resolve lord_lhd3: core.
Hint Resolve lord_lhd4: core.
Hint Resolve lord_lhd5: core.
Hint Resolve lord_lhd6: core.

Lemma lonce_mem1: forall (l: list nat) (u: nat), list_once l u -> list_member l u.
Proof.
  intros.
  induction H; subst; auto.
Qed.

Hint Resolve lonce_mem1: core.

(* Lemma lord_ord_1: forall (l: list nat) (u: nat) (v: nat), list_order l u v -> not (list_order l v u) -> (u = v). *)
(* Proof. *)
(* Admitted. *)

(* Hint Resolve lord_ord_1: core. *)

Lemma lord_once_1: forall (l: list nat) (u: nat) (v: nat), u = v -> list_order l u v -> not (list_once l u).
Proof.
  intros.
  intro. subst. induction H1; subst.
  - induction l.
    + eapply lord_one_elem. apply H0.
    + destruct (Nat.eqb_spec a u'). subst. auto.
      apply IHl.
      inversion H0; subst. invsub H6; auto. invsub H5; auto. intro. apply H1; auto.
  - invsub H0; auto.
Qed.

Lemma lord_once_2: forall (l: list nat) (u: nat) (v: nat), u = v -> list_order l u v -> not (list_once l v).
Proof.
  intros.
  intro. subst. induction H1.
  - subst. apply H1. invsub H0; eauto.
  - apply IHlist_once. invsub H0; auto.
Qed.

Lemma lord_once_3: forall (l: list nat) (u: nat), list_once l u -> not (list_order l u u).
Proof.
  intros.
  induction H; auto.
  intro. invsub H1; auto. apply H0; eauto.
  intro. invsub H1; auto.
Qed.

Hint Resolve lord_once_1: core.
Hint Resolve lord_once_2: core.
Hint Resolve lord_once_3: core.

Lemma lmem_ord_once_1: forall (l: list nat) (u: nat) (v: nat),
    list_member l u -> list_member l v ->
    not (list_order l u v) -> not (list_order l v u) ->
    list_once l u.
Proof.
  intros. assert (u = v). apply (lord_lhd6 l); auto. subst.
  induction l.
  - inversion H.
  - destruct (Nat.eqb_spec a v); subst; auto.
    apply lonce2; auto. apply IHl; auto.
    + invsub H; auto. exfalso. auto.
    + invsub H; auto. exfalso. auto.
Qed.

Lemma lmem_ord_once_2: forall (l: list nat) (u: nat) (v: nat),
    list_member l u -> list_member l v ->
    not (list_order l u v) -> not (list_order l v u) ->
    list_once l v.
Proof.
  intros.
  eapply lmem_ord_once_1; auto. apply H. auto. auto.
Qed.

Hint Resolve lmem_ord_once_1: core.
Hint Resolve lmem_ord_once_2: core.

Lemma lhd_mem_ord_1: forall (l: list nat) (u: nat) (v: nat),
    list_head l u -> not (u = v) -> list_member l v -> list_order l u v.
Proof.
  intros.
  destruct H.
  - invsub H1; auto.
  - invsub H1; auto.
Qed.

Lemma lhd_mem_ord_2: forall (l: list nat) (u: nat) (v: nat),
    list_head l u /\ not (list_order l u v) /\ (list_member l v) -> u = v.
Proof.
  intros. destruct (Nat.eqb_spec u v); subst; auto.
  exfalso. destruct_pairs. apply H0; auto. apply lhd_mem_ord_1; auto.
Qed.

Hint Resolve lhd_mem_ord_1: core.
Hint Resolve lhd_mem_ord_2: core.

Lemma lord_ord_mem1: forall (l: list nat) (u: nat) (v: nat),
    not (list_order l u v) -> not (list_order l v u) -> list_member l u -> list_member l v -> u = v.
Proof.
  intros. apply (lord_lhd6 l); auto.
Qed.

Lemma lord_ord_mem2: forall (l: list nat) (u: nat) (v: nat),
   list_member l u -> list_member l v -> not (u = v) -> not (list_order l u v) -> list_order l v u.
Proof.
  intros. apply (lord_lhd5 l); auto.
Qed.

Lemma lord_ord_mem3: forall (l: list nat) (u: nat) (v: nat),
   list_member l u -> list_member l v -> not (u = v) -> not (list_order l v u) -> list_order l u v.
Proof.
  intros. apply (lord_lhd5 l); auto.
Qed.

Hint Resolve lord_ord_mem1: core.
Hint Resolve lord_ord_mem2: core.
Hint Resolve lord_ord_mem3: core.

Hint Unfold not: core.

Lemma rewrite_not_disj P Q: not (P \/ Q) <-> (not P) /\ (not Q).
Proof. split; auto. intros. intro. destruct H. destruct H0; contradiction. Qed.

Inductive push_spec: nat -> list nat -> list nat -> Prop :=
| canonical_push_spec: forall x l l',
    (forall u, list_head l' u <-> u = x) ->
    (forall u, list_member l' u <-> ((u = x) \/ (list_member l u))) ->
    (forall u v, list_order l' u v <->
            ((list_order l u v) \/ ((u = x) /\ (list_member l v)))) ->
    (forall u, list_once l' u <->
             (((u <> x) /\ (list_once l u)) \/ ((u = x) /\ not (list_member l u)))) ->
    push_spec x l l'.

Definition push (x: nat) (l: list nat): list nat := x :: l.

Lemma push_push_spec: forall x l l', (push x l = l') -> (push_spec x l l').
Proof.
  unfold push. intros. subst.
  apply canonical_push_spec; intro.
  - split; auto. intro. invsub H; auto.
  - split; intros; auto; invsub H; auto.
  - split; intros; auto; invsub H; auto. destruct_pairs. subst.
    destruct H; auto.
  - split; intros; auto; invsub H; auto; destruct_pairs; subst; auto.
Qed.

Inductive nil_spec: list nat -> Prop :=
| canonical_nil_spec: forall l',
    (forall u, not (list_head l' u)) ->
    (forall u, not (list_member l' u)) ->
    (forall u v, not (list_order l' u v)) ->
    (forall u, not (list_once l' u)) ->
    nil_spec l'.

Definition nil: list nat := [].

Lemma nil_nil_spec: (nil_spec nil).
Proof.
  unfold nil. intros. subst.
  apply canonical_nil_spec; intro;
    try (split; intros; auto; invsub H; auto; destruct_pairs; subst; auto);
    try (intros; intro; inversion H).
Qed.

Inductive id_spec: list nat -> list nat -> Prop :=
| canonical_id_spec: forall l l',
    (forall u, list_head l' u <-> list_head l u) ->
    (forall u, list_member l' u <-> list_member l u) ->
    (forall u v, list_order l' u v <-> list_order l u v) ->
    (forall u, list_once l' u <-> list_once l u) ->
    id_spec l l'.

Definition id (l: list nat): list nat := l.

Lemma id_id_spec: forall l l', (id l = l') -> (id_spec l l').
Proof.
  unfold id. intros. subst.
  apply canonical_id_spec; intro;
     try (split; intros; auto; invsub H; auto; destruct_pairs; subst; auto);
    try (intros; intro; inversion H).
Qed.

Inductive is_empty_spec: list nat -> bool ->  Prop :=
| canonical_is_empty_spec: forall l' b,
    (forall u, Bool.Is_true b -> not (list_head l' u)) ->
    (forall u, Bool.Is_true b -> not (list_member l' u)) ->
    (forall u v, Bool.Is_true b -> not (list_order l' u v)) ->
    (forall u, Bool.Is_true b ->  not (list_once l' u)) ->
    is_empty_spec l' b.

Definition is_empty (l: list nat): bool :=
  match l with
  | [] => true
  | _ => false
  end.

Lemma is_empty_is_empty_spec: forall l l', (is_empty l = l') -> (is_empty_spec l l').
Proof.
  unfold is_empty. intros. subst.
  apply canonical_is_empty_spec; intro.
  induction l; intros.
  - intro. inversion H0.
  - inversion H.
  - destruct l; intros.
    + intro. inversion H0.
    + inversion H.
  - intros. intro. destruct l; intros. inversion H0. inversion H.
  - intros. intro. destruct l; intros. inversion H0. inversion H.
Qed.

Inductive top_spec: list nat -> nat -> Prop :=
| canonical_top_spec: forall l x,
    (forall u, u = x <-> list_head l u ) ->
    top_spec l x.

Definition top (l: list nat): option nat :=
  match l with
  | [] => None
  | h :: _ => Some h
  end.

Lemma top_top_spec: forall x l, ((top l) = Some x) -> (top_spec l x).
Proof.
  unfold top. intros. subst.
  apply canonical_top_spec; intro.
  destruct l.
  - inversion H.
  - split; auto; intros; invsub H; auto. invsub H0; auto.
Qed.

Inductive tail_spec: list nat -> list nat -> Prop :=
| canonical_tail_spec: forall l l',
    (forall u , list_head l' u -> (list_member l u)) ->
    (forall u , list_member l' u -> (list_member l u)) ->
    (forall u v, list_order l' u v -> list_order l u v) ->
    (forall u, list_once l' u ->
          ((not (list_head l u) /\ (list_once l u)) \/ ((list_head l u) /\ not (list_once l u) /\ (list_member l u)))) ->
    (forall u, ((list_member l u) /\ not (list_member l' u)) -> list_head l u) ->
    (forall u v, (list_order l u v /\ not (list_head l u)) -> list_order l' u v) ->
    (forall u, (list_head l u /\ not (list_member l' u)) -> not (list_order l u u)) ->
    tail_spec l l'.

Definition tail (l: list nat): option (list nat) :=
  match l with
  | [] => None
  | h :: t => Some t
  end.

Lemma tail_tail_spec: forall l l', ((tail l) = Some l') -> (tail_spec l l').
Proof.
  unfold tail. intros. subst.
  apply canonical_tail_spec.
  - induction l; invsub H; intros; auto.
  - induction l; invsub H; intros; auto.
  - induction l; invsub H; intros; auto.
  - induction l; invsub H; intros; auto.
    destruct (Nat.eqb_spec a u).
    + subst. right. split; auto. split; auto. intro. invsub H1; auto.
    + left. split; auto. intro. invsub H1; auto.
  - induction l; invsub H; intros; auto.
    destruct_pairs. invsub H0; auto. exfalso; auto.
  - destruct l; invsub H; intros; auto.
    destruct_pairs. inversion H0; subst; auto.
    exfalso; auto.
  - destruct l; invsub H; intros; auto.
    destruct_pairs. invsub H0; auto.
Qed.

Inductive concat_spec: list nat -> list nat -> list nat ->  Prop :=
| canonical_concat_spec: forall l1 l2 l',
    (forall u, list_head l' u -> (list_head l1 u \/ list_head l2 u)) ->
    (forall u, list_member l' u <-> (list_member l1 u \/ list_member l2 u)) ->
    (forall u v, list_order l' u v <-> (list_order l1 u v \/ list_order l2 u v \/ (list_member l1 u /\ list_member l2 v))) ->
    (forall u, list_once l' u <-> ((list_once l1 u /\ not (list_member l2 u)) \/
                              (list_once l2 u /\ not (list_member l1 u)))) ->
    concat_spec l1 l2 l'.

Definition concat (l1: list nat) (l2: list nat): list nat := l1 ++ l2.

Lemma concat_concat_spec2: forall l1 l2,
    (forall u, list_member (l1 ++ l2) u <-> (list_member l1 u \/ list_member l2 u)).
Proof.
  unfold concat. intros. subst.
  split; intros; auto.
  + induction l1; auto.
    destruct (Nat.eqb_spec a u); auto.
    invsub H. exfalso; auto.
    apply IHl1 in H3. destruct H3.
    left; auto. right; auto.
  + induction l1; auto.
    destruct H. inversion H. auto.
    destruct (Nat.eqb_spec a u); subst; simpl; auto.
    simpl. apply lmem2. apply IHl1.
    destruct H. left; auto. invsub H; auto. exfalso; auto. right; auto.
Qed.

Lemma concat_concat_spec1: forall l1 l2,
    (forall u, list_head (l1 ++ l2) u -> (list_head l1 u \/ list_head l2 u)).
Proof.
  unfold concat. intros.
  intros; destruct l1; auto. left. simpl in H. inversion H; subst; auto.
Qed.

Lemma concat_concat_spec1': forall l1 l2,
    (forall u, list_head (l1 ++ l2) u -> (list_head l1 u \/ (list_head l2 u /\ l1 = []) )).
Proof.
  unfold concat. intros.
  intros; destruct l1; auto. invsub H.
  - destruct l1; auto.
  - simpl in H. invsub H; auto.
Qed.

Lemma concat_concat_spec3: forall l1 l2,
    (forall u v, list_order (l1 ++ l2) u v <-> (list_order l1 u v \/ list_order l2 u v \/ (list_member l1 u /\ list_member l2 v))).
Proof.
  unfold concat. intros. subst.
  split; intros; auto.
  + induction l1; invsub H; auto.
    rewrite concat_concat_spec2 in H5.
    destruct H5. left. auto. right. right. auto.
    apply IHl1 in H4.
    destruct H4. left; auto. destruct H0. right. left. auto.
    destruct H0. right. right. auto.
  + destruct H.
    induction H; subst; auto. simpl; auto. apply lord1; auto. rewrite concat_concat_spec2.
    left. auto.
    simpl. auto.
    induction l1. simpl. destruct H; auto. destruct H. inversion H.
    destruct (Nat.eqb_spec a u). subst. simpl; auto.
    destruct H. apply lord2. apply IHl1. left; auto. apply lord1; auto. rewrite concat_concat_spec2. right. destruct H. auto.
    apply lord2. apply IHl1. destruct H. left; auto. destruct H. invsub H; auto. exfalso; auto.
Qed.

Lemma concat_concat_spec4: forall l1 l2,
    (forall u, list_once (l1 ++ l2) u <-> ((list_once l1 u /\ not (list_member l2 u)) \/
                              (list_once l2 u /\ not (list_member l1 u)))).
Proof.
  unfold concat. intros. subst.
   split; intros; auto.
    + induction l1; subst; auto. simpl in H. right. split; auto. intro. inversion H0.
      destruct (Nat.eqb_spec a u); subst. invsub H; subst. left. split; auto. apply lonce1; auto. intro. apply H4. rewrite concat_concat_spec2. auto. intro. apply H4. rewrite concat_concat_spec2. auto. exfalso. auto. invsub H. exfalso. auto.
      apply IHl1 in H4. destruct H4. left. destruct H0. split; auto.
      destruct H0. right. split; auto. intro. invsub H3. exfalso; auto. auto.
    + destruct H. destruct H. induction H; subst. simpl. apply lonce1; auto. intro. rewrite concat_concat_spec2 in H. tauto. simpl. apply lonce2; auto. destruct H. induction l1; auto. simpl. apply lonce2. intro. subst. apply H0; auto. apply IHl1. intro. auto.
Qed.

Lemma concat_concat_spec: forall l1 l2 l', (concat l1 l2 = l') -> (concat_spec l1 l2 l').
Proof.
  unfold concat. intros. subst.
  apply canonical_concat_spec; intro.
  - intros; destruct l1; auto. left. simpl in H. inversion H; subst; auto.
  - rewrite concat_concat_spec2. reflexivity.
  - intros. rewrite -> concat_concat_spec3. reflexivity.
  - intros. rewrite -> concat_concat_spec4. reflexivity.
Qed.

Inductive reverse_spec: list nat -> list nat -> Prop :=
| canonical_reverse_spec: forall l l',
    (forall u, list_head l' u -> list_member l u) ->
    (forall u, list_member l' u <-> list_member l u) ->
    (forall u v, list_order l' u v <-> list_order l v u) ->
    (forall u, list_once l' u <-> list_once l u) ->
    (* (forall u v, list_order l u v /\ not (u = v) -> not (list_head l' u)) -> *)
    (forall u v, list_head l' u -> list_member l v -> not (u = v) -> list_order l v u) ->
    reverse_spec l l'.

Lemma reverse_reverse_spec_mem: forall l, (forall u, list_member (rev l) u <-> list_member l u).
Proof.
  intros. split; subst; intros; auto.
  + induction l; intros; auto. simpl in H. rewrite concat_concat_spec2 in H.
    destruct H; auto. invsub H; auto. inversion H3.
  + induction l; intros; auto. simpl. rewrite concat_concat_spec2.
    invsub H; subst; auto.
Qed.

Lemma reverse_reverse_spec: forall l l', (rev l = l') -> (reverse_spec l l').
Proof.
  intros. subst.
  apply canonical_reverse_spec; intro.
  - induction l; intros; auto. simpl in H. apply concat_concat_spec1 in H.
    destruct H; auto. invsub H; auto.
  - rewrite reverse_reverse_spec_mem. reflexivity.
  - split; subst; intros; auto.
    + induction l; intros; auto. simpl in H. inversion H. simpl in H.
      rewrite concat_concat_spec3 in H.
      destruct H; auto. destruct H. apply lord_one_elem in H. inversion H. destruct H. invsub H0. rewrite reverse_reverse_spec_mem in H. auto. inversion H4.
    + induction l; intros; auto. simpl in H. inversion H. simpl.
      rewrite concat_concat_spec3.
      invsub H; subst. right. right. split; auto. rewrite reverse_reverse_spec_mem; auto. left. auto.
  - split; subst; intros; auto.
    + induction l; intros; auto. simpl in H. rewrite concat_concat_spec4 in H.
      destruct H. destruct H. apply lonce2; auto. destruct H. invsub H; auto. apply lonce1; auto. intro. rewrite <- reverse_reverse_spec_mem in H1. auto. inversion H5.
    + induction l; intros; auto. simpl. rewrite concat_concat_spec4.
      invsub H. right; split; auto. apply lonce1; auto. intro. inversion H0. intro. rewrite reverse_reverse_spec_mem in H0; auto. left. split; auto. intro. invsub H0. invsub H0; auto. inversion H6.
  - intros.
    remember (rev l) as l'. assert (l = rev l').
    rewrite Heql'. rewrite rev_involutive. auto. rewrite H2 in H0. rewrite H2. clear Heql'. clear H2. clear l.
    induction l'. inversion H. invsub H. simpl in H0. invsub H0; auto. inversion H5. clear H. simpl in H0. rewrite concat_concat_spec2 in H0. destruct H0.
    simpl. rewrite concat_concat_spec3. right. right. split; auto.
    invsub H; auto. exfalso; auto. inversion H4.
Qed.

Ltac destruct_disj :=
 match goal with
 | [H : (_ \/ _) |- _] => destruct H
 | [H : _ |- (_ /\ _)] => split
 end.

Ltac solve_eq :=
  match goal with
  | [H : _ |- (_ = _) ] => (try symmetry; auto with core); auto with core
  end.

Ltac solve_not :=
  match goal with
  | [H : _ |- (not _) ] => intro Z
  end; subst; auto with core.

Ltac intr_not :=
  match goal with
  | [_ : _ |- (not _) ] => intro Z
  end.

Ltac solve_disjs := repeat (destruct_disj);
                    destruct_pairs; subst;
                    try contradiction; try solve_eq; try solve_not; auto with core; eauto;
                    try (exfalso; auto with core; eauto).
Ltac solve_push :=
  intro pushspec;
  inversion pushspec as [a b c Hhd Hmem Hord Honce]; subst;
  try setoid_rewrite Hhd; try setoid_rewrite Hmem; try setoid_rewrite Hord; try setoid_rewrite Honce;
  clear Hhd Hmem Hord Honce;
  repeat ((repeat setoid_rewrite rewrite_not_conj);
          (repeat setoid_rewrite rewrite_not_disj);
          (repeat setoid_rewrite rewrite_not_not));
  intros;
  try (match goal with
  | _ : _ |- not _ => intro
  end); destruct_pairs; auto with core; try solve_disjs.

Ltac solve_nil :=
  intro nilspec;
  inversion nilspec as [a Hhd Hmem Hord Honce]; subst; intros;
  try apply Hhd;
  try apply Hmem;
  try apply Hord;
  try apply Honce;
  auto with core.

Ltac solve_id :=
  intro pushspec;
  inversion pushspec as [a b Hhd Hmem Hord Honce]; subst;
  try setoid_rewrite Hhd; try setoid_rewrite Hmem; try setoid_rewrite Hord; try setoid_rewrite Honce;
  clear Hhd Hmem Hord Honce;
  repeat ((repeat setoid_rewrite rewrite_not_conj);
          (repeat setoid_rewrite rewrite_not_disj);
          (repeat setoid_rewrite rewrite_not_not));
  intros; try (match goal with
  | _ : _ |- not _ => intro
  end); destruct_pairs; auto with core; try solve_disjs.

Ltac solve_is_empty :=
  intro nilspec;
  inversion nilspec as [a b Hhd Hmem Hord Honce]; subst; intros;
  try destruct_pairs; auto with core; try solve_disjs;
  try apply Hhd;
  try apply Hmem;
  try apply Hord;
  try apply Honce;
  auto with core; destruct_pairs; auto with core;
  try (match goal with
  | H: (Bool.Is_true _), H' : (list_member _ _) |- _ =>  try (eapply Hmem in H; auto with core)
  | H: (Bool.Is_true _), H' : (list_head _ _) |- _ =>  try (eapply Hhd in H; auto with core)
  | H: (Bool.Is_true _), H' : (list_order _ _) |- _ =>  try (eapply Hord in H; auto with core)
  | H: (Bool.Is_true _), H' : (list_once _ _) |- _ =>  try (eapply Honce in H; auto with core)
  end); try solve_disjs.

Ltac solve_top :=
  intro pushspec;
  inversion pushspec as [a b Hhd]; subst; intros; try intr_not; destruct_pairs;
  try (match goal with
       | x: nat, y: nat, z: nat |- _ => destruct (Hhd x); destruct (Hhd y); destruct (Hhd z)
       | x: nat, y: nat |- _ => destruct (Hhd x); destruct (Hhd y)
       | x: nat |- _ => destruct (Hhd x)
       end); auto with core; eauto; try solve_disjs.

Ltac solve_tail :=
  intro pushspec;
  inversion pushspec as [a b Hhd Hmem Hord Honce Hhd' Hord' Hord'']; subst;
  try apply Hhd';
  intros; destruct_pairs; auto with core; try solve_disjs.

Ltac solve_reverse :=
  intro pushspec;
  inversion pushspec as [a b Hhd Hmem Hord Honce Hhd'']; subst;
  try setoid_rewrite Hhd; try setoid_rewrite Hmem; try setoid_rewrite Hord; try setoid_rewrite Honce;
  clear Hhd Hmem Hord Honce;
  repeat ((repeat setoid_rewrite rewrite_not_conj);
          (repeat setoid_rewrite rewrite_not_disj);
          (repeat setoid_rewrite rewrite_not_not));
  intros; destruct_pairs; auto with core;
  try (match goal with
       | u_0: nat, u_1: nat |- _ =>
         destruct (Nat.eqb_spec u_0 u_1); subst; auto with core; try (eapply Hhd''; auto with core)
       end);
  try solve_disjs.

Ltac solve_concat :=
  intro pushspec;
  inversion pushspec as [a b c Hhd Hmem Hord Honce]; subst;
  try setoid_rewrite Hhd; try setoid_rewrite Hmem; try setoid_rewrite Hord; try setoid_rewrite Honce;
  clear Hhd Hmem Hord Honce;
  repeat ((repeat setoid_rewrite rewrite_not_conj);
          (repeat setoid_rewrite rewrite_not_disj);
          (repeat setoid_rewrite rewrite_not_not));
  intros; destruct_pairs; auto with core;
  try (match goal with
       | u: nat, v: nat |- _ => destruct (Nat.eqb_spec u v); subst; auto with core
       end);
  try solve_disjs.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import BinPos.

Open Scope positive_scope.

Definition Pleb x y :=
 match Pcompare x y Eq with Gt => false | _ => true end.

(** A Square Root function for positive numbers *)

(** We procede by blocks of two digits : if p is written qbb'
    then sqrt(p) will be sqrt(q)~0 or sqrt(q)~1.
    For deciding easily in which case we are, we store the remainder
    (as a positive_mask, since it can be null).
    Instead of copy-pasting the following code four times, we
    factorize as an auxiliary function, with f and g being either
    xO or xI depending of the initial digits.
    NB: (Pminus_mask (g (f 1)) 4) is a hack, morally it's g (f 0).
*)

Definition Psqrtrem_step (f g:positive->positive) p :=
 match p with
  | (s, IsPos r) =>
    let s' := s~0~1 in
    let r' := g (f r) in
    if Pleb s' r' then (s~1, Pminus_mask r' s')
    else (s~0, IsPos r')
  | (s,_)  => (s~0, Pminus_mask (g (f 1)) 4)
 end.

Fixpoint Psqrtrem p : positive * positive_mask :=
 match p with
  | 1 => (1,IsNul)
  | 2 => (1,IsPos 1)
  | 3 => (1,IsPos 2)
  | p~0~0 => Psqrtrem_step xO xO (Psqrtrem p)
  | p~0~1 => Psqrtrem_step xO xI (Psqrtrem p)
  | p~1~0 => Psqrtrem_step xI xO (Psqrtrem p)
  | p~1~1 => Psqrtrem_step xI xI (Psqrtrem p)
 end.

Definition Psqrt p := fst (Psqrtrem p).

(** An inductive relation for specifying sqrt results *)

Inductive PSQRT : positive*positive_mask -> positive -> Prop :=
 | PSQRT_exact : forall s x, x=s*s -> PSQRT (s,IsNul) x
 | PSQRT_approx : forall s r x, x=s*s+r -> r <= s~0 -> PSQRT (s,IsPos r) x.

(** Correctness proofs *)

Lemma Psqrtrem_step_spec : forall f g p x,
 (f=xO \/ f=xI) -> (g=xO \/ g=xI) ->
 PSQRT p x -> PSQRT (Psqrtrem_step f g p) (g (f x)).
Proof.
intros f g _ _ Hf Hg [ s _ -> | s r _ -> Hr ].
(* exact *)
unfold Psqrtrem_step.
destruct Hf,Hg; subst; simpl Pminus_mask;
 constructor; try discriminate; now rewrite Psquare_xO.
(* approx *)
assert (Hfg : forall p q, g (f (p+q)) = p~0~0 + g (f q))
 by (intros; destruct Hf, Hg; now subst).
unfold Psqrtrem_step. unfold Pleb.
case Pcompare_spec; [intros EQ | intros LT | intros GT].
(* - EQ *)
rewrite <- EQ. rewrite Pminus_mask_diag.
destruct Hg; subst g; try discriminate.
destruct Hf; subst f; try discriminate.
injection EQ; clear EQ; intros <-.
constructor. now rewrite Psquare_xI.
(* - LT *)
destruct (Pminus_mask_Gt (g (f r)) (s~0~1)) as (y & -> & H & _).
change Eq with (CompOpp Eq). now rewrite <- Pcompare_antisym, LT.
constructor.
rewrite Hfg, <- H. now rewrite Psquare_xI, Pplus_assoc.
apply Ple_lteq, Pcompare_p_Sq in Hr; change (r < s~1) in Hr.
apply Ple_lteq, Pcompare_p_Sq; change (y < s~1~1).
apply Pplus_lt_mono_l with (s~0~1).
rewrite H. simpl. rewrite Pplus_carry_spec, Pplus_diag. simpl.
set (s1:=s~1) in *; clearbody s1.
destruct Hf,Hg; subst; red; simpl;
  apply Hr || apply Pcompare_eq_Lt, Hr.
(* - GT *)
constructor.
rewrite Hfg. now rewrite Psquare_xO.
apply Ple_lteq, Pcompare_p_Sq, GT.
Qed.

Lemma Psqrtrem_spec : forall p, PSQRT (Psqrtrem p) p.
Proof.
fix 1.
 destruct p; try destruct p; try (constructor; easy);
  apply Psqrtrem_step_spec; auto.
Qed.

Lemma Psqrt_spec : forall p,
 let s := Psqrt p in s*s <= p < (Psucc s)*(Psucc s).
Proof.
 intros p. simpl.
 assert (H:=Psqrtrem_spec p).
 unfold Psqrt in *. destruct Psqrtrem as (s,rm); simpl.
 inversion_clear H; subst.
 (* exact *)
 split. red. rewrite Pcompare_refl. discriminate.
  apply Pmult_lt_mono; apply Pcompare_p_Sp.
 (* approx *)
 split.
 apply Ple_lteq; left. apply Plt_plus_r.
 rewrite (Pplus_one_succ_l).
 rewrite Pmult_plus_distr_r, !Pmult_plus_distr_l.
 rewrite !Pmult_1_r. simpl (1*s).
 rewrite <- Pplus_assoc, (Pplus_assoc s s), Pplus_diag, Pplus_assoc.
 rewrite (Pplus_comm (_+_)). apply Pplus_lt_mono_l.
 rewrite <- Pplus_one_succ_l. now apply Pcompare_p_Sq, Ple_lteq.
Qed.