(* experimentations on HoTT; chapter 1 *)
(* requires coq 8.5 *)

Require Import Utf8 QArith.
Require Import NPeano.

(* no default implicit without arguments *)
Arguments eq_refl [A] x.

Notation "⊥" := False.
Notation "⊤" := True.
Notation "'ℬ'" := (bool : Type).
Notation "'ℕ'" := nat.
Notation "( x , y ) '_{' P }" := (existT P x y)
  (at level 0, only parsing).
(*
Notation "( x , y ) '_{' P }" := (existT P x y)
  (at level 0, format "'[' ( x ,  y ) _{ P } ']'", only parsing).
*)

Open Scope nat_scope.

(* hott section 1.12 *)

Definition indiscernability {A} C (x y : A) (p : x = y) :
  C x → C y
:=
  match p return (C x → C _) with
  | eq_refl _ => id
  end.

Theorem indiscernability_prop : ∀ A C (x : A),
  indiscernability C x x (eq_refl x) = id.
Proof. reflexivity. Qed.

(* hott section 1.12.1 *)

Theorem path_induction0 : ∀ A C c,
  ∃ (f : ∀ (x y : A) (p : x = y), C x y p),
  ∀ x, f x x (eq_refl x) = c x.
Proof.
intros A C c.
exists
  (λ a _ p,
   match p return (C _ _ p) with
   | eq_refl _ => c a
   end).
reflexivity.
Qed.

Theorem based_path_induction : ∀ A a C c,
  ∃ (f : ∀ (x : A) (p : a = x), C x p),
  f a (eq_refl a) = c.
Proof.
intros A a C c.
exists
  (λ _ p,
   match p in (_ = y) return (∀ D, D _ (eq_refl _) → D y p) with
   | eq_refl _ => λ _, id
   end C c).
reflexivity.
Qed.

(* hott section 1.12.2 *)

Theorem path_based_path_induction_iff :
  (∀ A (x : A) C c,
   ∃ (f : ∀ (x y : A) (p : x = y), C x y p),
   ∀ x, f x x (eq_refl x) = c x)
  ↔
  (∀ A a C c,
   ∃ (f : ∀ (x : A) (p : a = x), C x p),
   f a (eq_refl a) = c).
Proof.
Abort. (* to be done *)

(* hott chapter 1 exercises *)

(* Exercise 1.1. Given functions f : A → B and g : B → C, define their
  composite g o f : A → C.
    Show that we have h o (g o f ) ≡ (h o g) o f. *)

Definition composite {A B C} (f : A → B) (g : B → C) x := g (f x).
Notation "g '◦' f" := (composite f g) (at level 40, left associativity).
(* composite : ∀ A B C : Type, (A → B) → (B → C) → A → C *)

Theorem composite_assoc {A B C D} : ∀ (f : A → B) (g : B → C) (h : C → D),
  h ◦ (g ◦ f) = (h ◦ g) ◦ f.
Proof. reflexivity. Qed.

(* Exercise 1.2. Derive the recursion principle for products rec_{AxB}
   using only the projections, and verify that the definitional
   equalities are valid. Do the same for Σ-types. *)

Definition AxB_pr₁ {A B} (x : A * B) := match x with (a, _) => a end.
Definition AxB_pr₂ {A B} (x : A * B) := match x with (_, b) => b end.

Definition rec_AxB {A B C} (g : A → B → C) x := g (AxB_pr₁ x) (AxB_pr₂ x).

Theorem verif_rec_AxB_eq_def : ∀ A B C (g : A → B → C) a b,
  rec_AxB g (a, b) = g a b.
Proof. reflexivity. Qed.

Definition Σ_pr₁ {A B} (x : { y : A & B y }) : A :=
  match x with existT _ a _ => a end.
Definition Σ_pr₂ {A B} (x : { y : A & B y }) : B (Σ_pr₁ x) :=
  match x with existT _ _ b => b end.

Definition rec_Σ {A B C} (g : ∀ x : A, B x → C) x := g (Σ_pr₁ x) (Σ_pr₂ x).

Theorem verif_rec_Σ_eq_def : ∀ A B C (g : ∀ x : A, B x → C) a b,
  rec_Σ g (existT B a b) = g a b.
Proof. reflexivity. Qed.

(* Exercise 1.3. Derive the induction principle for products ind_{AxB},
   using only the projections and the propositional uniqueness principle
   uppt. Verify that the definitional equalities are valid. Generalize
   uppt to Σ-types, and do the same for Σ-types. (This requires concepts
   from Chapter 2.) *)

Definition uupt {A B} (x : A * B) :=
  let (a, b) return ((AxB_pr₁ x, AxB_pr₂ x) = x) := x in
  eq_refl (a, b).

Definition ind_AxB {A B} C (g : ∀ x y, C (x, y)) (x : A * B) :=
  match uupt x return (C _ → C _) with
  | eq_refl _ => id
  end (g (AxB_pr₁ x) (AxB_pr₂ x)).

Theorem verif_ind_AxB_eq_def : ∀ A B C (g : ∀ x y, C (x, y)) (a : A) (b : B),
  ind_AxB C g (a, b) = g a b.
Proof. reflexivity. Qed.

Definition Σ_uupt {A B} (x : {y : A & B y}) :=
 let (a, b) return (existT _ (Σ_pr₁ x) (Σ_pr₂ x) = x) := x in
 eq_refl (existT _ a b).

Definition ind_Σ {A B} C (g : ∀ a (b : B a), C (existT _ a b))
    (x : {y : A & B y}) :=
  match Σ_uupt x with
  | eq_refl _ => id
  end (g (Σ_pr₁ x) (Σ_pr₂ x)).

Theorem verif_ind_Σ_eq_def : ∀ A B C g (a : A) (b : B),
  ind_Σ C g (existT _ a b) = g a b.
Proof. reflexivity. Qed.

(* Exercise 1.4. Assuming as given only the 'iterator' for natural numbers
         iter : Π (C : U) C → (C → C) → ℕ → C
   with the defining equations
             iter(C, c₀, cs, 0) :≡ c₀,
       iter(C, c₀, cs, succ(n)) :≡ cs(iter(C, c₀, cs, n)),

   derive a function having the type of the recursor rec_ℕ. Show that
   the defining equations of the recursor hold propositionally for this
   function, using the induction principle for ℕ. *)

Fixpoint iter {C} c₀ (cs : C → C) m :=
  match m with
  | 0 => c₀
  | S n => cs (iter c₀ cs n)
  end.

(* iter : ∀ C : Type, C → (C → C) → ℕ → C *)

(* iter C c₀ cs n ≡ cs (cs (cs (cs … (cs c₀)))) with 'n' cs *)
(* rec_ℕ C c₀ cs n ≡ cs n (cs (n-1) (cs (n-2) … (cs 0 c₀))) with 'n' cs *)

Definition iter_f {A B} (cs : _ → _ → B) (r : ℕ * A) :=
  (S (fst r), cs (fst r) (snd r)).

Definition rec_ℕ' {C} (c₀ : C) (cs : ℕ → C → C) (n : ℕ) :=
  snd (iter (0, c₀) (iter_f cs) n).

(*
Eval compute in rec_ℕ' nil (λ n l, cons n (cons 7 l)) 5.
*)

Theorem rec_ℕ_0 : ∀ C (c₀ : C) cs, rec_ℕ' c₀ cs 0 = c₀.
Proof. reflexivity. Qed.

Theorem rec_ℕ_succ : ∀ C (c₀ : C) cs n,
  rec_ℕ' c₀ cs (S n) = cs n (rec_ℕ' c₀ cs n).
Proof.
intros.
unfold rec_ℕ'; simpl; f_equal.
induction n; [ reflexivity | simpl ].
rewrite IHn; reflexivity.
Qed.

(* Exercise 1.5. Show that if we define A + B :≡ Σ (x:2) rec₂(U,A,B,x),
   then we can give a definition of ind_A+B for which the definitional
   equalities stated in §1.7 hold. *)

Notation "'Σ' ( x : A ) , B" :=
  ({ x : A & B }) (at level 0, x at level 0, B at level 100, only parsing).
Notation "'Π' ( x : A ) , B" :=
  (∀ x : A, B) (at level 0, x at level 0, B at level 100, only parsing).

Definition rec₂ C (c₀ c₁ : C) (b : bool) := if b then c₀ else c₁.

Definition ApB A B := Σ (x : bool), rec₂ Type A B x.

Definition ApB_inl (A B : Type) (a : A) := existT (rec₂ Type A B) true a.
Definition ApB_inr (A B : Type) (b : B) := existT (rec₂ Type A B) false b.

(* definition by tactics *)
Definition ind_ApB_1 {A B : Type} :
  Π (C : ApB A B → Type),
    (Π  (a : A), C (ApB_inl A B a)) →
    (Π  (b : B), C (ApB_inr A B b)) →
    Π (x : ApB A B), C x.
Proof.
intros C HA HB x.
induction x as (b, x).
destruct b; [ apply HA | apply HB ].
Qed.

(* same definition, by value *)
Definition ind_ApB_2 {A B : Type} (C : Π (_ : ApB A B), Type)
    (HA : Π (a : A), C (ApB_inl A B a))
    (HB : Π (b : B), C (ApB_inr A B b))
    (x : ApB A B) :=
  let (v, u) as s return (C s) := x in
  (if v return Π (z : _), C (existT _ v z) then HA else HB) u.

(* ind_ApB_1
     : Π (A : U),
       Π (B : U),
       Π (C : Π (_ : ApB A B), U),
       Π (_ : Π (a : A), C (ApB_inl A B a)),
       Π (_ : Π (b : B), C (ApB_inr A B b)), Π (x : ApB A B), C x *)
(* ind_ApB_2
     : Π (A : U),
       Π (B : U),
       Π (C : Π (_ : ApB A B), U),
       Π (_ : Π (a : A), C (ApB_inl A B a)),
       Π (_ : Π (b : B), C (ApB_inr A B b)), Π (x : ApB A B), C x *)

(* Exercise 1.6. Show that if we define AxB :≡ Π (x:2) rec₂(U,A,B,x),
   then we can give a definition of ind_AxB for which the definitional
   equalities stated in §1.5 hold propositionally (i.e. using equality
   types). (This requires the function extensionality axiom, which is
   introduced in §2.9.) *)

Definition AxB' A B := Π (x : bool), rec₂ Type A B x.

Definition AxB'_pair {A B} (a : A) (b : B) : AxB' A B :=
  λ x,
  match x return if x then A else B with
  | true => a
  | false => b
  end.

Definition AxB'_pr₁ {A B} (x : AxB' A B) : A := x true.
Definition AxB'_pr₂ {A B} (x : AxB' A B) : B := x false.

Axiom simple_function_extensionality : ∀ A B (f g : ∀ x : A, B x),
  (∀ x, f x = g x) → f = g.

(* when need of extensionality and its reverse, rather consider using
   Π_type.funext, defined later, than this function_extensionality as
   extensionality axiom *)

