From Theories Require Import
  Tactics Chap_2_Framework.

(** * Specification *)

(** ** Syntax *)

Inductive Typ :=
  | t_void
  | t_arr (t1 t2 : Typ).

Inductive Exp :=
  | e_var (x : nat)
  | e_app (e1 e2 : Exp)
  | e_abs (e : Exp).

Inductive Val :=
  | v_abs (ve : List Val) (e : Exp).

(** ** Type System *)

Definition TypEnv := List Typ.

Inductive ExpTyp : TypEnv -> Exp -> Typ -> Prop :=
  | et_var :
      forall x te t1,
      indexr x te = some t1 ->
      ExpTyp te (e_var x) t1
  | et_app :
      forall te e1 e2 t1 t2,
      ExpTyp te e1 (t_arr t1 t2) ->
      ExpTyp te e2 t1 ->
      ExpTyp te (e_app e1 e2) t2
  | et_abs :
      forall te e t1 t2,
      ExpTyp (t1 :: te) e t2 ->
      ExpTyp te (e_abs e) (t_arr t1 t2).

(** ** Semantics *)

Definition ValEnv := List Val.

Fixpoint eval (n : nat) (ve : ValEnv) (e : Exp) : CanTimeout (CanErr Val) :=
  match n with
  | 0 => none
  | S n =>
      match e with
      | e_var x => done (indexr x ve)
      | e_abs e => done (noerr (v_abs ve e))
      | e_app e1 e2 =>
          ' v_abs ve1' e1' <- eval n ve e1;
          ' v2 <- eval n ve e2;
          eval n (v2 :: ve1') e1'
      end
  end.

(** ** Type Soundness *)

Inductive ValTyp : Val -> Typ -> Prop :=
  | vt_abs :
      forall ve te e t1 t2,
      Forall2 ValTyp ve te ->
      ExpTyp (t1 :: te) e t2 ->
      ValTyp (v_abs ve e) (t_arr t1 t2)
  .

Definition WfEnv : ValEnv -> TypEnv -> Prop :=
  Forall2 ValTyp.

(** * Theorems *)

Hint Constructors Typ Exp Val ExpTyp ValTyp Opt List.
Hint Unfold indexr length ValEnv TypEnv WfEnv.
Hint Resolve ex_intro.

Theorem type_soundness :
  forall n e te ve res t,
  eval n ve e = done res ->
  ExpTyp te e t ->
  WfEnv ve te ->
  exists v, res = noerr v /\ ValTyp v t.
Proof.
  intros n. induction n.
  Case "n = 0". intros until 0. intros Heval. inversion Heval.
  Case "n = S n". intros until 0. intros Heval Htype Hwf. destruct e.
    Case2 "var".
      inversion Heval as [Heval']; clear Heval Heval'.
      inversion Htype; subst te0 x t1; rename H1 into Htype'.
      destruct (fa2_indexr Hwf Htype') as [v [I V]].
      rewrite I. eexists. split. reflexivity. exact V.
    Case2 "app".
      inversion Htype; subst t2 e0 e3 te0;
        rename H2 into Htype1; rename H4 into Htype2; rename t into t2.
      simpl in Heval.
      remember (eval n ve e1) as mmv1.
      destruct mmv1 as [mv1|].
      Case3 "mmv1 = some mv1".
        (** Apply [IHn] to [e1] *)
        assert (exists v1, mv1 = some v1 /\ ValTyp v1 (t_arr t1 t2)) as [v1 [E1 HVtype1]].
          { eapply IHn; eauto. }
        subst mv1.
        (** Invert [v1] to closure [v_abs ve0 e] with [ExpTyp] evidence. *)
        inversion HVtype1; subst t0 t3. subst v1.
        remember (eval n ve e2) as mmv2.
        destruct mmv2 as [mv2|].
        Case4 "mmv2 = some mv2".
          (** Apply [IHn] to [e2] *)
          assert (exists v2, mv2 = some v2 /\ ValTyp v2 t1) as [v2 [E2 HVtype2]].
            { eapply IHn; eauto. }
          subst mv2.
          (** Apply [IHn] to closure body [e] *)
          eapply IHn; eauto.
        Case4 "mmv2 = none  [contradiction]".
          inversion Heval.
      Case3 "mmv1 = none  [contradiction]".
        inversion Heval.
    Case2 "abs".
      inversion Htype; subst te0 e0. subst t.
      inversion Heval as [Heval']; clear Heval Heval'.
      eexists. split. eauto. eapply vt_abs; eauto.
Qed.


(* -*- mode: coq; mode: visual-line -*- *)
(** * Comparing definitions of equivalence *)

Require Import HoTT.Basics HoTT.Types.
Require Import HProp.
Require Import HoTT.Tactics.

Local Open Scope nat_scope.
Local Open Scope path_scope.

Generalizable Variables A B f.

Section AssumeFunext.
Context `{Funext}.

(** In this file we show that several different definitions of "equivalence" are all equivalent to the one we have chosen.  This also yields alternative proofs that [IsEquiv f] is an hprop. *)

(** ** Contractible maps *)

(** We say a map is "contractible" if all of its homotopy fibers are contractible.  (More generally, a map is n-truncated if all of its homotopy fibers are n-truncated.)  This was Voevodsky's first definition of equivalences in homotopy type theory.

   It is fairly straightforward to show that this definition is *logically* equivalent to the one we have given.
*)

Definition fcontr_isequiv `(f : A -> B)
  : IsEquiv f -> (forall b:B, Contr {a : A & f a = b}).
Proof.
  intros ? b.  exists (f^-1 b ; eisretr f b).  intros [a p].
  refine (path_sigma' _ ((ap f^-1 p)^ @ eissect f a) _).
  rewrite (transport_compose (fun y => y = b) f _ _), transport_paths_l.
  rewrite ap_pp, ap_V, <- ap_compose, inv_Vp, concat_pp_p.
  rewrite (concat_A1p (eisretr f) p).
  rewrite eisadj.  by apply concat_V_pp.
Defined.

Definition isequiv_fcontr `(f : A -> B)
  : (forall b:B, Contr {a : A & f a = b}) -> IsEquiv f.
Proof.
  intros ?. refine (Build_IsEquiv _ _ _
    (fun b => (center {a : A & f a = b}).1)
    (fun b => (center {a : A & f a = b}).2)
    (fun a => (@contr {x : A & f x = f a} _ (a;1))..1)
    _).
  intros a. apply moveL_M1.
  rewrite <- transport_paths_l, <- transport_compose.
  exact ((@contr {x : A & f x = f a} _ (a;1))..2).
Defined.

(** It follows that when proving a map is an equivalence, we may assume its codomain is inhabited. *)
Definition isequiv_inhab_codomain
           `(f : A -> B) (feq : B -> IsEquiv f)
: IsEquiv f.
Proof.
  apply isequiv_fcontr.
  intros b.
  apply fcontr_isequiv, (feq b).
Defined.

(** Therefore, since both are hprops, they are equivalent by [equiv_iff_hprop].  However, we can also use this to *prove* that [IsEquiv] is an hprop.  We begin by showing that if [f] is an equivalence, then the type of sections of [f] and the type of retractions of [f] are both contractible. *)

Definition contr_sect_equiv `(f : A -> B) `{IsEquiv A B f}
  : Contr {g : B -> A & Sect g f}.
Proof.
  (* First we turn homotopies into paths. *)
  refine (contr_equiv' { g : B -> A & f o g = idmap } _).
  - symmetry.
    refine (equiv_functor_sigma' 1 _); intros g.
    exact (equiv_path_forall (f o g) idmap).
    (* Now this is just the fiber over [idmap] of postcomposition with [f], and the latter is an equivalence since [f] is. *)
  - apply fcontr_isequiv; exact _.
Defined.

Definition contr_retr_equiv `(f : A -> B) `{IsEquiv A B f}
  : Contr {g : B -> A & Sect f g}.
Proof.
  (* This proof is just like the previous one. *)
  refine (contr_equiv' { g : B -> A & g o f = idmap } _).
  - symmetry.
    refine (equiv_functor_sigma' 1 _); intros g.
    exact (equiv_path_forall (g o f) idmap).
  - apply fcontr_isequiv; exact _.
Defined.

(** Using this, we can prove that [IsEquiv f] is an h-proposition.  We make this a [Local Definition] since we already have a [Global Instance] of it available in [types/Equiv].  *)

Local Definition hprop_isequiv `(f : A -> B) : IsHProp (IsEquiv f).
Proof.
  apply hprop_inhabited_contr; intros ?.
  (* Get rid of that pesky record. *)
  refine (contr_equiv _ (issig_isequiv f)).
  (* Now we claim that the top two elements, [s] and the coherence relation, taken together are contractible, so we can peel them off. *)
  refine (contr_equiv' {g : B -> A & Sect g f}
    (equiv_functor_sigma' 1
      (fun g => (@equiv_sigma_contr (Sect g f)
        (fun r => {s : Sect f g & forall x, r (f x) = ap f (s x) })
        _)))^-1).
  (* What remains afterwards is just the type of sections of [f]. *)
  2:apply contr_sect_equiv; assumption.
  intros r.
  (* Now we claim this is equivalent to a certain space of paths. *)
  refine (contr_equiv'
    (forall x, (existT (fun a => f a = f x) x 1) = (g (f x); r (f x)))
    _^-1).
  (* The proof of this equivalence is basically just rearranging quantifiers and paths. *)
  - refine (_ oE (equiv_sigT_coind (fun x => g (f x) = x)
                                   (fun x p => r (f x) = ap f p))).
    refine (equiv_functor_forall' 1 _); intros a; simpl.
    refine (equiv_path_inverse _ _ oE _).
    refine ((equiv_path_sigma (fun x => f x = f a)
                              (g (f a) ; r (f a)) (a ; 1%path)) oE _); simpl.
    refine (equiv_functor_sigma' 1 _); intros p; simpl.
    rewrite (transport_compose (fun y => y = f a) f), transport_paths_l.
    refine (equiv_moveR_Vp _ _ _ oE _).
      by rewrite concat_p1; apply equiv_idmap.
      (* Finally, this is a space of paths in a fiber of [f]. *)
  - refine (@contr_forall _ _ _ _); intros a.
    refine (@contr_paths_contr _ _ _ _).
      by refine (fcontr_isequiv f _ _).
Qed.

(** Now since [IsEquiv f] and the assertion that its fibers are contractible are both HProps, logical equivalence implies equivalence. *)

Definition equiv_fcontr_isequiv `(f : A -> B)
  : (forall b:B, Contr {a : A & f a = b}) <~> IsEquiv f.
Proof.
  apply equiv_iff_hprop.
  - by apply isequiv_fcontr.
  - by apply fcontr_isequiv.
Defined.

(** Alternatively, we could also construct this equivalence directly, and derive the fact that [IsEquiv f] is an HProp from that.  *)

Local Definition equiv_fcontr_isequiv' `(f : A -> B)
  : (forall b:B, Contr {a : A & f a = b}) <~> IsEquiv f.
Proof.
  (* First we get rid of those pesky records. *)
  refine (_ oE (equiv_functor_forall_id
    (fun b => (issig_contr {a : A & f a = b})^-1))).
  refine (issig_isequiv f oE _).
  (* Now we can really get to work.
     First we peel off the inverse function and the [eisretr]. *)
  refine (_ oE (equiv_sigT_coind _ _)^-1).
  refine (_ oE
    (@equiv_functor_sigma' _ _ _ (fun f0 => forall x y, f0 x = y)
      (equiv_sigT_coind _ _)
      (fun fg => equiv_idmap (forall x y,
        (equiv_sigT_coind _ (fun b a => f a = b) fg x = y))))^-1).
  refine (_ oE (equiv_sigma_assoc _ _)^-1).
  refine (equiv_functor_sigma_id _). intros g.
  refine (equiv_functor_sigma_id _). intros r. simpl.
  (* Now we use the fact that Paulin-Mohring J is an equivalence. *)
  refine (_ oE (@equiv_functor_forall' _ _
    (fun x => forall a (y : f a = x),
      (existT (fun a => f a = x) (g x) (r x)) = (a;y))
    _ _ 1
    (fun x:B => equiv_sigT_ind
      (fun y:exists a:A, f a = x => (g x;r x) = y)))^-1).
  refine (_ oE equiv_flip _).
  refine (_ oE (@equiv_functor_forall' _ _
    (fun a => existT (fun a' => f a' = f a) (g (f a)) (r (f a)) = (a;1%path))
    _ _ 1
    (fun a => equiv_paths_ind (f a)
      (fun b y => (existT (fun a => f a = b) (g b) (r b)) = (a;y))))^-1).
  (* We identify the paths in a Sigma-type. *)
  refine (_ oE (@equiv_functor_forall' _ _
    (fun a =>
      exists p, transport (fun a' : A => f a' = f a) p (r (f a)) = 1%path)
    _ _ 1
    (fun a => equiv_path_sigma (fun a' => f a' = f a)
      (g (f a);r (f a)) (a;1%path)))^-1).
  (* Now we can peel off the [eissect]. *)
  refine (_ oE (equiv_sigT_coind
    (fun a => g (f a) = a)
    (fun a p => transport (fun a' => f a' = f a) p (r (f a)) = 1%path))^-1).
  refine (equiv_functor_sigma' 1 _). intros s.
  (* And what's left is the [eisadj]. *)
  refine (equiv_functor_forall' 1 _). intros a; simpl.
  refine (_ oE (equiv_concat_l
             (transport_compose (fun b => b = f a) f (s a) (r (f a))
              @ transport_paths_l (ap f (s a)) (r (f a)))^ 1%path)).
  exact ((equiv_concat_r (concat_p1 _) _)
           oE ((equiv_moveR_Vp (r (f a)) 1 (ap f (s a)))^-1)).
Defined.

(** ** Bi-invertible maps *)

(** A map is "bi-invertible" if it has both a section and a retraction, not necessarily the same.  This definition of equivalence was proposed by Andre Joyal. *)

Definition BiInv `(f : A -> B) : Type
  := {g : B -> A & Sect f g} * {h : B -> A & Sect h f}.

(** It seems that the easiest way to show that bi-invertibility is equivalent to being an equivalence is also to show that both are h-props and that they are logically equivalent. *)

Definition isequiv_biinv `(f : A -> B)
  : BiInv f -> IsEquiv f.
Proof.
  intros [[g s] [h r]].
  exact (isequiv_adjointify f g
    (fun x => ap f (ap g (r x)^ @ s (h x))  @ r x)
    s).
Defined.

Global Instance isprop_biinv `(f : A -> B) : IsHProp (BiInv f) | 0.
Proof.
  apply hprop_inhabited_contr.
  intros bif; pose (fe := isequiv_biinv f bif).
  apply @contr_prod.
  (* For this, we've done all the work already. *)
  - by apply contr_retr_equiv.
  - by apply contr_sect_equiv.
Defined.

Definition equiv_biinv_isequiv `(f : A -> B)
  : BiInv f <~> IsEquiv f.
Proof.
  apply equiv_iff_hprop.
  - by apply isequiv_biinv.
  - intros ?.  split.
    + by exists (f^-1); apply eissect.
    + by exists (f^-1); apply eisretr.
Defined.

(** ** n-Path-split maps.

A map is n-path-split if its induced maps on the first n iterated path-spaces are split surjections.  Thus every map is 0-path-split, the 1-path-split maps are the split surjections, and so on.  It turns out that for n>1, being n-path-split is the same as being an equivalence. *)

Fixpoint PathSplit (n : nat) `(f : A -> B) : Type
  := match n with
       | 0 => Unit
       | S n => (forall a, hfiber f a) *
                forall (x y : A), PathSplit n (@ap _ _ f x y)
     end.

Definition isequiv_pathsplit (n : nat) `{f : A -> B}
: PathSplit n.+2 f -> IsEquiv f.
Proof.
  intros [g k].
  pose (h := fun x y p => (fst (k x y) p).1).
  pose (hs := fun x y => (fun p => (fst (k x y) p).2)
                         : Sect (h x y) (ap f)).
  clearbody hs; clearbody h; clear k.
  apply isequiv_fcontr; intros b.
  apply contr_inhabited_hprop.
  2:exact (g b).
  apply hprop_allpath; intros [a p] [a' p'].
  refine (path_sigma' _ (h a a' (p @ p'^)) _).
  refine (transport_paths_Fl _ _ @ _).
  refine ((inverse2 (hs a a' (p @ p'^)) @@ 1) @ _).
  refine ((inv_pp p p'^ @@ 1) @ _).
  refine (concat_pp_p _ _ _ @ _).
  refine ((1 @@ concat_Vp _) @ _).
  exact ((inv_V p' @@ 1) @ concat_p1 _).
Defined.

Global Instance contr_pathsplit_isequiv
           (n : nat) `(f : A -> B) `{IsEquiv _ _ f}
: Contr (PathSplit n f).
Proof.
  generalize dependent B; revert A.
  simple_induction n n IHn; intros A B f ?.
  - exact _.
  - refine contr_prod.
    refine contr_forall.
    intros; apply fcontr_isequiv; exact _.
Defined.

Global Instance ishprop_pathsplit (n : nat) `(f : A -> B)
: IsHProp (PathSplit n.+2 f).
Proof.
  apply hprop_inhabited_contr; intros ps.
  pose (isequiv_pathsplit n ps).
  exact _.
Defined.

Definition equiv_pathsplit_isequiv (n : nat) `(f : A -> B)
: PathSplit n.+2 f <~> IsEquiv f.
Proof.
  refine (equiv_iff_hprop _ _).
  - apply isequiv_pathsplit.
  - intros ?; refine (center _).
Defined.

(** Path-splitness transfers across commutative squares of equivalences. *)
Lemma equiv_functor_pathsplit (n : nat) {A B C D}
      (f : A -> B) (g : C -> D) (h : A <~> C) (k : B <~> D)
      (p : g o h == k o f)
: PathSplit n f <~> PathSplit n g.
Proof.
  destruct n as [|n].
  1:apply equiv_idmap.
  destruct n as [|n].
  - simpl.
    refine (_ *E equiv_contr_contr).
    refine (equiv_functor_forall' k^-1 _); intros d.
    unfold hfiber.
    refine (equiv_functor_sigma' h _); intros a.
    refine (equiv_concat_l (p a) d oE _).
    simpl; apply equiv_moveR_equiv_M.
  - refine (_ oE equiv_pathsplit_isequiv n f).
    refine ((equiv_pathsplit_isequiv n g)^-1 oE _).
    apply equiv_iff_hprop; intros e.
    + refine (isequiv_commsq f g h k (fun a => (p a)^)).
    + refine (isequiv_commsq' f g h k p).
Defined.

(** A map is oo-path-split if it is n-path-split for all n.  This is also equivalent to being an equivalence. *)

Definition ooPathSplit `(f : A -> B) : Type
  := forall n, PathSplit n f.

Definition isequiv_oopathsplit `{f : A -> B}
: ooPathSplit f -> IsEquiv f
  := fun ps => isequiv_pathsplit 0 (ps 2).

Global Instance contr_oopathsplit_isequiv
           `(f : A -> B) `{IsEquiv _ _ f}
: Contr (ooPathSplit f).
Proof.
  apply contr_forall.
Defined.

Global Instance ishprop_oopathsplit `(f : A -> B)
: IsHProp (ooPathSplit f).
Proof.
  apply hprop_inhabited_contr; intros ps.
  pose (isequiv_oopathsplit ps).
  exact _.
Defined.

Definition equiv_oopathsplit_isequiv `(f : A -> B)
: ooPathSplit f <~> IsEquiv f.
Proof.
  refine (equiv_iff_hprop _ _).
  - apply isequiv_oopathsplit.
  - intros ?; refine (center _).
Defined.

End AssumeFunext.

(** ** Relational equivalences *)
(** This definition is due to Peter LeFanu Lumsdaine on the HoTT mailing list.  This definition gives more judgmental properties, though has the downside of jumping universe levels. *)
Section relational.
  Record RelEquiv A B :=
    { equiv_rel : A -> B -> Type;
      relequiv_contr_f : forall a, Contr { b : B & equiv_rel a b };
      relequiv_contr_g : forall b, Contr { a : A & equiv_rel a b } }.

  Arguments equiv_rel {A B} _ _ _.
  Global Existing Instance relequiv_contr_f.
  Global Existing Instance relequiv_contr_g.

  Definition issig_relequiv {A B}
  : { equiv_rel : A -> B -> Type
    | { f : forall a, Contr { b : B & equiv_rel a b }
      | forall b, Contr { a : A & equiv_rel a b } } }
      <~> RelEquiv A B.
  Proof.
    issig.
  Defined.

  Definition relequiv_of_equiv {A B} (e : A <~> B) : RelEquiv A B.
  Proof.
    refine {| equiv_rel a b := e a = b |}.
    { intro b.
      exists (e^-1 b; eisretr e b).
      intros [a H].
      destruct H.
      simple refine (path_sigma _ _ _ _ _).
      { simpl; apply eissect. }
      { simpl.
        abstract (rewrite eisadj; destruct (eissect e a); reflexivity). } }
  Defined.

  Definition equiv_of_relequiv {A B} (e : RelEquiv A B) : A <~> B.
  Proof.
    refine (equiv_adjointify
              (fun a => (center { b : B & equiv_rel e a b}).1)
              (fun b => (center { a : A & equiv_rel e a b}).1)
              _ _);
    intro x; cbn.
    { refine (ap pr1 (contr _) : _.1 = (x; _).1).
      exact (center {a : A & equiv_rel e a x}).2. }
    { refine (ap pr1 (contr _) : _.1 = (x; _).1).
      exact (center {b : B & equiv_rel e x b}).2. }
  Defined.

  Definition RelIsEquiv {A B} (f : A -> B)
    := { r : RelEquiv A B | forall x, (center { b : B & equiv_rel r x b }).1 = f x }.

  (** TODO: Prove [ishprop_relisequiv `{Funext} {A B} f : IsHProp (@RelIsEquiv A B f)] *)

  (** * Judgmental property *)
  Definition inverse_relequiv {A B} (e : RelEquiv A B) : RelEquiv B A
    := {| equiv_rel a b := equiv_rel e b a |}.

  Definition reinv_V {A B} (e : RelEquiv A B)
  : inverse_relequiv (inverse_relequiv e) = e
    := 1.

  (** TODO: Is there a definition of this that makes [inverse_relequiv (relequiv_idmap A)] be [relequiv_idmap A], judgmentally? *)
  Definition relequiv_idmap A : RelEquiv A A
    := {| equiv_rel a b := a = b |}.

  (** TODO: Define composition; we probably need truncation to do this? *)
End relational.


(** vectors and various lemmas *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* vec {A} B l is a B-list of the same size as l *)
Inductive vec {A : Type} (B : Type) : list A -> Type :=
    NilV : vec B nil
  | ConsV : forall a lA, B -> vec B lA -> vec B (a :: lA).

Arguments NilV {A}{B}.

Definition vec_hd {A B}(a : A)(l : list A)(v : vec B (a :: l)) : B :=
  match v with ConsV _ b _ => b end.
Definition vec_tl {A B}(a : A)(l : list A)(v : vec B (a :: l)) : vec B l :=
  match v with ConsV _ _ v => v end.

Declare Scope vec_scope.
Delimit Scope vec_scope with v.

Infix "::" := (ConsV _) (only parsing) : vec_scope.

Definition vec_map {A B C : Type}(f : A -> B -> C) :=
  fix rec (l : list A) (v : vec B l) : vec C l :=
  match v with
    NilV => NilV
  | ConsV a b lB => ConsV a (f a b) (rec _ lB)
    end.

Definition vec_hd_map  {A B C}(a : A)(l : list A)(f : A -> B -> C)
                          (v : vec B (a :: l)) :
                         vec_hd (vec_map f v) = f a (vec_hd v) :=
  match v with ConsV _ b v' => eq_refl _ end.

Definition vec_tl_map  {A B C}(a : A)(l : list A)(f : A -> B -> C)
                          (v : vec B (a :: l)) :
                         vec_tl (vec_map f v) = vec_map f (vec_tl v) :=
  match v with ConsV _ b v' => eq_refl _ end.

Fixpoint vec_map_id {A B : Type}{l : list A}(v : vec B l) : vec_map (fun _ x => x) v = v.
  destruct v.
  -  reflexivity.
  -  cbn.
     f_equal.
     apply vec_map_id.
Defined.

Lemma vec_map_map {A B C D : Type}(f : A -> B -> C) (g : A -> C -> D) {l : list A}
      (v : vec B l) : vec_map g (vec_map f v) = vec_map (fun a b => g a (f a b)) v.
  induction v; cbn; congruence.
Qed.

Definition vec_map_ext {A B C : Type}(f g : A -> B -> C) {l : list A}
      (v : vec B l) (h : forall a b, f a b = g a b): vec_map f v = vec_map g v.
  induction v; cbn; congruence.
Defined.

Fixpoint vec_max {A : Type}(l : list A) (v : vec nat l) : nat :=
  match v with
    NilV => 0
  | ConsV a b lB => Nat.max b (vec_max lB)
    end.

Lemma commutes_if {A B : Type}(f : A -> B)(b : bool) x y :
  (if b then f x else f y) = f (if b then x else y).
Proof.
destruct b; reflexivity.
Qed.
Lemma if_if {A : Type}(b : bool) (x y z : A) :
  (if b then if b then x else y else z) = (if b then x else z).
  destruct b ; reflexivity.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. lfind.  reflexivity.  }
Admitted.

Theorem append_rev_cons:
   forall (l1 l2: lst) (x: natural),
   rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
   induction l1; induction l2; try (simpl; reflexivity).
   { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
   f_equal. }
   { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
   induction l1.
   { induction l2.
   { simpl. rewrite append_rev_cons.
      rewrite <- 2 append_assoc.
      f_equal. }
   { simpl. rewrite append_nil. reflexivity. }
   }
   { intro. simpl. rewrite append_nil. reflexivity. }
Qed.

Theorem rev_involutive : forall (x : lst), eq (rev (rev x)) x.
Proof.
   induction x.
   { simpl. rewrite rev_append. simpl. f_equal.
   assumption. }
   { simpl. reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst), eq (rev (append (rev x) Nil)) x.
Proof.
   intro.
   rewrite append_nil.
   apply rev_involutive.
Qed.


From ZornsLemma Require Export DirectedSets.
From Topology Require Export TopologicalSpaces InteriorsClosures Continuity.

Set Asymmetric Patterns.

Section Net.

Variable I:DirectedSet.
Variable X:TopologicalSpace.

Definition Net := DS_set I -> X.

Definition net_limit (x:Net) (x0:X) : Prop :=
  forall U:Ensemble X, open U -> In U x0 ->
  for large i:DS_set I, In U (x i).

Definition net_cluster_point (x:Net) (x0:X) : Prop :=
  forall U:Ensemble X, open U -> In U x0 ->
  exists arbitrarily large i:DS_set I, In U (x i).

Lemma net_limit_is_cluster_point: forall (x:Net) (x0:X),
  net_limit x x0 -> net_cluster_point x x0.
Proof.
intros.
red. intros.
red. intros.
destruct (H U H0 H1).
destruct (DS_join_cond i x1).
destruct H3.
exists x2.
split; trivial.
now apply H2.
Qed.

Lemma net_limit_in_closure: forall (S:Ensemble X)
  (x:Net) (x0:X),
  (exists arbitrarily large i:DS_set I, In S (x i)) ->
  net_limit x x0 -> In (closure S) x0.
Proof.
intros.
apply NNPP.
intro.
pose proof (H0 (Complement (closure S))).
match type of H2 with | ?A -> ?B -> ?C => assert (C) end.
{ apply H2; trivial.
  apply closure_closed. }
destruct H3, (H x1).
contradiction (H3 x2);
  [ | apply closure_inflationary ];
  tauto.
Qed.

Lemma net_cluster_point_in_closure: forall (S:Ensemble X)
  (x:Net) (x0:X),
  (for large i:DS_set I, In S (x i)) ->
  net_cluster_point x x0 -> In (closure S) x0.
Proof.
intros.
apply NNPP.
intro.
pose proof (H0 (Complement (closure S))).
match type of H2 with | ?A -> ?B -> ?C => assert (C) end.
{ apply H2; trivial.
  apply closure_closed. }
destruct H, (H3 x1), H4.
contradiction H5.
apply closure_inflationary.
now apply H.
Qed.

End Net.

Arguments net_limit {I} {X}.
Arguments net_cluster_point {I} {X}.
Arguments net_limit_is_cluster_point {I} {X}.
Arguments net_limit_in_closure {I} {X}.
Arguments net_cluster_point_in_closure {I} {X}.

Section neighborhood_net.

Variable X:TopologicalSpace.
Variable x:X.

Inductive neighborhood_net_DS_set : Type :=
  | intro_neighborhood_net_DS :
    forall (U:Ensemble X) (y:X),
    open U -> In U x -> In U y -> neighborhood_net_DS_set.

Definition neighborhood_net_DS_ord
  (Uy Vz:neighborhood_net_DS_set) : Prop :=
  match Uy, Vz with
  | intro_neighborhood_net_DS U _ _ _ _,
    intro_neighborhood_net_DS V _ _ _ _ =>
    Included V U
  end.

Definition neighborhood_net_DS : DirectedSet.
refine (Build_DirectedSet neighborhood_net_DS_set
  neighborhood_net_DS_ord _ _).
- constructor;
    red; intros;
    destruct x0.
  + simpl. auto with sets.
  + destruct y, z.
    simpl in H, H0.
    simpl.
    auto with sets.
- intros.
  destruct i, j.
  assert (open (Intersection U U0)) by
    now apply open_intersection2.
  assert (In (Intersection U U0) x) by
    auto with sets.
  exists (intro_neighborhood_net_DS (Intersection U U0) x
    H H0 H0).
  simpl.
  auto with sets.
Defined.

Definition neighborhood_net : Net neighborhood_net_DS X :=
  fun (x:neighborhood_net_DS_set) => match x with
  | intro_neighborhood_net_DS _ y _ _ _ => y
  end.

Lemma neighborhood_net_limit: net_limit neighborhood_net x.
Proof.
red. intros.
exists (intro_neighborhood_net_DS U x H H0 H0).
intros.
destruct j.
simpl in H1.
simpl.
auto with sets.
Qed.

End neighborhood_net.

Lemma net_limits_determine_topology:
  forall {X:TopologicalSpace} (S:Ensemble X)
  (x0:X), In (closure S) x0 ->
  exists I:DirectedSet, exists x:Net I X,
  (forall i:DS_set I, In S (x i)) /\ net_limit x x0.
Proof.
intros.
assert (forall U:Ensemble X, open U -> In U x0 ->
  Inhabited (Intersection S U)).
{ intros.
  apply NNPP. intro.
  assert (Included (closure S) (Complement U)).
  { apply closure_minimal; red.
    - now rewrite Complement_Complement.
    - intros.
      intro.
      contradiction H2.
      exists x.
      auto with sets. }
  contradict H1.
  now apply H3. }
pose (Ssel := fun n:neighborhood_net_DS_set X x0 =>
  match n with
  | intro_neighborhood_net_DS V y _ _ _ => (In S y)
  end).
pose (our_DS_set := {n:neighborhood_net_DS_set X x0 | Ssel n}).
pose (our_DS_ord := fun (n1 n2:our_DS_set) =>
  neighborhood_net_DS_ord X x0 (proj1_sig n1) (proj1_sig n2)).
assert (preorder our_DS_ord).
{ constructor; red.
  - intros. red.
    apply preord_refl.
    apply (@DS_ord_cond (neighborhood_net_DS X x0)).
  - intros x y z.
    unfold our_DS_ord. apply preord_trans.
    apply (@DS_ord_cond (neighborhood_net_DS X x0)). }
assert (forall i j:our_DS_set, exists k:our_DS_set,
  our_DS_ord i k /\ our_DS_ord j k).
{ destruct i, x, j.
  destruct x.
  assert (open (Intersection U U0)) by
    now apply open_intersection2.
  assert (In (Intersection U U0) x0) by
    auto with sets.
  assert (Inhabited (Intersection S (Intersection U U0))) by
    now apply H0.
  destruct H4.
  destruct H4.
  pose (k0 := intro_neighborhood_net_DS X x0
    (Intersection U U0) x H2 H3 H5).
  assert (Ssel k0).
  { red. now unfold k0. }
  exists (exist _ k0 H6).
  split; red; simpl; auto with sets. }
pose (our_DS := Build_DirectedSet our_DS_set our_DS_ord H1 H2).
exists our_DS.
exists (fun i:our_DS_set => neighborhood_net X x0 (proj1_sig i)).
split.
- intros.
  now destruct i, x.
- red. intros.
  assert (Inhabited (Intersection S U)) by
    now apply H0.
  destruct H5.
  destruct H5.
  pose (i0 := intro_neighborhood_net_DS X x0
    U x H3 H4 H6).
  assert (Ssel i0) by trivial.
  exists (exist _ i0 H7).
  intros.
  destruct j, x1.
  simpl in H8.
  red in H8. simpl in H8.
  simpl.
  auto with sets.
Qed.

Section Nets_and_continuity.

Variable X Y:TopologicalSpace.
Variable f:X -> Y.

Lemma continuous_func_preserves_net_limits:
  forall {I:DirectedSet} (x:Net I X) (x0:X),
    net_limit x x0 -> continuous_at f x0 ->
    net_limit (fun i:DS_set I => f (x i)) (f x0).
Proof.
intros.
red. intros V ? ?.
assert (neighborhood V (f x0)).
{ apply open_neighborhood_is_neighborhood.
  now split. }
destruct (H0 V H3) as [U [? ?]].
destruct H4.
pose proof (H U H4 H6).
apply eventually_impl_base with (fun i:DS_set I => In U (x i));
  trivial.
intros.
assert (In (inverse_image f V) (x i)) by auto with sets.
now destruct H9.
Qed.

Lemma func_preserving_net_limits_is_continuous:
  forall x0:X,
  (forall (I:DirectedSet) (x:Net I X),
    net_limit x x0 -> net_limit (fun i:DS_set I => f (x i)) (f x0))
  -> continuous_at f x0.
Proof.
intros.
pose proof (H (neighborhood_net_DS X x0)
  (neighborhood_net X x0)
  (neighborhood_net_limit X x0)).
apply continuous_at_open_neighborhoods.
intros.
destruct H1, (H0 V H1 H2).
destruct x as [U].
exists U.
repeat split; trivial.
apply (H3 (intro_neighborhood_net_DS X x0 U x o i H4)).
simpl. auto with sets.
Qed.

End Nets_and_continuity.

Section Subnet.

Variable X:TopologicalSpace.
Variable I:DirectedSet.
Variable x:Net I X.

Inductive Subnet {J:DirectedSet} : Net J X -> Prop :=
  | intro_subnet: forall h:DS_set J -> DS_set I,
    (forall j1 j2:DS_set J, DS_ord j1 j2 ->
       DS_ord (h j1) (h j2)) ->
    (exists arbitrarily large i:DS_set I,
       exists j:DS_set J, h j = i) ->
    Subnet (fun j:DS_set J => x (h j)).

Lemma subnet_limit: forall (x0:X) {J:DirectedSet}
  (y:Net J X), net_limit x x0 -> Subnet y ->
  net_limit y x0.
Proof.
intros.
destruct H0.
red. intros.
destruct (H U H2 H3).
destruct (H1 x1).
destruct H5, H6.
exists x3.
intros.
apply H4.
apply preord_trans with x2; trivial.
- apply DS_ord_cond.
- rewrite <- H6.
  now apply H0.
Qed.

Lemma subnet_cluster_point: forall (x0:X) {J:DirectedSet}
  (y:Net J X), net_cluster_point y x0 ->
  Subnet y -> net_cluster_point x x0.
Proof.
intros.
destruct H0 as [h h_increasing h_dominant].
red. intros.
red. intros.
destruct (h_dominant i).
destruct H2, H3.
destruct (H U H0 H1 x2).
destruct H4.
exists (h x3).
split; trivial.
apply preord_trans with x1; trivial.
- apply DS_ord_cond.
- rewrite <- H3.
  now apply h_increasing.
Qed.

Section cluster_point_subnet.

Variable x0:X.
Hypothesis x0_cluster_point: net_cluster_point x x0.
Hypothesis I_nonempty: inhabited (DS_set I).

Record cluster_point_subnet_DS_set : Type := {
  cps_i:DS_set I;
  cps_U:Ensemble X;
  cps_U_open_neigh: open_neighborhood cps_U x0;
  cps_xi_in_U: In cps_U (x cps_i)
}.

Definition cluster_point_subnet_DS_ord
  (iU1 iU2 : cluster_point_subnet_DS_set) : Prop :=
  DS_ord (cps_i iU1) (cps_i iU2) /\
  Included (cps_U iU2) (cps_U iU1).

Definition cluster_point_subnet_DS : DirectedSet.
refine (Build_DirectedSet
  cluster_point_subnet_DS_set
  cluster_point_subnet_DS_ord
  _ _).
- constructor.
  + red. intros.
    split; auto with sets.
    apply preord_refl.
    apply DS_ord_cond.
  + red. intros.
    destruct H, H0.
    red. split; auto with sets.
    apply preord_trans with (cps_i y); trivial.
    apply DS_ord_cond.
- intros.
  destruct i as [i0 U0 ? ?].
  destruct j as [i1 U1 ? ?].
  destruct (DS_join_cond i0 i1).
  destruct H.
  pose proof (x0_cluster_point
    (Intersection U0 U1)).
  match type of H1 with | _ -> _ -> ?C =>
    assert C end.
  { apply H1.
    - apply open_intersection2;
        (apply cps_U_open_neigh0 ||
         apply cps_U_open_neigh1).
    - constructor.
      + apply cps_U_open_neigh0.
      + apply cps_U_open_neigh1. }
  destruct (H2 x1), H3.
  pose (ki := x2).
  pose (kU := Intersection U0 U1).
  assert (open_neighborhood kU x0).
  { split.
    - apply open_intersection2.
      + apply cps_U_open_neigh0.
      + apply cps_U_open_neigh1.
    - constructor.
      + apply cps_U_open_neigh0.
      + apply cps_U_open_neigh1. }
  assert (In kU (x ki)) by trivial.
  exists (Build_cluster_point_subnet_DS_set
    ki kU H5 H6).
  split; red; simpl; split.
  + apply preord_trans with x1; trivial.
    apply DS_ord_cond.
  + red. intros.
    now destruct H7.
  + apply preord_trans with x1; trivial.
    apply DS_ord_cond.
  + red. intros.
    now destruct H7.
Defined.

Definition cluster_point_subnet : Net
  cluster_point_subnet_DS X :=
  fun (iU:DS_set cluster_point_subnet_DS) =>
  x (cps_i iU).

Lemma cluster_point_subnet_is_subnet:
  Subnet cluster_point_subnet.
Proof.
constructor.
- intros.
  destruct j1, j2.
  simpl in H. simpl.
  red in H. tauto.
- red. intros.
  exists i. split.
  + apply preord_refl, DS_ord_cond.
  + assert (open_neighborhood Full_set x0).
    { repeat constructor.
      apply open_full. }
    assert (In Full_set (x i)) by
      constructor.
    now exists (Build_cluster_point_subnet_DS_set
      i Full_set H H0).
Qed.

Lemma cluster_point_subnet_converges:
  net_limit cluster_point_subnet x0.
Proof.
red. intros.
destruct I_nonempty as [i0].
destruct (x0_cluster_point U H H0 i0).
destruct H1.
assert (open_neighborhood U x0) by
  now split.
exists (Build_cluster_point_subnet_DS_set
  x1 U H3 H2).
intros.
destruct j.
red in H4. simpl in H4.
red in H4. simpl in H4.
unfold cluster_point_subnet. simpl.
destruct H4. auto with sets.
Qed.

Lemma net_cluster_point_impl_subnet_converges:
  exists J:DirectedSet, exists y:Net J X,
  Subnet y /\ net_limit y x0.
Proof.
exists cluster_point_subnet_DS.
exists cluster_point_subnet.
split.
- exact cluster_point_subnet_is_subnet.
- exact cluster_point_subnet_converges.
Qed.

End cluster_point_subnet.

End Subnet.


Check not.

(* overriding existing definition *)
Definition not (b:bool) :=
  match b with
    | true  =>  false
    | false =>  true
  end.

Check not.

(* cannot override again in same file for some reason *)
Definition not' (b:bool) := if b then false else true.

Lemma not_same : forall b:bool, not b = not' b.
Proof.
  intro b. elim b.
    clear b. simpl. reflexivity.
    clear b. simpl. reflexivity.
Qed.

Definition func1 :=
  fun (x:nat) (H:{x=0}+{x<>0}) =>
    match H with
      | left  _ => true
      | right _ => false
    end.

Check func1.

Definition func2 :=
  fun (x:nat) (H:{x=0}+{x<>0}) =>
    if H then true else false.

Check func2.

Lemma func_same: forall x:nat, forall H:{x=0}+{x<>0},
  func1 x H = func2 x H.
Proof.
  intros x H. elim H.
    clear H. intro H. simpl. reflexivity.
    clear H. intro H. simpl. reflexivity.
Qed.


Require Import prosa.classic.util.tactics.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype.

(* Lemmas about the exists for Ordinals: [exists x, P x]. *)
Section OrdExists.

  Lemma exists_ord0:
    forall P,
      [exists x in 'I_0, P x] = false.
  Proof.
    intros P.
    apply negbTE; rewrite negb_exists; apply/forall_inP.
    intros x; destruct x as [x LT].
    by exfalso; rewrite ltn0 in LT.
  Qed.

  Lemma exists_recr:
    forall n P,
      [exists x in 'I_n.+1, P x] =
      [exists x in 'I_n, P (widen_ord (leqnSn n) x)] || P (ord_max).
  Proof.
    intros n P.
    apply/idP/idP.
    {
      move => /exists_inP EX; destruct EX as [x IN Px].
      destruct x as [x LT].
      remember LT as LT'; clear HeqLT'.
      rewrite ltnS leq_eqVlt in LT; move: LT => /orP [/eqP EQ | LT].
      {
        apply/orP; right.
        unfold ord_max; subst x.
        apply eq_trans with (y := P (Ordinal LT')); last by done.
        by f_equal; apply ord_inj.
      }
      {
        apply/orP; left.
        apply/exists_inP; exists (Ordinal LT); first by done.
        apply eq_trans with (y := P (Ordinal LT')); last by done.
        by f_equal; apply ord_inj.
      }
    }
    {
      intro OR; apply/exists_inP.
      move: OR => /orP [/exists_inP EX | MAX].
      {
        by destruct EX as [x IN Px]; exists (widen_ord (leqnSn n) x).
      }
      by exists ord_max.
    }
  Qed.

End OrdExists.

(* Lemmas about the forall for Ordinals: [exists x, P x]. *)
Section OrdForall.

  Lemma forall_ord0:
    forall P,
      [forall x in 'I_0, P x].
  Proof.
    intros P; apply/forall_inP.
    by intros x IN0; destruct x.
  Qed.

  Lemma forall_recr:
    forall n P,
      [forall x in 'I_n.+1, P x] =
      [forall x in 'I_n, P (widen_ord (leqnSn n) x)] && P (ord_max).
  Proof.
    intros n P.
    apply/idP/idP.
    {
      move => /forall_inP ALL.
      apply/andP; split; last by apply ALL.
      by apply/forall_inP; intros x IN; apply ALL.
    }
    {
      move => /andP [/forall_inP ALL MAX].
      apply/forall_inP; intros x IN.
      destruct x as [x LT].
      unfold ord_max in *.
      remember LT as LT'; clear HeqLT'.
      rewrite ltnS leq_eqVlt in LT; move: LT => /orP [/eqP EQ | LT].
      {
        subst n.
        apply/eqP; rewrite -MAX; apply/eqP.
        by unfold ord_max; apply f_equal, ord_inj.
      }
      {
        feed (ALL (Ordinal LT)); first by done.
        apply/eqP; rewrite -ALL; apply/eqP.
        by apply f_equal, ord_inj.
      }
    }
  Qed.

End OrdForall.

(* Tactics for simplifying exists and forall. *)
Ltac simpl_exists_ord := rewrite !exists_recr !exists_ord0 /=.
Ltac simpl_forall_ord := rewrite !forall_recr !forall_ord0 /=.


(* ***************************************************************** *)
(*                                                                   *)
(* Released: 2020/03/26.                                             *)
(* Due: 2020/03/30, 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 (Assignment3.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 "Assignment3.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.ImpExt1.
Require Import PL.ImpExt2.
Require Import Coq.micromega.Psatz.

(* ################################################################# *)
(** * Task 1: Hoare Logic Based Verification *)

Module Task1.
Import Assertion_S.
Import Assertion_S_Tac.
Import Assertion_S_Rules.
Import Concrete_Pretty_Printing.
Import Axiomatic_semantics.
Import derived_rules.

Module Task1_1.
Import Axiomatic_semantics.
Import derived_rules.

(** **** Exercise: 3 stars, standard (tri_correct)  *)

(** The following program try to find the smallest number [N] such
that [1 + 2 + 3 + .. + N > X].

    S ::= 0;;
    N ::= 0;;
    While S <= X Do
      N ::= N + 1;;
      S ::= S + N
    EndWhile.

Remember, you can always add auxiliary lemmas before start proving
the main theorem in every subtasks. But of course, these lemmas needs
to be proved. *)

Local Instance X: var := new_var().
Local Instance S: var := new_var().
Local Instance N: var := new_var().

Lemma enter_loop:
0 <= {[X]} AND {[S]} = 0 AND {[N]} = 0
|-- 2 * {[S]} = {[N]} * ({[N]} + 1) AND {[N]} * ({[N]} - 1) <= 2 * {[X]}.
Proof.
  entailer.
  intros.
  lia.
Qed.

Lemma after_loop:
2 * {[S]} = {[N]} * ({[N]} + 1) AND {[N]} * ({[N]} - 1) <= 2 * {[X]}
AND NOT {[S <= X]}
|-- {[N]} * ({[N]} - 1) <= 2 * {[X]} AND 2 * {[X]} < {[N]} * ({[N]} + 1).
Proof.
  entailer.
  intros.
  lia.
Qed.

Lemma loop_body:
  EXISTS x,
  2 * {[S]} = x * (x + 1) AND x * (x - 1) <= 2 * {[X]} AND {[S]} <= {[X]}
  AND {[N]} = x + 1
|--   2 * {[S]} = ({[N]} - 1) * {[N]}
 AND ({[N]} - 1) * ({[N]} - 2) <= 2 * {[X]} AND {[S]} <= {[X]} .
Proof.
  entailer.
  intros.
  destruct H as [k H].
  lia.
Qed.

Lemma exit_loop:
EXISTS x,
(2 * {[S]} = ({[N]} - 1) * {[N]} AND ({[N]} - 1) * ({[N]} - 2) <= 2 * {[X]}
 AND {[S]} <= {[X]}) [S |-> x] AND {[S]} = {[(S + N) [S |-> x]]}
|-- 2 * {[S]} = {[N]} * ({[N]} + 1) AND {[N]} * ({[N]} - 1) <= 2 * {[X]}.
Proof.
  entailer.
  intros.
  destruct H as [k H].
  lia.
Qed.

Fact tri_correct:
  {{ 0 <= {[X]} }}
    S ::= 0;;
    N ::= 0;;
    While S <= X Do
      N ::= N + 1;;
      S ::= S + N
    EndWhile
  {{ {[N * (N-1)]} <= 2 * {[X]} AND
     2 * {[X]} < {[N * (N + 1)]} }}.
Proof.
  apply hoare_asgn_seq.
  apply hoare_asgn_seq.
  assert_simpl.
  eapply hoare_consequence;
  [ apply enter_loop |
  | apply after_loop].
  apply hoare_while.
  apply hoare_asgn_seq.
  assert_subst. assert_simpl.
  eapply hoare_consequence;
  [ apply loop_body
  | apply hoare_asgn_fwd
  | apply exit_loop].
Qed.

(** [] *)

End Task1_1.

Module Task1_2.
Import Axiomatic_semantics.
Import derived_rules.

(** **** Exercise: 3 stars, standard (sqrt_correct)  *)

(** The following program computes the integer part of [X]'s square
root.

    I ::= 0;;
    While (I+1)*(I+1) <= X Do
      I ::= I+1
    EndWhile.

Your task is to prove its correctness. *)

Local Instance X: var := new_var().
Local Instance I: var := new_var().

Lemma into_loop: forall m:Z,
0 <= {[X]} AND {[X]} = m AND {[I]} = 0
|-- 0 <= {[X]} AND {[X]} = m AND  {[I]} * {[I]} <= m.
Proof.
  intros.
  entailer.
  intros.
  lia.
Qed.

Lemma after_loop: forall m:Z,
0 <= {[X]} AND {[X]} = m AND {[I]} * {[I]} <= m AND NOT {[(I + 1) * (I + 1) <= X]}
|-- {[I]} * {[I]} <= m AND m < ({[I]} + 1) * ({[I]} + 1).
Proof.
  intros.
  entailer.
  intros.
  lia.
Qed.

Lemma loop_body: forall m:Z,
EXISTS x,
(0 <= {[X]} AND {[X]} = m AND {[I]} * {[I]} <= m AND {[(I + 1) * (I + 1) <= X]})
[I |-> x] AND {[I]} = {[(I + 1) [I |-> x]]}
|-- 0 <= {[X]} AND {[X]} = m AND {[I]} * {[I]} <= m.
Proof.
  intros.
  entailer.
  intros.
  destruct H as [k H].
  lia.
Qed.

Fact sqrt_correct: forall m: Z,
  {{ 0 <= {[X]} AND {[X]} = m }}
    I ::= 0;;
    While (I+1)*(I+1) <= X Do
      I ::= I+1
    EndWhile
  {{ {[I]} * {[I]} <= m AND m < ({[I]} + 1) * ({[I]} + 1) }}.
Proof.
  intros.
  apply hoare_asgn_seq.
  assert_simpl.
  eapply hoare_consequence;
  [ apply into_loop |
  | apply after_loop].
  apply hoare_while.
  eapply hoare_consequence_post;
  [ apply hoare_asgn_fwd
  | apply loop_body].
Qed.

(** [] *)

End Task1_2.

End Task1.

(* ################################################################# *)
(** * Task 2: Understanding Denotations *)

(** In this task, you will read descriptions about program states and decide
    whether the following pairs of programs states belong to corresponding
    programs' denotations. *)

(** **** Exercise: 1 star, standard  *)
Module Task2_1.

(** Suppose [X] and [Y] are different program variables. If [st X = 1] and
    [st Y = 2], then does (st, st) belong to the following program's denotation?

    Y ::= X + 1

    1: Yes. 2: No. *)

Definition my_choice: Z := 1.

End Task2_1.
(** [] *)

(** **** Exercise: 1 star, standard  *)
Module Task2_2.

(** Suppose [X] is a program variables. If [st1 X = 100], [st2 X = 1] and all
    other variables in [st1] and [st2] are zero, then does (st1, st2) belong to
    the following program's denotation?

    While 1 <= X Do X ::= X + 1 EndWhile

    1: Yes. 2: No. *)

Definition my_choice: Z := 2.

End Task2_2.
(** [] *)

(** **** Exercise: 1 star, standard  *)
Module Task2_3.

(** Suppose [X] and [Y] are different program variables. If [st1 X = 1],
    [st1 Y = 2], [st2 X = 2], [st2 Y = 1] and all other variables in [st1] and
    [st2] are zero, then does (st1, st2) belong to the following program's
    denotation?

    Z ::= X;; X ::= Y;; Y ::= Z

    1: Yes. 2: No. *)

Definition my_choice: Z := 2.

End Task2_3.
(** [] *)

(* ################################################################# *)
(** * Task 3: Reasoning About Recursions *)

(** Here is a recursive function about integer expressions. Try to understand
    what it tries to do and prove related properties. *)

Fixpoint aexp_reverse (a: aexp): aexp :=
  match a with
  | ANum n => ANum n
  | AId X => AId X
  | APlus a1 a2 => APlus (aexp_reverse a2) (aexp_reverse a1)
  | AMinus a1 a2  => AMinus (aexp_reverse a1) (aexp_reverse a2)
  | AMult a1 a2 => AMult (aexp_reverse a2) (aexp_reverse a1)
  end.

(** **** Exercise: 2 stars, standard (reverse_equiv)  *)
Lemma reverse_equiv: forall a st, aeval (aexp_reverse a) st = aeval a st.
Proof.
  intros.
  induction a;simpl.
  - reflexivity.
  - reflexivity.
  - unfold Func.add.
    rewrite IHa1, IHa2.
    lia.
  - unfold Func.sub.
    rewrite IHa1, IHa2.
    lia.
  - unfold Func.mul.
    rewrite IHa1, IHa2.
    lia.
Qed.

(** **** Exercise: 2 stars, standard (reversed_reverse)  *)
Lemma reversed_reverse: forall a1 a2,
  aexp_reverse a1 = a2 ->
  a1 = aexp_reverse a2.
Proof.
  intros.
  rewrite <- H. clear H.
  induction a1; simpl; try reflexivity.
  - rewrite IHa1_1, IHa1_2 at 1.
    reflexivity.
  - rewrite IHa1_1, IHa1_2 at 1.
    reflexivity.
  - rewrite IHa1_1, IHa1_2 at 1.
    reflexivity.
Qed.

(** You may wonder whether [aexp_reverse] is a meaningful operation. Well, it
    might be. Try to answer the following questions about it. *)

(** **** Exercise: 1 star, standard  *)
Module Task3_3.

(** In comparison, which one of the following is the better optimazation?

    - do [fold_constants] directly;

    - do [fold_constants] after [aexp_reverse].

    Choose one correct statement:

    0. They always generate results with the same length.

    1. The first one always generates shorter (or equivalent) result and
       statement 0 is wrong.

    2. The second one always generates shorter (or equivalent) result and
       statement 0 is wrong.

    3. They are not comparable. *)

Definition my_choice: Z := 3.

End Task3_3.
(** [] *)

(** **** Exercise: 1 star, standard  *)
Module Task3_4.

(** In comparison, which one of the following is the better optimazation?

    - do [fold_constants] directly;

    - do [fold_constants], then [aexp_reverse], and [fold_constants] again
      in the end

    Choose one correct statement:

    0. They always generate results with the same length.

    1. The first one always generates shorter (or equivalent) result and
       statement 0 is wrong.

    2. The second one always generates shorter (or equivalent) result and
       statement 0 is wrong.

    3. They are not comparable. *)

Definition my_choice: Z := 2.

End Task3_4.
(** [] *)

(* ################################################################# *)
(** * Task 4: Understanding Higher-Order Functions *)

(** Suppose [f] and [g] are both functions from [A] to [A]. How shall we define
    the function that applies [f] first and then applies [g]? *)

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

Definition compose {A: Type} (f g: A -> A): A -> A :=
  fun x => g (f x).

(** It is obvious that [ compose f (compose g h) ] is equivalent with
    [ compose (compose f g) h ]. Your task is to prove it in Coq. *)

Theorem compose_assoc: forall f g h: Z -> Z,
  Func.equiv (compose f (compose g h)) (compose (compose f g) h).
Proof.
  intros.
  unfold Func.equiv.
  intros.
  unfold compose.
  reflexivity.
Qed.

(** [] *)

(* Thu Mar 26 09:44:52 CST 2020 *)


Require Import Coq.Lists.List.

Section ListLexOrder.
  Variable T : Type.
  Variable cmp : T -> T -> comparison.

  Fixpoint list_lex_cmp (ls rs : list T) : comparison :=
    match ls , rs with
      | nil , nil => Eq
      | nil , _ => Lt
      | _ , nil => Gt
      | l :: ls , r :: rs =>
        match cmp l r with
          | Eq => list_lex_cmp ls rs
          | x => x
        end
    end.
End ListLexOrder.

Section Sorting.
  Variable T : Type.
  Variable cmp : T -> T -> comparison.

  Section insert.
    Variable val : T.

    Fixpoint insert_in_order (ls : list T) : list T :=
      match ls with
        | nil => val :: nil
        | l :: ls' =>
          match cmp val l with
            | Gt => l :: insert_in_order ls'
            | _ => val :: ls
          end
      end.
  End insert.

  Fixpoint sort (ls : list T) : list T :=
    match ls with
      | nil => nil
      | l :: ls =>
        insert_in_order l (sort ls)
    end.

End Sorting.

Lemma insert_in_order_inserts : forall T C x l,
  exists h t, insert_in_order T C x l = h ++ x :: t /\ l = h ++ t.
Proof.
  clear. induction l; simpl; intros.
  exists nil; exists nil; eauto.
  destruct (C x a).
  exists nil; simpl. eauto.
  exists nil; simpl. eauto.
  destruct IHl. destruct H. intuition. subst.
  rewrite H0. exists (a :: x0). exists x1. simpl; eauto.
Qed.

Require Import Coq.Sorting.Permutation.

Lemma sort_permutation : forall T (C : T -> T -> _) x,
  Permutation (sort _ C x) x.
Proof.
  induction x; simpl.
  { reflexivity. }
  { destruct (insert_in_order_inserts T C a (sort T C x)) as [ ? [ ? ? ] ].
    destruct H. rewrite H. rewrite <- Permutation_cons_app. reflexivity. rewrite H0 in *. symmetry; auto. }
Qed.


Require Import String.

(* Simply typed lambda calculus with pairs *)

Inductive STyp :=
  | STInt : STyp
  | STFun : STyp -> STyp -> STyp
  | STTuple : STyp -> STyp -> STyp.

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

Fixpoint join A (e : SExp (SExp A)) : SExp A :=
  match e with
    | STVar x => x
    | STLit n => STLit _ n
    | STLam t f => STLam _ t (fun x => join _ (f (STVar _ x)))
    | STApp e1 e2 => STApp _ (join _ e1) (join _ e2)
    | STPair e1 e2 => STPair _ (join _ e1) (join _ e2)
    | STProj1 e => STProj1 _ (join _ e)
    | STProj2 e => STProj2 _ (join _ e)
  end.

(* STLC: Evaluation (incomplete rules, but sufficient?) *)

Inductive Ev : forall a, SExp (SExp a) -> SExp a -> Prop :=
  | Beta : forall a t f e, Ev a (STApp _ (STLam _ t f) e) (join _ (f (join _ e))).

Definition Ev2 A (e : SExp (SExp A)) : option (SExp A) :=
  match e with
    | STApp (STLam t f) e => Some (join _ (f (join _ e))) (* beta *)
    | e => Some (join _ e) (* wrong! *)
  end.

Definition e1 A (p : SExp A) : SExp A :=
  STApp _ (STLam _ (STTuple STInt STInt) (fun pair => STPair _ (STProj1 _ (STVar _ pair)) (STProj2 _ (STVar _ pair)))) p.

Definition e2 A (p : SExp A) : SExp A :=
  STPair _ (STProj1 _ (STProj1 _ p)) (STProj2 _ (STProj1 _ p)).

Lemma equalExp : forall A (p : SExp (SExp A)), Ev2 _ (e1 _ p) = Ev2 _ (e2 _ p).
Proof.
unfold e1. unfold e2. simpl. intros.
admit.
Defined.

Definition Exp := forall A, SExp A.

(* System I (no polymorphism yet) *)

Inductive PTyp : Type :=
  | PInt : PTyp
  | Fun : PTyp -> PTyp -> PTyp
  | And : PTyp -> PTyp -> PTyp.

Fixpoint ptyp2styp (t : PTyp) : STyp :=
  match t with
    | PInt => STInt
    | Fun t1 t2 => STFun (ptyp2styp t1) (ptyp2styp t2)
    | And t1 t2 => STTuple (ptyp2styp t1) (ptyp2styp t2)
  end.

Require Import Arith.
Require Import Setoid.

(* Subtyping relation *)

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

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

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

(* Smart constructors for Sub *)

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

Definition sfun : forall o1 o2 o3 o4, Sub o3 o1 -> Sub o2 o4 -> Sub (Fun o1 o2) (Fun  o3 o4).
unfold Sub; intros.
admit.
Defined.

Definition sand1 : forall t t1 t2, Sub t t1 -> Sub t t2 -> Sub t (And t1 t2).
admit.
Defined.

Definition sand2 : forall t t1 t2, Sub t1 t -> Sub (And  t1 t2) t.
admit.
Defined.

Definition sand3 : forall t t1 t2, Sub t2 t -> Sub (And  t1 t2) t.
admit.
Defined.

(* Orthogonality: Implementation *)

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

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

(* Orthogonality: Specification *)

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

(* Well-formed types *)

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

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

Lemma reflex : forall (t1 : PTyp), Sub t1 t1.
Proof.
(*induction t1; auto.
auto. apply sand1. inversion IHt1_1. induction H. apply sand2. auto. apply AInt.
apply sand2. auto. apply AFun.
apply sand1. admit. admit. apply sand2; auto. apply sand2; auto.  *)
induction t1; intros; auto.
Defined.

(* Orthogonality algorithm is complete *)

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

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

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

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

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

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

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

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

(* coercive subtyping is coeherent *)

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

(* Old theorems *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(* A functional definition : algorithm *)

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

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

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


Require Import Relations.

Lemma wf_inclusion :
 forall (A:Set) (R S:A -> A -> Prop),
   inclusion A R S -> well_founded S -> well_founded R.
Proof.
 intros A R S Hincl Hwf x.
 elim x using (well_founded_ind Hwf).
 intros x' Hrec; apply Acc_intro.
 intros y Hr; apply Hrec; apply Hincl; assumption.
Qed.


From Coq Require Import List Lia.
From StructTact Require Import StructTactics ListTactics.
From StructTact Require Import FilterMap RemoveAll.
Import ListNotations.

Set Implicit Arguments.

Fixpoint subseq {A} (xs ys : list A) : Prop :=
  match xs, ys with
    | [], _ => True
    | x :: xs', y :: ys' => (x = y /\ subseq xs' ys') \/ subseq xs ys'
    | _, _ => False
  end.

Section subseq.
  Variable A B : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Lemma subseq_refl : forall (l : list A), subseq l l.
  Proof using.
    induction l; simpl; tauto.
  Qed.

  Lemma subseq_trans :
    forall (zs xs ys : list A),
      subseq xs ys ->
      subseq ys zs ->
      subseq xs zs.
  Proof using.
    induction zs; intros; simpl in *;
      repeat break_match; subst; simpl in *; intuition; subst; eauto;
        right; (eapply IHzs; [|eauto]); simpl; eauto.
  Qed.

  Lemma subseq_In :
    forall (ys xs : list A) x,
      subseq xs ys ->
      In x xs ->
      In x ys.
  Proof using.
    induction ys; intros.
    - destruct xs; simpl in *; intuition.
    - simpl in *.
      break_match; simpl in *; intuition auto; subst; intuition eauto;
        right; (eapply IHys; [eauto| intuition auto with datatypes]).
  Qed.

  Theorem subseq_NoDup :
    forall (ys xs : list A),
      subseq xs ys ->
      NoDup ys ->
      NoDup xs.
  Proof using.
    induction ys; intros.
    - destruct xs; simpl in *; intuition.
    - simpl in *. invc_NoDup.
      break_match.
      + constructor.
      + intuition.
        subst. constructor; eauto using subseq_In.
  Qed.

  Lemma subseq_remove :
    forall (x : A) xs,
      subseq (remove A_eq_dec x xs) xs.
  Proof using.
    induction xs; intros; simpl.
    - auto.
    - repeat break_match; auto.
      + intuition congruence.
      + find_inversion. auto.
  Qed.

  Lemma subseq_map :
    forall (f : A -> B) ys xs,
      subseq xs ys ->
      subseq (map f xs) (map f ys).
  Proof using.
    induction ys; intros; simpl in *.
    - repeat break_match; try discriminate; auto.
    - repeat break_match; try discriminate; auto.
      intuition.
      + subst. simpl in *. find_inversion. auto.
      + right. repeat find_reverse_rewrite. auto.
  Qed.

  Lemma subseq_cons_drop :
    forall xs ys (a : A),
      subseq (a :: xs) ys -> subseq xs ys.
  Proof using.
    induction ys; intros; simpl in *; intuition; break_match; eauto.
  Qed.

  Lemma subseq_length :
    forall (ys xs : list A),
      subseq xs ys ->
      length xs <= length ys.
  Proof using.
    induction ys; intros; simpl in *; break_match;
      intuition auto with datatypes arith.
    subst. simpl in *. specialize (IHys l).
    concludes. auto with arith.
  Qed.

  Lemma subseq_subseq_eq :
    forall (xs ys : list A),
      subseq xs ys ->
      subseq ys xs ->
      xs = ys.
  Proof using.
    induction xs; intros; destruct ys; simpl in *;
      intuition eauto using f_equal2, subseq_cons_drop.
    exfalso.
    repeat find_apply_lem_hyp subseq_length.
    simpl in *. lia.
  Qed.

  Lemma subseq_filter :
    forall (f : A -> bool) xs,
      subseq (filter f xs) xs.
  Proof using.
    induction xs; intros; simpl.
    - auto.
    - repeat break_match; intuition congruence.
  Qed.

  Lemma subseq_nil :
    forall xs,
      subseq (A:=A) [] xs.
  Proof using.
    destruct xs; simpl; auto.
  Qed.

  Lemma subseq_skip :
    forall a xs ys,
      subseq(A:=A) xs ys ->
      subseq xs (a :: ys).
  Proof using.
    induction ys; intros; simpl in *; repeat break_match; intuition.
  Qed.

  Lemma subseq_filterMap :
    forall (f : B -> option A) ys xs,
      subseq xs ys ->
      subseq (filterMap f xs) (filterMap f ys).
  Proof using.
    induction ys; intros; simpl in *; repeat break_match; auto; try discriminate; intuition; subst.
    - simpl. find_rewrite. auto.
    - auto using subseq_skip.
    - auto using subseq_nil.
    - simpl. find_rewrite. auto.
  Qed.

  Lemma subseq_app_r :
    forall xs ys,
      subseq (A:=A) ys (xs ++ ys).
  Proof using.
    induction xs; intros; simpl.
    + auto using subseq_refl.
    + break_match.
      * auto.
      * right. auto using subseq_nil.
  Qed.

  Lemma subseq_app_tail :
    forall ys xs zs,
      subseq (A:=A) xs ys ->
      subseq (xs ++ zs) (ys ++ zs).
  Proof using.
    induction ys; intros; simpl in *.
    - break_match; intuition auto using subseq_refl.
    - repeat break_match.
      + auto.
      + discriminate.
      + simpl in *. subst. right. auto using subseq_app_r.
      + simpl in *. find_inversion. intuition.
        rewrite app_comm_cons. auto.
  Qed.

  Lemma subseq_app_head :
    forall xs ys zs,
      subseq (A:=A) ys zs ->
      subseq (A:=A) (xs ++ ys) (xs ++ zs).
  Proof using.
    induction xs; intros; simpl; intuition.
  Qed.

  Lemma subseq_2_3 :
    forall xs ys zs x y,
      subseq(A:=A) (xs ++ ys ++ zs) (xs ++ x :: ys ++ y :: zs).
  Proof using.
    auto using subseq_refl, subseq_skip, subseq_app_head.
  Qed.

  Lemma subseq_middle :
    forall xs y zs,
      subseq (A:=A) (xs ++ zs) (xs ++ y :: zs).
  Proof using.
    intros.
    apply subseq_app_head.
    apply subseq_skip.
    apply subseq_refl.
  Qed.

  Lemma subseq_remove_all :
    forall (ds l l' : list A),
      subseq l l' ->
      subseq (remove_all A_eq_dec ds l) l'.
  Proof using.
    induction ds; intros; simpl.
    - auto.
    - apply IHds.
      eapply subseq_trans.
      apply subseq_remove.
      auto.
  Qed.
End subseq.


Require Import MathClasses.interfaces.canonical_names.
Require Import Coq.Lists.List.
Require Import BijNat.
Require Import MeetSemiLattice.
Require Import DistrLattice.
Require Import PreorderEquiv.

(** * Definition of sigma-frames
    They are meet semilattices with countable joins, such
    that meet distributes over joins.

    We omit the sigma prefix in the coq development. *)

Section Frame_Definition.

Class Frame {t:Type} {le: Le t} :=
  MkFrame {
      frame_msl :> MeetSemiLattice le;

      (* countable joins *)
      V : (nat -> t) -> t;
      v_le: forall u : (nat -> t), forall n: nat, u n ≤ V u;
      v_univ: forall u : (nat -> t), forall z : t, (forall n : nat, u n ≤ z) -> V u ≤ z;

      (* distributivity *)
      cdistr_l: forall x u, x ⊓ (V u) ≤ (V (fun n => x ⊓ (u n)));
    }.

  Context {t : Type}.
  Context {le : Le t}.

  Variable (F : @Frame t le).
  Existing Instance Feq_equiv.

  (** ** Properties of the countable join *)
  (* Countable join is a morphism *)

  Lemma V_compat_le : forall a b, (forall n, a n ≤ b n) -> V a ≤ V b.
  Proof.
    intros.
    apply v_univ.
    intros.
    apply (le_trans _ (b n) _ (H n)).
    apply v_le.
  Qed.

  Lemma V_morphism : forall a b, (forall n, a n = b n) -> V a = V b.
    unfold Feq.
    intros.
    split.

    apply V_compat_le.
    firstorder.
    apply V_compat_le.
    firstorder.
  Qed.

  Add Morphism V : morphism_V.
  Proof.
    apply V_morphism.
  Qed.

  Lemma V_le_le : forall x t u, t ≤ u x -> t ≤ V u.
  Proof.
    intros.
    apply le_trans with (y := u x).
    apply H.
    apply v_le.
  Qed.

  Ltac smart_V_le n :=
    apply (V_le_le n);
    simpl;
    try (apply le_refl).

  Lemma V_const : forall x, V (fun _ => x) = x.
  Proof.
    intros.
    split.
    apply v_univ. intro ; apply le_refl.
    apply (V_le_le O).
    apply le_refl.
  Qed.

  Lemma V_top : forall u, (exists n, u n = ⊤) -> V u = ⊤.
  Proof.
    intros.
    destruct H as [n H].
    split.
    apply top_le.
    setoid_rewrite <- H.
    apply v_le.
  Qed.

  Lemma V_bot : V (fun _ => ⊥) = ⊥.
  Proof.
    apply V_const.
  Qed.

  Lemma V_comm : forall w : nat -> nat -> t,
                   V (fun n => V (fun m => w n m)) = V (fun m => V (fun n => w n m)).
  Proof.
    intros.
    unfold Feq.
    split; repeat (apply v_univ; intro).
    - (* <= *)
      apply le_trans with (y := V (fun n1 => w n1 n0)).
      smart_V_le n.
      smart_V_le n0.

    - (* >= *)
      apply le_trans with (y := V (fun m => w n0 m)).
      smart_V_le n.
      smart_V_le n0.
  Qed.

  Definition my_pairer w (n : nat) : t := w (fst (bijNNinv n)) (snd (bijNNinv n)).

  Lemma V_pair : forall w : nat -> nat -> t,
                   V (fun n => w (fst (bijNNinv n)) (snd (bijNNinv n))) =
                   V (fun n => V (fun m => w n m)).
  Proof.
    intro.
    unfold Feq. split.

    - (* <= *)
      apply v_univ. intro.
      smart_V_le (fst (bijNNinv n)).
      smart_V_le (snd (bijNNinv n)).

    - (* >= *)
      repeat (apply v_univ; intro).
      assert (w n n0 = (my_pairer w (bijNN (n,n0)))).
      unfold my_pairer.
      rewrite bijNNinv_bijNN.
      reflexivity.
      rewrite H.
      apply v_le.
  Qed.

  (** ** Distributivity *)

  Lemma cdistr_r: forall x u, V (fun n => x ⊓ (u n)) ≤ x ⊓ (V u).
  Proof.
    intros.
    apply v_univ. intro.
    apply meet_le.
    apply le_refl.
    eapply v_le.
  Qed.

  Lemma cdistr : forall x u, x ⊓ (V u) = V (fun n => x ⊓ (u n)).
  Proof.
    intros. split.
    apply cdistr_l.
    apply cdistr_r.
  Qed.

  Lemma V_meet : forall a b, V a ⊓ V b = V (fun n => a (bijNN1 n) ⊓ b (bijNN2 n)).
  Proof.
    intros.
    split.
    - rewrite cdistr.
      apply v_univ.
      intro.
      assert (V a ⊓ b n = b n ⊓ V a) by (apply meet_comm).
      rewrite H, cdistr.
      apply v_univ.
      intro.
      set (h := (fun n1 => a (bijNN1 n1) ⊓ b (bijNN2 n1))).
      assert (b n ⊓ a n0 = h (bijNN (n0,n))).
      unfold h ; rewrite bijNN1_eq, bijNN2_eq ; apply meet_comm.
      rewrite H0 ; apply v_le.

    - apply v_univ. intro.
      apply meet_univ.
      + apply le_trans with (y := a (bijNN1 n)).
        apply meet_l.
        apply v_le.
      + apply le_trans with (y := b (bijNN2 n)).
        apply meet_r.
        apply v_le.
  Qed.

  (** ** Finite joins
      It seems easier to first define finite joins
      and then to define binary joins, so that we
      have a distributive lattice, even if this
      distributive lattice gives us again the finite
      joins.

    *)

  Require Import SeqOfList.

  Instance t_po : Preorder le.
  Proof. apply msl_preorder. Defined.
  Existing Instance setoid_msl.

  Definition Vf (l : list t) : t := V (seq_of_list l).

  Add Morphism Vf : Vf_morphism.
  Proof.
    intros. unfold Vf.
    apply V_morphism.
    apply seq_of_list_morphism.
    apply setoid_msl. apply t_po.
    assumption.
  Qed.

  Lemma Vf_nil : Vf [] = ⊥.
  Proof.
    unfold Vf, seq_of_list.
    apply V_bot.
  Qed.

  Hint Resolve Vf_nil.

  Definition joinf (u v : list t) := u ++ v.
  Instance joinf_join : Join (list t) := joinf.

  (** ** Binary joins *)

  Definition joinb (u v : t) := Vf [u ; v].
  Instance joinb_join : Join t := joinb.

  Ltac unfold_joinb :=
    unfold join, joinb_join, joinb, Vf.

  Lemma joinb_l : forall u v : t, u ≤ u ⊔ v.
  Proof.
    intros.
    unfold_joinb. simpl.
    set (f := (u ::: v ::: (fun _ :nat => ⊥))).
    assert (u = f O) by reflexivity.
    rewrite H. apply v_le.
  Qed.

  Lemma joinb_r : forall u v : t, v ≤ u ⊔ v.
  Proof.
    intros ; unfold_joinb ; simpl.
    set (f := (u ::: v ::: (fun _ : nat => ⊥))).
    assert (v = f (S O)) by reflexivity.
    rewrite H. apply v_le.
  Qed.

  Lemma joinb_univ : forall u v w : t, u ≤ w -> v ≤ w -> u ⊔ v ≤ w.
  Proof.
    intros ; unfold_joinb ; simpl.
    apply v_univ ; intro.
    destruct n ; simpl ; try assumption.
    destruct n ; simpl ; try assumption.
    apply bot_le.
  Qed.

  Lemma joinb_distr : forall u v w, u ⊓ (v ⊔ w) ≤ (u ⊓ v) ⊔ (u ⊓ w).
  Proof.
    intros.
    unfold_joinb.
    apply le_trans with (y := V (fun n => u ⊓ (seq_of_list [v;w] n))).
    apply cdistr_l.
    unfold seq_of_list.
    apply v_univ. intro.
    destruct n ; simpl.
    smart_V_le O.
    destruct n ; simpl.
    smart_V_le (S O).
    rewrite meet_bot_r.
    apply bot_le.
  Qed.

  Instance dl_frame : DistrLattice le :=
    MkDistrLattice
      t
      le
      frame_msl
      joinb
      joinb_l
      joinb_r
      joinb_univ
      joinb_distr.

  (** ** Compactness *)

  Fixpoint partial_V (u : (nat -> t)) (n : nat) : t :=
    match n with
      | 0 => ⊥
      | S n => (u O) ⊔ (partial_V (V_tail u) n)
    end.

  Lemma partial_V_le : forall u n, partial_V u n ≤ V u.
  Proof.
    intros.
    generalize u as w.
    induction n.

    - (* 0 *)
      intros.
      apply bot_le.

    - (* S n *)
      intros.
      simpl.
      apply joinb_univ.
      apply v_le.
      apply (le_trans _ (V (V_tail w)) _).
      apply IHn.
      apply v_univ.
      intro. unfold V_tail.
      apply v_le.
  Qed.

  Definition compact := forall u, (V u = ⊤) -> (exists n, partial_V u n = ⊤).

(** One way to define finite or infinite enumerations would
     be to use streams, like this:

<<
  CoInductive enumeration (T : Type) :=
  | ENil : enumeration T
  | ECons : T -> enumeration T -> enumeration T.
>>

  The problem with this definition is that we can't decide
  whether the enumeration is finite or not.
 *)

End Frame_Definition.

Add Parametric Morphism (T : Type) (Tle : Le T) (Tf : Frame) : V with signature (pointwise_relation nat Feq ==> Feq) as f_V_morphism.
Proof.
  apply V_morphism.
Qed.

(** * Frame morphisms *)

Section Frame_Morphism_Definition.
  Context {tA : Type}.
  Context {leA : Le tA}.
  Existing Instance Feq_equiv.

  Context {tB : Type}.
  Context {leB : Le tB}.

  Require Import Coq.Program.Basics.

  Variable (FA : @Frame tA leA).
  Variable (FB : @Frame tB leB).

  Definition mslA := @frame_msl tA leA FA.
  Definition mslB := @frame_msl tB leB FB.

  Open Scope program_scope. (* for ∘ (function composition) *)
  Existing Instance joinb_join.

  Variable (f : tA -> tB).
  Class FMorphism :=
    MkFMorphism
      {
        fmorph_mslmorph :> MSLMorphism mslA mslB f;
        (* preserves countable joins *)
        morph_V: forall u : nat -> tA, f (V u) = V (f ∘ u)
      }.

  Existing Instance listeq_equiv.

  Variable fmorph : FMorphism.
  Existing Instance fmorph.

  Proposition FMorphism_join : forall a b, f (a ⊔ b) = f a ⊔ f b.
  Proof.
    intros.
    unfold join, joinb_join, joinb.
    assert ([f a; f b] = map f [a; b]) by reflexivity.
    unfold Vf.
    rewrite H.
    rewrite seq_of_list_compose.
    apply morph_V.
    apply Feq_equivalence.
    apply msl_preorder.
    apply mslmorph_bot.
    apply fmorph_mslmorph.
  Qed.

End Frame_Morphism_Definition.

(* exported_tactics *)
Ltac smart_V_le n :=
  apply (V_le_le n);
  simpl;
  try (apply le_refl).


Require Export List.

Inductive ltree (A : Set) : Set :=
  lnode: A -> list (ltree A) ->  ltree A .

Inductive ntree (A : Set) : Set :=
               nnode: A -> nforest A ->  ntree A
with nforest (A : Set) : Set :=
          nnil: nforest A
         | ncons: ntree A -> nforest A ->  nforest A.

Scheme
ntree_ind2 := Induction for ntree Sort Prop
   with
   nforest_ind2 := Induction for nforest Sort Prop.

Section correct_ltree_ind.
Variables (A : Set) (P : ltree A ->  Prop) (Q : list (ltree A) ->  Prop).
Hypotheses
   (H : forall (a : A) (l : list (ltree A)), Q l ->  P (lnode A a l))
   (H0 : Q nil)
   (H1 : forall (t : ltree A),
         P t -> forall (l : list (ltree A)), Q l ->  Q (cons t l)).

Fixpoint ltree_ind2 (t : ltree A) : P t :=
 match t as x return P x with
    lnode a l =>
      H a l ((fix l_ind (l' : list (ltree A)) : Q l' :=
                     match l' as x return Q x with
                        nil => H0
                       | cons t1 tl => H1 t1 (ltree_ind2 t1) tl (l_ind tl)
                     end) l)
 end.

End correct_ltree_ind.

Fixpoint ltree_to_ntree (A : Set) (t : ltree A) {struct t} : ntree A :=
 match t with
   lnode x l =>
     nnode
      A x
      ((fix
        list_tree_to_nforest (l' : list (ltree A)) : nforest A :=
           match l' with
             nil => nnil A
            | t1 :: tl =>
                ncons A (ltree_to_ntree A t1) (list_tree_to_nforest tl)
           end) l)
 end.
Fixpoint
 ntree_to_ltree (A : Set) (t : ntree A) {struct t} : ltree A :=
    match t with nnode x f => lnode A x (nforest_to_list_ltree A f) end
 with
 nforest_to_list_ltree (A : Set) (f : nforest A) {struct f} : list (ltree A) :=
    match f with
      nnil => nil
     | ncons t f' => ntree_to_ltree A t :: nforest_to_list_ltree A f'
    end.

Theorem ltree_o_ntree:
 forall (A : Set) (t : ntree A),  ltree_to_ntree A (ntree_to_ltree A t) = t.
intros A t;
 elim t
  using ntree_ind2
 with ( P0 :=
      fun l =>
      (fix
       list_tree_to_nforest (l' : list (ltree A)) : nforest A :=
          match l' with
            nil => nnil A
           | t1 :: tl => ncons A (ltree_to_ntree A t1) (list_tree_to_nforest tl)
          end) (nforest_to_list_ltree A l) = l ).
simpl.
intros a f IHf; rewrite IHf; trivial.
simpl; trivial.
simpl.
intros n IHn f IHf; rewrite IHn; rewrite IHf; trivial.
Qed.

Theorem ntree_o_ltree:
 forall (A : Set) (t : ltree A),  ntree_to_ltree A (ltree_to_ntree A t) = t.
intros A t;
 elim t
  using ltree_ind2
 with ( Q :=
      fun l =>
      nforest_to_list_ltree
       A
       ((fix
         list_tree_to_nforest (l' : list (ltree A)) : nforest A :=
            match l' with
              nil => nnil A
             | t1 :: tl =>
                 ncons A (ltree_to_ntree A t1) (list_tree_to_nforest tl)
            end) l) = l ).
simpl; intros a l IHl; rewrite IHl; trivial.
simpl; trivial.
simpl; intros t' IHt' tl IHtl; rewrite IHt'; rewrite IHtl; trivial.
Qed.