Require Import HoTT.
Local Open Scope path_scope.
Local Open Scope equiv_scope.

(* Exercise 2.1 *)

Lemma translr {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z.
  induction p. induction q. reflexivity.
Defined.

Lemma transl {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z.
  induction p. apply q.
Defined.

Lemma transr {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z.
  induction q. apply p.
Defined.

Lemma eq_lr_l {A : Type} {x y z : A} (p : x = y) (q : y = z) : translr p q = transl p q.
  induction p. induction q. reflexivity.
Defined.

Lemma eq_l_r {A : Type} {x y z : A} (p : x = y) (q : y = z) : transl p q = transr p q.
  induction p. induction q. reflexivity.
Defined.

(* Cleverly need to swap these arguments >:-) Otherwise, running sym on
the correctly oriented version would also work.  *)
Lemma eq_lr_r {A : Type} {x y z : A} (p : x = y) (q : y = z) : translr p q = transr p q.
  induction q. induction p. reflexivity.
Defined.

(* in all the proofs, we need to do induction on both equalities, because
we need to compute to refl = refl. *)

(* Exercise 2.2 *)
Lemma eq_triangle {A : Type} {x y z : A} (p : x = y) (q : y = z) : eq_lr_l p q @ eq_l_r p q = eq_lr_r p q.
  induction p. induction q. reflexivity.
Qed.

(* Exercise 2.3 *)
(* It's not obvious that there /is/ another proof, but there is, which
works off of a variant of the Yoneda lemma. An alternative way of looking
at it is we are strengthening the inductive hypothesis. *)
Lemma transy {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z.
  generalize q; clear q.
  generalize z; clear z.
  induction p. trivial.
Defined.

Print transy.
(*
transy =
fun (A : Type) (x y z : A) (p : x = y) (q : y = z) =>
paths_rect x (fun (y0 : A) (_ : x = y0) => forall z0 : A, y0 = z0 -> x = z0)
  (fun z0 : A => idmap) y p z q
     : forall (A : Type) (x y z : A), x = y -> y = z -> x = z
*)
Print transl.
(*
transl =
fun (A : Type) (x y z : A) (p : x = y) (q : y = z) =>
paths_rect x (fun (y0 : A) (_ : x = y0) => y0 = z -> x = z) idmap y p q
     : forall (A : Type) (x y z : A), x = y -> y = z -> x = z
*)

Lemma eq_y_l {A : Type} {x y z : A} (p : x = y) (q : y = z) : transy p q = transl p q.
  induction p. reflexivity.
Qed.

(* Exercise 2.4 *)

(*
0-path is a point
1-path is a path (the boundary is the two endpoints)
2-path is a homotopy of paths (the boundary is the two endpaths)
*)

(* The key insight is that the 'type' of a n-dimensional path contains
a sigma in it.  You rarely see sigma when we talk about the 'type' of paths
because we will usually have some endpoints in the context.  If you remove
the context, you need to somehow provide the context.  Who provides the
context?  If it's considered part of the path itself, the context needs to
be baked in with the path; since it's part of the type it is in a sigma. *)

(*
A 0-path in A is a point in A.
A 1-path is (x, y, p) with x y : A,     p : x = y
A 2-path is (p, q, r) with p q : x = y, r : p = q
*)

Fixpoint npath (A : Type) (n : nat) :=
  match n with
      | 0 => A
      | S n' => { x : npath A n' & { y : npath A n' & x = y } }
  end.
Eval compute in (npath nat 2).

(* This is equivalent to what you need, but it's worth convincing yourself that
this is in fact that the equalities all work out.
 {x : nat & x' : nat & y : nat & y' : nat & p : x = y & q : x' = y' & ex : x = x' & ey : y = y' & p = transport2 ex ey q } *)

(* Exercise 2.5 *)
Definition eq2_3_6 {A B x y} (f : A -> B) (p : x = y) : f x = f y -> transport (fun _ => B) p (f x) = f y :=
  fun q => transport_const _ _ @ q.
Definition eq2_3_7 {A B x y} (f : A -> B) (p : x = y) : transport (fun _ => B) p (f x) = f y -> f x = f y :=
  fun q => (transport_const _ _)^ @ q. (* careful with associativity precedence *)

(* I don't know what an "inverse equivalence" is, but it seems like these ought to form an equivalence *)

Definition ex2_5_beta {A B x y} (f : A -> B) (p : x = y) (fp : f x = f y) : eq2_3_7 f p (eq2_3_6 f p fp) = idmap fp.
  unfold eq2_3_6, eq2_3_7.
  path_induction; reflexivity.
Defined.

Definition ex2_5_alpha {A B x y} (f : A -> B) (p : x = y) (fp : transport (fun _ => B) p (f x) = f y) : eq2_3_6 f p (eq2_3_7 f p fp) = idmap fp.
  unfold eq2_3_6, eq2_3_7.
  path_induction; reflexivity.
Defined.

(* Because this chapter does not contain a discussion of the "adjointification" of equivalences
(and all of the proofs simply assume a black box way to get there), we don't worry about it either.) *)
Lemma ex2_5 {A B x y} (f : A -> B) (p : x = y) : IsEquiv (eq2_3_6 f p).
  apply (isequiv_adjointify _ (eq2_3_7 f p) (ex2_5_alpha f p) (ex2_5_beta f p)).
Qed.

(* In some cases, however, the adjointification condition is pretty easy to do. *)
Lemma ex2_5' {A B x y} (f : A -> B) (p : x = y) : IsEquiv (eq2_3_6 f p).
  refine (BuildIsEquiv _ _ _ (eq2_3_7 f p) (ex2_5_alpha f p) (ex2_5_beta f p) _).
  intros; unfold ex2_5_alpha, ex2_5_beta, eq2_3_6, eq2_3_7; path_induction; reflexivity.
Defined.

(* Exercise 2.6 *)

Definition invconcat {A} {x y z : A} (p : x = y) : x = z -> y = z.
  path_induction; reflexivity.
Defined.

Definition concat_alpha {A} {x y z : A} (p : x = y) (q : x = z) : @concat A x y z p (@invconcat A x y z p q) = idmap q.
  path_induction; reflexivity.
Defined.

Definition concat_beta {A} {x y z : A} (p : x = y) (q : y = z) : @invconcat A x y z p (@concat A x y z p q) = idmap q.
  path_induction; reflexivity.
Defined.

Lemma ex2_6 {A} {x y z : A} (p : x = y) : IsEquiv (@concat A x y z p).
  apply (isequiv_adjointify _ (@invconcat A x y z p) (concat_alpha p) (concat_beta p)).
Defined.

Lemma ex2_6' {A} {x y z : A} (p : x = y) : IsEquiv (@concat A x y z p).
  refine (BuildIsEquiv _ _ _ (@invconcat A x y z p) (concat_alpha p) (concat_beta p) _).
  intros; unfold invconcat, concat_alpha, concat_beta, concat; path_induction; reflexivity.
Defined.

(* Exercise 2.7 *)

(* pair^= is path_prod.  It's important to give the second path_prod the
arguments to help Coq figure out the definitional equality.
This lemmma is called ap_functor_prod in the standard library, and f is
defined as functor_prod *)
(* NB: defining f using fst/snd and not a match is fairly essential to
   convincing Coq that things are definitionally equal in the way necessa *)
Theorem theorem2_6_5 {A B A' B'} (g : A -> A') (h : B -> B') (x y : A * B) (p : fst x = fst y) (q : snd x = snd y) :
  let f z := (g (fst z), h (snd z)) in
    ap f (path_prod x y p q) = path_prod (f x) (f y) (ap g p) (ap h q).
  intros. destruct x; destruct y; simpl in *. path_induction; reflexivity.
Qed.
Print ap_functor_prod.

(* The key to writing down the generalized version of this theorem relies
on the three useful lemmas 2.3.{9-11}.  They're available in the HoTT library
but it is instructive to state and prove them here. *)

Lemma lemma2_3_9 {A : Type} (P : A -> Type) {x y z : A} (p : x = y) (q : y = z) (u : P x) :
  transport _ q (transport _ p u) = transport _ (p @ q) u.
  path_induction; reflexivity.
Defined.
Print transport_pp. (* Actually, you don't need this one. Yet. *)

Lemma lemma2_3_10 {A B : Type} (f : A -> B) (P : B -> Type) {x y : A} (p : x = y) (u : P (f x)) :
  transport (P o f) p u = transport P (ap f p) u.
  path_induction; reflexivity.
Defined.
Print transport_compose.

Lemma lemma2_3_11 {A : Type} (P Q : A -> Type) (f : forall x : A, P x -> Q x) {x y : A} (p : x = y) (u : P x) :
  transport Q p (f x u) = f y (transport P p u).
  path_induction; reflexivity.
Defined.
Print ap_transport. (* It's not entirely clear why it's called 'ap' transport, since no ap is involved. *)

(* A useful trick which jgross showed me: if you are not sure how a theorem should
be stated, replace it with a : Type, and fill it out using tactic mode.  This is actually
one of those cases where Agda would be superior to Coq for doing these types of proofs,
since holes are natively supported in goals, whereas we have to do some acrobatics. *)

Theorem ex2_7' {A A'} {P : A -> Type} {P' : A' -> Type} (g : A -> A') (h : forall a, P a -> P' (g a)) (x y : sigT P) (p : x.1 = y.1) (q : transport _ p x.2 = y.2) : Type.
  refine (let f z := (g z.1 ; h z.1 z.2) in
    ap f (path_sigma P x y p q) = path_sigma P' (f x) (f y) (ap g p) _).
  subst f; simpl.
  transitivity (transport (P' o g) p (h x .1 x .2)).
  symmetry. apply (lemma2_3_10 g P' _ _).
  transitivity (h y .1 (transport P p x .2)).
  apply (lemma2_3_11 P (P' o g) _ _ _).
  apply ap.
  exact q.
Defined.

(* Unfortunately, Coq has expanded some of the lemmas into matches on identity,
so we will have to reverse engineer the true theorem in one go. *)
Print ex2_7'.

Theorem ex2_7 {A A'} {P : A -> Type} {P' : A' -> Type} (g : A -> A') (h : forall a, P a -> P' (g a)) (x y : sigT P) (p : x.1 = y.1) (q : transport _ p x.2 = y.2) :
  let f z := (g z.1 ; h z.1 z.2) in
    ap f (path_sigma P x y p q) =
       path_sigma P' (f x) (f y) (ap g p) (concat (inverse (lemma2_3_10 g P' _ _))
                                                  (concat (lemma2_3_11 P (P' o g) _ _ _) (ap _ q))).
  intros; subst f. destruct x; destruct y; simpl in *; unfold lemma2_3_10, lemma2_3_11.
  path_induction; reflexivity.
Qed.

(* This is stated and proved in the library proper in slightly different form *)
Print ap_functor_sigma.

(* Exercise 2.8 *)

(* Reader is also encouraged to check out commentary here, by Bob Harper:
https://www.dropbox.com/sh/jwtpx1rzal7um28/sOgTLhW1Zu/cancellation.pdf  *)

(* coproducts aka sums *)
Require Import Sum.

(* We first reproduce the left-code and the right-code which is presented in
Section 2.12 of the HoTT book, as well as the appropriate equivalences. *)

Definition lcode {A B} (a0 : A) (x : A + B) :=
  match x return Type with inl a => a0 = a | inr b => Empty end.
Definition lencode {A B} {a0 : A} {x : A + B} (p : inl a0 = x) : lcode a0 x :=
  transport (lcode a0) p 1.
Definition ldecode {A B} {a0 : A} {x : A + B} (c : lcode a0 x) : inl a0 = x.
  destruct x. exact (ap inl c). destruct c.
Defined.
(* Done with tactics to automatically push the lambda abstraction inside the
case on x and avoid writing all of the annotations for dependent match. *)
Print ldecode.
Lemma thm2_12_15_alpha {A B} {a0 : A} {x : A + B} (c : lcode a0 x) : (lencode (ldecode c)) = c.
  destruct x; destruct c; reflexivity.
Qed.
Lemma thm2_12_15_beta {A B} {a0 : A} {x : A + B} (p : inl a0 = x) : (ldecode (lencode p)) = p.
  path_induction; reflexivity.
Qed.
Theorem thm2_12_15 {A B} (a0 : A) (x : A + B) : IsEquiv (@lencode A B a0 x).
  apply (isequiv_adjointify _ ldecode thm2_12_15_alpha thm2_12_15_beta ).
Qed.

Definition rcode {A B} (b0 : B) (x : A + B) := match x return Type with inl a => Empty | inr b => b0 = b end.
Definition rencode {A B} {b0 : B} {x : A + B} (p : inr b0 = x) : rcode b0 x := transport (rcode b0) p 1.
Definition rdecode {A B} {b0 : B} {x : A + B} (c : rcode b0 x) : inr b0 = x.
  destruct x. destruct c. f_ap.
Defined.
Lemma thm2_12_15'_alpha {A B} {b0 : B} {x : A + B} (c : rcode b0 x) : (rencode (rdecode c)) = c.
  destruct x; destruct c. reflexivity.
Qed.
Lemma thm2_12_15'_beta {A B} {b0 : B} {x : A + B} (p : inr b0 = x) : (rdecode (rencode p)) = p.
  path_induction. reflexivity.
Qed.
Theorem thm2_12_15' {A B} (b0 : B) (x : A + B) : IsEquiv (@rencode A B b0 x).
  apply (isequiv_adjointify _ rdecode thm2_12_15'_alpha thm2_12_15'_beta ).
Qed.

(* To a new reader, it probably will not be obvious what the codes are for.
The hardest part of this question is knowing how to /state/ the functoriality
property at all.

Referring back to the question statement, we've been asked to state and
prove a corresponding theorem to the functoriality of ap on products.
We can go ahead and attempt to translate the theorem into the language
of coproducts, but the first question one has to answer here is, what corresponds
pair^= here?  We have been instructed that pair^= is the "introduction rule"
for equality on products; we are looking for a similar introduction rule for
equality on sums.  But where it was simply enough to provide two equalities
in the case of product (a negative type former), which equality we provide
for a sum type depends on the tags of the values. (a positive type variable)
So what this "equality" is, is in fact the *code* for equality over coproducts.

While we may not have a good idea what the type of this introduction rule
is, we might know what it is named.  Fortunately, the standard library
already provides us the introduction rule for coproducts; and we can see what
the *code* is (the lhs of the arrow): *)

Check path_sum.

(* In the HoTT library, the matches for the codes for coproducts are all explicitly
written out.  However, it will simplify our work if we wrap them up in a definition,
which we will call 'code'. I take advantage of the previous left-code and right-code
definitions, but there's not any specific reason why they have to be used.  When
Harper gives a presentation of this material, he simply states that these are
defined by double case-match. *)

Definition code {A B} (x0 : A + B) (x : A + B) :=
  match x0 with
      inl a0 => lcode a0 x
    | inr b0 => rcode b0 x
  end.

(* For completeness, though, here is the expanded version: *)
Definition code' {A B} (x0 : A + B) (x : A + B) :=
  match x0 with
      inl a0 => match x with
                    inl a => a0 = a
                  | inr b => Empty
                end
    | inr b0 => match x with
                    inl a => Empty
                  | inr b => b0 = b
                end
  end.
(* Sanity check that these are definitionally equal: *)
Lemma code_code' {A B} (x0 : A + B) (x : A + B) : code x0 x = code' x0 x. reflexivity. Qed.

Definition encode {A B} {x0 x : A + B} (p : x0 = x) : code x0 x.
  destruct x0; [ exact (lencode p) | exact (rencode p) ].
Defined.
Definition decode {A B} {x0 x : A + B} (c : code x0 x) : x0 = x.
  destruct x0; [ exact (ldecode c) | exact (rdecode c) ].
Defined.
Lemma encode_eq_alpha {A B} {x0 : A + B} {x : A + B} (c : code x0 x) : encode (decode c) = c.
  destruct x0. apply thm2_12_15_alpha. apply thm2_12_15'_alpha.
Defined.
Lemma encode_eq_beta {A B} {x0 : A + B} {x : A + B} (p : x0 = x) : decode (encode p) = p.
  path_induction; destruct x0; reflexivity.
Qed.
Theorem encode_eq {A B} (x0 : A + B) (x : A + B) : IsEquiv (@encode A B x0 x).
  apply (isequiv_adjointify _ decode encode_eq_alpha encode_eq_beta ).
Qed.

(* The statement of functoriality ap, then, says what the action of ap
is on elements of the /code/. (In the case of products, that was just the pair of equalities.) *)

Theorem ex2_8 {A B A' B' : Type} (g : A -> A') (h : B -> B') (x y : A + B) (pq : code x y) :
  let f z := match z with inl z' => inl (g z') | inr z' => inr (h z') end in
  ap f (path_sum x y pq) = path_sum (f x) (f y)
     ((match x return code x y -> code (f x) (f y) with
          inl a0 => match y return lcode a0 y -> lcode (g a0) (f y) with
                        inl a => ap g
                      | inr b => fun p => p
                    end
        | inr b0 => match y return rcode b0 y -> rcode (h b0) (f y) with
                        inl a => fun p => p
                      | inr b => ap h
                    end
      end) pq).
  destruct x; destruct y; unfold code, lcode, rcode in *;
  try solve [destruct pq]; path_induction; reflexivity.
Qed.

(* Harper describes a rather interesting alternate method for proving functoriality, which
I tried developing here, but gave up midway.
Definition apf_inv {A B} (f : A -> B) {eq : IsEquiv f} {a a' : A} : f a = f a' -> a = a' :=
  fun q => ((eissect f a) ^ @ ap (f ^-1)%equiv q @ (eissect f a'))%path.
Definition apf_alpha {A B} {f : A -> B} {eq : IsEquiv f} {a a' : A} (p : a = a') : apf_inv f (ap f p) = p.
  path_induction. unfold apf_inv; simpl.
  refine (concat (ap (fun p => (p @ eissect f a)%path) (concat_p1 _)) _).
  apply concat_Vp.
Defined.
Definition apf_beta {A B} {f : A -> B} {eq : IsEquiv f} {a a' : A} (q : f a = f a') : ap f (apf_inv f q) = q.
  (* Notice path_induction doesn't do anything *)
  (* Discover the correct path *)
  unfold apf_inv.
  refine ((concat_p1 _) ^ @ _)%path.
  assert (p : a = a').
    refine ((eissect f a) ^ @ _)%path.
    refine ((ap (f ^-1)%equiv q) @ _)%path.
    exact ((eissect f a')).
  unfold apf_inv.
  path_induction.

Theorem apf_eq {A B} {f : A -> B} {eq : IsEquiv f} {x y : A}: IsEquiv (@ap _ _ f x y).
  *)
(* Exercise 2.9 *)

Definition sum_universal_iso {A B X : Type} (f : A + B -> X) : (A -> X) * (B -> X) := (fun a => f (inl a), fun b => f (inr b)).
Definition sum_universal_osi {A B X : Type} (hg : (A -> X) * (B -> X)) : A + B -> X := let (g, h) := hg in fun x => match x with inl a => g a | inr b => h b end.
Definition sum_universal_alpha {A B X : Type} `{Funext} (f : A + B -> X) : sum_universal_osi (sum_universal_iso f) = f.
  unfold sum_universal_iso, sum_universal_osi. apply H; intro x. destruct x; reflexivity.
Defined.
Definition sum_universal_beta {A B X : Type} (hg : (A -> X) * (B -> X)) : sum_universal_iso (sum_universal_osi hg) = hg.
  unfold sum_universal_iso, sum_universal_osi. destruct hg; reflexivity.
Defined.

Definition sum_universal {A B X : Type} `{Funext} : (A -> X) * (B -> X) <~> (A + B -> X).
  apply (equiv_adjointify sum_universal_osi sum_universal_iso sum_universal_alpha sum_universal_beta).
Defined.

(* Presence of function extensionality makes doing the adjointified version annoying. *)

(* Exercise 2.10 *)

Definition sigma_assoc_iso {A} {B : A -> Type} (C : sigT (fun x : A => B x) -> Type) (p : sigT (fun x : A => sigT (fun y : B x => C (x; y)))) : (sigT (fun (p : sigT (fun x : A => B x)) => C p)) := ((p.1; p.2.1); p.2.2).

Definition sigma_assoc_osi {A} {B : A -> Type} (C : sigT (fun x : A => B x) -> Type) (p : sigT (fun (p : sigT (fun x : A => B x)) => C p)) : (sigT (fun x : A => sigT (fun y : B x => C (x; y)))).
  destruct p. destruct x. refine (x; _). refine (b; _). exact c.
Defined.
(* Looking at the dependent pattern match is instructive, and shows the classic
trick for refining the type of c. But I'm a lazy bastard, and the match is about
what I want. *)
Print sigma_assoc_osi.

Ltac simplHyp :=
  match goal with
      | [ H : _ * _ |- _ ] => destruct H
      | [ H : sigT _ |- _ ] => destruct H
  end.

Ltac crush := simpl in *; repeat simplHyp; try trivial; try solve [f_ap].

Definition sigma_assoc {A} {B : A -> Type} (C : sigT (fun x : A => B x) -> Type) :
  sigT (fun x : A => sigT (fun y : B x => C (x; y))) <~> sigT (fun (p : sigT (fun x : A => B x)) => C p).
  refine (equiv_adjointify (@sigma_assoc_iso A B C) (@sigma_assoc_osi A B C) _ _);
  intro; unfold sigma_assoc_osi, sigma_assoc_iso; crush.
Qed.

(* Exercise 2.11 *)

(* To show that something is the corner of a pullback square, we just need to
show the desired equivalence. *)

Require Import ObjectClassifier.
Print pullback.

Definition pullback1 {A B C} (f : A -> C) (g : B -> C) (p : pullback f g) : A := p.1.
Definition pullback2 {A B C} (f : A -> C) (g : B -> C) (p : pullback f g) : B := p.2.1.

(* Stating the definitions of pullf and pullf_inv using apD10 is *critical*;
 we will be doing reasoning with the fact that apD10 is an equivalence, and
 if some of the parts of the definition are unfolded it will greatly obscure
 what is going on. *)
Definition pullf {A B C} X `{Funext} (f : A -> C) (g : B -> C) (h : X -> pullback f g) : pullback (@compose X _ _ f) (@compose X _ _ g).
  refine (pullback1 f g o h; _).
  refine (pullback2 f g o h; _).
  apply path_forall; intro.
  exact (h x).2.2.
Defined.
Definition pullf_inv {A B C} X (f : A -> C) (g : B -> C) (z : pullback (@compose X _ _ f) (@compose X _ _ g)) (x : X) : pullback f g.
  refine (z.1 x; (z.2.1 x; _)).
  exact (apD10 z.2.2 x).
Defined.

Theorem ex2_11 `{Funext} {A B C X} {f : A -> C} {g : B -> C} : IsEquiv (pullf X f g).
  refine (isequiv_adjointify _ (pullf_inv X f g) _ _).

  unfold Sect, pullf_inv, pullf, path_forall; simpl. destruct 0 as [f' [g' p]]; simpl. f_ap. f_ap.
  apply ((ap apD10)^-1)%equiv.
  apply (eisretr apD10).

  unfold Sect, pullf_inv, pullf, path_forall; intro h; simpl.
  apply path_forall; intro x.
  repeat (apply path_sigma_uncurried; exists idpath; simpl).
  change (h x).2.2 with ((fun x' => (h x').2.2) x); f_ap. (* because higher-order unification is undecidable *)
  apply eisretr.
Qed.

(* Exercise 2.12 *)

(* In the previous exercise we specialized (since h = .1 and k = .2.1), but for this exercise P is
generic so it will be good to properly define pullback squares and the induced map in full
generality. *)

(* P.S. I tried an alternate formulation where squares were defined specifically as pullbacks.
But this is a little annoying when you have two squares joined together, because you have
to explicitly state that two edges of the square are equal. So I decided to go back to the
more straightforward version. *)

(* It's important to specify the input type of compose, since the inferencer gets
confused otherwise. *)

(* P -> A
   ↓    ↓
   B -> C *)
Definition induced_map `{Funext} {P A B C} (f : A -> C) (g : B -> C) (h : P -> A) (k : P -> B) (p : f o h = g o k) X (i : X -> P) : pullback (@compose X _ _ f) (@compose X _ _ g).
  refine (h o i; (k o i; _)).
  change (f o h o i = g o k o i).
  refine (apD10 _ i).
  exact (ap compose p).
Defined.

(* BTW, why couldn't pullf be defined in the same, graceful manner?  Well,
the trouble is while the p here is explicitly provided, in the pullback case
we got it out of the fact that pullbacks come with equality proofs.  We could
have factored this out, so that the call-site of pullf was responsible
for the extraction, but doing it the other way seemed more natural. It's a
sleight of hand that reduces the arguments you need to pass around. (In
a sense, we embedded the proof that it is a commutative square). *)

Definition pullback_square `{Funext} {P A B C}
                           (f : A -> C) (g : B -> C) (h : P -> A) (k : P -> B)
                           (p : f o h = g o k) :=
  forall X, IsEquiv (induced_map f g h k p X).

(* The squares reproduced for your convenience:
  A -> C -> E
  ↓ p  ↓ q  ↓
  B -> D -> F
    \--r--/  *)

(* XXX I don't actually know if this is called whiskering *)
Definition whisker
          {A B C D E F}
          {ac : A -> C}
          {ab : A -> B}
          {cd : C -> D}
          {bd : B -> D}
          {ce : C -> E}
          {ef : E -> F}
          {df : D -> F}
          (p : cd o ac = bd o ab)
          (q : ef o ce = df o cd)
  : ef o ce o ac = df o bd o ab.
transitivity (df o cd o ac); [f_ap|].
change (df o (cd o ac) = df o (bd o ab)); f_ap.
Defined.

(* the hard one *)
Definition induced_map_inv1
          `{Funext}
          {A B C D E F X}
          (ac : A -> C)
          (ab : A -> B)
          (cd : C -> D)
          (bd : B -> D)
          (ce : C -> E)
          (ef : E -> F)
          (df : D -> F)
          (p : cd o ac = bd o ab)
          (q : ef o ce = df o cd)
          (P : pullback_square ef df ce cd q)
          (S : pullback_square cd bd ac ab p)
          (z : pullback (@compose X _ _ ef) (@compose X _ _ (df o bd)))
          : X -> A.
let r := constr:((z.1; (bd o z.2.1; z.2.2)) : pullback (@compose X _ _ ef) (@compose X _ _ df)) in pose r as z'.
let r := constr:(@equiv_inv _ _ _ (P X) z') in pose r as xc.
let r := constr:(induced_map ef df ce cd q X xc) in pose r as z''.
let r := constr:(@eisretr _ _ _ (P X) _ : z'' = z') in pose r as alpha. (* crucial! *)
apply (S X).
refine (xc ; (z.2.1 ; _)).
  etransitivity; [| apply (alpha..2..1)]. (* ho ho, use the retraction! *)
  destruct (alpha ..1). (* get rid of pesky transport *) reflexivity.
Defined.
Print induced_map_inv1.
Definition induced_map_inv2
          `{Funext}
          {A B C D E F X}
          (ac : A -> C)
          (ab : A -> B)
          (cd : C -> D)
          (bd : B -> D)
          (ce : C -> E)
          (ef : E -> F)
          (df : D -> F)
          (p : cd o ac = bd o ab)
          (q : ef o ce = df o cd)
          (P : pullback_square ef df ce cd q)
          (S : pullback_square ef (df o bd) (ce o ac) ab (whisker p q))
          (z : pullback (@compose X _ _ cd) (@compose X _ _ bd))
          : X -> A.
apply (S X).
refine (ce o z.1 ; (z.2.1 ; _)).
destruct z as [xc [xb r]]; simpl.
transitivity (df o cd o xc). change (ef o ce o xc = df o cd o xc); f_ap.
change (df o (cd o xc) = df o (bd o xb)); f_ap.
Defined.

Theorem ex2_12
          `{Funext}
          {A B C D E F}
          (ac : A -> C)
          (ab : A -> B)
          (cd : C -> D)
          (bd : B -> D)
          (ce : C -> E)
          (ef : E -> F)
          (df : D -> F)
          (p : cd o ac = bd o ab)
          (q : ef o ce = df o cd)
          (P : pullback_square ef df ce cd q)
  : (pullback_square cd bd ac ab p <-> pullback_square ef (df o bd) (ce o ac) ab (whisker p q)).
constructor; intro S; intro X.

refine (isequiv_adjointify _ (induced_map_inv1 ac ab cd bd ce ef df p q P S) _ _).
intro z.  destruct z as [x [y r]].
(* The proof here now acts a little differently than the other equivalence
proofs we have encountered.  The first instinct (especially given the other
equivalence proofs in this chapter) is to destruct the input as much as possible,
and then show that things simplify to the original.  However, this strategy
will not work here,   *)
admit.
intro z. unfold induced_map; simpl. unfold induced_map_inv1; simpl.
admit.

refine (isequiv_adjointify _ (induced_map_inv2 ac ab cd bd ce ef df p q P S) _ _).
intro z. unfold induced_map_inv2.
Abort.

(* Exercise 2.13 *)

(* Intuitively, the two inhabitants of Bool ~ Bool are id and neg. *)

Definition equiv_bool_id : Equiv Bool Bool.

Definition ex2_13_f (H : Equiv Bool Bool) : Bool.
  destruct H.
Abort.

Definition ex2_13_g : Bool -> Equiv Bool Bool.
  intro b; destruct b.
Abort.

Lemma ex2_13 : Equiv (Equiv Bool Bool) Bool.
Abort.


(** Support for atoms, i.e., objects with decidable equality.  We
    provide here the ability to generate an atom fresh for any finite
    collection, e.g., the lemma [atom_fresh_for_set], and a tactic to
    pick an atom fresh for the current proof context.

    Authors: Arthur Charguéraud and Brian Aydemir.

    Implementation note: In older versions of Coq, [OrderedTypeEx]
    redefines decimal constants to be integers and not natural
    numbers.  The following scope declaration is intended to address
    this issue.  In newer versions of Coq, the declaration should be
    benign. *)

Require Import List.
Require Import Max.
Require Import OrderedType.
Require Import OrderedTypeEx.
Open Scope nat_scope.

Require Import FiniteSets.
Require Import FSetDecide.
Require Import FSetNotin.
Require Import ListFacts.

(* ********************************************************************** *)
(** * Definition *)

(** Atoms are structureless objects such that we can always generate
    one fresh from a finite collection.  Equality on atoms is [eq] and
    decidable.  We use Coq's module system to make abstract the
    implementation of atoms.  The [Export AtomImpl] line below allows
    us to refer to the type [atom] and its properties without having
    to qualify everything with "[AtomImpl.]". *)

Module Type ATOM.

  Parameter atom : Set.

  Parameter atom_fresh_for_list :
    forall (xs : list atom), {x : atom | ~ List.In x xs}.

  Declare Module Atom_as_OT : UsualOrderedType with Definition t := atom.

  Parameter eq_atom_dec : forall x y : atom, {x = y} + {x <> y}.

End ATOM.

(** The implementation of the above interface is hidden for
    documentation purposes. *)

Module AtomImpl : ATOM.

  (* begin hide *)

  Definition atom := nat.

  Lemma max_lt_r : forall x y z,
    x <= z -> x <= max y z.
  Proof.
    induction x. auto with arith.
    induction y; auto with arith.
      simpl. induction z. omega. auto with arith.
  Qed.

  Lemma nat_list_max : forall (xs : list nat),
    { n : nat | forall x, In x xs -> x <= n }.
  Proof.
    induction xs as [ | x xs [y H] ].
    (* case: nil *)
    exists 0. inversion 1.
    (* case: cons x xs *)
    exists (max x y). intros z J. simpl in J. destruct J as [K | K].
      subst. auto with arith.
      auto using max_lt_r.
  Qed.

  Lemma atom_fresh_for_list :
    forall (xs : list nat), { n : nat | ~ List.In n xs }.
  Proof.
    intros xs. destruct (nat_list_max xs) as [x H].
    exists (S x). intros J. lapply (H (S x)). omega. trivial.
  Qed.

  Module Atom_as_OT := Nat_as_OT.
  Module Facts := OrderedTypeFacts Atom_as_OT.

  Definition eq_atom_dec : forall x y : atom, {x = y} + {x <> y} :=
    Facts.eq_dec.

  (* end hide *)

End AtomImpl.

Export AtomImpl.

(* ********************************************************************** *)
(** * Finite sets of atoms *)

(* ********************************************************************** *)
(** ** Definitions *)

Module AtomSet : FiniteSets.S with Module E := Atom_as_OT :=
  FiniteSets.Make Atom_as_OT.

(** The type [atoms] is the type of finite sets of [atom]s. *)

Notation atoms := AtomSet.F.t.

(** Basic operations on finite sets of atoms are available, in the
    remainder of this file, without qualification.  We use [Import]
    instead of [Export] in order to avoid unnecessary namespace
    pollution. *)

Import AtomSet.F.

(** We instantiate two modules which provide useful lemmas and tactics
    work working with finite sets of atoms. *)

Module AtomSetDecide := FSetDecide.Decide AtomSet.F.
Module AtomSetNotin  := FSetNotin.Notin   AtomSet.F.

(* *********************************************************************** *)
(** ** Tactics for working with finite sets of atoms *)

(** The tactic [fsetdec] is a general purpose decision procedure
    for solving facts about finite sets of atoms. *)

Ltac fsetdec := try apply AtomSet.eq_if_Equal; AtomSetDecide.fsetdec.

(** The tactic [notin_simpl] simplifies all hypotheses of the form [(~
    In x F)], where [F] is constructed from the empty set, singleton
    sets, and unions. *)

Ltac notin_simpl := AtomSetNotin.notin_simpl_hyps.

(** The tactic [notin_solve], solves goals of the form [(~ In x F)],
    where [F] is constructed from the empty set, singleton sets, and
    unions.  The goal must be provable from hypothesis of the form
    simplified by [notin_simpl]. *)

Ltac notin_solve := AtomSetNotin.notin_solve.

(* *********************************************************************** *)
(** ** Lemmas for working with finite sets of atoms *)

(** We make some lemmas about finite sets of atoms available without
    qualification by using abbreviations. *)

Notation eq_if_Equal        := AtomSet.eq_if_Equal.
Notation notin_empty        := AtomSetNotin.notin_empty.
Notation notin_singleton    := AtomSetNotin.notin_singleton.
Notation notin_singleton_rw := AtomSetNotin.notin_singleton_rw.
Notation notin_union        := AtomSetNotin.notin_union.

(* ********************************************************************** *)
(** * Additional properties *)

(** One can generate an atom fresh for a given finite set of atoms. *)

Lemma atom_fresh_for_set : forall L : atoms, { x : atom | ~ In x L }.
Proof.
  intros L. destruct (atom_fresh_for_list (elements L)) as [a H].
  exists a. intros J. contradiction H.
  rewrite <- InA_iff_In. auto using elements_1.
Qed.

(* ********************************************************************** *)
(** * Additional tactics *)

(* ********************************************************************** *)
(** ** ## Picking a fresh atom *)

(** We define three tactics which, when combined, provide a simple
    mechanism for picking a fresh atom.  We demonstrate their use
    below with an example, the [example_pick_fresh] tactic.

   [(gather_atoms_with F)] returns the union of [(F x)], where [x]
   ranges over all objects in the context such that [(F x)] is
   well typed.  The return type of [F] should be [atoms].  The
   complexity of this tactic is due to the fact that there is no
   support in [Ltac] for folding a function over the context. *)

Ltac gather_atoms_with F :=
  let rec gather V :=
    match goal with
    | H: ?S |- _ =>
      let FH := constr:(F H) in
      match V with
      | empty => gather FH
      | context [FH] => fail 1
      | _ => gather (union FH V)
      end
    | _ => V
    end in
  let L := gather empty in eval simpl in L.

(** [(beautify_fset V)] takes a set [V] built as a union of finite
    sets and returns the same set with empty sets removed and union
    operations associated to the right.  Duplicate sets are also
    removed from the union. *)

Ltac beautify_fset V :=
  let rec go Acc E :=
     match E with
     | union ?E1 ?E2 => let Acc1 := go Acc E2 in go Acc1 E1
     | empty => Acc
     | ?E1 => match Acc with
              | empty => E1
              | context [E1] => Acc
              | _ => constr:(union E1 Acc)
              end
     end
  in go empty V.

(** The tactic [(pick fresh Y for L)] takes a finite set of atoms [L]
    and a fresh name [Y], and adds to the context an atom with name
    [Y] and a proof that [(~ In Y L)], i.e., that [Y] is fresh for
    [L].  The tactic will fail if [Y] is already declared in the
    context. *)

Tactic Notation "pick" "fresh" ident(Y) "for" constr(L) :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (atom_fresh_for_set L) as [Y Fr]).

(* ********************************************************************** *)
(** ** Demonstration *)

(** The [example_pick_fresh] tactic below illustrates the general
    pattern for using the above three tactics to define a tactic which
    picks a fresh atom.  The pattern is as follows:
      - Repeatedly invoke [gather_atoms_with], using functions with
        different argument types each time.
      - Union together the result of the calls, and invoke
        [(pick fresh ... for ...)] with that union of sets. *)

Ltac example_pick_fresh Y :=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  pick fresh Y for (union A B).

Lemma example_pick_fresh_use : forall (x y z : atom) (L1 L2 L3: atoms), True.
(* begin show *)
Proof.
  intros x y z L1 L2 L3. example_pick_fresh k.

  (** At this point in the proof, we have a new atom [k] and a
      hypothesis [Fr : ~ In k (union L1 (union L2 (union L3 (union
      (singleton x) (union (singleton y) (singleton z))))))]. *)

  trivial.
Qed.
(* end show *)


(* ***************************************************************** *)
(*                                                                   *)
(* Released: 2020/04/04.                                             *)
(* Due: 2020/04/08, 23:59:59, CST.                                   *)
(*                                                                   *)
(* 0. Read instructions carefully before start writing your answer.  *)
(*                                                                   *)
(* 1. You should not add any hypotheses in this assignment.          *)
(*    Necessary ones have been provided for you.                     *)
(*                                                                   *)
(* 2. In order to check whether you have finished all tasks or not,  *)
(*    just see whether all "Admitted" has been replaced.             *)
(*                                                                   *)
(* 3. You should submit this file (Assignment4.v) on CANVAS.         *)
(*                                                                   *)
(* 4. Only valid Coq files are accepted. In other words, please      *)
(*    make sure that your file does not generate a Coq error. A      *)
(*    way to check that is: click "compile buffer" for this file     *)
(*    and see whether an "Assignment4.vo" file is generated.         *)
(*                                                                   *)
(* 5. Do not copy and paste others' answer.                          *)
(*                                                                   *)
(* 6. Using any theorems and/or tactics provided by Coq's standard   *)
(*    library is allowed in this assignment, if not specified.       *)
(*                                                                   *)
(* 7. When you finish, answer the following question:                *)
(*                                                                   *)
(*      Who did you discuss with when finishing this                 *)
(*      assignment? Your answer to this question will                *)
(*      NOT affect your grade.                                       *)
(*      (* FILL IN YOUR ANSWER HERE AS COMMENT *)                    *)
(*                                                                   *)
(* ***************************************************************** *)

Require Import PL.Imp.
Require Import PL.ImpExt3.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.micromega.Psatz.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.

(** In this assignment, we are going to establish another denotational semantics
    for our simple imperative language. This time, a program's denotation is
    defined as a ternary relation. Specifically, [st1, t, st2] belongs to the
    denotation of program [c] if and only if executing [c] from [st1] may take
    time [t] and stop at state [st2].

    We could write a more realistic definition here, but in order to make things
    simple, we assume every assignment command takes one unit of time, every
    testing (for either if-command, or loop condition testing) takes one unit of
    time and the [Skip] command does not take any time. *)

Definition skip_sem: state -> Z -> state -> Prop :=
  fun st1 t st2 =>
    st1 = st2 /\ t = 0.

Definition asgn_sem (X: var) (E: aexp): state -> Z -> state -> Prop :=
  fun st1 t st2 =>
    st2 X = aeval E st1 /\
    forall Y, X <> Y -> st1 Y = st2 Y /\
    t = 1.

Definition seq_sem (d1 d2: state -> Z -> state -> Prop)
  : state -> Z -> state -> Prop
:=
  fun st1 t st3 =>
    exists t1 t2 st2,
      d1 st1 t1 st2 /\ d2 st2 t2 st3 /\ t = t1 + t2.

Definition test_sem (X: state -> Prop): state -> Z -> state -> Prop :=
  fun st1 t st2 =>
    st1 = st2 /\ X st1 /\ t = 1.

Definition union_sem (d d': state -> Z -> state -> Prop)
  : state -> Z -> state -> Prop
:=
  fun st1 t st2 =>
    d st1 t st2 \/ d' st1 t st2.

Definition if_sem (b: bexp) (d1 d2: state -> Z -> state -> Prop)
  : state -> Z -> state -> Prop
:=
  union_sem
    (seq_sem (test_sem (beval b)) d1)
    (seq_sem (test_sem (beval (! b))) d2).

Fixpoint iter_loop_body
  (b: bexp)
  (loop_body: state -> Z -> state -> Prop)
  (n: nat)
  : state -> Z -> state -> Prop
:=
  match n with
  | O => test_sem (beval (! b))
  | S n' => seq_sem
              (test_sem (beval b))
              (seq_sem loop_body (iter_loop_body b loop_body n'))
  end.

Definition omega_union_sem (d: nat -> state -> Z -> state -> Prop)
  : state -> Z -> state -> Prop
:=
  fun st1 t st2 => exists n, d n st1 t st2.

Definition loop_sem (b: bexp) (loop_body: state -> Z -> state -> Prop)
  : state -> Z -> state -> Prop
:=
  omega_union_sem (iter_loop_body b loop_body).

Fixpoint ceval (c: com): state -> Z -> state -> Prop :=
  match c with
  | CSkip => skip_sem
  | CAss X E => asgn_sem X E
  | CSeq c1 c2 => seq_sem (ceval c1) (ceval c2)
  | CIf b c1 c2 => if_sem b (ceval c1) (ceval c2)
  | CWhile b c => loop_sem b (ceval c)
  end.

(* ################################################################# *)
(** * Task 1: The Theory Of Ternary Relations *)

Definition sem_equiv (d1 d2: state -> Z -> state -> Prop): Prop :=
  forall st1 t st2, d1 st1 t st2 <-> d2 st1 t st2.

(** You should first prove that [sem_equiv] is an equivalence relation and it
    is preserved by [seq_sem], [union_sem], [omega_union_sem]. Also, [test_sem]
    will always turn equivalent state sets into equivalent ternary relations. *)

(** **** Exercise: 1 star, standard (sem_equiv_refl)  *)

Lemma sem_equiv_refl: Reflexive sem_equiv.
Proof.
  unfold Reflexive, sem_equiv.
  intros.
  split;intro;exact H.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (sem_equiv_sym)  *)

Lemma sem_equiv_sym: Symmetric sem_equiv.
Proof.
  unfold Symmetric, sem_equiv.
  intros.
  split;intro;apply H,H0.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (sem_equiv_trans)  *)

Lemma sem_equiv_trans: Transitive sem_equiv.
Proof.
  unfold Transitive, sem_equiv.
  intros.
  split;intro.
  - apply H0, H, H1.
  - apply H, H0, H1.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (seq_sem_equiv)  *)

Lemma seq_sem_equiv: Proper (sem_equiv ==> sem_equiv ==> sem_equiv) seq_sem.
Proof.
  unfold Proper, respectful.
  intros. unfold seq_sem, sem_equiv.
  intros. split;intros [t1 [t2 [st' [H1 [H2 H3]]]]].
  - exists t1, t2, st'. repeat split.
    + apply H. exact H1.
    + apply H0. exact H2.
    + exact H3.
  - exists t1, t2, st'. repeat split.
    + apply H. exact H1.
    + apply H0. exact H2.
    + exact H3.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (union_sem_equiv)  *)

Lemma union_sem_equiv: Proper (sem_equiv ==> sem_equiv ==> sem_equiv) union_sem.
Proof.
  unfold Proper, respectful.
  intros. unfold union_sem, sem_equiv.
  intros. split;intros [H1|H1];
  try apply H in H1; try apply H0 in H1; tauto.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (omega_union_sem_equiv)  *)

Lemma omega_union_sem_equiv: forall d1 d2: nat -> state -> Z -> state -> Prop,
  (forall n: nat, sem_equiv (d1 n) (d2 n)) ->
  sem_equiv (omega_union_sem d1) (omega_union_sem d2).
Proof.
  intros.
  unfold sem_equiv, omega_union_sem.
  split;intros [n H0];exists n;apply H;tauto.
Qed.

(** [] *)

(** **** Exercise: 1 star, standard (test_sem_equiv)  *)

Lemma test_sem_equiv: Proper (Sets.equiv ==> sem_equiv) test_sem.
Proof.
  unfold Proper, respectful.
  intros. unfold sem_equiv,test_sem.
  intros. split; intros [H1 [H2 H3]];apply H in H2;tauto.
Qed.
(** [] *)

Existing Instances sem_equiv_refl
                   sem_equiv_sym
                   sem_equiv_trans
                   seq_sem_equiv
                   union_sem_equiv
                   test_sem_equiv.

(** Also, it is important that [union_sem] is commutative and associative, and
    [seq_sem] is associative, distributive and absorbing [skip_sem].  *)

(** **** Exercise: 1 star, standard (union_sem_comm)  *)

Lemma union_sem_comm: forall d1 d2,
  sem_equiv (union_sem d1 d2) (union_sem d2 d1).
Proof.
  intros.
  unfold sem_equiv, union_sem.
  intros. tauto.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (union_sem_assoc)  *)

Lemma union_sem_assoc: forall d1 d2 d3,
  sem_equiv (union_sem d1 (union_sem d2 d3)) (union_sem (union_sem d1 d2) d3).
Proof.
  intros.
  unfold sem_equiv, union_sem.
  intros. tauto.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (seq_sem_assoc)  *)

Lemma seq_sem_assoc: forall d1 d2 d3,
  sem_equiv (seq_sem d1 (seq_sem d2 d3)) (seq_sem (seq_sem d1 d2) d3).
Proof.
Proof.
  intros.
  unfold sem_equiv, seq_sem.
  intros.
  split; intros [t1 [t2 [st3 [H1 H2]]]].
  - destruct H2 as [[t3 [t4 [st4 [H2 [H3 H4]]]]] H5].
    exists (t1+t3), t4, st4.
    repeat split;subst t t2;auto;try lia.
    exists t1,t3, st3.
    tauto.
  - destruct H2 as [H4 H5].
    destruct H1 as [t3 [t4 [st4 [H1 [H2 H3]]]]].
    exists t3, (t4 + t2), st4.
    repeat split;auto;try lia.
    exists t4, t2, st3.
    tauto.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (seq_union_distr_l)  *)

Lemma seq_union_distr_l: forall d1 d2 d3,
  sem_equiv
    (seq_sem d1 (union_sem d2 d3))
    (union_sem (seq_sem d1 d2) (seq_sem d1 d3)).
Proof.
  intros. unfold sem_equiv.
  intros. unfold seq_sem, union_sem. split;intro.
  - destruct H as [t1 [t2 [st3 [H1 [[H2|H2] H3]]]]].
    + left. exists t1, t2,st3. tauto.
    + right. exists t1, t2, st3. tauto.
  - destruct H as [[t1 [t2 [st3 H]]]|[t1 [t2 [st3 H]]]];
    exists t1, t2, st3;tauto.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (seq_union_distr_r)  *)

Lemma seq_union_distr_r: forall d1 d2 d3,
  sem_equiv
    (seq_sem (union_sem d1 d2) d3)
    (union_sem (seq_sem d1 d3) (seq_sem d2 d3)).
Proof.
  unfold sem_equiv, seq_sem, union_sem.
  intros. split;intro.
  - destruct H as [t1 [t2 [st3 [[H|H] H1]]]].
    + left. exists t1, t2, st3. tauto.
    + right. exists t1, t2, st3. tauto.
  - destruct H as [[t1 [t2 [st3 H]]]|[t1 [t2 [st3 H]]]];
    exists t1, t2, st3;tauto.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (seq_skip_l)  *)

Lemma seq_skip_l: forall d, sem_equiv (seq_sem skip_sem d) d.
Proof.
  intros. unfold sem_equiv, seq_sem, skip_sem.
  intros. split;intro.
  - destruct H as [t1 [t2 [st3 [[? ?] [? ?]]]]].
    subst. apply H1.
  -  exists 0, t, st1. tauto.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (seq_skip_r)  *)

Lemma seq_skip_r: forall d, sem_equiv (seq_sem d skip_sem) d.
Proof.
  intros. unfold sem_equiv, seq_sem, skip_sem.
  intros. split;intro.
  - destruct H as [t1 [t2 [st3 [? [[? ?] ?]]]]].
    subst. rewrite Zplus_0_r. apply H.
  - exists t, 0, st2. rewrite Zplus_0_r. tauto.
Qed.
(** [] *)

(* ################################################################# *)
(** * Task 2: Program Equivalence Is An Equivalence *)

(** By a different program semantics, we can have a different sense of program
    equivalence. For example, the following two program were thought to be
    equivalent in class because they have the same effects: [ X ::= 0 ] vs.
    [ X ::= 1;; X ::= 0 ]. However, they take different amount of time to
    execute according to our semantic model. Thus, in some sense, they are
    not that equivalent.

    In this task, we will prove for you that our new program equivalence (see
    below) is an equivalence relation. You need to answer some questions about
    these proofs. *)

Definition com_equiv (c1 c2: com): Prop :=
  sem_equiv (ceval c1) (ceval c2).

Lemma com_equiv_refl: Reflexive com_equiv.
Proof.
  unfold Reflexive, com_equiv.
  intros.
  reflexivity.
Qed.

(** **** Exercise: 1 star, standard (com_equiv_refl_uses)  *)

(** Which property/properties about [sem_equiv] does this proof use?

    1. Reflexivity, [sem_equiv_refl];

    2. Symmetry, [sem_equiv_sym];

    3. Transitivity, [sem_equiv_trans].

    Hint: this is a multiple-choice problem. You should use an ascending Coq
    list to describe your answer, e.g. [1; 2; 3; 4], [1; 3], [2]. *)

Definition com_equiv_refl_uses: list Z := [1].
(** [] *)

Lemma com_equiv_sym: Symmetric com_equiv.
Proof.
  unfold Symmetric, com_equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

(** **** Exercise: 1 star, standard (com_equiv_sym_uses)  *)

(** Which property/properties about [sem_equiv] does this proof use?

    1. Reflexivity, [sem_equiv_refl];

    2. Symmetry, [sem_equiv_sym];

    3. Transitivity, [sem_equiv_trans]. *)

Definition com_equiv_sym_uses: list Z := [1;2;3].
(** [] *)

Lemma com_equiv_trans: Transitive com_equiv.
Proof.
  unfold Transitive, com_equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

(** **** Exercise: 1 star, standard (com_equiv_trans_uses)  *)

(** Which property/properties about [sem_equiv] does this proof use?

    1. Reflexivity, [sem_equiv_refl];

    2. Symmetry, [sem_equiv_sym];

    3. Transitivity, [sem_equiv_trans]. *)

Definition com_equiv_trans_uses: list Z := [1;3].
(** [] *)

(* ################################################################# *)
(** * Task 3: Program Equivalence Is A Congruence *)

(** In this task, you need to prove that [com_equiv] is a congruence. The first
    one is done for you.*)

Lemma CSeq_congr: Proper (com_equiv ==> com_equiv ==> com_equiv) CSeq.
Proof.
  unfold Proper, respectful.
  unfold com_equiv.
  intros c1 c1' ? c2 c2' ?.
  simpl.
  rewrite H, H0.
  reflexivity.
Qed.

(** **** Exercise: 1 star, standard (CAss_congr)  *)

Instance asgn_congr: forall (X: var),
Proper (aexp_equiv ==> sem_equiv) (asgn_sem X).
Proof.
  unfold Proper, respectful.
  intros. unfold sem_equiv.
  unfold ceval, asgn_sem, sem_equiv.
  intros. split;intro.
  - rewrite <- H. exact H0.
  - rewrite H. exact H0.
Qed.

Lemma CAss_congr: forall (X: var),
  Proper (aexp_equiv ==> com_equiv) (CAss X).
Proof.
  unfold Proper, respectful.
  unfold com_equiv.
  intros X s1 s1' ?. simpl.
  rewrite H.
  reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (CIf_congr)  *)

Lemma CIf_congr:
  Proper (bexp_equiv ==> com_equiv ==> com_equiv ==> com_equiv) CIf.
Proof.
  unfold Proper, respectful.
  unfold com_equiv.
  intros b b' ? x y ? x' y' ?.
  simpl. unfold if_sem. rewrite H0. rewrite H1.
  unfold bexp_equiv in H.
  simpl. rewrite H.
  reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (CWhile_congr)  *)

Lemma CWhile_congr:
  Proper (bexp_equiv ==> com_equiv ==> com_equiv) CWhile.
Proof.
  hnf. unfold respectful.
  unfold com_equiv.
  intros b b' ? x x' ?.
  simpl. unfold loop_sem.
  apply omega_union_sem_equiv.
  intros.
  induction n.
  - simpl. unfold bexp_equiv in H. rewrite H.
    reflexivity.
  - simpl. rewrite IHn. unfold bexp_equiv in H.
    rewrite H. rewrite H0. reflexivity.
Qed.

(** [] *)

(* ################################################################# *)
(** * Task 4: Typical Program Transiformations *)

(** In this task, you need to prove that the following transformations still
    genetate equivalent programs, according to our new definition of
    [com_equiv]. Hint: some lemmas that we have proved in previous tasks may be
    helpful. *)

(** **** Exercise: 1 star, standard (swap_if_branches)  *)

Theorem swap_if_branches : forall b c1 c2,
  com_equiv
    (If b Then c1 Else c2 EndIf)
    (If (BNot b) Then c2 Else c1 EndIf).
Proof.
  intros.
  unfold com_equiv. simpl.
  unfold if_sem.
  simpl.
  rewrite Sets_complement_complement.
  apply union_sem_comm.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (seq_assoc)  *)

Theorem seq_assoc : forall c1 c2 c3,
  com_equiv ((c1;;c2);;c3) (c1;;(c2;;c3)).
Proof.
  intros.
  unfold com_equiv.
  simpl. rewrite seq_sem_assoc.
  reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (if_seq)  *)
Theorem if_seq : forall b c1 c2 c3,
  com_equiv
    (If b Then c1 Else c2 EndIf;; c3)
    (If b Then c1;; c3 Else c2;; c3 EndIf).
Proof.
  intros.
  unfold com_equiv.
  simpl. unfold if_sem.
  rewrite seq_union_distr_r.
  rewrite !seq_sem_assoc.
  reflexivity.
Qed.
(** [] *)

(* ################################################################# *)
(** * Task 5: Understanding Bourbaki-Witt Fix Point *)

Module BW_FixPoint.

Section BW_FixPoint.

(** Given a boolean expression [b] and a loop body's denotation [d], we have
    defined [loop_sem b d] as the whole loop's denotation. In this new
    denotational semantics, [loop_sem b d] is also the least fix point of the
    following [F], although its construction is not identical to the one in
    Bourbaki-Witt Fix Point theorem. *)

Variable b: bexp.
Variable d: state -> Z -> state -> Prop.

Definition F X := if_sem b (seq_sem d X) skip_sem.

(** In other words, [loop_sem b d] is equivalent with [F (loop_sem b d)]. *)

(** Now, let's discover the relation between our definition of [loop_sem] and
    Bourbaki-Witt's construction. Bourbaki-Witt's construction is based on a
    bottom element, in this case, the empty ternary relation. *)

Definition Bot: state -> Z -> state -> Prop := fun _ _ _ => False.

(** And the least fix point is the least upper bound of:

    - Bot

    - F Bot

    - F (F Bot)

    - F (F (F Bot))

    - ... *)

Fixpoint FBot (n: nat) :=
  match n with
  | O => Bot
  | S n' => F (FBot n')
  end.

Definition loop_sem' := omega_union_sem (FBot).

(** In this case, the least upper bound of a ternary relation sequence is their
    [omega_union_sem]. Thus, Bourbaki-Witt's fixpoint can be formalized as
    [loop_sem'] above. *)

End BW_FixPoint.

(** Now, let's discover the relationship between [loop_sem]'s construction and
    [loop_sem']'s construction.

    Hint 1: Both [iter_loop_body] and [FBot] are recursively defined. You may
    write [simpl] to use their definitions.

    Hint 2: Some properties about [union_sem], [seq_sem] and [skip_sem] in
    previous tasks may be helpful here.

    Hint 3: Proving some extra properties about [Bot] could make your proofs
    more concise. *)

(** **** Exercise: 2 stars, standard (FBot1_fact)  *)

Fact FBot1_fact: forall b d, sem_equiv (iter_loop_body b d 0) (FBot b d 1).
Proof.
  intros.
  simpl.
  unfold F, if_sem.
  simpl. rewrite seq_skip_r.
  split;intro.
  - right. exact H.
  - destruct H.
    + hnf in H. destruct H as [t1 [t2 [st3 [? [? ?]]]]].
      hnf in H0. destruct H0 as [t3 [t4 [st4 [? [? ?]]]]].
      hnf in H2. destruct H2.
    + exact H.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard (FBot2_fact)  *)

Instance FB_congruence b d : Proper (sem_equiv ==> sem_equiv) (F b d ).
Proof. hnf. intros.
  unfold F. unfold if_sem. rewrite H.
  reflexivity.
Qed.

Fact FBot2_fact: forall b d,
  sem_equiv
    (union_sem (iter_loop_body b d 1) (iter_loop_body b d 0))
    (FBot b d 2).
Proof.
  intros.
  replace (FBot b d 2) with (F b d (FBot b d 1)) by reflexivity.
  rewrite <- FBot1_fact.
  simpl. unfold F, if_sem.
  rewrite seq_skip_r.
  reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard (FBot_n_fact_statement)  *)

(** For generic natural number [n], what is the connection between [FBot b d n]
    and [iter_loop_body]? Write down a proposition to describe this connection.
    Note that your [FBot_n_fact_statement] should have the following form:

    - forall b d n, sem_equiv (...) (FBot b d n).

    And you probably need to write some auxiliary definition(s) first. *)

Fixpoint finite_union_sem (n:nat)
   (rs: nat -> state -> Z -> state -> Prop): state -> Z -> state -> Prop :=
   match n with
   | O => rs O
   | S n' => union_sem (rs (S n')) (finite_union_sem n' rs)
   end.

Definition FBot_n_fact_statement: Prop :=
  forall b d n, sem_equiv (finite_union_sem n (iter_loop_body b d)) (FBot b d (S n)).

Lemma FBot_n_fact_help: forall b d n,
  sem_equiv
    (finite_union_sem (S n) (iter_loop_body b d))
    ( union_sem
      (test_sem (beval (! b)))
      (seq_sem (test_sem (beval b))
         (seq_sem d (finite_union_sem n (iter_loop_body b d))))).
Proof.
  induction n.
  + simpl. apply union_sem_comm.
  + replace (finite_union_sem (S (S n)) (iter_loop_body b d)) with
    (union_sem (iter_loop_body b d (S (S n))) (finite_union_sem (S n) (iter_loop_body b d)))
    by reflexivity.
    rewrite IHn at 1.
    rewrite union_sem_assoc.
    rewrite (union_sem_comm _ (test_sem (beval (! b)))).
    rewrite <- union_sem_assoc.
    simpl. rewrite seq_union_distr_l.
    rewrite seq_union_distr_l. reflexivity.
Qed.

Theorem FBot_n_fact: FBot_n_fact_statement.
Proof.
  hnf. intros.
  induction n.
  - apply FBot1_fact.
  - replace (FBot b d (S (S n)))
      with (F b d (FBot b d (S n))) by reflexivity.
    rewrite <- IHn.
    simpl. unfold F, if_sem.
    rewrite seq_skip_r.
    destruct n.
    + simpl. reflexivity.
    + simpl.
      rewrite (FBot_n_fact_help b d n) at 1.
      rewrite seq_union_distr_l.
      rewrite seq_union_distr_l.
      simpl.
      rewrite (union_sem_comm (test_sem (Sets.complement (beval b)))).
      rewrite union_sem_assoc.
      reflexivity.
Qed.

(** [] *)

End BW_FixPoint.

(* Fri Apr 3 20:44:10 CST 2020 *)


Variables A B : Prop.
Lemma ex7 : ((A \/ B) /\ ~ A) -> B.
Proof.
  intro HaOrHb_and_Hna.
  destruct HaOrHb_and_Hna as [Ha_or_Hb Hna].
  destruct Ha_or_Hb as [Ha | Hb].
  +
    contradiction.
  +
    exact Hb.
Qed.


(** * Definition of functions and constructors *)

Require Export Relations.
Set Implicit Arguments.

Section Global.

  Section Def.

    Variables X Y X' Y': Type.

(*
    Record function: Type := mkfun {
      body:> relation2 X Y -> relation2 X Y;
      Hmon: forall R S, incl R S -> incl (body R) (body S)
    }.
*)

    Definition function2 := relation2 X Y -> relation2 X' Y'.
    Definition function  := relation2 X Y -> relation2 X Y.

    Definition increasing (F: function) :=
      forall R S, incl R S -> incl (F R) (F S).

    Definition contains (F G: function2) := forall R, incl (F R) (G R).

    (** Constant and identity functions *)
    Definition constant S: function2 := fun _ => S.
    Definition identity: function := fun R => R.

    (** Binary and general union functions *)
    Definition Union2 F G: function2 := fun R => union2 (F R) (G R).
    Definition Union I H: function2 := fun R => union (fun i: I => H i R).

  End Def.

  Section Def'.

    Variables X Y Z X' Y' Z' X'' Y'': Type.

    Definition transparent (B: relation X) (F: function2 X Y X Y') :=
      forall R, incl (F (comp (star B) R)) (comp (star B) (F R)).

    (** Chaining functions *)
    Definition chaining_l (S: relation2 X Y): function2 Y Z X Z := comp S.
    Definition chaining_r (S: relation2 Y Z): function2 X Y X Z := fun R => comp R S.
    Definition Chain (F: function2 X Y X' Y') (G: function2 X Y Y' Z') := fun R => comp (F R) (G R).

    (** Composition *)
    Definition Comp (G: function2 X' Y' X'' Y'') (F: function2 X Y X' Y') := fun R => G (F R).

    Variable F: function X Y.
    Variable R: relation2 X Y.

    (** Simple iteration function *)
    Fixpoint Exp(n: nat): relation2 X Y :=
      match n with
	| O => R
	| S n => F (Exp n)
      end.
    Definition Iter := union Exp.

    (** Increasing iteration function *)
    (* inverser n et R ? *)
    Fixpoint UExp(n: nat): relation2 X Y :=
      match n with
	| O => R
	| S n => union2 (UExp n) (F (UExp n))
      end.
    Definition UIter := union UExp.

    Lemma UExp_incl: forall n, incl (UExp n) (UExp (S n)).
    Proof. intros n x y H; left; auto. Qed.

    Lemma UIter_incl: incl R UIter.
    Proof. intros x y H; exists 0; auto. Qed.

  End Def'.

  Section UIter.
    Variables X Y: Type.
    Variable F: function X Y.
    Hypothesis HF: increasing F.

    Lemma UExp_inc: forall n R S, incl R S -> incl (UExp F R n) (UExp F S n).
    Proof.
      intros n R S H; induction n as [ | n IH ]; intros x y XY; simpl; auto.
      celim XY; intro XY.
      left; exact (IH _ _ XY).
      right; apply (HF IH XY).
    Qed.

    (* begin hide *)
    Lemma UIter_inc: increasing (UIter F).
    Proof.
      intros R S H x y XY; destruct XY as [ n XY ].
      exists n; apply (UExp_inc n H _ _ XY).
    Qed.

    Lemma UExp_UExp: forall R m n, UExp F (UExp F R n) m = UExp F R (m+n).
    Proof.
      intros R m; induction m as [ | m IH ]; intros n.
      reflexivity.
      simpl; rewrite IH; reflexivity.
    Qed.

    Hypothesis HF0: forall R, incl R (F R).
    Hypothesis HF2: forall R, incl (F (F R)) (F R).
    Lemma UIter_02: contains (UIter F) F.
    Proof.
      intros R x y H; destruct H as [ n H ]; cgen H; cgen y; cgen x;
	induction n as [ | n IH ]; intros x y H.
      apply HF0; exact H.
      celim H; intro H; auto.
      apply HF2; exact (HF IH H).
    Qed.
    (* end hide *)

  End UIter.

  Section UIter'.
    Variable X: Type.
    Variable F: function X X.
    Hypothesis HF: forall R, eeq (trans (F R)) (F (trans R)) .
    Hypothesis HF': increasing F.

    Lemma UExp_trans: forall n R, eeq (trans (UExp F R n)) (UExp F (trans R) n).
      intros n R; induction n as [ | n IH ]; split; intros x y H; auto; celim H; intro H.
      left; exact (proj1 IH _ _ H).
      right; apply (HF' (proj1 IH)); apply (proj1 (HF (UExp F R n))); auto.
      left; exact (proj2 IH _ _ H).
      right; apply (proj2 (HF (UExp F R n))); apply (HF' (proj2 IH) H).
    Qed.

    Lemma UIter_trans: forall R, eeq (trans (UIter F R)) (UIter F (trans R)).
      intro R; split; intros x y H; destruct H as [ i H ]; exists i.
      exact (proj1 (UExp_trans i R) _ _ H).
      exact (proj2 (UExp_trans i R) _ _ H).
    Qed.
  End UIter'.
End Global.

Hint Immediate UExp_incl.
Hint Immediate UIter_incl.


Require Export Bool.
Require Export List.
Export ListNotations.

Require Export common.

Module BLang.

(* The terms of our boolean logic, all at one level *)
Inductive bterm : Type :=
  | BTrue   : bterm
  | BFalse  : bterm
  | BIf     : bterm -> bterm -> bterm -> bterm
  | BZero   : bterm
  | BSucc   : bterm -> bterm
  | BPred   : bterm -> bterm
  | BIsZero : bterm -> bterm.

(* Notation for if statements *)
Notation "'BIF' t1 'THEN' t2 'ELSE' t3 'FI'" :=
  (BIf t1 t2 t3) (at level 80, right associativity).

Reserved Notation "t '||' t'" (at level 50, left associativity).

(* Evaluation relations, defined inductively *)
Inductive bevalR : bterm -> bterm -> Prop :=
  | E_IfTrue: forall (t2 t3: bterm),
      (BIF BTrue THEN t2 ELSE t3 FI || t2)
  | E_IfFalse: forall (t2 t3: bterm),
      (BIF BFalse THEN t2 ELSE t3 FI || t3)
  | E_If: forall (t1 t1' t2 t3: bterm),
      (t1 || t1') ->
      (BIF t1 THEN t2 ELSE t3 FI || BIF t1' THEN t2 ELSE t3 FI)
  where "t '||' t'" := (bevalR t t') : type_scope.

(**
s = if true then false else false
def
t = if s then true else true
def
u = if false then true else true

if t then false else false -> if u then false else false

witnessed by the following derivation tree:

------------- E-IfTrue
s -> false

------------- E-If
t ->  u

------------- E-If
if t then false else false -> if u then false else false

**)

Definition s : bterm :=
  BIF BTrue THEN BFalse ELSE BFalse FI.

Definition t : bterm :=
  BIF s THEN BTrue ELSE BTrue FI.

Definition u : bterm :=
  BIF BFalse THEN BTrue ELSE BTrue FI.

Example Ex353:
  (BIF t THEN BFalse ELSE BFalse FI || BIF u THEN BFalse ELSE BFalse FI).
Proof.
  apply E_If.
  apply E_If.
  apply E_IfTrue.
Qed.

(**
Theorem [Determinacy of one-step evaluation]:
  If t -> t' and t -> t'' then t' == t''
**)

Theorem one_step_deterministic : forall t t' t'' : bterm,
  (t || t') ->
  (t || t'') ->
  t' = t''.
Proof.
  intros t t' t'' erel1  erel2.
  generalize dependent t''.
  (* By induction on a derivation of t -> t' *)
  bevalR_cases (induction erel1; intros) Case.
  (* If the rule used in the derivation of t -> t' is E-IfTrue *)
  Case "E_IfTrue".
    (* If the rule used in the derivation of t -> t'' is E-IfTrue,
     *  then trivially t = t''  *)
    inversion erel2. reflexivity.
    (* E-IfFalse is ruled out by the fact that t = true *)
    (* E-If is ruled out by the fact that t is not further reducable *)
    inversion H3.
  (* A simular argument holds if t -> t' is E-IfFalse *)
  Case "E_IfFalse".
    inversion erel2. reflexivity.
    inversion H3.
  (* Finaly, if the last rule in the derivation of t -> t' is E-If,
   * then we have evidence that the guard of this has an evaluation
   * relation. *)
  Case "E_If".
    bevalR_cases (inversion erel2) SCase.
    (* We can rule out E-IfFalse by false's lack of relation *)
    SCase "E_IfTrue".
      subst.
      inversion erel1.
    (* Similarly E-IfTrue *)
    SCase "E_IfFalse".
      subst.
      inversion erel1.
    (* And now, the induction hypothesis applies *)
    SCase "E_If".
      rewrite IHerel1 with t1'0.
      reflexivity.
      assumption.
Qed.

End BLang.


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

Require Import notations List.
Require Export coherence_graph.

(** * Syntax for observations *)
Inductive observation {G : Graph} :=
| o_true : observation
| o_false : observation
| o_obs : vertex -> observation
| o_or : observation -> observation -> observation
| o_and : observation -> observation -> observation
| o_impl : observation -> observation -> observation.

Notation "⊤o" := o_true.
Notation "⊥o" := o_false.
Notation " ⦑ o ⦒ " := (o_obs o).
Infix " ⟇ " := o_or (at level 50).
Infix " ⟑ " := o_and (at level 50).
Infix " → " := o_impl (at level 50).

Definition Join {G : Graph} : list observation -> observation :=
  fold_right o_or ⊥o.
Definition Meet {G : Graph} : list observation -> observation :=
  fold_right o_and ⊤o.

Notation " ⋁ " := Join.
Notation " ⋀ " := Meet.

Definition π {G : Graph} {decG : DecidableGraph G} (s : fcliques) :=
  ⋀ (map o_obs ($ s)).


Require Import Logic.Axiom.LEM.

Require Import Logic.Fol.Syntax.

Require Import Logic.Set.Set.
Require Import Logic.Set.Incl.
Require Import Logic.Set.Elem.
Require Import Logic.Set.Equal.
Require Import Logic.Set.Foundation.

Require Import Logic.Lang1.Syntax.
Require Import Logic.Lang1.Context.
Require Import Logic.Lang1.SemanCtx.
Require Import Logic.Lang1.Semantics.
Require Import Logic.Lang1.Environment.

Open Scope Set_Incl_scope.

(* Lemma 'coherence' expressed in set theory abstract syntax.                   *)
(* This formulation is correct provided the variables n m are distinct.         *)
Definition coherenceF (n m:nat) : Formula :=
    All n (All m (Imp (Sub n m) (Not (Elem m n)))).

Import Semantics.
(* Evaluating coherenceF in any environment 'yields' the lemma coherence.       *)
Lemma evalCoherenceF : forall (e:Env) (n m:nat),
    m <> n ->
    eval e (coherenceF n m)
        <->
    forall (x y:set), x <= y -> ~ y :: x.
Proof.
    intros e n m Hmn. unfold coherenceF. rewrite evalAll. split; intros H x.
    - remember (H x)  as H' eqn:E. clear E H.  rewrite evalAll in H'. intros y.
      remember (H' y) as H  eqn:E. clear E H'. rewrite evalImp in H.
      rewrite evalSub in H. rewrite evalNot in H. rewrite evalElem in H.
      rewrite bindSame in H. rewrite bindDiff in H. rewrite bindSame in H.
        + assumption.
        + assumption.
    - rewrite evalAll. intros y. rewrite evalImp, evalSub, evalNot, evalElem.
      rewrite bindSame, bindDiff, bindSame. apply H.
        + assumption.
Qed.

Import SemanCtx.
Lemma evalCoherenceFCtx : forall (G:Context) (n m:nat),
    n <> m ->
    G :- (coherenceF n m) >>
        forall (x y:set), x <= y -> ~ y :: x.
Proof.
    intros G n m H1. unfold coherenceF.
    apply evalAll. intros x. apply evalAll. intros y. apply evalImp.
    - apply evalSub.
        + apply FindS; try assumption. apply FindZ.
        + apply FindZ.
    - apply evalNot, evalElem.
        + apply FindZ.
        + apply FindS; try assumption. apply FindZ.
Qed.

(* Lemma 'noSelfElem' expressed in set theory abstract syntax.                  *)
Definition noSelfElemF (n:nat) : Formula := All n (Not (Elem n n)).

Import Semantics.
(* Evaluating noSelfElemF in any environment 'yields' the lemma noSelfElem.     *)
Lemma evalNoSelfElemF : forall (e:Env) (n:nat),
    eval e (noSelfElemF n) <-> forall (x:set), ~ x :: x.
Proof.
    intros e n. unfold noSelfElemF. rewrite evalAll. split; intros H x.
    - remember (H x) as H' eqn:E. clear E H. rewrite evalNot in H'.
      rewrite evalElem in H'. rewrite bindSame in H'. assumption.
    - rewrite evalNot, evalElem, bindSame. apply H.
Qed.

Import SemanCtx.
Lemma evalNoSelfElemFCtx : forall (G:Context) (n:nat),
    G :- (noSelfElemF n) >>  forall (x:set), ~ x :: x.
Proof.
    intros G n. unfold noSelfElemF.
    apply evalAll. intros x. apply evalNot, evalElem; apply FindZ.
Qed.

(* Lemma 'noUniverse' expressed in set theory abstract syntax.                  *)
(* This formulation is correct provided the variables n m are distinct.         *)
Definition noUniverseF (n m:nat) : Formula := Not (Exi n (All m (Elem m n))).

Import Semantics.
(* Evaluating noUniverseF in any environment 'yields' the lemma noUniverse.     *)
Lemma evalNoUniverseF : LEM -> forall (e:Env) (n m:nat),
    m <> n ->
    eval e (noUniverseF n m)
        <->
    ~ exists (x:set), forall (y:set), y :: x.
Proof.
    intros L e n m Hmn. unfold noUniverseF. rewrite evalNot, evalExi.
    split; intros H1 [x H2]; apply H1; exists x.
    - rewrite evalAll. intros y. rewrite evalElem, bindSame, bindDiff, bindSame.
      apply H2. assumption.
    - rewrite evalAll in H2. intros y. remember (H2 y) as H eqn:E. clear E H2 H1.
      rewrite evalElem in H. rewrite bindSame in H. rewrite bindDiff in H.
      rewrite bindSame in H. assumption. assumption.
    - assumption.
Qed.

Import SemanCtx.
Lemma evalNoUniverseFCtx : LEM -> forall (G:Context) (n m:nat),
    n <> m ->
    G :- (noUniverseF n m) >>
        ~ exists (x:set), forall (y:set), y :: x.
Proof.
    intros L G n m H1. unfold noUniverseF.
    apply evalNot, evalExi; try assumption. intros x. apply evalAll. intros y.
    apply evalElem; try (apply FindZ). apply FindS; try assumption. apply FindZ.
Qed.

(* Theorem 'foundation' expressed in set theory abstract syntax.                *)
(* This formulation is correct provided the variables n m are distinct.         *)
(* Of course this formulation is somewhat arbitrary as we decided to introduce  *)
(* the builtin predicate 'Min' as part of the language.                         *)
Definition foundationF (n m:nat) : Formula :=
    All n (Imp (Not (Empty n)) (Exi m (Min m n))).

Import Semantics.
(* Evaluating foundationF in any environment 'yields' the theorem foundation.   *)
Lemma evalFoundationF : LEM -> forall (e:Env) (n m:nat),
    m <> n ->
    eval e (foundationF n m)
        <->
    forall (x:set), ~(x == Nil) -> exists (y:set), minimal y x.
Proof.
    intros L e n m Hmn. unfold foundationF. rewrite evalAll. split; intros H x.
    - remember (H x) as H' eqn:E. clear E H. rewrite evalImp in H'.
      rewrite evalNot in H'. rewrite evalEmpty in H'. rewrite bindSame in H'.
      intros H. remember (H' H) as H0 eqn:E. clear E H H'.
      rewrite evalExi in H0. destruct H0 as [y H]. exists y.
      rewrite evalMin in H. rewrite bindSame in H. rewrite bindDiff in H.
      rewrite bindSame in H.
        + assumption.
        + assumption.
        + assumption.
        + assumption.
    - rewrite evalImp, evalNot, evalEmpty, bindSame, evalExi.
      remember (H x) as H' eqn:E. clear E H. intros H.
      remember (H' H) as H1 eqn:E. clear E H H'. destruct H1 as [y H].
      exists y. rewrite evalMin, bindSame, bindDiff, bindSame.
        + assumption.
        + assumption.
        + assumption.
        + assumption.
Qed.

Import SemanCtx.
Lemma evalFoundationFCtx : LEM -> forall (G:Context) (n m:nat),
    n <> m ->
    G :- (foundationF n m)  >>
        forall (x:set), ~(x == Nil) -> exists (y:set), minimal y x.
Proof.
    intros L G n m H1. unfold foundationF.
    apply evalAll. intros x. apply evalImp.
    - apply evalNot, evalEmpty, FindZ.
    - apply evalExi; try assumption. intros y. apply evalMin; try assumption.
        + apply FindZ.
        + apply FindS; try assumption. apply FindZ.
Qed.


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

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.
Require Import Program.

Require Import LensLaws.Isomorphism.
Require Import LensLaws.Crush.

Definition Lens (A B : Set) : Type := { X : Set & Iso A (X * B) }.

Lemma iso_is_lens_ex {A B} (i : Iso A B) : Iso A (prod unit B).
Proof.
  destruct i as [f g H H0].
  apply (MkIso
    (fun (a : A) => (tt, f(a)))
    (fun (p : unit * B) => match p with (tt, b) => g b end)); crush. Defined.

Lemma iso_is_lens {A B} (i : Iso A B) : Lens A B.
Proof.
  exists unit.
  exact (iso_is_lens_ex i). Defined.

Lemma lens_compose {A B C} (ab : Lens A B) (bc : Lens B C) : Lens A C.
Proof.
  intros.
  destruct ab as [X ab]. destruct ab as [axb xba H H0].
  destruct bc as [Y bc]. destruct bc as [byc ycb H1 H2].
  exists (prod X Y).

  apply (MkIso
    (fun (a : A) => (fst (axb a), fst (byc (snd (axb a))), snd (byc (snd (axb a)))))
    (fun (t : X * Y * C) => xba (fst (fst t), ycb (snd (fst t), snd t)))); crush. Defined.

Definition lens_view {A B} (lens : Lens A B) (a : A) : B.
Proof.
  destruct lens.
  destruct i.
  exact (snd (f a)). Defined.

Definition lens_set {A B} (lens : Lens A B) (a : A) (b : B) : A.
Proof.
  destruct lens.
  destruct i.
  exact (g (fst (f a), b)). Defined.

Theorem lens_law1 {A B} (lens : Lens A B) :
  forall a b, lens_view lens (lens_set lens a b) = b.
Proof.
  intros a b. destruct lens as [X ab]. destruct ab as [axb xba H H0]. crush. Qed.

Theorem lens_law2 {A B} (lens : Lens A B) :
  forall a, lens_set lens a (lens_view lens a) = a.
Proof.
  intros a. destruct lens as [X ab]. destruct ab as [axb xba H H0]. crush. Qed.

Lemma lens_law3_weak {A B} (lens : Lens A B) :
  forall a b, lens_set lens (lens_set lens a b) b = lens_set lens a b.
Proof.
  intros a b.
  assert (
    lens_set lens (lens_set lens a b) b =
    lens_set lens (lens_set lens a b) (lens_view lens (lens_set lens a b))).
    f_equal. symmetry. apply lens_law1.
  rewrite H.
  rewrite lens_law2.
  reflexivity. Qed.

Theorem lens_law3 {A B} (lens : Lens A B) :
  forall a b b', lens_set lens (lens_set lens a b') b = lens_set lens a b.
Proof.
  intros a b b'. destruct lens as [X ab]. destruct ab as [axb xba H H0]. crush. Qed.

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.

Lemma sigma_eq {A} {P : A -> Prop} (x y : A) (px : P x) (py : P y) (eqp : x = y) :
  (eq_ind x P px y eqp = py) ->
  exist P x px = exist P y py.
Proof.
  intros. subst. f_equal. Qed.

Theorem lens_complete {A B : Set} (view : A -> B) (set : A -> B -> A):
  (forall a b, view (set a b) = b) ->
  (forall a, set a (view a) = a) ->
  (forall a b b', set (set a b) b' = set a b') ->
  Lens A B.
Proof.
  intros law1 law2 law3.

  exists ({ba : B -> A | exists (a : A), ba = set a}).

  (* This definitions help to find right forms *)
  (*
  assert (FWD: A -> {ba : B -> A | exists (a : A), ba = set a} * B).
  refine
    (fun (a : A) => (exist _ (set a) (ex_intro _ a eq_refl), view a)).
  assert (BWD: {ba : B -> A | exists (a : A), ba = set a} * B -> A).
  refine
    (fun p => match p as A with (exist _ ba _, b) => ba b end).
  *)

  set (FWD := fun (a : A) => (exist (fun ba => exists (a : A), ba = set a) (set a) (ex_intro (fun x => set a = set x) a eq_refl), view a)).
  set (BWD := fun (p : {ba : B -> A | exists (a : A), ba = set a} * B) => match p as A with (exist _ ba _, b) => ba b end).

  apply (MkIso FWD BWD); subst FWD; subst BWD.

  - intro a; simpl. symmetry. apply law2.
  - intro p. destruct p as [ba b]; destruct ba as [ba Hba]. destruct Hba as [a Hba].
    f_equal.
    + simpl. subst. symmetry.
      assert (set (set a b) = set a) as Hsetset.
      extensionality b'. apply law3.
      apply sigma_eq with (eqp := Hsetset).
      apply proof_irrelevance.
    + rewrite Hba. symmetry. apply law1. Defined.


Load "8_filter_even_gt_7.v".

Require Import PeanoNat.

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X := pair (filter test l) (filter (fun x => negb (test x)) l).

Check pair.
Search (nat -> bool).

Example test_partition1: partition Nat.odd [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof.
  simpl. reflexivity.
Qed.

Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof.
  simpl. reflexivity.
Qed.