Theorem AxB'_pair_proj {A B} : ∀ x : AxB' A B,
  AxB'_pair (AxB'_pr₁ x) (AxB'_pr₂ x) = x.
Proof.
intros x.
apply simple_function_extensionality.
intros b.
destruct b; reflexivity.
Qed.

(* definition by tactics *)
Definition ind_AxB'_1 {A B : Type} :
  Π (C : AxB' A B → Type),
    (Π  (x : A), Π  (y : B), C (AxB'_pair x y))
    →  Π (x : AxB' A B), C x.
Proof.
intros C H x.
pose proof AxB'_pair_proj x as Hx.
rewrite <- Hx; apply H.
Qed.

(* same definition, by value *)
Definition ind_AxB'_2 {A B : Type} C
     (H : Π (x : A), Π (y : B), C (AxB'_pair x y)) x :=
  match AxB'_pair_proj x in (_ = y) return (C y) with
  | eq_refl _ => H (AxB'_pr₁ x) (AxB'_pr₂ x)
  end.

(* ind_AxB'_1
     : Π (A : Type),
       Π (B : Type),
       Π (C : Π (_ : AxB' A B), Type),
       Π (_ : Π (x : A), Π (y : B), C (AxB'_pair x y)), Π (x : AxB' A B), C x
*)
(* ind_AxB'_2
     : Π (A : Type),
       Π (B : Type),
       Π (C : Π (_ : AxB' A B), Type),
       Π (_ : Π (x : A), Π (y : B), C (AxB'_pair x y)), Π (x : AxB' A B), C x
*)

(* Exercise 1.7. Give an alternative derivation of ind'_=A from ind_=A
   which avoids the use of universes. (This is easiest using concepts
   from later chapters.) *)

(* definition from §1.12.1 *)
Definition ind_eqA {A} :
  Π (C : Π (x : A), Π (y : A), (x = y) → Type),
    (Π (x : A), C x x (eq_refl x))
    → Π (x : A), Π (y : A), Π (p : x = y), C x y p
  := λ C c x y p,
     match p with
     | eq_refl _ => c x
     end.

Theorem ind_eqA_def_eq {A} : ∀ C c (x : A), ind_eqA C c x x (eq_refl x) = c x.
Proof. reflexivity. Qed.

(* definition from §1.12.1 *)
Definition ind'_eqA {A} :
  Π (a : A),
  Π (C : Π (x : A), (a = x) → Type), C a (eq_refl a)
  → Π (x : A), Π (p : a = x), C x p
  := λ a C P x p,
     match p with
     | eq_refl _ => λ _ y, y
     end C P.

Theorem ind'_eqA_def_eq {A} : ∀ (a : A) C c, ind'_eqA a C c a (eq_refl a) = c.
Proof. reflexivity. Qed.

(* alternative definition from ind_eqA *)
Definition ind'_eqA_bis {A} :
  Π (a : A),
  Π (C : Π (x : A), (a = x) → Type), C a (eq_refl a)
  → Π (x : A), Π (p : a = x), C x p.
Proof.
Abort. (* not obvious, see that later *)

(* exercise abandoned... *)

(* Exercise 1.8. Define multiplication and exponentiation using rec_ℕ.
   Verify that (ℕ, +, 0, ×, 1) is a semiring using only ind_ℕ. You will
   probably also need to use symmetry and transitivity of equality,
   Lemmas 2.1.1 and 2.1.2. *)

(* doing more: playing with hypeoperations... *)
Definition ℕ_add x := rec_ℕ' x (λ _, S).
Definition ℕ_mul x := rec_ℕ' 0 (λ _, ℕ_add x).
Definition ℕ_exp x := rec_ℕ' 1 (λ _, ℕ_mul x).
Definition ℕ_tet x := rec_ℕ' 1 (λ _, ℕ_exp x).
Definition ℕ_pen x := rec_ℕ' 1 (λ _, ℕ_tet x).

(*
Eval vm_compute in (ℕ_add 3 7).
Eval vm_compute in (ℕ_mul 3 7).
Eval vm_compute in (ℕ_exp 2 9).
Eval vm_compute in (ℕ_tet 2 3).
*)

Fixpoint ind_ℕ (C : ℕ → Type) P0 Pn n :=
  match n return C n with
  | 0 => P0
  | S n' => Pn n' (ind_ℕ C P0 Pn n')
  end.

Theorem ℕ_add_comm : ∀ x y, ℕ_add x y = ℕ_add y x.
Proof.
intros.
revert y.
apply ind_ℕ with (n := x).
 intros y.
 apply ind_ℕ with (n := y); [ reflexivity | idtac ].
 clear x y; intros x y.
 unfold ℕ_add; simpl.
 unfold rec_ℕ'; simpl; f_equal.
 assumption.

 clear x; intros x IHx y.
 unfold ℕ_add; simpl.
 unfold rec_ℕ'; simpl; f_equal.
 unfold ℕ_add in IHx.
 unfold rec_ℕ' in IHx; rewrite <- IHx.
 apply ind_ℕ with (n := y); [ reflexivity | simpl ].
 clear y; intros y IHy; f_equal.
 apply IHy.
Qed.

(* bon, mais après ça, j'arrête cet exo paskeu j'ai déjà fait des
   preuves de ce genre, c'est long et casse-couilles *)

(* Exercise 1.9. Define the type family Fin : ℕ → Type mentioned at the
   end of §1.3, and the dependent function fmax: Π (n : ℕ) Fin(n + 1)
   mentioned in §1.4. *)

Inductive Fin n := elem : ∀ i, i < n → Fin n.
Definition fmax n := elem (n + 1) n (Nat.lt_add_pos_r 1 n Nat.lt_0_1).

(* fmax
     : ∀ n : ℕ, Fin (n + 1) *)

(* Exercise 1.10. Show that the Ackermann function ack : ℕ → ℕ → ℕ
   is definable using only rec_ℕ satisfying the following equations:
                 ack(0,n) ≡ succ(n),
           ack(succ(m),0) ≡ ack(m,1),
      ack(succ(m),succ(n) ≡ ack(m,ack(succ(m),n)). *)

Fixpoint rec_ℕ {C} (c₀ : C) cs n :=
  match n with
  | 0 => c₀
  | S n' => cs n (rec_ℕ c₀ cs n')
  end.

Fixpoint ack m n :=
  match m with
  | 0 => S n
  | S m' => rec_ℕ (ack m' 1) (λ n r, ack m' r) n
  end.

(* not sure it is what is required since a Fixpoint is used even so
   and two recursive calls but I don't know how to do it without
   Fixpoint at all (i.e. using Definition) and only rec_ℕ (perhaps
   two rec_ℕs, one for m and one for n). However this rec_ℕ is
   mandatory, otherwise Coq would not accept a recursive call with
   (S m) in"ack (S m) n": what means that the simple definition of
   ack with Fixpoint and recursive calls cannot be written in Coq *)

Theorem ack_0 : ∀ n, ack 0 n = S n.
Proof. reflexivity. Qed.

Theorem ack_succ_0 : ∀ m, ack (S m) 0 = ack m 1.
Proof. reflexivity. Qed.

Theorem ack_succ_succ : ∀ m n, ack (S m) (S n) = ack m (ack (S m) n).
Proof. reflexivity. Qed.

(* Exercise 1.11. Show that for any type A, we have ¬¬¬A → ¬A *)

(* solution with tactics *)
Theorem not_not_not_1 : ∀ A, ¬¬¬A → ¬A.
Proof.
intros A Hnnn a.
apply Hnnn; intros HnA.
apply HnA; assumption.
Qed.

(* solution with proof term *)
Definition not_not_not_2 A (Hnnn : ¬¬¬A) : ¬A := λ a, Hnnn (λ HnA, HnA a).

(* this was on Prop; solutions on Types: *)

(* with tactics *)
Theorem not_not_not_3 : ∀ A, notT (notT (notT A)) → notT A.
Proof.
intros A Hnnn a.
apply Hnnn; intros HnA.
apply HnA; assumption.
Qed.

(* with proof term *)
Definition not_not_not_4 A (Hnnn : notT (notT (notT A))) : notT A :=
  λ a, Hnnn (λ HnA, HnA a).

(* Exercise 1.12. Using the propositions as types interpretation,
   derive the following tautologies.
     (i) If A, then (if B then A).
    (ii) If A, then not (not A).
   (iii) If (not A or not B), then not (A and B). *)

Inductive andT A B := conjT : A → B → andT A B.
Inductive orT A B :=
  | orT_introl : A → orT A B
  | orT_intror : B → orT A B.

Definition hott_ex_1_12_i : ∀ A B, A → B → A := λ A B HA HB, HA.
Definition hott_ex_1_12_ii : ∀ A, A → notT (notT A) := λ A HA HnA, HnA HA.
Definition hott_ex_1_12_iii : ∀ A B, orT (notT A) (notT B) → notT (andT A B) :=
  λ A B Hor Hand,
  match Hor with
  | orT_introl _ _ Hna => Hna (andT_rect A B (λ _, A) (λ a _, a) Hand)
  | orT_intror _ _ Hnb => Hnb (andT_rect A B (λ _, B) (λ _ b, b) Hand)
  end.

(* Exercise 1.13. Using propositions-as-types, derive the double negation
   of the principle of excluded middle, i.e. prove not (not (P or not P)). *)

Definition hott_ex_1_13 : (∀ P, orT P (notT P))
    → ∀ P, notT (notT (orT P (notT P)))
  := λ Hem P Hno, Hno (Hem P).

(* Exercise 1.14. Why do the induction principles for identity types
   not allow us to construct a function f : Π (x:A) Π (p:x=x) (p=eq_refl x)
   with the defining equation
          f(x,eq_refl_x) :≡ eq_refl_{eq_refl_x}    ? *)

(* Wrong explanation: I suppose it is because if there is y such that
   x = y, then there is another proof that x = x, because x = y
   implies y = x by symmetry and x = x, by transitivity, which creates
   another proof that x = x, ...
   ... which is different from eq_refl <- no, it is equal! *)

(* not sure *)

(* à voir... *)

(* Exercise 1.15. Show that indiscernability of identicals follows
   from path induction. *)

Definition path_induction {A} (C : Π (x : A), Π (y : A), Π (p : x = y), Type)
    (c : Π (x : A), C x x (eq_refl x)) (x y : A) (p : x = y) : C x y p :=
  match p return (C _ _ p) with
  | eq_refl _ => c x
  end.

Theorem path_induction_def : ∀ A (x : A) C c,
  path_induction C c x x (eq_refl x) = c x.
Proof. reflexivity. Qed.

Theorem path_induction_indiscernability {A} :
  Π (C : A → Type), Π (x : A), Π (y : A), x = y → C x → C y.
Proof.
intros C x y p px.
apply (path_induction (λ x y _, C x → C y) (λ _, id) x y p).
assumption.
Qed.


Require Export Iron.Language.SimpleData.ExpBase.
Require Export Iron.Language.SimpleData.ExpLift.
Require Export Iron.Language.SimpleData.ExpSubst.
Require Export Iron.Language.SimpleData.ExpAlt.

(* Weak normal forms cannot be reduced further by
   call-by-value evaluation. *)
Inductive wnfX : exp -> Prop :=
 | Wnf_XVar
   : forall i
   , wnfX (XVar i)

 | Wnf_XLam
   : forall t1 x2
   , wnfX (XLam t1 x2)

 | Wnf_XCon
   :  forall dc xs
   ,  Forall wnfX xs
   -> wnfX (XCon dc xs).
Hint Constructors wnfX.

(* Well formed expressions are closed under the given environment. *)
Inductive wfX : tyenv -> exp -> Prop :=
 | WfX_XVar
   :  forall te i
   ,  (exists t, get i te = Some t)
   -> wfX te (XVar i)

 | WfX_XLam
   :  forall te t x
   ,  wfX (te :> t) x
   -> wfX te (XLam t x)

 | WfX_XApp
   :  forall te x1 x2
   ,  wfX te x1 -> wfX te x2
   -> wfX te (XApp x1 x2)

 | WfX_XCon
   :  forall te dc xs
   ,  Forall (wfX te) xs
   -> wfX te (XCon dc xs)

 | WfX_XCase
   :  forall te x alts
   ,  wfX te x
   -> Forall (wfA te) alts
   -> wfX te (XCase x alts)

with    wfA : tyenv -> alt -> Prop :=
 | WfA_AAlt
   :  forall te dc ds ts x tsArgs tResult
   ,  getDataDef dc ds = Some (DefData dc tsArgs tResult)
   -> wfX (te >< tsArgs) x
   -> wfA te (AAlt dc ts x).

Hint Constructors wfX.
Hint Constructors wfA.

(* Closed expressions are well formed under an empty environment. *)
Definition closedX (xx: exp) : Prop
 := wfX nil xx.
Hint Unfold closedX.

(* Values are closed expressions that cannot be reduced further. *)
Inductive value : exp -> Prop :=
 | Value
   :  forall xx
   ,  wnfX xx -> closedX xx
   -> value xx.
Hint Constructors value.

Lemma value_wnfX
 : forall xx, value xx -> wnfX xx.
 Proof. intros. inverts H. auto. Qed.
Hint Resolve value_wnfX.

Lemma value_closedX
 : forall xx, value xx -> closedX xx.
 Proof. intros. inverts H. auto. Qed.
Hint Resolve value_closedX.

Lemma value_wnfXs_XCon
 : forall xs dc
 , value (XCon dc xs) -> Forall wnfX xs.
Proof.
 intros. inverts H. inverts H0. auto.
Qed.
Hint Resolve value_wnfXs_XCon.

Lemma value_closedXs_XCon
 : forall xs dc
 , value (XCon dc xs) -> Forall closedX xs.
Proof.
 intros. inverts H. inverts H1. auto.
Qed.
Hint Resolve value_closedXs_XCon.


Require Import Utf8.
Require Import List.
Require Import IxFree.Base IxFree.Connectives IxFree.Relations.
Require Import IxFree.UnaryFixpoint IxFree.BinaryFixpoint IxFree.TernaryFixpoint.
Require Import IxFree.RelationCurry.
Require Import IxFree.Contractive.

Require Import Arith.

Module Private.

Lemma contractive_curry (l : list Type) :
  ∀ (f : IRel l → IRel l), contractive l f →
  contractive (Prod l :: nil)
    (λ R, IRel_uncurry _ (f (IRel_curry _ R))).
Proof.
unfold contractive; intros f Hcon R₁ R₂ n.
iintro HR.
iapply (IRel_uncurry_equiv l (f (IRel_curry l R₁)) (f (IRel_curry l R₂)) n).
iapply (Hcon (IRel_curry l R₁) (IRel_curry l R₂) n).
later_shift.
iapply (IRel_curry_equiv l R₁ R₂ n); assumption.
Qed.

Lemma contractive_unary {A : Type} (f : IRel_1 A → IRel_1 A) :
  contractive (A :: nil) f → contractive_1 f.
Proof.
unfold contractive; unfold contractive_1.
intros Hcon n R₁ R₂ H x.
specialize (Hcon R₁ R₂ n); ispecialize Hcon.
+ later_shift.
  iintro x'.
  apply I_iff_intro_M; intros; apply H.
  apply le_lt_n_Sm; assumption.
+ simpl in Hcon.
  apply I_iff_elim_M; iapply Hcon.
Qed.

Lemma contractive_conv (l : list Type) (f : IRel l → IRel l) :
  contractive l f → contractive_1 (λ R, IRel_uncurry _ (f (IRel_curry _ R))).
Proof.
  intros; apply contractive_unary; apply contractive_curry; assumption.
Qed.

End Private.

Definition I_fix (l : list Type) (f : IRel l → IRel l)
    (p : contractive l f) : IRel l :=
  IRel_curry l (I_fix_1
    (λ R, IRel_uncurry l (f (IRel_curry l R)))
    (Private.contractive_conv l f p)
  ).

Lemma I_fix_unroll (l : list Type)
    (f : IRel l → IRel l) (p : contractive l f) :
  I_fix l f p ≾ᵣ f (I_fix l f p).
Proof.
unfold I_fix; simpl.
apply IRel_uncurry_subrel; simpl; intros x n H.
apply (I_fix_1_unroll (λ R, IRel_uncurry l (f (IRel_curry l R)))).
apply IRel_uncurry_curry_id; assumption.
Qed.

Lemma I_fix_roll (l : list Type)
    (f : IRel l → IRel l) (p : contractive l f) :
  f (I_fix l f p) ≾ᵣ I_fix l f p.
Proof.
unfold I_fix; simpl.
apply IRel_uncurry_subrel; simpl; intros x n H.
apply IRel_uncurry_curry_id.
apply (I_fix_1_roll (λ R, IRel_uncurry l (f (IRel_curry l R)))).
assumption.
Qed.

Module Private_x.

Lemma contractive_x_curry {A : Type} (P : A → list Type) :
  ∀ (f : IRel_x P → IRel_x P), contractive_x P f →
  contractive_x (λ x, Prod (P x) :: nil)
    (λ R, IRel_x_uncurry _ (f (IRel_x_curry _ R))).
Proof.
  unfold contractive_x.
  intros f Hcon R₁ R₂ n.
  iintro HR.
  iapply (IRel_x_uncurry_equiv _ (f (IRel_x_curry _ R₁)) (f (IRel_x_curry _ R₂)) n).
  iapply (Hcon (IRel_x_curry _ R₁) (IRel_x_curry _ R₂) n).
  later_shift.
  iapply (IRel_x_curry_equiv _ R₁ R₂ n); assumption.
Qed.

Lemma contractive_binary {A : Type} {P : A → Type} (f : IRel_2 P → IRel_2 P) :
  contractive_x (λ x, P x :: nil) f → contractive_2 f.
Proof.
  unfold contractive_x; unfold contractive_2.
  intros Hcon n R₁ R₂ H x y.
  specialize (Hcon R₁ R₂ n); ispecialize Hcon.
  + later_shift.
    iintro x' ; iintro y'.
    apply I_iff_intro_M; intros; apply H.
    apply le_lt_n_Sm; assumption.
  + simpl in Hcon.
    apply I_iff_elim_M.
    iespecialize Hcon.
    apply Hcon.
Qed.

Lemma contractive_x_conv {A : Type} (P : A → list Type) (f : IRel_x P → IRel_x P) :
  contractive_x P f → contractive_2 (λ R, IRel_x_uncurry _ (f (IRel_x_curry _ R))).
Proof.
  intros; apply contractive_binary; apply contractive_x_curry; assumption.
Qed.

End Private_x.

Program Definition I_fix_x {A : Type} (P : A → list Type) (f : IRel_x P → IRel_x P)
    (H : contractive_x P f) : IRel_x P :=
  IRel_x_curry _ (I_fix_2
    (λ R, IRel_x_uncurry _ (f (IRel_x_curry _ R)))
    (Private_x.contractive_x_conv _ f H)
  ).

Lemma I_fix_x_unroll {A : Type} (P : A → list Type)
    (f : IRel_x P → IRel_x P) (H : contractive_x _ f) :
  subrel_x _ (I_fix_x _ f H) (f (I_fix_x _ f H)).
Proof.
  unfold I_fix_x; simpl.
  apply IRel_x_uncurry_subrel; simpl ; intros x y n H'.
  apply (I_fix_2_unroll (λ R, IRel_x_uncurry _ (f (IRel_x_curry _ R)))).
  apply IRel_uncurry_curry_id; assumption.
Qed.

Lemma I_fix_x_roll {A : Type} (P : A → list Type)
    (f : IRel_x P → IRel_x P) (H : contractive_x _ f) :
  subrel_x _ (f (I_fix_x _ f H)) (I_fix_x _ f H).
Proof.
  unfold I_fix; simpl.
  apply IRel_x_uncurry_subrel; simpl; intros x y n H'.
  apply IRel_uncurry_curry_id.
  apply (I_fix_2_roll (λ R, IRel_x_uncurry _ (f (IRel_x_curry _ R)))).
  assumption.
Qed.

Module Private_xx.

Lemma contractive_xx_curry {A B : Type} (P : A → B → list Type) :
  ∀ (f : IRel_xx P → IRel_xx P), contractive_xx P f →
  contractive_xx (λ x y, Prod (P x y) :: nil)
    (λ R, IRel_xx_uncurry _ (f (IRel_xx_curry _ R))).
Proof.
  unfold contractive_xx.
  intros f Hcon R₁ R₂ n.
  iintro HR.
  iapply (IRel_xx_uncurry_equiv _ (f (IRel_xx_curry _ R₁)) (f (IRel_xx_curry _ R₂)) n).
  iapply (Hcon (IRel_xx_curry _ R₁) (IRel_xx_curry _ R₂) n).
  later_shift.
  iapply (IRel_xx_curry_equiv _ R₁ R₂ n); assumption.
Qed.

Lemma contractive_binary {A B : Type} {P : A → B → Type} (f : IRel_3 P → IRel_3 P) :
  contractive_xx (λ x y, P x y :: nil) f → contractive_3 f.
Proof.
  unfold contractive_xx; unfold contractive_3.
  intros Hcon n R₁ R₂ H x y z.
  specialize (Hcon R₁ R₂ n); ispecialize Hcon.
  + later_shift.
    iintro x' ; iintro y' ; iintro z'.
    apply I_iff_intro_M; intros; apply H.
    apply le_lt_n_Sm; assumption.
  + simpl in Hcon.
    apply I_iff_elim_M.
    iespecialize Hcon.
    apply Hcon.
Qed.

Lemma contractive_xx_conv {A B : Type} (P : A → B → list Type) (f : IRel_xx P → IRel_xx P) :
  contractive_xx P f → contractive_3 (λ R, IRel_xx_uncurry _ (f (IRel_xx_curry _ R))).
Proof.
  intros; apply contractive_binary; apply contractive_xx_curry; assumption.
Qed.

End Private_xx.

Program Definition I_fix_xx {A B : Type} (P : A → B → list Type) (f : IRel_xx P → IRel_xx P)
    (H : contractive_xx P f) : IRel_xx P :=
  IRel_xx_curry _ (I_fix_3
    (λ R, IRel_xx_uncurry _ (f (IRel_xx_curry _ R)))
    (Private_xx.contractive_xx_conv _ f H)
  ).

Lemma I_fix_xx_unroll {A B : Type} (P : A → B → list Type)
    (f : IRel_xx P → IRel_xx P) (H : contractive_xx _ f) :
  subrel_xx _ (I_fix_xx _ f H) (f (I_fix_xx _ f H)).
Proof.
  unfold I_fix_xx; simpl.
  apply IRel_xx_uncurry_subrel; simpl ; intros x y z n H'.
  apply (I_fix_3_unroll (λ R, IRel_xx_uncurry _ (f (IRel_xx_curry _ R)))).
  apply IRel_uncurry_curry_id; assumption.
Qed.

Lemma I_fix_xx_roll {A B : Type} (P : A → B → list Type)
    (f : IRel_xx P → IRel_xx P) (H : contractive_xx _ f) :
  subrel_xx _ (f (I_fix_xx _ f H)) (I_fix_xx _ f H).
Proof.
  unfold I_fix; simpl.
  apply IRel_xx_uncurry_subrel; simpl; intros x y z n H'.
  apply IRel_uncurry_curry_id.
  apply (I_fix_3_roll (λ R, IRel_xx_uncurry _ (f (IRel_xx_curry _ R)))).
  assumption.
Qed.


Set Implicit Arguments.
Require Import GMuAnnot.Prelude.
Require Import GMuAnnot.InfrastructureFV.
Require Import GMuAnnot.InfrastructureOpen.
Require Import GMuAnnot.InfrastructureSubst.
Require Import TLC.LibLogic.
Require Import TLC.LibLN.

Lemma subst_ttΘ_fresh : forall Θ T,
  substitution_sources Θ \n fv_typ T = \{} ->
  subst_tt' T Θ = T.
  induction Θ as [| [A U] Θ].
  - cbn. auto.
  - introv Fr.
    cbn in Fr.
    fold (from_list (List.map fst Θ)) in Fr.
    fold (substitution_sources Θ) in Fr.
    rewrite union_distributes in Fr.
    lets [FrA FrT]: union_empty Fr.
    cbn.
    rewrite subst_tt_fresh.
    + apply~ IHΘ.
    + eapply empty_inter_implies_notin.
      * apply FrA.
      * apply in_singleton_self.
Qed.

Lemma subst_tt_inside : forall Θ A P T,
    A \notin substitution_sources Θ ->
    (forall X U, List.In (X, U) Θ -> A \notin fv_typ U) ->
    subst_tt' (subst_tt A P T) Θ
    =
    subst_tt A (subst_tt' P Θ) (subst_tt' T Θ).
  induction Θ as [| [X U] Θ]; introv ThetaFr UFr; cbn; trivial.
  rewrite <- IHΘ.
  - f_equal.
    rewrite~ subst_commute.
    + cbn in ThetaFr.
      rewrite notin_union in ThetaFr.
      destruct~ ThetaFr.
    + eauto with listin.
  - cbn in ThetaFr.
    fold (from_list (List.map fst Θ)) in ThetaFr.
    fold (substitution_sources Θ) in ThetaFr.
    auto.
  - eauto with listin.
Qed.

Lemma subst_tt_prime_reduce_typ_all : forall O T,
    subst_tt' (typ_all T) O = typ_all (subst_tt' T O).
  induction O as [| [A U]]; cbn; auto.
Qed.

Lemma subst_tt_prime_reduce_tuple : forall O T1 T2,
    subst_tt' (T1 ** T2) O = subst_tt' T1 O ** subst_tt' T2 O.
  induction O as [| [A U]]; cbn; auto.
Qed.

Lemma subst_tt_prime_reduce_arrow : forall O T1 T2,
    subst_tt' (T1 ==> T2) O = subst_tt' T1 O ==> subst_tt' T2 O.
  induction O as [| [A U]]; cbn; auto.
Qed.

Lemma subst_tt_prime_reduce_typ_gadt : forall O Ts N,
    subst_tt' (typ_gadt Ts N) O = typ_gadt (List.map (fun T => subst_tt' T O) Ts) N.
  induction O as [| [A U]]; introv; cbn; auto.
  - rewrite~ List.map_id.
  - rewrite IHO.
    f_equal.
    rewrite List.map_map. auto.
Qed.

Lemma subst_tt_prime_reduce_typ_unit : forall O,
    subst_tt' (typ_unit) O = typ_unit.
  induction O as [| [A U]]; cbn; auto.
Qed.

Lemma subst_ttprim_open_tt : forall O T U,
  (forall A P, List.In (A, P) O -> type P) ->
  subst_tt' (open_tt T U) O
  =
  open_tt (subst_tt' T O) (subst_tt' U O).
  induction O as [| [X P]]; introv TP; cbn; auto.
  rewrite subst_tt_open_tt; eauto with listin.
Qed.


(*** Subset types *)
(** A couple functions for creating values/lists of subset types and
    some lemmas about them. *)

Set Implicit Arguments.
Unset Strict Implicit.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Require Import ProofIrrelevance.

Definition to_sigma A (f : A -> bool) (x : A) : option {x : A | f x} :=
  (match f x return f x = _ -> option {x : A | f x} with
   | false => fun _ => None
   | true => fun pf => Some (exist f x pf)
   end) erefl.

Fixpoint filter_sigma A (f : A -> bool) (l : seq A) : seq {x : A | f x} :=
  match l with
  | nil => nil
  | h :: t =>
    match to_sigma f h with
    | Some x => x :: filter_sigma f t
    | None => filter_sigma f t
    end
  end.

Lemma to_sigma_true_Some A (f : A -> bool) x :
  f x = true ->
  exists x', to_sigma f x = Some x'.
Proof.
  rewrite /to_sigma.
  move: (exist (fun x0 => f x0) x).
  case: (f x) => //.
    by move => s pf; exists (s erefl).
Qed.

Lemma to_sigma_inj (A : finType) (f : A -> bool) a b :
  to_sigma f a = Some b ->
  a = proj1_sig b.
Proof.
  rewrite /to_sigma.
  have H: forall pf', (proj1_sig (exist (fun x => f x) a pf') = a) by [].
  move: H.
  move: (exist (fun x => f x) a).
  case: (f a) => // s H; case.
    by rewrite -(H (erefl true)) => ->.
Qed.

Lemma to_sigma_None_false A (f : A -> bool) (a : A) :
  to_sigma f a = None ->
  f a = false.
Proof.
  move=> H. destruct (f a) eqn:Hf => //.
  have H0: (exists a', to_sigma f a = some a').
  { by apply to_sigma_true_Some, Hf. }
  destruct H0 as [a']. rewrite H in H0. inversion H0.
Qed.

Lemma mem_seq_filter
      (A : finType) (f : A -> bool) (x : A) (x' : {x : A | f x}) l :
  to_sigma f x = Some x' ->
  mem_seq (filter_sigma f l) x' ->
  mem_seq l x.
Proof.
  move=> H0 H1. induction l. inversion H1.
  simpl in H1. destruct (to_sigma f a) eqn:Hs.
  move: H1=> /orP [H1 | H1]. apply /orP. left.
  move: H1=> /eqP H1. subst.
  apply to_sigma_inj in Hs. apply to_sigma_inj in H0. subst => //.
  apply /orP. right. apply IHl; assumption.
  apply /orP. right. apply IHl; assumption.
Qed.

Lemma projT1_inj A (f : A -> bool) (a b : {x : A | f x}) :
  proj1_sig a = proj1_sig b ->
  a = b.
Proof.
  case: a; case: b=> /= x p x0 p0 H.
  by subst; f_equal; apply proof_irrelevance.
Qed.

Lemma projT1_pred_true A (f : A -> bool) (a : A) (b : {x : A | f x}) :
  a = proj1_sig b ->
  f a = true.
Proof. by case: b=> /= x H0 H1; rewrite H1 H0. Qed.

Lemma list_in_filter_sigma
      (A : finType) (f : A -> bool) (x : {x : A | f x}) (l : seq A) :
  List.In (proj1_sig x) l ->
  List.In x (filter_sigma f l).
Proof.
  move=> H. induction l. inversion H.
  simpl. simpl in H. destruct H as [H | H].
  - destruct (to_sigma f a) eqn:Hs.
    + simpl. apply to_sigma_inj in Hs. left. rewrite H in Hs.
      apply projT1_inj in Hs. by rewrite Hs.
    + apply projT1_pred_true in H. apply to_sigma_None_false in Hs.
      congruence.
  - destruct (to_sigma f a) eqn:Hs; try right; apply IHl; assumption.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Finite sets                                                             *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibList.
Require Import LibSet LibLogic LibEqual LibReflect.

(** DISCLAIMER: under construction *)

(* ********************************************************************** *)
(** * Abstract interface for finite sets *)

Module Type FsetSig.

(** Definitions and operations on finite sets *)

Section Operations.
Variables (A:Type).

Parameter fset : Type -> Type.
Parameter mem : A -> fset A -> Prop.
Parameter empty : fset A.
Parameter singleton : A -> fset A.
Parameter union : fset A -> fset A -> fset A.
Parameter inter : fset A -> fset A -> fset A.
Parameter remove : fset A -> fset A -> fset A.

(** Equality on these sets is extensional *)

Definition subset E F :=
  forall x, mem x E -> mem x F.

Definition notin x E :=
  ~ mem x E.

Definition disjoint E F :=
  inter E F = empty.

Definition from_list L :=
  fold_right (fun x acc => union (singleton x) acc) empty L.

End Operations.

Arguments empty {A}.

(** Notations *)

Notation "\{}" := (empty) : fset_scope.

Notation "\{ x }" := (singleton x) : fset_scope.

Notation "E \u F" := (union E F)
  (at level 37, right associativity) : fset_scope.

Notation "E \n F" := (inter E F)
  (at level 36, right associativity) : fset_scope.

Notation "E \- F" := (remove E F)
  (at level 35) : fset_scope.

Notation "x \in E" := (mem x E) (at level 39) : fset_scope.

Notation "x \notin E" := (notin x E) (at level 39) : fset_scope.

Notation "E \c F" := (subset E F)
  (at level 38) : fset_scope.

Delimit Scope fset_scope with fset.
Bind Scope fset_scope with fset.
Open Scope fset_scope.

Section Properties.
Variables A : Type.
Implicit Types x : A.
Implicit Types E : fset A.

(** Extensionality *)

Parameter fset_extens : forall E F,
  subset E F -> subset F E -> E = F.

(** Finiteness *)

Parameter fset_finite : forall E,
  exists L, E = from_list L.

(** Semantics of basic operations *)

Parameter in_empty : forall x,
  x \in \{} = False.

Parameter in_singleton : forall x y,
  x \in \{y} = (x = y).

Parameter in_union : forall x E F,
  x \in (E \u F) = ((x \in E) \/ (x \in F)).

Parameter in_inter : forall x E F,
  x \in (E \n F) = ((x \in E) /\ (x \in F)).

Parameter in_remove : forall x E F,
  x \in (E \- F) = ((x \in E) /\ (x \notin F)).

End Properties.

End FsetSig.

(* ********************************************************************** *)
(** * Implementation of finite sets *)

Module Export FsetImpl : FsetSig.

(** Note: most of the material contained in this module will ultimately
    be moved into the TLC library in a file called LibFset. *)

Close Scope container_scope.

Definition finite A (U:set A) :=
  exists L, forall x, is_in x U -> Mem x L.

Definition fset A := sig (@finite A).

Definition build_fset A (U:set A) (F:finite U) :=
  exist (@finite A) U F.

Section Operations.
Variables (A:Type).

Definition mem (x:A) (E:fset A) :=
  is_in x (proj1_sig E).

Lemma finite_empty : @finite A LibBag.empty.
Proof using. exists (@nil A). intros x. rewrite in_empty_eq. auto_false. Qed.

Definition empty : fset A :=
  build_fset finite_empty.

Lemma singleton_finite : forall (x:A),
  finite (LibBag.single x).
Proof using.
  intros. exists (x::nil). intros y.
  rewrite in_single_eq. intro_subst. constructor.
Qed.

Definition singleton (x : A) :=
  build_fset (singleton_finite x).

Lemma union_finite : forall U V : set A,
  finite U -> finite V -> finite (union U V).
Proof using.
  introv [L1 E1] [L2 E2]. exists (L1 ++ L2). intros x.
  rewrite in_union_eq. rewrite Mem_app_or_eq. introv [H|H]; auto.
Qed.

Definition union (E F : fset A) :=
  build_fset (union_finite (proj2_sig E) (proj2_sig F)).

Lemma inter_finite : forall U V : set A,
  finite U -> finite V -> finite (inter U V).
Proof using.
  introv [L1 E1] [L2 E2]. exists (L1 ++ L2). intros x.
  rewrite in_inter_eq. rewrite Mem_app_or_eq. autos*.
Qed.

Definition inter (E F : fset A) :=
  build_fset (inter_finite (proj2_sig E) (proj2_sig F)).

Lemma remove_finite : forall U V : set A,
  finite U -> finite V -> finite (remove U V).
Proof using.
  introv [L1 E1] [L2 E2]. exists L1. intros x.
  rewrite in_remove_eq. introv [H1 H2]; auto.
Qed.

Definition remove (E F : fset A) :=
  build_fset (remove_finite (proj2_sig E) (proj2_sig F)).

Definition subset E F :=
  forall x, mem x E -> mem x F.

Definition notin x E :=
  ~ mem x E.

Definition disjoint E F :=
  inter E F = empty.

Definition from_list L :=
  fold_right (fun x acc => union (singleton x) acc) empty L.

End Operations.

Arguments empty {A}.

(** Notations *)

Notation "\{}" := (empty) : fset_scope.

Notation "\{ x }" := (singleton x) : fset_scope.

Notation "E \u F" := (union E F)
  (at level 37, right associativity) : fset_scope.

Notation "E \n F" := (inter E F)
  (at level 36, right associativity) : fset_scope.

Notation "E \- F" := (remove E F)
  (at level 35) : fset_scope.

Notation "x \in E" := (mem x E) (at level 39) : fset_scope.

Notation "x \notin E" := (notin x E) (at level 39) : fset_scope.

Notation "E \c F" := (subset E F)
  (at level 38) : fset_scope.

Delimit Scope fset_scope with fset.
Bind Scope fset_scope with fset.
Open Scope fset_scope.

Section Properties.
Variables A : Type.
Implicit Types x : A.
Implicit Types E : fset A.

Lemma fset_extens_eq : forall E F,
  (forall x, x \in E = x \in F) -> E = F.
Proof using.
  unfold mem. intros [U FU] [V FV] H. simpls.
  apply exist_eq. apply in_extens. intros. rewrite* H.
Qed.

Lemma fset_extens : forall E F,
  subset E F -> subset F E -> E = F.
Proof using. intros. apply fset_extens_eq. extens*. Qed.

Lemma in_empty : forall x,
  x \in \{} = False.
Proof using. unfold mem, empty. simpl. intros. rewrite in_empty_eq. autos*. Qed.

Lemma in_singleton : forall x y,
  x \in \{y} = (x = y).
Proof using. unfold mem, singleton. simpl. intros. rewrite in_single_eq. autos*. Qed.

Lemma in_union : forall x E F,
  x \in (E \u F) = ((x \in E) \/ (x \in F)).
Proof using. unfold mem, union. simpl. intros. rewrite in_union_eq. autos*. Qed.

Lemma in_inter : forall x E F,
  x \in (E \n F) = ((x \in E) /\ (x \in F)).
Proof using. unfold mem, inter. simpl. intros. rewrite in_inter_eq. autos*. Qed.

Lemma in_remove : forall x E F,
  x \in (E \- F) = ((x \in E) /\ (x \notin F)).
Proof using. unfold mem, remove. simpl. intros. rewrite in_remove_eq. autos*. Qed.

Lemma from_list_spec : forall x L,
  x \in from_list L = Mem x L.
Proof using.
  unfold from_list. induction L; rew_list.
  rewrite in_empty. rewrite~ Mem_nil_eq.
  rewrite in_union, in_singleton. rewrite~ Mem_cons_eq. congruence.
Qed.

Hint Constructors Mem.

Lemma fset_finite : forall E,
  exists L, E = from_list L.
Proof using.
  intros [U [L' H]]. exists (filter (fun x => isTrue (is_in x U)) L').
  apply fset_extens_eq. intros x. rewrite from_list_spec.
  unfold mem at 1. simpl. extens. iff M.
    specializes H M. induction L'.
      inverts H.
      rewrite filter_cons. inverts H.
        rewrite (is_True M). rewrite~ isTrue_True.
        case_if; fold_bool; fold_prop; auto.
    clear H. induction L'.
      rewrite filter_nil in M. inverts M.
      rewrite filter_cons in M. cases_if; fold_bool; fold_prop.
        inverts~ M.
        apply~ IHL'.
Qed.

End Properties.

End FsetImpl.

(* ********************************************************************** *)
(** * Derivable properties about finite sets *)

Section Properties.
Variables A : Type.
Implicit Types x : A.
Implicit Types E : fset A.

(** Properties of [in] *)

Lemma in_empty_elim : forall x,
  x \in \{} -> False.
Proof using. introv H. rewrite~ in_empty in H. Qed.

Lemma in_singleton_self : forall x,
  x \in \{x}.
Proof using. intros. rewrite~ in_singleton. Qed.

(** Properties of [union] *)

Lemma union_same : forall E,
  E \u E = E.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_union.
Qed.

Lemma union_comm : forall E F,
  E \u F = F \u E.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_union.
Qed.

Lemma union_assoc : forall E F G,
  E \u (F \u G) = (E \u F) \u G.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_union.
Qed.

Lemma union_empty_l : forall E,
  \{} \u E = E.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all in_union.
    intros [ H | H ]. false. rewrite~ in_empty in H. auto.
    autos*.
Qed.

Lemma union_empty_r : forall E,
  E \u \{} = E.
Proof using. intros. rewrite union_comm. apply union_empty_l. Qed.

Lemma union_comm_assoc : forall E F G,
  E \u (F \u G) = F \u (E \u G).
Proof using.
  intros. rewrite union_assoc.
  rewrite (union_comm E F).
  rewrite~ <- union_assoc.
Qed.

(** Properties of [inter] *)

Lemma inter_same : forall E,
  E \n E = E.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_inter.
Qed.

Lemma inter_comm : forall E F,
  E \n F = F \n E.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_inter.
Qed.

Lemma inter_assoc : forall E F G,
  E \n (F \n G) = (E \n F) \n G.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all* in_inter.
Qed.

Lemma inter_empty_l : forall E,
  \{} \n E = \{}.
Proof using.
  intros. apply fset_extens;
   intros x; rewrite_all in_inter.
    intros. false* in_empty_elim.
    intros. false* in_empty_elim.
Qed.

Lemma inter_empty_r : forall E,
  E \n \{} = \{}.
Proof using. intros. rewrite inter_comm. apply inter_empty_l. Qed.

Lemma inter_comm_assoc : forall E F G,
  E \n (F \n G) = F \n (E \n G).
Proof using.
  intros. rewrite inter_assoc.
  rewrite (inter_comm E F).
  rewrite~ <- inter_assoc.
Qed.

(* Properties of [from_list] *)

Lemma from_list_nil :
  from_list (@nil A) = \{}.
Proof using. auto. Qed.

Lemma from_list_cons : forall x l,
  from_list (x::l) = \{x} \u (from_list l).
Proof using. auto. Qed.

(* Properties of [disjoint] *)

Lemma disjoint_comm : forall E F,
  disjoint E F -> disjoint F E.
Proof using. unfold disjoint. intros. rewrite~ inter_comm. Qed.

Lemma disjoint_in_notin : forall E F x,
  disjoint E F -> x \in E -> x \notin F.
Proof using.
  unfold disjoint. introv H InE InF. applys in_empty_elim x.
  rewrite <- H. rewrite in_inter. auto.
Qed.

(** Properties of [notin] *)

Lemma notin_empty : forall x,
  x \notin \{}.
Proof using. intros_all. rewrite~ in_empty in H. Qed.

Lemma notin_singleton : forall x y,
  x \notin \{y} <-> x <> y.
Proof using. unfold notin. intros. rewrite* <- in_singleton. Qed.

Lemma notin_same : forall x,
  x \notin \{x} -> False.
Proof using. intros. apply H. apply* in_singleton_self. Qed.

Lemma notin_union : forall x E F,
  x \notin (E \u F) <-> (x \notin E) /\ (x \notin F).
Proof using. unfold notin. intros. rewrite* in_union. Qed.

(** Properties of [subset] *)

Lemma subset_refl : forall E,
  E \c E.
Proof using. intros_all. auto. Qed.

Lemma subset_empty_l : forall E,
  \{} \c E.
Proof using. intros_all. rewrite* in_empty in H. Qed.

Lemma subset_union_weak_l : forall E F,
  E \c (E \u F).
Proof using. intros_all. rewrite* in_union. Qed.

Lemma subset_union_weak_r : forall E F,
  F \c (E \u F).
Proof using. intros_all. rewrite* in_union. Qed.

Lemma subset_union_2 : forall E1 E2 F1 F2,
  E1 \c F1 -> E2 \c F2 -> (E1 \u E2) \c (F1 \u F2).
Proof using. introv H1 H2. intros x. do 2 rewrite* in_union. Qed.

(** Properties of [remove] *)

Lemma union_remove : forall E F G,
  (E \u F) \- G = (E \- G) \u (F \- G).
Proof using.
  intros. apply fset_extens; intros x;
  repeat (first [ rewrite in_remove | rewrite in_union ]); autos*.
Qed.

End Properties.


From Coq Require Import omega.Omega.
From Coq Require Import Arith.Arith.
From LF Require Import Imp Maps.

Open Scope imp_scope.

Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | 0 => empty_st
  | S i' =>
    match c with
    | SKIP => st
    | l ::= a1 =>
      (l !-> aeval st a1 ; st)
    | c1 ;; c2 =>
      let st' := ceval_step2 st c1 i' in
      ceval_step2 st' c2 i'
    | TEST b THEN c1 ELSE c2 FI =>
      if (beval st b)
      then ceval_step2 st c1 i'
      else ceval_step2 st c2 i'
    | WHILE b1 DO c1 END =>
      if (beval st b1)
      then let st' := ceval_step2 st c1 i' in
           ceval_step2 st' c i'
      else st
    end
  end.
Close Scope imp_scope.

Open Scope imp_scope.

Fixpoint ceval_step3 (st : state) (c : com) (i : nat) : option state :=
  match i with
  | 0 => None
  | S i' =>
    match c with
    | SKIP => Some st
    | l ::= a1 =>
      Some (l !-> aeval st a1 ; st)
    | c1 ;; c2 =>
      match (ceval_step3 st c1 i') with
      | Some st' => ceval_step3 st' c2 i'
      | None => None
      end
    | TEST b THEN c1 ELSE c2 FI =>
      if (beval st b)
      then ceval_step3 st c1 i'
      else ceval_step3 st c2 i'
    | WHILE b1 DO c1 END =>
      if (beval st b1)
      then match (ceval_step3 st c1 i') with
           | Some st' => ceval_step3 st' c i'
           | None => None
           end
      else Some st
    end
  end.
Close Scope imp_scope.

Notation "'LETOPT' x <== e1 'IN' e2" :=
  (match e1 with
   | Some x => e2
   | None => None
   end)
    (right associativity, at level 60).

Open Scope imp_scope.

Fixpoint ceval_step (st : state) (c : com) (i : nat) : option state :=
  match i with
  | 0 => None
  | S i' =>
    match c with
    | SKIP =>
      Some st
    | l ::= a1 =>
      Some (l !-> aeval st a1 ; st)
    | c1 ;; c2 =>
      LETOPT st' <== ceval_step st c1 i' IN
             ceval_step st' c2 i'
    | TEST b THEN c1 ELSE c2 FI =>
      if (beval st b)
      then ceval_step st c1 i'
      else ceval_step st c2 i'
    | WHILE b1 DO c1 END =>
      if (beval st b1)
      then LETOPT st' <== ceval_step st c1 i' IN
                  ceval_step st' c i'
      else Some st
    end
  end.
Close Scope imp_scope.

Definition test_ceval (st : state) (c : com) :=
  match ceval_step st c 500 with
  | None => None
  | Some st => Some (st X, st Y, st Z)
  end.

Compute
     (test_ceval empty_st
         (X ::= 2;;
          TEST (X <= 1)
            THEN Y ::= 3
            ELSE Z ::= 4
            FI)).

Definition pup_to_n : com :=
  Y ::= 0;;
  WHILE X > 0 DO
    Y ::= Y + X;;
    X ::= X - 1
  END.

Example pup_to_n_1 :
  test_ceval (X !-> 5) pup_to_n = Some (0, 15, 0).
Proof. reflexivity. Qed.

Definition is_even : com :=
  WHILE X > 1 DO
    X ::= X - 2
  END;;
  TEST X = 0 THEN
    Z ::= 0
  ELSE
    Z ::= 1
  FI.

Example is_even_10 :
  test_ceval (X !-> 10) is_even = Some (0, 0, 0).
Proof. reflexivity. Qed.

Theorem ceval_step__ceval : forall c st st',
    (exists i, ceval_step st c i = Some st') ->
    st =[ c ]=> st'.
Proof.
  intro c. induction c.
  - intros st st' H. destruct H. destruct x as [| x' ].
    + inversion H.
    + inversion H. apply E_Skip.
  - intros st st' H. destruct H. destruct x0 as [| x0' ].
    + inversion H.
    + inversion H. apply E_Ass. reflexivity.
  - intros st st' H. destruct H. destruct x as [| x' ].
    + inversion H.
    + inversion H. destruct (ceval_step st c1 x') eqn:E.
      * assert (H2 : st =[ c1 ]=> s).
        { apply IHc1. exists x'. apply E. }
        assert (H3 : s =[ c2 ]=> st').
        { apply IHc2. exists x'. apply H1. }
        apply (E_Seq c1 c2 st s st'); assumption.
      * inversion H1.
  - intros st st' H. destruct H. destruct x as [| x' ].
    + inversion H.
    + destruct (beval st b) eqn:Eb.
      * apply E_IfTrue.
        { apply Eb. }
        { inversion H. rewrite Eb in H1. apply IHc1. eexists. apply H1. }
      * apply E_IfFalse.
        { apply Eb. }
        { inversion H. rewrite Eb in H1. apply IHc2. eexists. apply H1. }
  - intros st st' H. destruct H.
    generalize dependent st'.
    generalize dependent st.
    remember (WHILE b DO c END)%imp as while eqn:Heqwhile.
    induction x as [| x' IH ].
    + intros st st' H. inversion H.
    + intros st st' H. destruct (beval st b) eqn:Eb.
      * inversion H. destruct while.
        { inversion Heqwhile. }
        { inversion Heqwhile. }
        { inversion Heqwhile. }
        { inversion Heqwhile. }
        { inversion Heqwhile. subst. rewrite Eb in H1.
          destruct (ceval_step st c x') eqn:E.
          { apply IH in H1.
            assert (He : exists i, ceval_step st c i = Some s).
            { exists x'. apply E. }
            apply (IHc st s) in He.
            apply (E_WhileTrue b st s).
            { apply Eb. }
            { apply He. }
            { apply H1. }
          }
          { inversion H1. }
        }
      * inversion H. destruct while.
        { inversion Heqwhile. }
        { inversion Heqwhile. }
        { inversion Heqwhile. }
        { inversion Heqwhile. }
        { inversion Heqwhile. subst. rewrite Eb in H1.
          inversion H1. subst. apply E_WhileFalse.
          apply Eb.
        }
Qed.

Theorem ceval_step_more : forall i1 i2 st st' c,
    i1 <= i2 ->
    ceval_step st c i1 = Some st' ->
    ceval_step st c i2 = Some st'.
Proof.
  intro i1. induction i1 as [|i1' IH].
  - intros i2 st st' c H1 H2. inversion H2.
  - intros i2 st st' c H1 H2. inversion H2.
    destruct c.
    + destruct i2.
      * inversion H1.
      * reflexivity.
    + destruct i2.
      * inversion H1.
      * reflexivity.
    + destruct i2.
      * inversion H1.
      * simpl. destruct (ceval_step st c1 i1') eqn:E.
        { apply (IH i2) in E.
          { rewrite E. rewrite H0. apply (IH i2) in H0.
            { rewrite H0. reflexivity. }
            { apply le_S_n. apply H1. }
          }
          { apply le_S_n. apply H1. }
        }
        { inversion H0. }
    + destruct i2.
      * inversion H1.
      * destruct (beval st b) eqn:Eb.
        { simpl. rewrite Eb. rewrite H0. apply IH.
          { apply le_S_n. apply H1. }
          { apply H0. }
        }
        { simpl. rewrite Eb. rewrite H0. apply IH.
          { apply le_S_n. apply H1. }
          { apply H0. }
        }
    + destruct i2.
      * inversion H1.
      * destruct (beval st b) eqn:Eb.
        { simpl. rewrite Eb.
          destruct (ceval_step st c i1') eqn:E.
          { apply (IH i2) in E.
            { rewrite E. rewrite H0. apply (IH i2) in H0.
              { rewrite H0. reflexivity. }
              { apply le_S_n. apply H1. }
            }
            { apply le_S_n. apply H1. }
          }
          { inversion H0. }
        }
        { simpl. rewrite Eb. reflexivity. }
Qed.

Theorem ceval__ceval_step : forall c st st',
    st =[ c ]=> st' ->
    exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce.
  - exists 1. reflexivity.
  - exists 1. simpl. rewrite H. reflexivity.
  - destruct IHHce1 as [m IHHce1]. destruct IHHce2 as [n IHHce2].
    exists (m + n). destruct (m + n) eqn:E.
    + Search plus. apply plus_is_O in E. destruct E.
      subst. inversion IHHce1.
    + simpl. destruct n as [| n'].
      * inversion IHHce2.
      * destruct m as [| m'] eqn:Em.
        { inversion IHHce1. }
        { assert (Hle : m <= n0).
          { rewrite Nat.add_succ_r in E.
            apply eq_add_S in E.
            rewrite <- E. rewrite <- Em. apply Nat.le_add_r.
          }
          rewrite Em in Hle. apply (ceval_step_more _ _ _ _ _ Hle) in IHHce1.
          rewrite IHHce1. apply (ceval_step_more (S n') n0).
          { rewrite Nat.add_comm in E.
            rewrite Nat.add_succ_r in E.
            apply eq_add_S in E.
            rewrite <- E. apply Nat.le_add_r.
          }
          apply IHHce2.
        }
  - destruct IHHce. exists (S x). simpl. rewrite H.
    apply H0.
  - destruct IHHce. exists (S x). simpl. rewrite H.
    apply H0.
  - exists 1. simpl. rewrite H. reflexivity.
  - destruct IHHce1 as [m IHHce1]. destruct IHHce2 as [n IHHce2].
    exists (m + n). destruct (m + n) eqn:E.
    + apply plus_is_O in E. destruct E.
      subst. inversion IHHce1.
    + simpl. rewrite H. destruct n as [| n'].
      * inversion IHHce2.
      * destruct m as [| m'] eqn:Em.
        { inversion IHHce1. }
        { assert (Hle : m <= n0).
          { rewrite Nat.add_succ_r in E.
            apply eq_add_S in E.
            rewrite <- E. rewrite <- Em. apply Nat.le_add_r.
          }
          rewrite Em in Hle. apply (ceval_step_more _ _ _ _ _ Hle) in IHHce1.
          rewrite IHHce1. apply (ceval_step_more (S n') n0).
          { rewrite Nat.add_comm in E.
            rewrite Nat.add_succ_r in E.
            apply eq_add_S in E.
            rewrite <- E. apply Nat.le_add_r.
          }
          apply IHHce2.
        }
Qed.

Theorem ceval_and_ceval_step_coincide : forall c st st',
    st =[ c ]=> st' <->
    exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

Theorem ceval_deterministic' : forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 H1 H2.
  apply (ceval__ceval_step _ _ _) in H1.
  apply (ceval__ceval_step _ _ _) in H2.
  inversion H1 as [i1 E1].
  inversion H2 as [i2 E2].
  apply (ceval_step_more i1 (i1 + i2)) in E1.
  apply (ceval_step_more i2 (i1 + i2)) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  rewrite Nat.add_comm. apply Nat.le_add_r.
  apply Nat.le_add_r.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

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

Require Import ClassicalEpsilon.

Inductive _map (a b:Type) :=
  | _map_constr : (a -> b) -> _map a b.

(* Why3 goal *)
Definition map : forall (a:Type) (b:Type), Type.
intros.
exact (_map a b).
Defined.

Global Instance map_WhyType : forall (a:Type) {a_WT:WhyType a} (b:Type) {b_WT:WhyType b}, WhyType (map a b).
Proof.
intros.
repeat split.
exact (fun _ => why_inhabitant).
intros x y.
apply excluded_middle_informative.
Qed.

(* Why3 goal *)
Definition get: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b.
intros a a_WT b b_WT (m) x.
exact (m x).
Defined.

(* Why3 goal *)
Definition set: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b -> (map a b).
intros a a_WT b b_WT (m) x y.
split.
intros x'.
destruct (why_decidable_eq x x') as [H|H].
exact y.
exact (m x').
Defined.

(* Why3 goal *)
Lemma Select_eq :
forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
forall (m:(map a b)),
 forall (a1:a) (a2:a),
  forall (b1:b), (a1 = a2) -> ((get (set m a1 b1) a2) = b1).
Proof.
intros a a_WT b b_WT (m) a1 a2 b1 h1.
unfold get, set.
now case why_decidable_eq.
Qed.

(* Why3 goal *)
Lemma Select_neq :
forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
forall (m:(map a b)),
 forall (a1:a) (a2:a),
  forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1) a2) = (get m a2)).
Proof.
intros a a_WT b b_WT (m) a1 a2 b1 h1.
unfold get, set.
now case why_decidable_eq.
Qed.

(* Unused content named const
intros a a_WT b b_WT y.
exact (_map_constr _ _ (fun _ => y)).
Defined.
 *)
(* Unused content named Const
Proof.
easy.
Qed.
 *)


(**
  This file is copied from the HoTT library, with only minor changes: Namely that we do not require R to be a mere relation in the definition.
 *)

(* -*- mode: coq; mode: visual-line -*-  *)
Require Import HoTT.Basics.
Require Import Types.Universe Types.Arrow Types.Sigma.
Require Import HSet HProp UnivalenceImpliesFunext TruncType.
Require Import HIT.epi HIT.Truncations HIT.Connectedness.

Local Open Scope path_scope.

(** * Quotient of a Type by an hprop-valued relation

We aim to model:
<<
Inductive quotient : Type :=
   | class_of : A -> quotient
   | related_classes_eq : forall x y, (R x y), class_of x = class_of y
   | quotient_set : IsHSet quotient
>>
*)

Module Export Set_Quotient.

  Section Domain.

    Context {A : Type}.

    Private Inductive set_quotient (R : relation A): Type :=
    | class_of : A -> set_quotient R.

    (** The path constructors. *)
    Axiom related_classes_eq
    : forall {R : relation A} {x y : A}, R x y ->
                        class_of R x = class_of R y.

    Context (R : relation A).

    Axiom set_quotient_set : IsHSet (set_quotient R).
    Global Existing Instance set_quotient_set.

    Definition set_quotient_ind (P : (set_quotient R) -> Type) {sP : forall x, IsHSet (P x)}
               (dclass : forall x, P (class_of R x))
               (dequiv : (forall x y (H : R x y), (related_classes_eq H) # (dclass x) = dclass y))
    : forall q, P q
      := fun q => match q with class_of a => fun _ _ => dclass a end sP dequiv.

    Definition set_quotient_ind_compute {P sP} dclass dequiv x
    : @set_quotient_ind P sP dclass dequiv (class_of R x) = dclass x.
    Proof.
      reflexivity.
    Defined.

    (** Again equality of paths needs to be postulated *)
    Axiom set_quotient_ind_compute_path
    : forall P sP dclass dequiv,
      forall x y (H : R x y),
        apD (@set_quotient_ind P sP dclass dequiv) (related_classes_eq H)
        = dequiv x y H.

  End Domain.

End Set_Quotient.

Section rec.
  Context `{Univalence}.

  Context {A : Type} (R : relation A) .
  Definition set_quotient_rec {B : Type} {sB : IsHSet B}
             (dclass : (forall x : A, B))
             (dequiv : (forall x y, R x y -> dclass x = dclass y))
  : set_quotient R -> B.
  Proof.
    apply (set_quotient_ind R (fun _ : set_quotient _ => B)) with dclass.
    intros ?? H'. destruct (related_classes_eq H'). by apply dequiv.
  Defined.

  Definition set_quotient_rec2 {B : hSet} {dclass : (A -> A -> B)} :
             (forall x x' y, R x x' -> dclass x y = dclass x' y) ->
             (forall x y y', R y y' -> dclass x y = dclass x y') ->
      set_quotient R -> set_quotient R -> B.
  Proof.
    intros dequiv1 dequiv0.
    (* assert (dequiv0 : forall x x0 y : A, R x0 y -> dclass x x0 = dclass x y) *)
    (*   by (intros ? ? ? Hx; apply dequiv;[apply Hrefl|done]). *)
    refine (set_quotient_rec
              (fun x => set_quotient_rec (dclass x) (dequiv0 x)) _).
    intros x x' Hx.
    assert (h : dclass x = dclass x').
    { exact (path_arrow (dclass x) (dclass x') (fun y => dequiv1 x x' y Hx)). }

    apply path_forall. red.
    (* assert (dequiv1 : forall y : A, *)
    (*                     set_quotient_rec (dclass x) (dequiv0 x) (class_of _ y) = *)
    (*                     set_quotient_rec (dclass x') (dequiv0 x') (class_of _ y)) *)
    (*   by (intros; by apply dequiv). *)
    srapply (set_quotient_ind R).
    - intro a. simpl. apply (dequiv1 _ _ _ Hx).
    - intros. apply path_ishprop.
  Defined.

End rec.

  (* Double induction on two different quotients *)
  Definition set_quotient_rec2' `{Univalence} {A B : Type} (R : relation A) (S : relation B)
           {C : hSet} {dclass : (A -> B -> C)} :
             (forall x x' y, R x x' -> dclass x y = dclass x' y) ->
             (forall x y y', S y y' -> dclass x y = dclass x y') ->
      set_quotient R -> set_quotient S -> C.
  Proof.
    intros dequiv1 dequiv0.
    (* assert (dequiv0 : forall x x0 y : A, R x0 y -> dclass x x0 = dclass x y) *)
    (*   by (intros ? ? ? Hx; apply dequiv;[apply Hrefl|done]). *)
    (* srapply @set_quotient_rec. *)
    (* - intro x. *)
    (*   srapply @set_quotient_rec. *)
    (*   + exact (dclass x). *)
    refine (set_quotient_rec _
              (fun x => set_quotient_rec _ (dclass x) (dequiv0 x)) _).
    intros x x' Hx.
    assert (h : dclass x = dclass x').
    { exact (path_arrow (dclass x) (dclass x') (fun y => dequiv1 x x' y Hx)). }

    apply path_forall. red.
    (* assert (dequiv1 : forall y : A, *)
    (*                     set_quotient_rec (dclass x) (dequiv0 x) (class_of _ y) = *)
    (*                     set_quotient_rec (dclass x') (dequiv0 x') (class_of _ y)) *)
    (*   by (intros; by apply dequiv). *)
    srapply (set_quotient_ind S).
    - intro a. simpl. apply (dequiv1 _ _ _ Hx).
    - intros. apply path_ishprop.
  Defined.

Section Equiv.

  Context `{Univalence}.

  Context {A : Type} (R : relation A)
          {Htrans : Transitive R} {Hsymm : Symmetric R}.

  Lemma set_quotient_path2 : forall {x y : set_quotient R} (p q : x=y), p=q.
  Proof.
    apply @set_path2. apply _.
  Defined.

  Definition in_class {sR: is_mere_relation _ R} : set_quotient R -> A -> hProp.
  Proof.
    refine (set_quotient_ind R (fun _ => A -> hProp) (fun a b => BuildhProp (R a b)) _).
    intros. eapply concat;[apply transport_const|].
    apply path_forall. intro z. apply path_hprop; simpl.
    apply @equiv_iff_hprop; eauto.
  Defined.

  Context {Hrefl : Reflexive R}.

  Lemma in_class_pr {sR: is_mere_relation _ R} : forall x y, (in_class (class_of R x) y : Type) = R x y.
  Proof.
    reflexivity.
  Defined.

  Lemma set_quotient_ind_prop (P : set_quotient R -> Type)
        `{forall x, IsHProp (P x)} :
    forall dclass : forall x, P (class_of R x),
    forall q, P q.
  Proof.
    intros. apply (set_quotient_ind R P dclass).
    intros. apply path_ishprop.
  Defined.

  Global Instance decidable_in_class `{forall x y, Decidable (R x y)} {sR: is_mere_relation _ R}
  : forall x a, Decidable (in_class x a).
  Proof.
    refine (set_quotient_ind_prop _ _).
    intros a b; exact (transport Decidable (in_class_pr a b) _).
  Defined.

  Lemma class_of_repr {sR: is_mere_relation _ R}: forall q x, in_class q x -> q = class_of R x.
  Proof.
    apply (set_quotient_ind R
                        (fun q : set_quotient R => forall x, in_class q x -> q = class_of _ x)
                        (fun x y H => related_classes_eq H)).
    intros.
    apply path_forall. intro z.
    apply path_forall;intro H'.
    apply set_quotient_path2.
  Defined.

  Lemma classes_eq_related {sR: is_mere_relation _ R} : forall x y,
                               class_of R x = class_of R y -> R x y.
  Proof.
    intros x y H'.
    pattern (R x y).
    eapply transport.
    - apply in_class_pr.
    - pattern (class_of R x). apply (transport _ (H'^)).
      apply Hrefl.
  Defined.

  (** Thm 10.1.8 *)
  Theorem sets_exact {sR: is_mere_relation _ R} : forall x y, (class_of R x = class_of R y) <~> R x y.
    intros ??. apply equiv_iff_hprop.
    - apply classes_eq_related.
    - apply related_classes_eq.
  Defined.

  Definition set_quotient_ind_prop' : forall P : set_quotient R -> Type,
                                  forall (Hprop' : forall x, IsHProp (P (class_of _ x))),
                                    (forall x, P (class_of _ x)) -> forall y, P y.
  Proof.
    intros ? ? dclass. apply set_quotient_ind with dclass.
    - simple refine (set_quotient_ind R (fun x => IsHSet (P x)) _ _); cbn beta; try exact _.
      intros; apply path_ishprop.
    - intros. apply Hprop'.
  Defined.

  (** From Ch6 *)
  Theorem set_quotient_surjective: IsSurjection (class_of R).
  Proof.
    apply BuildIsSurjection.
    apply (set_quotient_ind_prop (fun y => merely (hfiber (class_of R) y))); try exact _.
    intro x. apply tr. by exists x.
  Defined.

  (** From Ch10 *)
  Definition set_quotient_ump' (B:hSet): (set_quotient R -> B) ->
                                     (sigT (fun f : A-> B => (forall a a0:A, R a a0 -> f a =f a0))).
    intro f. exists (compose f (class_of R) ).
    intros. f_ap. by apply related_classes_eq.
  Defined.

  (* Definition set_quotient_ump'' (B:hSet): (sigT (fun f : A-> B => (forall a a0:A, R a a0 -> f a =f a0))) *)
  (*                                     -> set_quotient R -> B. *)
  (*   intros [f H']. *)
  (*   apply (set_quotient_rec _ H'). *)
  (* Defined. *)

  (* Theorem set_quotient_ump (B:hSet): (set_quotient R -> B) <~> *)
  (*                                                  (sigT (fun f : A-> B => (forall a a0:A, R a a0 -> f a =f a0))). *)
  (* Proof. *)
  (*   refine (equiv_adjointify (set_quotient_ump' B) (set_quotient_ump'' B) _ _). *)
  (*   intros [f Hf]. *)
  (*   - by apply equiv_path_sigma_hprop. *)
  (*   - intros f. *)
  (*     apply path_forall. *)
  (*     red. apply set_quotient_ind_prop';[apply _|reflexivity]. *)
  (* Defined. *)

  (** Missing

  The equivalence with VVset_quotient [A//R].

  This should lead to the unnamed theorem:

  10.1.10. Equivalence relations are effective and there is an equivalence [A/R<~>A//R]. *)

  (**
  The theory of canonical quotients is developed by C.Cohen:
  http://perso.crans.org/cohen/work/quotients/
 *)

End Equiv.

Section Functoriality.

  Definition set_quotient_functor
             {A : Type} (R : relation A) {sR: is_mere_relation _ R}
             {B : Type} (S : relation B) {sS: is_mere_relation _ S}
             (f : A -> B) (fresp : forall x y, R x y -> S (f x) (f y))
  : set_quotient R -> set_quotient S.
  Proof.
    refine (set_quotient_rec R (class_of S o f) _).
    intros x y r.
    apply related_classes_eq, fresp, r.
  Defined.

  Context {A : Type} (R : relation A) {sR: is_mere_relation _ R}
          {B : Type} (S : relation B) {sS: is_mere_relation _ S}.

  Global Instance set_quotient_functor_isequiv
             (f : A -> B) (fresp : forall x y, R x y <-> S (f x) (f y))
             `{IsEquiv _ _ f}
  : IsEquiv (set_quotient_functor R S f (fun x y => fst (fresp x y))).
  Proof.
    simple refine (isequiv_adjointify _ (set_quotient_functor S R f^-1 _)
                               _ _).
    - intros u v s.
      apply (snd (fresp _ _)).
      abstract (do 2 rewrite eisretr; apply s).
    - intros x; revert x; simple refine (set_quotient_ind S _ _ _).
      + intros b; simpl. apply ap, eisretr.
      + intros; apply path_ishprop.
    - intros x; revert x; simple refine (set_quotient_ind R _ _ _).
      + intros a; simpl. apply ap, eissect.
      + intros; apply path_ishprop.
  Defined.

  Definition set_quotient_functor_equiv
             (f : A -> B) (fresp : forall x y, R x y <-> S (f x) (f y))
             `{IsEquiv _ _ f}
  : set_quotient R <~> set_quotient S
    := BuildEquiv _ _
         (set_quotient_functor R S f (fun x y => fst (fresp x y))) _.

  Definition set_quotient_functor_equiv'
             (f : A <~> B) (fresp : forall x y, R x y <-> S (f x) (f y))
  : set_quotient R <~> set_quotient S
    := set_quotient_functor_equiv f fresp.

End Functoriality.

Section Kernel.

  (** ** Quotients of kernels of maps to sets give a surjection/mono factorization. *)

  Context {fs : Funext}.

  (** A function we want to factor. *)
  Context {A B : Type} `{IsHSet B} (f : A -> B).

  (** A mere relation equivalent to its kernel. *)
  Context (R : relation A) {sR : is_mere_relation _ R}.
  Context (is_ker : forall x y, f x = f y <~> R x y).

  Theorem set_quotient_kernel_factor
  : exists (C : Type) (e : A -> C) (m : C -> B),
      IsHSet C * IsSurjection e * IsEmbedding m * (f = m o e).
  Proof.
    pose (C := set_quotient R).
    (* We put this explicitly in the context so that typeclass resolution will pick it up. *)
    assert (IsHSet C) by (unfold C; apply _).
    exists C.
    pose (e := class_of R).
    exists e.
    transparent assert (m : (C -> B)).
    { apply set_quotient_ind with f; try exact _.
      intros x y H. transitivity (f x).
      - apply transport_const.
      - exact ((is_ker x y) ^-1 H). }
    exists m.
    split.
    { split.
      { split.
        - assumption.
        - apply set_quotient_surjective. }
      intro u.
      apply hprop_allpath.
      assert (H : forall (x y : C) (p : m x = u) (p' : m y = u), x = y).
      { simple refine (set_quotient_ind R _ _ _).
        { intro a.
          simple refine (set_quotient_ind R _ _ _).
          { intros a' p p'; fold e in p, p'.
            apply related_classes_eq.
            refine (is_ker a a' _).
            change (m (e a) = m (e a')).
            exact (p @ p'^). }
          intros; apply path_ishprop. }
        intros; apply path_ishprop. }
      intros [x p] [y p'].
      apply path_sigma_hprop; simpl.
      exact (H x y p p'). }
    reflexivity.
  Defined.

End Kernel.


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import SfLib.
Require Import Imp.
Require Import Maps.

Definition Assertion := state -> Prop.

Definition assert_implies (P Q:Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q)
    (at level 80):hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  ((P ->> Q) /\ (Q ->> P)) (at level 80) : hoare_spec_scope.

Definition hoare_triple (P : Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
    c / st \\ st' ->
    P st ->
    Q st'.

Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level) : hoare_spec_scope.

Theorem hoare_post_true :
  forall (P Q : Assertion) c,
    (forall st, Q st) ->
    {{P}} c {{Q}}.
  unfold hoare_triple. auto.
Qed.

Theorem hoare_pre_false :
  forall (P Q:Assertion) c,
    (forall st, ~ (P st)) ->
    {{ P}} c{{Q}}.
  unfold hoare_triple.
  intros. elim (H st H1).
Qed.

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (t_update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

Theorem hoare_asgn :
  forall Q X a,
    {{ Q [ X |-> a]}} (X ::= a) {{Q}}.
  unfold hoare_triple. unfold assn_sub.
  intros. inversion H. subst n; auto.
Qed.

Example assn_sub_example:
  {{(fun st => st X = 3) [X |-> ANum 3]}}
    (X ::= (ANum 3))
    {{ fun st => st X = 3}}.
apply hoare_asgn.
Qed.

Example hoare_asgn_wrong:
  forall X a,
    {{fun x =>True}} (X ::= a) {{fun x=> aeval x (AId X) = aeval x a}}.

assert (forall X a,
          {{ (fun x=> aeval x (AId X) = aeval x a) [X |-> a] }}
            (X ::= a) {{fun x=> aeval x (AId X) = aeval x a}}).
intros; apply hoare_asgn.
unfold assn_sub in H. simpl in H. unfold t_update in H. intros.
destruct (eq_id_dec X X) eqn: h1.
pose (H X a). rewrite h1 in h. destruct a eqn:ha; unfold hoare_triple in h; unfold hoare_triple; simpl in h.
simpl in h. simpl. unfold hoare_triple. unfold hoare_triple in h. intros. apply (h st st' H0 eq_refl).
simpl in h. destruct (eq_id_dec X i). intros. pose (h st st' H0 eq_refl).
simpl. auto.
simpl. intros. apply (h st st' H0 eq_refl).
Abort.

Theorem hoare_asgn_fwd:
  (forall {X Y:Type} {f g: X -> Y},
     (forall (x:X), f x = g x) -> f = g) ->
     forall m a P X,
       {{fun st => P st /\ st X = m}}
         (X ::= a)
         {{fun st => P (t_update st X m)
                     /\ st X = aeval (t_update st X m) a}}.
  intros. unfold hoare_triple.
  intros. inversion H0.
  assert (st = t_update (t_update st X n) X m).
  apply H. unfold t_update. intro; case (eq_id_dec X x0); simpl; auto.
  intros; subst x0; auto. inversion H1; auto.
  rewrite <- H7. rewrite H6. unfold t_update. rewrite eq_id_dec_id.
  tauto.
Qed.

Theorem hoare_asgn_fwd_exists:
  (forall {X Y: Type} {f g:X -> Y},
     (forall x:X, f x = g x) -> f = g) ->
  forall a P,
    {{fun st => P st}}
      X ::= a
      {{fun st => exists m, P(t_update st X m) /\
                            st X = aeval (t_update st X m) a }}.

  unfold hoare_triple. intros.
  pose (eq_refl (st X)).
  pose (conj H1 e).
  pose (hoare_asgn_fwd H (st X) a P).
  unfold hoare_triple in h.
  pose (h X st st' H0 a0).
  exists (st X). auto.
Qed.

Theorem hoare_consequence_pre :
  forall (P P' Q : Assertion) c,
    {{P'}} c {{Q}} ->
    P ->> P' ->
    {{P}} c {{Q}}.
  unfold hoare_triple.
  unfold assert_implies.
  intros. apply (H st st'); auto.
Qed.

Theorem hoare_consequence_post :
  forall (P Q Q' : Assertion) c,
    {{P}} c {{Q'}} ->
    Q' ->> Q ->
    {{P}} c {{Q}}.

  unfold hoare_triple; unfold assert_implies.
  intros. apply (H0 st'). apply (H st st'); auto.
Qed.

Example hoare_asgn_example1:
  {{fun st => True}} (X::=(ANum 1)) {{fun st => st X = 1}}.
apply hoare_consequence_pre with (P' := (fun st => st X = 1)[ X |-> ANum 1]).
apply hoare_asgn.
unfold assn_sub. unfold t_update. intro. intro. rewrite eq_id_dec_id. simpl. auto.
Qed.

Theorem hoare_consequence:
  forall (P P' Q Q' :Assertion) c,
    {{P'}} c {{Q'}} ->
    P ->> P' ->
    Q' ->> Q ->
    {{P}} c {{Q}}.
  unfold hoare_triple; unfold assert_implies.
  intros. apply H1. apply (H st st'); auto.
Qed.

Theorem hoare_skip :
  forall P,
    {{P}} SKIP {{P}}.
  unfold hoare_triple.
  intros. inversion H. subst st'. auto.
Qed.

Theorem hoare_seq:
  forall P Q R c1 c2,
    {{P}} c1 {{Q}} ->
    {{Q}} c2 {{R}} ->
    {{P}} c1 ;; c2 {{R}}.

  unfold hoare_triple; intros.
  inversion H1. subst st''. subst st0.
  apply (H0 st'0 st'); auto. apply(H st st'0);auto.
Qed.

Example hoare_asgn_example3:
  forall a n,
    {{fun st => aeval st a = n}}
      (X ::= a ;; SKIP)
      {{fun st => st X = n}}.
intros. eapply hoare_seq.
eapply (hoare_consequence_pre).
apply (hoare_asgn (fun st:state => st X = n) _ _).
unfold assert_implies. unfold assn_sub. unfold t_update. intro. rewrite eq_id_dec_id. auto.
apply hoare_skip.
Qed.

Definition swap_program : com :=
  Z::= AId X;;
   X::= AId Y;;
   Y::= AId Z.

Theorem swap_exercise:
  {{fun st => st X <= st Y}}
    swap_program
    {{ fun st => st Y <= st X}}.
  unfold swap_program.
  eapply hoare_seq.
  eapply hoare_consequence_pre.
  apply (hoare_asgn (fun st:state => st Z <= st Y) Z _).
  unfold assn_sub. unfold t_update. simpl. unfold assert_implies. intros; rewrite eq_id_dec_id.
  case (eq_id_dec Z Y). intro; discriminate. auto.
  eapply hoare_seq. eapply hoare_consequence_pre. apply (hoare_asgn (fun st:state => st Z <= st X) X _).
  unfold assn_sub; unfold assert_implies; unfold t_update. simpl. intros; rewrite eq_id_dec_id.
  case (eq_id_dec X Z); intros; try discriminate; auto.
  eapply hoare_consequence_pre.
  apply (hoare_asgn (fun st:state => st Y <= st X) Y (AId Z)).
  unfold assn_sub; unfold t_update; simpl; unfold assert_implies. intros; rewrite eq_id_dec_id.
  case (eq_id_dec Y X); intros; try discriminate; auto.
Qed.

Definition bassn b:Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true:
  forall b st,
    beval st b = true -> (bassn b) st.
  unfold bassn. auto.
Qed.

Lemma bexp_eval_false :
  forall b st,
    beval st b = false -> ~ ((bassn b) st).

  unfold bassn. unfold not. intros. rewrite H0 in H; discriminate.
Qed.

Theorem hoare_if :
  forall P Q b c1 c2,
    {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
    {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
    {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
  unfold hoare_triple. intros. inversion H1. subst st'0. subst st0. subst c0. subst c3.
  pose (H st st' H9). unfold bassn in q. apply q; auto.
  subst st'0; subst st0; subst c3; subst c0.
  pose (H0 st st' H9). unfold bassn in q. rewrite H8 in q.
  apply q; auto.
Qed.

Theorem if_minus_plus:
  {{fun st => True}}
    IFB (BLe (AId X) (AId Y))
    THEN (Z::= AMinus (AId Y) (AId X))
    ELSE (Y::= APlus (AId X) (AId Z))
    FI
    {{fun st => st Y = st X + st Z}}.

  apply hoare_if. unfold bassn. eapply hoare_consequence_pre.
  apply (hoare_asgn (fun st => st Y = st X + st Z) _ _).
  unfold assert_implies. unfold assn_sub. simpl. unfold t_update. intro. rewrite eq_id_dec_id.
  case (eq_id_dec Z X); case (eq_id_dec Z Y); intros; try discriminate; auto.
  unfold leb_bydec in H. inversion H. SearchRewrite ( _ - _). generalize H1; case (le_dec (st X) (st Y)); intros; try discriminate; auto. omega.
  unfold bassn. eapply hoare_consequence_pre. apply (hoare_asgn _ _ _).
  unfold assert_implies. unfold assn_sub. unfold t_update. intro. rewrite eq_id_dec_id.
  case (eq_id_dec Y Z); case (eq_id_dec Y X); intros; try discriminate; auto.
Qed.

Module IF1.
  Inductive com: Type :=
| CSkip : com
| CAss : id -> aexp -> com
| CSeq : com -> com -> com
| CIf : bexp -> com -> com -> com
| CWhile : bexp -> com -> com
| CIf1 : bexp -> com -> com.

  Notation "'SKIP'" :=
    CSkip.

  Notation "c1 ;; c2" :=
    (CSeq c1 c2) (at level 80, right associativity).

  Notation "X '::=' a" :=
    (CAss X a) (at level 60).

  Notation "'WHILE' b 'DO' c 'END'" :=
    (CWhile b c) (at level 80, right associativity).

  Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
    (CIf e1 e2 e3) (at level 80, right associativity).

  Notation "'IF11' b 'THEN' c 'FI'" :=
    (CIf1 b c) (at level 80, right associativity).

  Reserved Notation "c1 '/' st '\\' st'" (at level 40, st at level 39).

  Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st:state, SKIP / st \\ st
  | E_Ass : forall (st:state) (a1:aexp) (n:nat) (X:id),
              aeval st a1 = n -> (X ::= a1) / st \\ (t_update st X n)
  | E_Seq : forall (c1 c2: com) (st st' st'' : state),
              c1 / st \\ st' -> c2 / st' \\ st'' -> (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall (st st' : state) (b1 : bexp) (c1 c2: com),
                 beval st b1 = false ->
                 c2 / st \\ st' -> (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileEnd : forall (b1: bexp) (st:state) (c1:com),
                   beval st b1 = false -> (WHILE b1 DO c1 END) / st \\ st
  | E_WhileLoop: forall (st st' st'' : state) (b1: bexp) (c1:com),
                   beval st b1 = true ->
                   c1 / st \\ st' ->
                   (WHILE b1 DO c1 END) / st' \\ st'' ->
                   (WHILE b1 DO c1 END) / st \\ st''
  | E_If1True : forall st st' b c,
                  beval st b = true ->
                  c / st \\ st' ->
                  (IF11 b THEN c FI) / st \\ st'
  | E_If1False : forall st b c,
                   beval st b = false ->
                   (IF11 b THEN c FI) / st \\ st
  where "c1 '/' st '\\' st'" := (ceval c1 st st').

  Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
    forall st st',
      c / st \\ st' ->
      P st ->
      Q st'.

  Notation "{{ P }} c {{ Q }}" := (hoare_triple P c Q)
                                (at level 90, c at next level)
                                  : hoare_spec_scope.

  Lemma hoare_if1_good :
    {{fun st => st X + st Y = st Z}}
      IF11 BNot (BEq (AId Y) (ANum 0)) THEN
      X ::= APlus (AId X) (AId Y)
      FI
      {{fun st => st X = st Z}}.
Proof.
    unfold hoare_triple. intros.
    inversion H. subst st0; subst st'0. inversion H6. unfold t_update. rewrite eq_id_dec_id.
    case (eq_id_dec Imp.X Z); auto. intros. simpl in H9. rewrite <- H9. auto.
    inversion H5. unfold beq_nat_bydec in H7. generalize H7. subst st'.
    case (eq_nat_dec (st Y) 0). intros; omega. simpl; intros; discriminate.
Qed.

  End IF1.

Lemma hoare_while :
    forall P b c,
      {{fun st => P st /\ bassn b st}} c {{P }} ->
      {{P}} WHILE b DO c END {{fun st => P st /\ ~(bassn b st)}}.

    unfold hoare_triple. unfold bassn.
    intros. generalize dependent H1.
    remember (WHILE b DO c END) as h. generalize dependent Heqh.
    elim H0; try (intros; discriminate).
    intros. inversion Heqh. subst c0. subst b0. pose (H st0 st'0 H2 (conj H6 H1)). auto.
    intros. inversion Heqh. subst b0; rewrite H1. auto.
Qed.

  Theorem always_loop_hoare :
    forall P Q,
      {{P}} WHILE BTrue DO SKIP END {{Q}}.

    unfold hoare_triple.
    intros. remember (WHILE BTrue DO SKIP END) as c.
    generalize dependent Heqc.
    elim H; try (intros; discriminate).
    intros. auto.
    intros. inversion Heqc. subst b. simpl H1; discriminate.
  Qed.

  Module REPEATEXERCISE.

    Inductive com : Type :=
  |  CSkip : com
  |  CAsgn : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

    Notation "'SKIP'" :=
      CSkip.

    Notation "c1 ;; c2" :=
      (CSeq c1 c2) (at level 80, right associativity).

    Notation " X '::=' a" :=
      (CAsgn X a) (at level 60).

    Notation "'WHILE' b 'DO' c 'END'" :=
      (CWhile b c) (at level 80, right associativity).

    Notation "'IFB' b 'THEN' c1 'ELSE' c2 'FI'" :=
      (CIf b c1 c2) (at level 80, right associativity).

    Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
      (CRepeat e1 b2) (at level 80, right associativity).

    Inductive ceval : state -> com -> state -> Prop :=
    | E_Skip : forall st,
                 ceval st SKIP st
    | E_Ass : forall st a1 n X,
                aeval st a1 = n ->
                ceval st (X ::= a1) (t_update st X n)
    | E_Seq : forall c1 c2 st st' st'',
                ceval st c1 st' ->
                ceval st' c2 st'' ->
                ceval st (c1 ;; c2) st''
    | E_IfTrue : forall st st' b1 (c1 c2:com),
                   beval st b1 = true ->
                   ceval st c1 st' ->
                   ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
    | E_IfFalse : forall st st' b1 (c1 c2:com),
                    beval st b1 = false ->
                    ceval st c2 st' ->
                    ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
    | E_WhileEnd : forall b1 st st' c1 c2,
                     beval st b1 = false ->
                     ceval st c2 st' ->
                     ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
    | E_WhileLoop : forall b1 st st'' st' c1,
                      beval st b1 = true ->
                      ceval st c1 st' ->
                      ceval st' (WHILE b1 DO c1 END) st'' ->
                      ceval st (WHILE b1 DO c1 END) st''
    | E_RepeatEnd : forall st st'' c b1 ,
                   ceval st c st'' ->
                   beval st'' b1 = true ->
                   ceval st (REPEAT c UNTIL b1 END) st''
    | E_RepeatR : forall st st' st'' c b,
                    ceval st c st' ->
                    beval st' b = false ->
                    ceval st' (REPEAT c UNTIL b END) st'' ->
                    ceval st (REPEAT c UNTIL b END) st''.

    Notation "c1 '/' st '\\' st'" :=
      (ceval st c1 st')
        (at level 40, st at level 39).

    Definition hoare_triple (P :Assertion) (c : com) (Q: Assertion) : Prop :=
      forall st st',
        (c / st \\ st') -> P st -> P st'.

    Definition ex1_repeat :=
      REPEAT
        X::= ANum 1;;
        Y::= APlus (AId Y) (ANum 1)
        UNTIL (BEq (AId X) (ANum 1)) END.

    Theorem ex1_repeat_works :
      ex1_repeat / empty_state
                 \\ t_update (t_update empty_state X 1) Y 1.
      unfold ex1_repeat. apply E_RepeatEnd.
      apply (E_Seq _ _ empty_state (t_update empty_state X (aeval empty_state (ANum 1))) _).
      apply E_Ass. auto.
      simpl. apply E_Ass. simpl. unfold t_update. case (eq_id_dec X Y); try (intros; discriminate).
      simpl. auto.
      simpl. unfold t_update. rewrite eq_id_dec_id. case (eq_id_dec Y X); auto.
    Qed.

    Notation "{{ P }} c {{ Q }}" :=
      (hoare_triple P c Q) (at level 90, c at next level).

    Theorem hoare_repeat:
      forall P c b,
        {{P}} c {{P}} ->
        {{P}} REPEAT c UNTIL b END {{ fun st => P st /\ (bassn b st)}}.

      unfold hoare_triple.
      intros. remember (REPEAT c UNTIL b END) as d.
      generalize dependent H1. generalize dependent Heqd.
      elim H0; try (intros; discriminate).
      intros. inversion Heqd; subst c0; subst b1. apply (H st0 st'' H1 H4).
      intros. inversion Heqd; subst c0; subst b0. pose (H st0 st'0 H1 H6).
      auto.
    Qed.

    End REPEATEXERCISE.

  Module HIMP.
    Inductive com : Type :=
  | CSkip : com
  | CAsgn : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CHavoc : id -> com.

    Notation "'SKIP'" :=
      CSkip.

    Notation "X '::=' a" :=
      (CAsgn X a) (at level 60).

    Notation "c1 ;; c2" :=
      (CSeq c1 c2) (at level 80, right associativity).

    Notation "'WHILE' b 'DO' c 'END'" :=
      (CWhile b c) (at level 80, right associativity).

    Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
      (CIf e1 e2 e3) (at level 80, right associativity).

    Notation "'HAVOC' X" := (CHavoc X) (at level 60).

    Reserved Notation "c1 '/' st '\\' st'" (at level 40, st at level 39).

    Inductive ceval : com -> state -> state -> Prop :=
    | E_Skip : forall st, SKIP / st \\ st
    | E_Ass : forall st (a1: aexp) (n:nat) X,
                aeval st a1 = n -> (X::= a1) / st \\ t_update st X n
    | E_Seq : forall c1 c2 st st' st'',
                c1 / st \\ st' -> c2 / st' \\ st'' -> (c1;;c2) / st \\ st''
    | E_IfTrue :
        forall (st st': state) (b1:bexp) (c1 c2:com),
          beval st b1 = true ->
          c1 / st \\ st' ->
          (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
    | E_IfFalse:
        forall (st st': state) (b1:bexp) (c1 c2:com),
          beval st b1 = true ->
          c2 / st \\ st' ->
          (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
    | E_WhileEnd :
        forall (b1: bexp) (st:state) (c1:com),
          beval st b1 = false ->
          (WHILE b1 DO c1 END) / st \\ st
    | E_WhileLoop :
        forall (st st' st'' : state) (b1:bexp) (c1:com),
          beval st b1 = true ->
          c1 / st \\ st' ->
          (WHILE b1 DO c1 END) / st' \\ st'' ->
          (WHILE b1 DO c1 END) / st \\ st''
    | E_Havoc :
        forall (st:state) (X:id) (n:nat),
          (HAVOC X) / st \\ t_update st X n
    where "c1 '/' st '\\' st'" := (ceval c1 st st').

    Definition hoare_triple (P :Assertion) (c : com) (Q: Assertion) : Prop :=
      forall st st',
        (c / st \\ st') -> P st -> P st'.
    Notation "{{ P }} c {{ Q }}" :=
      (hoare_triple P c Q) (at level 90, c at next level).

    Definition havoc_pre (X:id) (Q:Assertion) : Assertion :=
      fun st => forall (n:nat), Q (t_update st X n).

Require Import Coq.Logic.FunctionalExtensionality.

    Theorem hoare_havoc :
      forall (Q:Assertion) (X:id),
        {{ havoc_pre X Q}} HAVOC X {{Q}}.

      unfold hoare_triple. unfold havoc_pre.
      intros. inversion H. subst X0; subst st0.
      assert (t_update (t_update st X n0) X n = t_update st X n).
      apply functional_extensionality. unfold t_update.
      intro. case (eq_id_dec X x); auto.
      rewrite H1. apply H0.
    Qed.
End HIMP.


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

(*i $Id: NZBase.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import NZAxioms.

Module Type NZBasePropSig (Import NZ : NZDomainSig').

Include BackportEq NZ NZ. (** eq_refl, eq_sym, eq_trans *)

Lemma eq_sym_iff : forall x y, x==y <-> y==x.
Proof.
intros; split; symmetry; auto.
Qed.

(* TODO: how register ~= (which is just a notation) as a Symmetric relation,
    hence allowing "symmetry" tac ? *)

Theorem neq_sym : forall n m, n ~= m -> m ~= n.
Proof.
intros n m H1 H2; symmetry in H2; false_hyp H2 H1.
Qed.

Theorem eq_stepl : forall x y z, x == y -> x == z -> z == y.
Proof.
intros x y z H1 H2; now rewrite <- H1.
Qed.

Declare Left Step eq_stepl.
(* The right step lemma is just the transitivity of eq *)
Declare Right Step (@Equivalence_Transitive _ _ eq_equiv).

Theorem succ_inj : forall n1 n2, S n1 == S n2 -> n1 == n2.
Proof.
intros n1 n2 H.
apply pred_wd in H. now do 2 rewrite pred_succ in H.
Qed.

(* The following theorem is useful as an equivalence for proving
bidirectional induction steps *)
Theorem succ_inj_wd : forall n1 n2, S n1 == S n2 <-> n1 == n2.
Proof.
intros; split.
apply succ_inj.
apply succ_wd.
Qed.

Theorem succ_inj_wd_neg : forall n m, S n ~= S m <-> n ~= m.
Proof.
intros; now rewrite succ_inj_wd.
Qed.

(* We cannot prove that the predecessor is injective, nor that it is
left-inverse to the successor at this point *)

Section CentralInduction.

Variable A : predicate t.
Hypothesis A_wd : Proper (eq==>iff) A.

Theorem central_induction :
  forall z, A z ->
    (forall n, A n <-> A (S n)) ->
      forall n, A n.
Proof.
intros z Base Step; revert Base; pattern z; apply bi_induction.
solve_predicate_wd.
intro; now apply bi_induction.
intro; pose proof (Step n); tauto.
Qed.

End CentralInduction.

Tactic Notation "nzinduct" ident(n) :=
  induction_maker n ltac:(apply bi_induction).

Tactic Notation "nzinduct" ident(n) constr(u) :=
  induction_maker n ltac:(apply central_induction with (z := u)).

End NZBasePropSig.


(************************************************************************)
(*  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 Export Raxioms Rbase QArith_base Qreals LegacyField.
Import LegacyRing_theory.

Section LegacyQField.

(** In the past, the field tactic was not able to deal with setoid datatypes,
    so translating from Q to R and applying field on reals was a workaround.
    See now Qfield for a direct field tactic on Q. *)

Ltac QField := apply eqR_Qeq; autorewrite with q2r_simpl; try field; auto.

(** Examples of use: *)

Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z).
intros; QField.
Qed.

Let ex2 : forall x y : Q, ~ y==0 -> (x/y)*y == x.
intros; QField.
intro; apply H; apply eqR_Qeq.
rewrite H0; unfold Q2R; simpl; field; auto with real.
Qed.

End LegacyQField.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.

Require Import Basic_Cons.CCC.

Require Import NatTrans.NatTrans NatTrans.NatIso.
Require Import Yoneda.Yoneda.

(** 0 × a ≃ 0. where 0 is the initial object *)
Section Init_Prod.
  Context {C : Category} {C_CCC : CCC C} {init : (𝟘_ C)%object}.

  Local Notation "0" := (terminal init) : object_scope.

(*  Local Notation "a × b" := (CHP a b) : object_scope. *)

  (** Natural transformations to be used with Yoneda. *)

  Program Definition Init_Prod_lr a :
    (((((CoYoneda C) _o) ((×ᶠⁿᶜ C) _o (0, a)))%object)
      –≻ (((CoYoneda C) _o) 0)%object)%nattrans
    :=
      {|
        Trans := fun b f => @t_morph _ init b
      |}.

  Next Obligation.
  Proof.
    extensionality g.
    apply t_morph_unique.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Init_Prod_lr_obligation_1.
  Qed.

  Program Definition Init_Prod_rl a :
    (((((CoYoneda C) _o) 0)%object)
       –≻ (((CoYoneda C) _o) ((×ᶠⁿᶜ C) _o (0, a)))%object)%nattrans
    :=
      {|
        Trans := fun c g => compose C (Pi_1 (CCC_HP C init a)) (t_morph init c)
      |}.

  Next Obligation.
  Proof.
    extensionality g.
    simpl_ids.
    rewrite <- assoc.
    apply f_equal.
    apply (t_morph_unique init).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Init_Prod_rl_obligation_1.
  Qed.

  Theorem Init_Prod a :
    (((×ᶠⁿᶜ C) _o (0, a)%object) ≃ 0)%isomorphism.
  Proof.
    apply (@CoIso (C^op)).
    CoYoneda.
    apply (NatIso _ _ (Init_Prod_lr a) (Init_Prod_rl a)).
    {
      intros c.
      extensionality g; simpl.
      apply (t_morph_unique init).
    }
    {
      intros c.
      eapply functional_extensionality; intros g; simpl; simpl_ids.
      match goal with
          [|- ?A = ?B] =>
          erewrite <- uncurry_curry with(f := A);
            erewrite <- uncurry_curry with (f := B)
      end.
      apply f_equal.
      apply (t_morph_unique init).
    }
  Qed.

End Init_Prod.