Load FJ_tactics.
Require Import List.
Require Import FunctionalExtensionality.

Section Folds.

  (* ============================================== *)
  (* ALGEBRAS AND FOLDS                             *)
  (* ============================================== *)

  (* Ordinary Algebra *)
  Definition Algebra (F: Set -> Set) (A : Set) :=
    F A -> A.

  (* Mixin Algebra *)
  Definition Mixin (T: Set) (F: Set -> Set) (A : Set) :=
    (T -> A) -> F T -> A.

  (* Mendler Algebra *)
  Definition MAlgebra (F: Set -> Set) (A : Set) :=
    forall (R : Set), Mixin R F A.

  Definition Fix (F : Set -> Set) : Set :=
    forall (A : Set), MAlgebra F A -> A.

  Definition mfold {F : Set -> Set} :
    forall (A : Set) (f : MAlgebra F A),
      Fix F -> A:= fun A f e => e A f.

  Class Functor (F : Set -> Set) :=
    { fmap :
        forall {A B : Set} (f : A -> B), F A -> F B;
      fmap_fusion :
        forall (A B C: Set) (f : A -> B) (g : B -> C) (a : F A),
          fmap g (fmap f a) = fmap (fun e => g (f e)) a;
      fmap_id :
        forall (A : Set) (a : F A),
          fmap (@id A) a = a
    }.

  Definition in_t {F} : F (Fix F) -> Fix F :=
    fun F_e A f => f _ (mfold _ f) F_e.

  Definition fold_ {F : Set -> Set} {functor : Functor F} :
    forall (A : Set) (f : Algebra F A), Fix F -> A :=
      fun A f => mfold _ (fun r rec fa => f (fmap rec fa)).

  Definition out_t {F : Set -> Set} {fun_F : Functor F} : Fix F -> F (Fix F) :=
    @fold_ F fun_F _ (fmap in_t).

  Fixpoint boundedFix {A: Set}
    {Exp: Set -> Set}
    {fun_F: Functor Exp}
    (n : nat)
    (fM: Mixin (Fix Exp) Exp A)
    (default: A)
    (e: Fix Exp): A :=
    match n with
      | 0   => default
      | S n => fM (boundedFix n fM default) (out_t e)
    end.

  (* Indexed Algebra *)
  Definition iAlgebra {I : Set} (F : (I -> Prop) -> I -> Prop) (A : I -> Prop) :=
    forall i, F A i -> A i.

  (* Indexed Mendler Algebra *)
  Definition iMAlgebra {I : Set} (F : (I -> Prop) -> I -> Prop) (A : I -> Prop) :=
    forall i (R : I -> Prop), (forall i, R i -> A i) -> F R i -> A i.

  Definition iFix {I : Set} (F : (I -> Prop) -> I -> Prop) (i : I) : Prop :=
    forall (A : I -> Prop), iMAlgebra F A -> A i.

  Definition imfold {I : Set} (F : (I -> Prop) -> I -> Prop) :
    forall (A : I -> Prop) (f : iMAlgebra F A) (i : I),
      iFix F i -> A i := fun A f i e => e A f.

  Class iFunctor {I : Set} (F : (I -> Prop) -> I -> Prop) :=
    { ifmap :
        forall {A B : I -> Prop} i (f : forall i, A i -> B i), F A i -> F B i;
      ifmap_fusion :
        forall (A B C: I -> Prop) i (f : forall i, A i -> B i) (g : forall i, B i -> C i) (a : F A i),
          ifmap i g (ifmap i f a) = ifmap i (fun i e => g _ (f i e)) a;
      ifmap_id :
        forall (A : I -> Prop) i (a : F A i),
          ifmap i (fun _ => id) a = a
    }.

  Definition in_ti {I : Set} {F} : forall i : I, F (iFix F) i -> iFix F i :=
    fun i F_e A f => f _ _ (imfold _ _ f) F_e.

  Definition ifold_ {I : Set} (F : (I -> Prop) -> I -> Prop) {iFun_F : iFunctor F} :
    forall (A : I -> Prop) (f : iAlgebra F A) (i : I),
      iFix F i -> A i := fun A f i e => imfold _ _ (fun i' r rec fa => f i' (ifmap i' rec fa)) i e.

  Definition out_ti {I : Set} {F} {fun_F : iFunctor F} : forall i : I, iFix F i -> F (iFix F) i :=
    @ifold_ I F fun_F _ (fun i => ifmap i in_ti).

  (* Universal Property of Mendler Folds *)

  Lemma Universal_Property (F : Set -> Set) (A : Set) (f : MAlgebra F A) :
    forall (h : Fix F -> A),
      h = mfold _ f -> forall e, h (in_t e) = f _ h e.
  Proof.
    intros; rewrite H. unfold in_t. unfold mfold.
    reflexivity.
  Qed.

  Class Universal_Property' {F} {Fun_F : Functor F} (e : Fix F) :=
    { E_UP' : forall (A : Set) (f : MAlgebra F A) (h : Fix F -> A),
                (forall e, h (in_t e) = f _ h e) ->
                h e = mfold _ f e
    }.

  Lemma Fix_id F {fun_F : Functor F} e {UP' : Universal_Property' e} :
    mfold _ (fun _ rec x => in_t (fmap rec x)) e = e.
  Proof.
    intros; apply sym_eq.
    fold (id e); unfold id at 2; apply (E_UP'); intros.
    unfold id.
    unfold in_t.
    eapply (@functional_extensionality_dep Set).
    intros; eapply @functional_extensionality_dep; intros.
    rewrite fmap_id.
    reflexivity.
  Defined.

  Definition MAlg_to_Alg {F : Set -> Set} {A : Set} :
    MAlgebra F A -> Algebra F A := fun MAlg f => MAlg A id f.

  (* Universal Property of regular folds. *)

  Lemma Universal_Property_fold (F : Set -> Set) {fun_F : Functor F} (B : Set)
    (f : Algebra F B) : forall (h : Fix F -> B), h = fold_ _ f ->
      forall e, h (in_t e) = f (fmap h e).
  Proof.
    intros; rewrite H; reflexivity.
  Qed.

  Class Universal_Property'_fold {F} {fun_F : Functor F} (e : Fix F) :=
    { E_fUP' : forall (B : Set) (f : Algebra F B) (h : Fix F -> B),
                 (forall e, h (in_t e) = f (fmap h e)) ->
                 h e = fold_ _ f e
    }.

  Lemma Fix_id_fold F {fun_F : Functor F} e {UP' : Universal_Property'_fold e} :
    fold_ _ (@in_t F) e = e.
  Proof.
    intros; apply sym_eq.
    fold (id e); unfold id at 2; apply (E_fUP'); intros.
    rewrite fmap_id.
    unfold id.
    reflexivity.
  Qed.

  Lemma Fusion F {fun_F : Functor F} e {e_UP' : Universal_Property'_fold e} :
    forall (A B : Set) (h : A -> B) (f : Algebra F A) (g : Algebra F B),
      (forall a, h (f a) = g (fmap h a)) ->
      (fun e' => h (fold_ _ f e')) e = fold_ _ g e.
  Proof.
    intros; eapply E_fUP'; try eassumption; intros.
    rewrite (Universal_Property_fold F _ f _ (refl_equal _)).
    rewrite H.
    rewrite fmap_fusion; reflexivity.
  Qed.

  Lemma in_out_inverse (F : Set -> Set) (Fun_F : Functor F) :
    forall (e : Fix F) {fUP' : Universal_Property'_fold e},
      in_t (out_t e) = e.
  Proof.
    intros.
    rewrite <- (@Fix_id_fold _ _ e fUP') at -1.
    eapply E_fUP' with (h := fun e => in_t (out_t e)).
    intro.
    cut (out_t (in_t e0) = fmap (fun e1 => in_t (out_t e1)) e0); intros.
    rewrite H; reflexivity.
    unfold out_t.
    rewrite Universal_Property with (f := (fun (R : Set) (rec : R -> F (Fix F)) (fp : F R) =>
      fmap (fun r : R => in_t (rec r)) fp)); eauto.
    unfold fold_; unfold mfold.
    eapply functional_extensionality; intro.
    cut ((fun (r : Set) (rec : r -> F (Fix F)) (fa : F r) =>
      fmap in_t (fmap rec fa)) =
      fun (R : Set) (rec : R -> F (Fix F)) (fp : F R) =>
      fmap (fun r : R => in_t (rec r)) fp).
    intro; rewrite H; reflexivity.
    eapply (@functional_extensionality_dep Set); intro.
    eapply functional_extensionality_dep; intro.
    eapply functional_extensionality_dep; intro.
    rewrite fmap_fusion; reflexivity.
  Qed.

  Definition in_t_UP' (F : Set -> Set) (Fun_F : Functor F) :
    F (sig (@Universal_Property'_fold F Fun_F)) ->
    sig (@Universal_Property'_fold F Fun_F).
  Proof.
    intro e; intros.
    constructor 1 with (x := in_t (fmap (@proj1_sig _ _) e)).
    constructor; intros.
    rewrite H.
    unfold fold_, mfold.
    unfold in_t.
    repeat rewrite fmap_fusion.
    assert ((fun e0 : sig Universal_Property'_fold => h (proj1_sig e0)) =
      (fun e0 : sig Universal_Property'_fold =>
         mfold B (fun (r : Set) (rec : r -> B) (fa : F r) => f (fmap rec fa))
           (proj1_sig e0))) by
    (eapply @functional_extensionality_dep; intros e'; destruct e' as [e' e'_UP'];
      simpl; eapply E_fUP'; eauto).
    rewrite H0; reflexivity.
  Defined.

  Definition out_t_UP' (F : Set -> Set) (Fun_F : Functor F) :
    forall (e : Fix F),
      F (sig (@Universal_Property'_fold F Fun_F)).
  Proof.
    intros.
    eapply fold_; try assumption.
    unfold Algebra; intros.
    eapply fmap.
    apply in_t_UP'.
    assumption.
  Defined.

  Lemma out_in_inverse (F : Set -> Set) (Fun_F : Functor F) :
    forall (e : F (sig (@Universal_Property'_fold F Fun_F))),
      out_t (in_t (fmap (@proj1_sig _ _) e)) = fmap (@proj1_sig _ _) e.
  Proof.
    intros.
    unfold out_t.
    erewrite Universal_Property_fold; try reflexivity.
    rewrite fmap_fusion.
    rewrite fmap_fusion.
    assert ((fun e0 : sig Universal_Property'_fold =>
      in_t (fold_ (F (Fix F)) (fmap in_t) (proj1_sig e0))) =
    @proj1_sig _ _) by
    (eapply functional_extensionality; intros;
      fold (out_t (proj1_sig x));
        rewrite in_out_inverse; destruct x; simpl; eauto).
    rewrite H; reflexivity.
  Qed.

  Lemma in_t_UP'_inject (F : Set -> Set) (Fun_F : Functor F) :
    forall (e e' : F (sig (@Universal_Property'_fold F Fun_F))),
      in_t (fmap (@proj1_sig _ _) e) = in_t (fmap (@proj1_sig _ _) e') ->
      fmap (@proj1_sig _ _) e = fmap (@proj1_sig _ _) e'.
  Proof.
    intros; apply (f_equal out_t) in H;
      repeat rewrite out_in_inverse in H; eauto.
  Qed.

  Lemma in_out_UP'_inverse (H : Set -> Set) (Fun_H : Functor H) :
    forall (h : Fix H),
      Universal_Property'_fold h ->
      proj1_sig (in_t_UP' H Fun_H (out_t_UP' H Fun_H h)) = h.
  Proof.
    intros; simpl.
    assert ((fmap (@proj1_sig _ _) (out_t_UP' H Fun_H h)) = out_t h).
    unfold out_t.
    eapply E_fUP' with (h0 := fun e => fmap (@proj1_sig _ _) (out_t_UP' H Fun_H e)).
    intros.
    rewrite fmap_fusion.
    assert (out_t_UP' H Fun_H (in_t e) =
            fmap (fun e => in_t_UP' _ _ (out_t_UP' _ _ e)) e).
    unfold out_t_UP' at 1.
    erewrite Universal_Property_fold with
      (f := (fun H2 : H (H (sig Universal_Property'_fold)) =>
        fmap (in_t_UP' H Fun_H) H2)) (fun_F := Fun_H); eauto.
    rewrite fmap_fusion; reflexivity.
    rewrite H1; rewrite fmap_fusion; simpl; reflexivity.
    rewrite H1.
    rewrite in_out_inverse; unfold mfold; eauto.
  Qed.

  Lemma out_in_fmap (F : Set -> Set) (Fun_F : Functor F) :
    forall (e : F (Fix F)),
      out_t_UP' F _ (in_t e) =
      fmap (fun e => in_t_UP' _ _ (out_t_UP' _ _ e)) e.
  Proof.
    intros; unfold out_t_UP' at 1.
    erewrite Universal_Property_fold with
    (f := (fun H2 : F (F (sig Universal_Property'_fold)) =>
      fmap (in_t_UP' F Fun_F) H2)) (fun_F := Fun_F); eauto.
    rewrite fmap_fusion; reflexivity.
  Qed.

  Definition UP'_P {F : Set -> Set} {Fun_F : Functor F}
    (P : forall e : Fix F, Universal_Property'_fold e -> Prop) (e : Fix F) :=
    sigT (P e).

  Definition UP'_P2 {F F' : Set -> Set}
    {Fun_F : Functor F} {Fun_F' : Functor F'}
    (P : forall e : (Fix F) * (Fix F'),
      Universal_Property'_fold (fst e) /\ Universal_Property'_fold (snd e) -> Prop)
    (e : (Fix F) * (Fix F')) := sig (P e).

  Definition UP'_F (F : Set -> Set) {Fun_F : Functor F} :=
    sig (Universal_Property'_fold (F := F)).

  Fixpoint boundedFix_UP {A: Set}
    {Exp: Set -> Set}
    {fun_F: Functor Exp}
    (n : nat)
    (fM: Mixin (UP'_F Exp) Exp A)
    (default: A)
    (e: UP'_F Exp): A :=
    match n with
      | 0   => default
      | S n => fM (boundedFix_UP n fM default) (out_t_UP' _ _ (proj1_sig e))
    end.

  Lemma bF_UP_in_out : forall {A: Set}
    {Exp: Set -> Set}
    {fun_F: Functor Exp}
    (n : nat)
    (fM: Mixin (UP'_F Exp) Exp A)
    (default: A)
    (e: Fix Exp)
    (e_UP' : Universal_Property'_fold e),
    boundedFix_UP n fM default (in_t_UP' _ _ (out_t_UP' _ _ e)) =
    boundedFix_UP n fM default (exist _ e e_UP').
  Proof.
    induction n; simpl; intros; eauto.
    generalize in_out_UP'_inverse as H0; intro; simpl in H0; rewrite H0; auto.
  Qed.

  (* ============================================== *)
  (* FUNCTOR COMPOSITION                            *)
  (* ============================================== *)

  Definition inj_Functor {F G : Set -> Set} {A : Set} : Set := sum (F A) (G A).

  Notation "A :+: B"  := (@inj_Functor A B) (at level 80, right associativity).

  Global Instance Functor_Plus G H {fun_G : Functor G} {fun_H : Functor H} :
    Functor (G :+: H) :=
    {| fmap :=
         fun (A B : Set) (f : A -> B) (a : (G :+: H) A) =>
           match a with
             | inl G' => inl _ (fmap f G')
             | inr H' => inr _ (fmap f H')
           end
    |}.
  Proof.
    (* fmap_fusion *)
    intros; destruct a;
    rewrite fmap_fusion; reflexivity.
    (* fmap_id *)
    intros; destruct a;
    rewrite fmap_id; reflexivity.
  Defined.

  Class Sub_Functor (sub_F sub_G : Set -> Set) : Set :=
    { inj : forall {A : Set}, sub_F A -> sub_G A;
      prj : forall {A : Set}, sub_G A -> option (sub_F A);
      inj_prj : forall {A : Set} (ga : sub_G A) (fa : sub_F A),
                  prj ga = Some fa -> ga = inj fa;
      prj_inj : forall {A : Set} (fa : sub_F A),
                  prj (inj fa) = Some fa
    }.

  Notation "A :<: B"  := (Sub_Functor A B) (at level 80, right associativity).

  (* Need the 'Global' modifier so that the instance survives the Section.*)
  Global Instance Sub_Functor_inl (F G H : Set -> Set) (sub_F_G : F :<: G) :
    F :<: (G :+: H) :=
    {| inj := fun (A : Set) (e : F A) => inl _ (@inj F G sub_F_G _ e);
       prj := fun (A: Set) (e : (G :+: H) A) =>
                match e with
                  | inl e' => prj e'
                  | inr _  => None
                end
    |}.
  Proof.
    intros; destruct ga; [rewrite (inj_prj _ _ H0); reflexivity | discriminate].
    intros; simpl; rewrite prj_inj; reflexivity.
  Defined.

  Global Instance Sub_Functor_inr (F G H : Set -> Set) (sub_F_H : F :<: H) :
    F :<: (G :+: H) :=
    {| inj := fun (A : Set) (e : F A) => inr _ (@inj F H sub_F_H _ e);
       prj := fun (A : Set) (e : (G :+: H) A) =>
                match e with
                  | inl _  => None
                  | inr e' => prj e'
                end
    |}.
  Proof.
    intros; destruct ga; [discriminate | rewrite (inj_prj _ _ H0); reflexivity ].
    intros; simpl; rewrite prj_inj; reflexivity.
  Defined.

  Global Instance Sub_Functor_id {F : Set -> Set} : F :<: F :=
    {| inj := fun A => @id (F A);
       prj := fun A => @Some (F A)
    |}.
  Proof.
    unfold id; congruence.
    reflexivity.
  Defined.

  (* ============================================== *)
  (* WELL-FORMEDNESS OF FUNCTORS                    *)
  (* ============================================== *)

  Class WF_Functor (F G: Set -> Set)
    (subfg: F :<: G)
    {Fun_F: Functor F}
    {Fun_G: Functor G} : Set :=
    { wf_functor :
        forall (A B : Set) (f : A -> B) (fa: F A) ,
          fmap f (inj fa) (F := G) = inj (fmap f fa)
    }.

  Global Instance WF_Functor_id {F : Set -> Set} {Fun_F : Functor F} :
    WF_Functor F F Sub_Functor_id.
  Proof.
    econstructor; intros; reflexivity.
  Defined.

  Global Instance WF_Functor_plus_inl {F G H : Set -> Set}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    {Fun_H : Functor H}
    {subfg : F :<: G}
    {WF_Fun_F : WF_Functor F _ subfg}
    :
    WF_Functor F (G :+: H) (Sub_Functor_inl F G H _).
  Proof.
    econstructor; intros.
    simpl; rewrite wf_functor; reflexivity.
  Defined.

  Global Instance WF_Functor_plus_inr {F G H : Set -> Set}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    {Fun_H : Functor H}
    {subfh : F :<: H}
    {WF_Fun_F : WF_Functor F _ subfh}
    :
    WF_Functor F (G :+: H) (Sub_Functor_inr F G H _ ).
  Proof.
    econstructor; intros.
    simpl; rewrite wf_functor; reflexivity.
  Defined.

  (* ============================================== *)
  (* INJECTION + PROJECTION                         *)
  (* ============================================== *)

  Definition inject' {F G: Set -> Set} {Fun_F : Functor F} {subGF: G :<: F} :
    G (sig (@Universal_Property'_fold F Fun_F)) -> (sig (@Universal_Property'_fold F Fun_F)) :=
    fun gexp => in_t_UP' _ _ (inj gexp).

  Definition inject {F G: Set -> Set} {Fun_F : Functor F} {subGF: G :<: F} :
    G (sig (@Universal_Property'_fold F Fun_F)) -> Fix F :=
      fun gexp => proj1_sig (in_t_UP' _ _ (inj gexp)).

  Definition project {F G: Set -> Set} {Fun_F: Functor F} {subGF : G :<: F } :
    Fix F -> option (G (sig (@Universal_Property'_fold F Fun_F))) :=
      fun exp => prj (out_t_UP' _ _ exp).

  Lemma project_inject : forall (G H : Set -> Set)
    (Fun_G : Functor G)
    (Fun_H : Functor H)
    (sub_G_H : G :<: H)
    (h : Fix H) (g : G (sig (@Universal_Property'_fold H Fun_H))),
    Universal_Property'_fold h ->
    project h = Some g -> h = inject g.
  Proof.
    intros.
    apply inj_prj in H1.
    unfold inject; rewrite <- H1.
    erewrite in_out_UP'_inverse; eauto.
  Qed.

  Lemma inject_project : forall (F G  : Set -> Set)
    (Fun_F : Functor F)
    (Fun_G : Functor G)
    (sub_G_F : G :<: F)
    (g : G (sig (@Universal_Property'_fold F Fun_F))),
    fmap (@proj1_sig _ _) (out_t_UP' _ _ (inject g)) =
    (fmap (@proj1_sig _ _) (inj g)).
  Proof.
    unfold inject; intros; simpl.
    rewrite out_in_fmap.
    rewrite fmap_fusion.
    assert (forall e : sig Universal_Property'_fold,
      proj1_sig (in_t_UP' F Fun_F (out_t_UP' F Fun_F (proj1_sig e))) = proj1_sig e).
    intros; eapply in_out_UP'_inverse.
    intros; destruct e as [e e_UP']; eassumption.
    rewrite fmap_fusion.
    rewrite (functional_extensionality _ _ H).
    reflexivity.
  Qed.

  Class Distinct_Sub_Functor (F G H : Set -> Set)
    {Fun_H : Functor H}
    {sub_F_H : F :<: H}
    {sub_G_H : G :<: H}
    : Set :=
    { inj_discriminate :
        forall A f g,
          inj (Sub_Functor := sub_F_H) (A := A) f
          <> inj (Sub_Functor := sub_G_H) (A := A) g
    }.

  Global Instance Distinct_Sub_Functor_plus
    (F G H I : Set -> Set)
    (Fun_G : Functor G)
    (Fun_I : Functor I)
    (sub_F_G : F :<: G)
    (sub_H_I : H :<: I)
    :
    Distinct_Sub_Functor F H (G :+: I).
  Proof.
    econstructor; intros.
    unfold not; simpl; unfold id; intros.
    discriminate.
  Defined.

  Global Instance Distinct_Sub_Functor_plus'
    (F G H I : Set -> Set)
    (Fun_G : Functor G)
    (Fun_I : Functor I)
    (sub_F_G : F :<: G)
    (sub_H_I : H :<: I)
    :
    Distinct_Sub_Functor F H (I :+: G).
  Proof.
    econstructor; intros.
    unfold not; simpl; unfold id; intros.
    discriminate.
  Defined.

  Global Instance Distinct_Sub_Functor_inl
    (F G H I : Set -> Set)
    (Fun_G : Functor G)
    (Fun_I : Functor I)
    (sub_F_G : F :<: G)
    (sub_H_G : H :<: G)
    (Dist_inl : Distinct_Sub_Functor F H G)
    :
    Distinct_Sub_Functor F H (G :+: I).
  Proof.
    econstructor; intros.
    unfold not; intros.
    simpl in H0; injection H0; intros.
    eapply (inj_discriminate (Distinct_Sub_Functor := Dist_inl) _ f g H1).
  Defined.

  Global Instance Distinct_Sub_Functor_inr
    (F G H I : Set -> Set)
    (Fun_G : Functor G)
    (Fun_I : Functor I)
    (sub_F_G : F :<: G)
    (sub_H_G : H :<: G)
    (Dist_inl : Distinct_Sub_Functor F H G)
    :
    Distinct_Sub_Functor F H (I :+: G).
  Proof.
    econstructor; intros.
    unfold not; intros.
    simpl in H0; injection H0; intros.
    eapply (inj_discriminate (Distinct_Sub_Functor := Dist_inl) _ f g H1).
  Defined.

  Lemma inject_discriminate : forall {F G H : Set -> Set}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    {Fun_H : Functor H}
    {sub_F_H : F :<: H}
    {sub_G_H : G :<: H}
    {WF_F : WF_Functor _ _ sub_F_H}
    {WF_G : WF_Functor _ _ sub_G_H},
    Distinct_Sub_Functor F G H ->
    forall f g, inject (subGF := sub_F_H) f <> inject (subGF := sub_G_H) g.
  Proof.
    unfold inject; simpl; intros.
    unfold not; intros H3; apply in_t_UP'_inject in H3.
    repeat rewrite wf_functor in H3.
    eapply (inj_discriminate _ _ _ H3).
  Qed.

  (* ============================================== *)
  (* INDEXED FUNCTOR COMPOSITION                    *)
  (* ============================================== *)

  Definition inj_iFunctor {I : Set} {F G : (I -> Prop) -> I -> Prop} {A : I -> Prop} : I -> Prop :=
    fun i => or (F A i) (G A i).

  Notation "A ::+:: B"  := (@inj_iFunctor _ A B) (at level 80, right associativity).

  Global Instance iFunctor_Plus {I : Set} (G H : (I -> Prop) -> I -> Prop)
    {fun_G : iFunctor G} {fun_H : iFunctor H} : iFunctor (G ::+:: H) :=
    {| ifmap :=
         fun (A B : I -> Prop) (i : I) (f : forall i, A i -> B i) (a : (G ::+:: H) A i) =>
           match a with
             | or_introl G' => or_introl _ (ifmap i f G')
             | or_intror H' => or_intror _ (ifmap i f H')
           end
    |}.
  Proof.
    (* ifmap_fusion *)
    intros; destruct a;
    rewrite ifmap_fusion; reflexivity.
    (* ifmap_id *)
    intros; destruct a;
    rewrite ifmap_id; reflexivity.
  Defined.

  Class Sub_iFunctor {I : Set} (sub_F sub_G : (I -> Prop) -> I -> Prop) : Prop :=
    { inj_i : forall {A : I -> Prop} i, sub_F A i -> sub_G A i;
         prj_i : forall {A : I -> Prop} i, sub_G A i -> (sub_F A i) \/ True
    }.

  Notation "A ::<:: B"  := (Sub_iFunctor A B) (at level 80, right associativity).

  (* Need the 'Global' modifier so that the instance survives the Section.*)

  Global Instance Sub_iFunctor_inl {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop) (sub_F_G : F ::<:: G) :
    F ::<:: (G ::+:: H) :=
    {| inj_i := fun (A : I' -> Prop) i (e : F A i) =>
                  or_introl _ (@inj_i _ F G sub_F_G _ _ e);
       prj_i := fun (A: I' -> Prop) i (e : (G ::+:: H) A i) =>
                  match e with
                    | or_introl e' => prj_i _ e'
                    | or_intror _  => or_intror _ I
                  end
    |}.

  Global Instance Sub_iFunctor_inr {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop) (sub_F_H : F ::<:: H) :
    F ::<:: (G ::+:: H) :=
    {| inj_i := fun (A : I' -> Prop) i (e : F A i) =>
                    or_intror _ (@inj_i _ F H sub_F_H _ _ e);
       prj_i := fun (A: I' -> Prop) i (e : (G ::+:: H) A i) =>
                  match e with
                    | or_intror e' => prj_i _ e'
                    | or_introl _  => or_intror _ I
                  end
    |}.

  Global Instance Sub_iFunctor_id {I : Set} {F : (I -> Prop) -> I -> Prop} : F ::<:: F :=
    {| inj_i := fun A i e => e;
       prj_i := fun A i e => or_introl _ e
    |}.

  Definition inject_i {I : Set} {F G: (I -> Prop) -> I -> Prop} {subGF: Sub_iFunctor G F} :
    forall i, G (iFix F) i -> iFix F i:=
    fun i gexp => in_ti i (inj_i i gexp).

  Definition project_i {I : Set} {F G: (I -> Prop) -> I -> Prop}
    {fun_F: iFunctor F}
    {subGF: Sub_iFunctor G F} :
    forall i, iFix F i -> (G (iFix F) i) \/ True :=
      fun i fexp => prj_i i (out_ti i fexp).

End Folds.

Notation "A :+: B"  := (@inj_Functor A B) (at level 80, right associativity).
Notation "A :<: B"  := (Sub_Functor A B) (at level 80, right associativity).
Notation "A ::+:: B"  := (@inj_iFunctor _ A B) (at level 80, right associativity).
Notation "A ::<:: B"  := (Sub_iFunctor _ A B) (at level 80, right associativity).

Definition inj'' {F G : Set -> Set} (sub_F_G: F :<: G) {A : Set} := @inj F G sub_F_G A.

Section FAlgebra.

  (* ============================================== *)
  (* OPERATIONS INFRASTRUCTURE                      *)
  (* ============================================== *)

  Class FAlgebra (Name : Set) (T: Set) (A: Set) (F: Set -> Set) : Set :=
    { f_algebra : Mixin T F A }.

  (* Definition FAlgebra_Plus (Name: Set) (T: Set) (A : Set) (F G : Set -> Set)
    {falg: FAlgebra Name T A F} {galg: FAlgebra Name T A G} :
    FAlgebra Name T A (F :+: G) :=
    Build_FAlgebra Name T A _
    (fun f fga =>
      (match fga with
         | inl fa => f_algebra f fa
         | inr ga => f_algebra f ga
       end)). *)

  Global Instance FAlgebra_Plus (Name: Set) (T: Set) (A : Set) (F G : Set -> Set)
    {falg: FAlgebra Name T A F} {galg: FAlgebra Name T A G} :
    FAlgebra Name T A (F :+: G) | 6 :=
    {| f_algebra := fun f fga =>
                      match fga with
                        | inl fa => f_algebra f fa
                        | inr ga => f_algebra f ga
                      end
    |}.

  (* The | 6 gives the generated Hint a priority of 6. If this is
     less than that of other instances for FAlgebra, the
     typeclass inference algorithm will loop.
     *)

  Class WF_FAlgebra (Name T A: Set) (F G: Set -> Set)
    (subfg: F :<: G)
    (falg: FAlgebra Name T A F)
    (galg: FAlgebra Name T A G): Set :=
    { wf_algebra :
        forall rec (fa: F T),
          @f_algebra Name T A G galg rec (@inj F G subfg T fa)
          = @f_algebra Name T A F falg rec fa
    }.

  Global Instance WF_FAlgebra_id {Name T A : Set} {F} {falg: FAlgebra Name T A F}:
    WF_FAlgebra Name T A F F Sub_Functor_id falg falg.
  Proof.
    econstructor. intros.
    unfold inj.
    unfold Sub_Functor_id.
    unfold id.
    reflexivity.
  Defined.

  Global Instance WF_FAlgebra_inl
    {Name A T : Set}
    {F G H}
    {falg: FAlgebra Name T A F}
    {galg: FAlgebra Name T A G}
    {halg: FAlgebra Name T A H}
    {sub_F_G: F :<: G}
    {wf_F_G: WF_FAlgebra Name T A F G sub_F_G falg galg}
    :
    WF_FAlgebra Name T A F (G :+: H) (Sub_Functor_inl F G H sub_F_G) falg (@FAlgebra_Plus Name T A G H galg halg).
  Proof.
    econstructor. intros.
    unfold inj. unfold Sub_Functor_inl.
    simpl.
    rewrite (wf_algebra rec fa).
    reflexivity.
  Defined.

  Global Instance WF_FAlgebra_inr
    {Name T A : Set}
    {F G H}
    {falg: FAlgebra Name T A F}
    {galg: FAlgebra Name T A G}
    {halg: FAlgebra Name T A H}
    {sub_F_H: F :<: H}
    {wf_G_H: WF_FAlgebra Name T A F H sub_F_H falg halg}
    :
    WF_FAlgebra Name T A F (G :+: H) (Sub_Functor_inr F G H sub_F_H) falg (@FAlgebra_Plus Name T A G H galg halg).
  Proof.
    econstructor. intros.
    unfold inj.
    unfold Sub_Functor_inr.
    simpl.
    rewrite (wf_algebra rec fa).
    reflexivity.
  Defined.

End FAlgebra.

  (* ============================================== *)
  (* INDUCTION PRINCIPLES INFRASTRUCTURE            *)
  (* ============================================== *)

Section WF_Ind_FAlgebras.

  Class PAlgebra (Name : Set) (A: Set) (F: Set -> Set) : Set :=
    { p_algebra : Algebra F A}.

  (* Definition PAlgebra_Plus (Name: Set) (A : Set) (F G : Set -> Set)
    {falg: PAlgebra Name A F} {galg: PAlgebra Name A G} :
    PAlgebra Name A (F :+: G) :=
    Build_PAlgebra Name A _
    (fun fga =>
      (match fga with
         | inl fa => p_algebra fa
         | inr ga => p_algebra ga
       end)). *)

  Global Instance PAlgebra_Plus (Name: Set) (A : Set) (F G : Set -> Set)
    {falg: PAlgebra Name A F} {galg: PAlgebra Name A G} :
    PAlgebra Name A (F :+: G) | 6 :=
    {| p_algebra := fun fga =>
                      match fga with
                        | inl fa => p_algebra fa
                        | inr ga => p_algebra ga
                      end
    |}.

  Class WF_Ind {E F: Set -> Set} {Name : Set} {Fun_E : Functor E} {Fun_F : Functor F}
    {P : Fix E -> Prop} {sub_F_E : F :<: E}
    (F_Alg : PAlgebra Name (sig P) F) :=
    { proj_eq :
        forall e,
          proj1_sig (p_algebra (PAlgebra := F_Alg) e) =
          in_t (inj (Sub_Functor := sub_F_E) (fmap (@proj1_sig _ _) e))
    }.

  Instance Sub_Functor_inl' (F G H : Set -> Set) (sub_F_G : (F :+: G) :<: H) :
    F :<: H :=
    {| inj := fun (A : Set) (e : F A) => @inj _ _ sub_F_G A (inl _ e);
       prj := fun (A : Set) (ha : H A) =>
                match @prj _ _ sub_F_G A ha with
                  | Some (inl f) => Some f
                  | Some (inr g) => None
                  | None => None
                end
    |}.
  Proof.
    intros until fa; caseEq (prj ga);
      [rewrite (inj_prj _ _ H0); destruct i; congruence | discriminate].
    intros; rewrite prj_inj; reflexivity.
  Defined.

  Instance Sub_Functor_inr' (F G H : Set -> Set) (sub_F_G : (F :+: G) :<: H) :
    G :<: H :=
    {| inj := fun (A : Set) (e : G A) => (@inj _ _ sub_F_G A (inr _ e));
       prj := fun (A : Set) (H0 : H A) =>
                match @prj _ _ sub_F_G A H0 with
                  | Some (inl f) => None
                  | Some (inr g) => Some g
                  | None => None
                end
    |}.
  Proof.
    intros until fa; caseEq (prj ga);
      [rewrite (inj_prj _ _ H0); destruct i; congruence | discriminate].
    intros; rewrite prj_inj; reflexivity.
  Defined.

  Global Instance WF_Ind_Plus_split {F G H}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    {Fun_H : Functor H}
    {sub_F_G_H : (F :+: G) :<: H}
    {Name : Set}
    {P : Fix H -> Prop}
    {F_Alg: PAlgebra Name (sig P) F}
    {G_Alg: PAlgebra Name (sig P) G}
    (WF_falg : @WF_Ind H F Name Fun_H Fun_F _ (Sub_Functor_inl' _ _ _ sub_F_G_H)
      F_Alg)
    (WF_falg : @WF_Ind H G Name Fun_H Fun_G _ (Sub_Functor_inr' _ _ _ sub_F_G_H)
      G_Alg)
    :
    @WF_Ind H (F :+: G) _ _ _ P _ (PAlgebra_Plus Name _ F G) | 0.
  Proof.
    econstructor; intros.
    destruct e; simpl.
    rewrite (proj_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H)); simpl;
    reflexivity.
    rewrite (proj_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H)); simpl;
    reflexivity.
  Defined.

  (* The key reasoning lemma. *)
  Lemma Ind {F : Set -> Set}
    {Fun_F : Functor F}
    {P : Fix F -> Prop}
    {N : Set}
    {Ind_Alg : PAlgebra N (sig P) F}
    {WF_Ind_Alg : WF_Ind Ind_Alg}
    :
    forall (f : Fix F)
      (fUP' : Universal_Property'_fold f),
      P f.
  Proof.
    intros.
    cut (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f) = id f).
    unfold id.
    intro f_eq; rewrite <- f_eq.
    eapply (proj2_sig (fold_ _ (@p_algebra _ _ _ Ind_Alg) f)).
    erewrite (@Fusion _ Fun_F f fUP' _ _ (@proj1_sig (Fix F) P)
                      (@p_algebra _ _ _ Ind_Alg) in_t).
    eapply Fix_id_fold; unfold id; assumption.
    intros; rewrite (proj_eq (WF_Ind := WF_Ind_Alg)).
    simpl; unfold id; reflexivity.
  Defined.

  Class WF_Ind2 {E E' F: Set -> Set} {Name : Set}
    {Fun_E : Functor E} {Fun_E : Functor E'} {Fun_F : Functor F}
    {P : (Fix E) * (Fix E') -> Prop} {sub_F_E : F :<: E} {sub_F_E' : F :<: E'}
    (F_Alg : PAlgebra Name (sig P) F) :=
    { proj1_eq :
        forall e,
          fst (proj1_sig (p_algebra (PAlgebra := F_Alg) e)) =
          in_t (inj (Sub_Functor := sub_F_E) (fmap (fun e => fst (proj1_sig e)) e));
      proj2_eq :
        forall e,
          snd (proj1_sig (p_algebra (PAlgebra := F_Alg) e)) =
          in_t (inj (Sub_Functor := sub_F_E') (fmap (fun e => snd (proj1_sig e)) e))
    }.

  Global Instance WF_Ind2_Plus_split {F G H H'}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    {Fun_H : Functor H}
    {Fun_H' : Functor H'}
    {sub_F_G_H : (F :+: G) :<: H}
    {sub_F_G_H' : (F :+: G) :<: H'}
    {Name : Set}
    {P : (Fix H) * (Fix H') -> Prop}
    {F_Alg: PAlgebra Name (sig P) F}
    {G_Alg: PAlgebra Name (sig P) G}
    (WF_falg : @WF_Ind2 H H' F Name Fun_H Fun_H' Fun_F _
      (Sub_Functor_inl' _ _ _ sub_F_G_H) (Sub_Functor_inl' _ _ _ sub_F_G_H')
      F_Alg)
    (WF_falg : @WF_Ind2 H H' G Name Fun_H Fun_H' Fun_G _
      (Sub_Functor_inr' _ _ _ sub_F_G_H) (Sub_Functor_inr' _ _ _ sub_F_G_H')
      G_Alg)
    :
    @WF_Ind2 H H' (F :+: G) _ _ _ _ P _ _ (PAlgebra_Plus Name _ F G) | 0.
  Proof.
    econstructor; intros; destruct e; simpl.
    rewrite (proj1_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H)
                      (sub_F_E' := Sub_Functor_inl' _ _ _ sub_F_G_H')); simpl;
    reflexivity.
    rewrite (proj1_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H)
                      (sub_F_E' := Sub_Functor_inr' _ _ _ sub_F_G_H')); simpl;
    reflexivity.
    rewrite (proj2_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H)
                      (sub_F_E' := Sub_Functor_inl' _ _ _ sub_F_G_H')); simpl;
    reflexivity.
    rewrite (proj2_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H)
                      (sub_F_E' := Sub_Functor_inr' _ _ _ sub_F_G_H')); simpl;
    reflexivity.
  Defined.

  Lemma Ind2 {F : Set -> Set}
    {Fun_F : Functor F}
    {P : (Fix F) * (Fix F) -> Prop}
    {N : Set}
    {Ind_Alg : PAlgebra N (sig P) F}
    {WF_Ind_Alg : WF_Ind2 Ind_Alg}
    :
    forall (f : Fix F)
      (fUP' : Universal_Property'_fold f),
      P (f, f).
  Proof.
    intros.
    cut (fst (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f)) = f).
    cut (snd (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f)) = f).
    intros f2_eq f1_eq; rewrite <- f1_eq at 1; rewrite <- f2_eq at -1.
    generalize (proj2_sig (fold_ _ (@p_algebra _ _ _ Ind_Alg) f)).
    destruct (proj1_sig (fold_ (sig P) p_algebra f)); simpl; auto.
    erewrite (@Fusion _ Fun_F f fUP' _ _ (fun e => snd (proj1_sig e))
      (@p_algebra _ _ _ Ind_Alg) in_t).
    eapply Fix_id_fold; unfold id; assumption.
    intros; rewrite (proj2_eq (WF_Ind2 := WF_Ind_Alg)).
    simpl; unfold id; reflexivity.
    erewrite (@Fusion _ Fun_F f fUP' _ _ (fun e => fst (proj1_sig e))
      (@p_algebra _ _ _ Ind_Alg) in_t).
    eapply Fix_id_fold; unfold id; assumption.
    intros; rewrite (proj1_eq (WF_Ind2 := WF_Ind_Alg)).
    simpl; unfold id; reflexivity.
  Defined.

  Class iPAlgebra (Name : Set) {I : Set} (A : I -> Prop) (F: (I -> Prop) -> I -> Prop) : Prop :=
    { ip_algebra : iAlgebra F A}.

  (* Definition iPAlgebra_Plus (Name: Set) {I : Set} (A : I -> Prop)
    (F G : (I -> Prop) -> I -> Prop)
    {falg: iPAlgebra Name A F} {galg: iPAlgebra Name A G} :
    iPAlgebra Name A (F ::+:: G) :=
      Build_iPAlgebra Name _ A _
      (fun f fga =>
        (match fga with
           | or_introl fa => ip_algebra f fa
           | or_intror ga => ip_algebra f ga
         end)). *)

  Global Instance iPAlgebra_Plus (Name: Set) {I : Set} (A : I -> Prop)
    (F G : (I -> Prop) -> I -> Prop)
    {falg: iPAlgebra Name A F} {galg: iPAlgebra Name A G} :
    iPAlgebra Name A (F ::+:: G) | 6 :=
    {| ip_algebra := fun f fga =>
                       match fga with
                         | or_introl fa => ip_algebra f fa
                         | or_intror ga => ip_algebra f ga
                       end
    |}.

  Class iWF_Ind {I : Set} {E F: (I -> Prop) -> I -> Prop} {Name : Set}
    {Fun_E : iFunctor E} {Fun_F : iFunctor F}
    {P : forall i, iFix E i -> Prop} {sub_F_E : Sub_iFunctor F E}
    (F_Alg : iPAlgebra Name (fun i => sig (P i)) F) :=
    { iproj_eq :
        forall i e,
          proj1_sig (ip_algebra (iPAlgebra := F_Alg) i e) =
          in_ti i (inj_i (Sub_iFunctor := sub_F_E) i
                         (ifmap i (fun i => proj1_sig (P := P i)) e))
    }.

  Definition Sub_iFunctor_inl' {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop)
    (isub_F_G : Sub_iFunctor (F ::+:: G) H) :
    Sub_iFunctor F H :=
    {| inj_i := fun (A : I' -> Prop) (i : I') (fai : F A i) =>
                  @inj_i _ _ _ isub_F_G _ _ (or_introl (G A i) fai);
       prj_i := fun (A : I' -> Prop) (i : I') (hai : H A i) =>
                  let o := prj_i i hai in
                  match o with
                    | or_introl (or_introl H2) => or_introl True H2
                    | or_introl (or_intror _) => or_intror (F A i) I
                    | or_intror H1 => or_intror (F A i) H1
                  end
    |}.

  Definition Sub_iFunctor_inr' {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop)
    (isub_F_G : Sub_iFunctor (F ::+:: G) H) :
    Sub_iFunctor G H :=
    {| inj_i := fun (A : I' -> Prop) (i : I') (gai : G A i) =>
                  @inj_i _ _ _ isub_F_G _ _ (or_intror _ gai);
       prj_i := fun (A : I' -> Prop) (i : I') (hai : H A i) =>
                  let o := prj_i i hai in
                  match o with
                    | or_introl (or_intror H2) => or_introl True H2
                    | or_introl (or_introl _) => or_intror _ I
                    | or_intror H1 => or_intror _ H1
                  end
    |}.

  Global Instance iWF_Ind_Plus_split {I : Set}
    {F G H : (I -> Prop) -> I -> Prop}
    {Fun_F : iFunctor F}
    {Fun_G : iFunctor G}
    {Fun_H : iFunctor H}
    {sub_F_G_H : Sub_iFunctor (F ::+:: G) H}
    {Name : Set}
    {P : forall i, iFix H i -> Prop}
    {F_Alg: iPAlgebra Name (fun i => sig (P i)) F}
    {G_Alg: iPAlgebra Name (fun i => sig (P i)) G}
    {WF_falg : @iWF_Ind _ H F Name Fun_H Fun_F _ (Sub_iFunctor_inl' _ _ _ sub_F_G_H)
      F_Alg}
    {WF_falg : @iWF_Ind _ H G Name Fun_H Fun_G _ (Sub_iFunctor_inr' _ _ _ sub_F_G_H)
      G_Alg}
    :
    @iWF_Ind _ H (F ::+:: G) _ _ _ P _ (iPAlgebra_Plus Name _ F G) | 0.
  Proof.
    econstructor; intros.
    destruct e; simpl.
    rewrite (iproj_eq (sub_F_E := @Sub_iFunctor_inl' _ _ _ _ sub_F_G_H)); simpl;
    reflexivity.
    rewrite (iproj_eq (sub_F_E := @Sub_iFunctor_inr' _ _ _ _ sub_F_G_H)); simpl;
    reflexivity.
  Defined.

End WF_Ind_FAlgebras.

(* ============================================== *)
(* ADDTIONAL MENDLER ALGEBRA INFRASTRUCTURE       *)
(* ============================================== *)

Section WF_MAlgebras.

  Class WF_MAlgebra {Name : Set} {F : Set -> Set} {A : Set}
    {Fun_F : Functor F}(MAlg : forall R, FAlgebra Name R A F) :=
    { wf_malgebra :
        forall (T T' : Set) (f : T' -> T) (rec : T -> A) (ft : F T'),
          f_algebra (FAlgebra := MAlg T) rec (fmap f ft) =
          f_algebra (FAlgebra := MAlg T') (fun ft' => rec (f ft')) ft
    }.

  Global Instance WF_MAlgebra_Plus {Name : Set} {F G : Set -> Set} {A : Set}
    {Fun_F : Functor F}
    {Fun_G : Functor G}
    (MAlg_F : forall R, FAlgebra Name R A F)
    (MAlg_G : forall R, FAlgebra Name R A G)
    {WF_MAlg_F : WF_MAlgebra MAlg_F}
    {WF_MAlg_G : WF_MAlgebra MAlg_G}
    :
    @WF_MAlgebra Name (F :+: G) A _ (fun R => FAlgebra_Plus Name R A F G).
  Proof.
    constructor; intros.
    destruct ft; simpl; apply wf_malgebra.
  Qed.

End WF_MAlgebras.

Definition Smarked (S: Set) : Set := S.

Ltac Smark H :=
  let t := type of H in
  let n:= fresh in
    (assert (n:Smarked t); [exact H | clear H; rename n into H]).

Ltac unSmark H := unfold Smarked in H.

Ltac unSmark_all := unfold Smarked in *|-.

Ltac WF_Falg_rewrite' :=
  match goal with
    | H : WF_FAlgebra _ _ _ _ _ _ _ |- _ =>
      try rewrite (wf_algebra (WF_FAlgebra := H)); Smark H; WF_Falg_rewrite'
    | _ => simpl
  end;
  unSmark_all.

Ltac WF_Falg_rewrite := unfold inject, in_t; WF_Falg_rewrite'.

Ltac fold_ind := eapply Ind.

Hint Extern 0 (FAlgebra _ _ _ (_ :+: _)) =>
  apply FAlgebra_Plus; eauto with typeclass_instances : typeclass_instances.

Hint Extern 0 (forall _, FAlgebra _ _ _ _) =>
  intros; eauto with typeclass_instances : typeclass_instances.

Hint Extern 0 (forall _, PAlgebra _ _ _) =>
  intros; eauto with typeclass_instances : typeclass_instances.

Hint Extern 0 (PAlgebra _ _ (_ :+: _)) =>
  apply PAlgebra_Plus; eauto with typeclass_instances : typeclass_instances.

Hint Extern 0 (iPAlgebra _ _ (_ :+: _)) =>
  apply iPAlgebra_Plus; eauto with typeclass_instances : typeclass_instances.

Hint Extern 0 (WF_Ind _) =>
  let e := fresh in
    constructor; intro e; destruct e; reflexivity : typeclass_instances.

Hint Extern 0 (WF_Ind2 _) =>
  let e := fresh in
    constructor; intro e; destruct e; reflexivity : typeclass_instances.

Hint Extern 0 (WF_MAlgebra _) =>
  let T := fresh in
    let T' := fresh in
      let f' := fresh in
        let rec' := fresh in
          let ft := fresh in
            constructor; intros T T' f' rec' ft; destruct ft;
              simpl; auto; fail : typeclass_instances.

Ltac discriminate_inject H :=
  first [ apply inj_prj in H | idtac ];
    contradict H;
      solve [ apply inject_discriminate; auto with typeclass_instances
            | apply not_eq_sym; apply inject_discriminate; auto with typeclass_instances
            | apply inj_discriminate; auto with typeclass_instances
            | apply not_eq_sym; apply inj_discriminate; auto with typeclass_instances
            ].

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Export ZArith  List  Arith Bool.

Section Minimal_propositional_logic.
  Variables P Q R T : Prop.

(* Exercise 3.2 *)

Lemma idP : P -> P.
Proof.
  intro p; assumption.
Qed.

Lemma idPP : (P -> P) -> (P -> P).
Proof.
  intros _ p; assumption.
Qed.

Lemma imp_trans: (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros Hpq Hqr p; apply Hqr; apply Hpq; assumption.
Qed.

Lemma imp_perm : (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros Hpqr q p; apply Hpqr; assumption.
Qed.

Lemma ignore_Q : (P -> R) -> P -> Q -> R.
Proof.
  intros Hpr p q; apply Hpr; assumption.
Qed.

Lemma delta_imp : (P -> P -> Q) -> P -> Q.
Proof.
  intros Hpr p; apply Hpr;  assumption.
Qed.

Lemma delta_impR : (P -> Q) -> (P -> P -> Q).
Proof.
  intros Hpq p _; apply Hpq; assumption.
Qed.

Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
Proof.
  intros Hpq Hpr Hqrt p; apply Hqrt; [apply Hpq | apply Hpr]; assumption.
Qed.

Lemma weak_peirce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
  intros H0; apply H0.
  intros H1; apply H1.
  intros p ; apply H0.
  intros H2. assumption.
Qed.

(* Exercise 3.4 -- needs paper *)

(* Exercise 3.5 *)

Section section_for_cut_example.
  Hypotheses (H: P -> Q)
             (H0: Q -> R)
             (H1: (P -> R) -> T -> Q)
             (H2: (P -> R) -> T).

  Theorem cut_example : Q.
  Proof.
    cut (P -> R).
    intro H3.
    apply H1; [assumption | apply H2; assumption].
    intro p ; apply H0; apply H; assumption.
  Qed.

  Theorem cut_example' : Q.
  Proof.
    apply H1; [intro p; apply H0; apply H; assumption | idtac].
    apply H2; intro p; apply H0; apply H; assumption.
  Qed.

  Print cut_example.
  Print cut_example'.

(*
cut_example =
let H3 : P -> R := fun p : P => H0 (H p) in (fun H4 : P -> R => H1 H4 (H2 H4)) H3
     : Q

cut_example' = H1 (fun p : P => H0 (H p)) (H2 (fun p : P => H0 (H p)))
     : Q
*)

End section_for_cut_example.

End Minimal_propositional_logic.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Vector Theory implemented with SafeNatFun (no Module)
  author    : ZhengPu Shi
  date      : 2021.12

  remark    :
  1. This is safe version of NatFun, which corrected the shape problem
 *)

Require Export SafeNatFun.Matrix.

Generalizable Variable A B C Aeq Beq Ceq Aadd Aopp Amul Ainv.

(** Control the scope *)
Open Scope nat_scope.
Open Scope A_scope.
Open Scope mat_scope.
Open Scope vec_scope.

(* ######################################################################### *)
(** * Basic vector theory *)

Section basic_vectory_theory.

  Context `{Equiv_Aeq : Equivalence A Aeq} {A0:A}.
  Infix "==" := (Aeq) : A_scope.
  Infix "==" := (eqlistA Aeq) : list_scope.

  (** Vector type *)
  Definition vec n := @mat A n 1.

  (** make a vector by a function *)
  Definition mk_vec {n : nat} (f : nat -> A) : vec n :=
    mk_mat (fun i j => if j =? 0 then f i else A0).

  (** matrix equality *)
  Definition veq {n} (v1 v2 : vec n) := meq (Aeq:=Aeq) v1 v2.
  Infix "==" := veq : vec_scope.

  Notation "m ! i ! j " := (mnth (A0:=A0) m i j) : mat_scope.

  (** veq is equivalence relation *)
  Lemma veq_equiv : forall n, Equivalence (veq (n:=n)).
  Proof.
    intros. unfold veq. unfold meq.
    apply meq_equiv.
  Qed.

  (** Get element of vector (unsafe) *)
  Notation "v $ i " := (matf v i 0) : vec_scope.

  (** Get element of vector (safe) *)
  Definition vnth {n} (v : vec n) i : A := v!i!0.
  Notation "v ! i " := (vnth v i) : vec_scope.

  Lemma vnth_eq_vnth_raw : forall {n : nat} (v : vec n),
      (forall i, i < n -> v!i == v$i)%A.
  Proof.
    intros. unfold vnth. apply mnth_eq_mnth_raw; auto.
  Qed.

  (** veq and mnth should satisfy this constraint *)
  Lemma veq_iff_vnth : forall {n : nat} (v1 v2 : vec n),
      (v1 == v2) <-> (forall i, i < n -> (v1!i == v2!i)%A).
  Proof.
    unfold veq, vec, vnth.
    intros;  split; intros.
    - rewrite (meq_iff_mnth (A0:=A0)) in H. apply H; auto.
    - apply (meq_iff_mnth (A0:=A0)). intros.
      assert (j = 0) by lia. rewrite H2. apply H. auto.
  Qed.

  (* ==================================== *)
  (** ** List like operations for vector *)

  (** vcons *)
  Definition vcons {n} (a : A) (v : vec n) : vec (S n) :=
    mk_vec (fun i => match i with 0 => a | S i' => v $ i' end).

  Lemma vcons_spec : forall n a (v : vec n) i,
      ((vcons a v) $ 0 == a)%A /\ (i < n -> v $ i == (vcons a v) $ (S i))%A.
  Proof.
    intros. unfold vcons. split.
    - intros. solve_mnth.
    - solve_mnth.
  Qed.

  (** Get a vector from a given vector by remove one element *)
  Definition vremove {n : nat} (v : vec (S n)) (k : nat) : vec n :=
    mk_vec (fun i => if i <? k then v ! i else v ! (S i)).

  (* ==================================== *)
  (** ** Convert between list and vector *)
  (* Definition v2l {n} (v : vec n) : list A := @Matrix.mcol _ n 1 0 v. *)
  (* Definition l2v {n} (l : list A) : vec n := l2m (A0:=A0) (row2col l). *)

  Definition v2l {n} (v : vec n) : list A := map (fun i : nat => v $ i) (seq 0 n).

  Definition l2v n (l : list A) : vec n :=
    mk_mat (fun i j => if (i <? n) && (j =? 0) then nth i l A0 else A0).

  (** list of vector to dlist *)
  Definition vl2dl {n} (l : list (vec n)) : list (list A) :=
    map v2l l.

  Lemma v2l_length : forall {n} (v : vec n), length (v2l v) = n.
  Proof.
    intros. unfold v2l. rewrite map_length, seq_length; auto.
  Qed.

  Lemma v2l_l2v_id : forall {n} (l : list A),
      length l = n -> (@v2l n (@l2v n l) == l)%list.
  Proof.
    intros. unfold l2v,v2l. simpl.
    rewrite (list_eq_iff_nth A0 n); auto.
    - intros. rewrite ?nth_map_seq; auto.
      rewrite ?Nat.add_0_r. apply Nat.ltb_lt in H0. rewrite H0; simpl. easy.
    - rewrite map_length, seq_length; auto.
  Qed.

  Lemma l2v_v2l_id : forall {n} (v : vec n), l2v n (v2l v) == v.
  Proof.
    intros. destruct v as [v].
    unfold l2v,v2l. simpl. lma.
    rewrite ?nth_map_seq; auto.
    rewrite Nat.add_0_r. easy.
  Qed.

  (* ==================================== *)
  (** ** Make concrete vector *)
  Definition mk_vec2 (a0 a1 : A) : vec 2 := l2v 2 [a0;a1].
  Definition mk_vec3 (a0 a1 a2 : A) : vec 3 := l2v 3 [a0;a1;a2].
  Definition mk_vec4 (a0 a1 a2 a3 : A) : vec 4 := l2v 4 [a0;a1;a2;a3].

  (* ==================================== *)
  (** ** Convert between tuples and vector *)
  Definition t2v_2 (t : @T2 A) : vec 2 :=
    let '(a,b) := t in l2v 2 [a;b].
  Definition t2v_3 (t : @T3 A) : vec 3 :=
    let '(a,b,c) := t in l2v 3 [a;b;c].
  Definition t2v_4 (t : @T4 A) : vec 4 :=
    let '(a,b,c,d) := t in l2v 4 [a;b;c;d].

  Definition v2t_2 (v : vec 2) : @T2 A := (v$0, v$1).
  Definition v2t_3 (v : vec 3) : @T3 A := (v$0, v$1, v$2).
  Definition v2t_4 (v : vec 4) : @T4 A := (v$0, v$1, v$2, v$3).

  Lemma v2t_t2v_id_2 : forall (t : A * A), v2t_2 (t2v_2 t) = t.
  Proof.
    intros. destruct t. simpl. unfold v2t_2. f_equal.
  Qed.

  Lemma t2v_v2t_id_2 : forall (v : vec 2), t2v_2 (v2t_2 v) == v.
  Proof.
    intros. apply veq_iff_vnth. intros i Hi. simpl.
    repeat (try destruct i; auto; try lia); easy.
  Qed.

  (** mapping of a vector *)
  Definition vmap {n} (v : vec n) f : vec n := mmap f v.

  (** folding of a vector *)
  (*   Definition vfold : forall {B : Type} {n} (v : vec n) (f : A -> B) (b : B), B. *)

  (** mapping of two matrices *)
  Definition vmap2 {n} (v1 v2 : vec n) f : vec n := mmap2 f v1 v2.

  (* ======================================================================= *)
  (** ** Advanced matrix construction by mixing vectors and matrices *)
  Section AdvancedConstrtuct.

    (* Check A. *)
    (* Check Equiv_Aeq. *)
    (* Context `{Equiv_Aeq : Equivalence A Aeq} {A0 A1 : A}. *)
    (* Infix "==" := (meq (Aeq:=Aeq)) : mat_scope. *)

    (* (** Vector type *) *)
    (* Definition vecr n := @mat A 1 n. *)
    (* Definition vecc n := @mat A n 1. *)

    (** Construct a matrix with a vector and a matrix by row *)
    Definition mconsr {r c} (v : vec c) (m : mat r c) : mat (S r) c :=
      mk_mat (fun i j => match i with
                         | O => v $ j
                         | S i' => m $ i' $ j
                         end).

    (** Construct a matrix with a vector and a matrix by column *)
    Definition mconsc {r c} (v : vec r) (m : mat r c) : mat r (S c) :=
      mk_mat (fun i j => match j with
                         | O => v $ i
                         | S j' => m $ i $ j'
                         end).

    (* (** Equality of two forms of ConstructByRow *) *)
    (* Lemma mconsr_eq {r c} (v : vecr c) (m : @mat A r c) : mconsr v m == (v, m). *)
    (* Proof. unfold mconsr. auto. Qed. *)

    (* (** Construct a matrix by rows with the matrix which row number is 0 *) *)
    (* Lemma mconsr_mr0 : forall {n} (v : @vec A n) (m : @mat A 0 n), *)
    (*   mconsr v m = [v]. *)
    (* Proof. intros. destruct m. unfold mconsr. auto. Qed. *)

    (* (** Construct a matrix by rows with the matrix which row column is 0 *) *)
    (* Lemma mconsr_mc0 : forall {n} (v : @vec A 0) (m : @mat A n 0), *)
    (*   mconsr v m = (tt, m). *)
    (* Proof. intros. destruct v. unfold mconsr. auto. Qed. *)

    (* (** Construct a matrix by columns with the matrix which row number is 0 *) *)
    (* Lemma mconsc_mr0 : forall {n} (v : @vec A 0) (m : @vec (@vec A n) 0), *)
    (*   mconsc v m = tt. *)
    (* Proof. intros. destruct m. unfold mconsc. auto. Qed.   *)

  End AdvancedConstrtuct.

End basic_vectory_theory.
Arguments l2v {A}.
Notation "v $ i " := (matf v i 0) : vec_scope.

Section test.
  Notation "v ! i " := (vnth (A0:=0) v i) : vec_scope.
  Definition v1 : vec 3 := l2v 0 3 [1;2;3].
  Definition m1 : mat 3 3 := l2m (A0:=0) [[10;11;12];[13;14;15];[16;17;18]].
  Goal v1!(v1!0) = 2. auto. Qed.
  Goal m2l (mconsr v1 m1) = [[1;2;3];[10;11;12];[13;14;15];[16;17;18]]. auto. Qed.
  Goal m2l (mconsc v1 m1) = [[1;10;11;12];[2;13;14;15];[3;16;17;18]]. auto. Qed.
End test.

(* ######################################################################### *)
(** * Ring vector theory implemented with SafeNatFun *)

Section ring_vector_theory.

  Context `{AG : AGroup}.
  Infix "+" := Aadd : A_scope.
  Infix "+" := (ladd (Aadd:=Aadd)) : list_scope.
  Notation "- a" := (Aopp a) : A_scope.
  Infix "-" := (fun a b => a + (-b)) : A_scope.
  Infix "==" := Aeq : A_scope.
  Infix "==" := (eqlistA Aeq) : list_scope.
  Infix "==" := (meq (Aeq:=Aeq)) : mat_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.

  (** ** Zero vector *)
  Definition vec0 {n} : vec n := mat0 A0 n 1.

  (** Assert that a vector is an zero vector. *)
  Definition vzero {n} (v : vec n) : Prop := v == vec0.

  (** Assert that a vector is an non-zero vector. *)
  Definition vnonzero {n} (v : vec n) : Prop := ~(vzero v).

  (** vec0 is equal to mat0 with column 1 *)
  Lemma vec0_eq_mat0 : forall n, vec0 == mat0 A0 n 1.
  Proof.
    intros. easy.
  Qed.

  (** *** Vector addition *)

  Definition vadd {n} (v1 v2 : vec n) : vec n := madd (Aadd:=Aadd) v1 v2.
  Infix "+" := vadd : vec_scope.

  (** v1 + v2 = v2 + v1 *)
  Lemma vadd_comm : forall {n} (v1 v2 : vec n), (v1 + v2) == (v2 + v1).
  Proof.
    intros. apply madd_comm.
  Qed.

  (** (v1 + v2) + v3 = v1 + (v2 + v3) *)
  Lemma vadd_assoc : forall {n} (v1 v2 v3 : vec n), (v1 + v2) + v3 == v1 + (v2 + v3).
  Proof.
    intros. apply madd_assoc.
  Qed.

  (** vec0 + v = v *)
  Lemma vadd_0_l : forall {n} (v : vec n), vec0 + v == v.
  Proof.
    intros. apply madd_0_l.
  Qed.

  (** v + vec0 = v *)
  Lemma vadd_0_r : forall {n} (v : vec n), v + vec0 == v.
  Proof.
    intros. apply madd_0_r.
  Qed.

  (** *** Vector opposite *)

  Definition vopp {n} (v : vec n) : vec n := mopp (Aopp:=Aopp) v.
  Notation "- v" := (vopp v) : vec_scope.

  (** v + (- v) = vec0 *)
  Lemma vadd_opp : forall {n} (v : vec n), v + (- v) == vec0.
  Proof.
    intros. apply madd_opp.
  Qed.

  (** *** Vector subtraction *)

  Definition vsub {n} (v1 v2 : vec n) : vec n := v1 + (- v2).
  Infix "-" := vsub : vec_scope.

  (** *** Below, we need a ring structure *)
  Context `{R : Ring A Aadd A0 Aopp Amul A1 Aeq}.
  Infix "*" := Amul : A_scope.

  Add Ring ring_inst : make_ring_theory.

  (** *** Vector scalar multiplication *)

  Definition vcmul {n} a (v : vec n) : vec n := mcmul (Amul:=Amul) a v.
  Definition vmulc {n} (v : vec n) a : vec n := mmulc (Amul:=Amul) v a.
  Infix "c*" := vcmul : vec_scope.
  Infix "*c" := vmulc : vec_scope.

  (** v *c a = a c* v *)
  Lemma vmulc_eq_vcmul : forall {n} a (v : vec n), (v *c a) == (a c* v).
  Proof.
    intros. apply mmulc_eq_mcmul.
  Qed.

  (** a c* (b c* v) = (a * b) c* v *)
  Lemma vcmul_assoc : forall {n} a b (v : vec n), a c* (b c* v) == (a * b)%A c* v.
  Proof.
    intros. apply mcmul_assoc.
  Qed.

  (** a c* (b c* v) = b c* (a c* v) *)
  Lemma vcmul_perm : forall {n} a b (v : vec n), a c* (b c* v) == b c* (a c* v).
  Proof.
    intros. apply mcmul_perm.
  Qed.

  (** (a + b) c* v = (a c* v) + (b c* v) *)
  Lemma vcmul_add_distr_l : forall {n} a b (v : vec n),
      (a + b)%A c* v == (a c* v) + (b c* v).
  Proof.
    intros. apply mcmul_add_distr_r.
  Qed.

  (** a c* (v1 + v2) = (a c* v1) + (a c* v2) *)
  Lemma vcmul_add_distr_r : forall {n} a (v1 v2 : vec n),
      a c* (v1 + v2) == (a c* v1) + (a c* v2).
  Proof.
    intros. apply mcmul_add_distr_l.
  Qed.

  (** 1 c* v = v *)
  Lemma vcmul_1_l : forall {n} (v : vec n), A1 c* v == v.
  Proof.
    intros. apply mcmul_1_l.
  Qed.

  (** 0 c* v = vec0 *)
  Lemma vcmul_0_l : forall {n} (v : vec n), A0 c* v == vec0.
  Proof.
    intros. apply mcmul_0_l.
  Qed.

  (** *** Vector dot product *)

  (** dot production of two vectors. *)
  Definition vdot {n : nat} (v1 v2 : vec n) : A :=
    fold_left Aadd (map (fun i => v1$i * v2$i) (seq 0 n)) A0.

  Infix "⋅" := vdot : vec_scope.

  (** vdot is a proper morphism respect to Aeq *)
  Lemma vdot_aeq_mor {n} :
    Proper (veq (Aeq:=Aeq) ==> veq (Aeq:=Aeq) ==> Aeq) (@vdot n).
  Proof.
    repeat (hnf; intros).
    apply fold_left_aeq_mor; try easy.
    rewrite (veq_iff_vnth (A0:=A0)) in H,H0.
    rewrite (list_eq_iff_nth A0 n); auto.
    - intros. rewrite !nth_map_seq; auto.
      rewrite Nat.add_0_r. rewrite <- ?(vnth_eq_vnth_raw (A0:=A0)); auto.
      rewrite H,H0; auto. easy.
    - rewrite map_length, seq_length; auto.
    - rewrite map_length, seq_length; auto.
  Qed.
  Global Existing Instance vdot_aeq_mor.

  (** dot production is commutative *)
  Lemma vdot_comm : forall {n} (v1 v2 : vec n), (v1 ⋅ v2 == v2 ⋅ v1)%A.
  Proof.
    intros. unfold vdot.
    apply fold_left_aeq_mor; try easy.
    apply SetoidListExt.map_ext. intros. ring.
  Qed.

  (** 0 * v = 0 *)
  Lemma vdot_0_l : forall {n} (v : vec n), (vec0 ⋅ v == A0)%A.
  Proof.
    intros.
    unfold vdot. cbn.
    destruct v as [v]; simpl.
    assert (map (fun i => A0 * v i 0) (seq 0 n) == map (fun i => A0) (seq 0 n))%list.
    { apply SetoidListExt.map_ext. intros. ring. }
    rewrite H. clear H.
    induction n; simpl; try easy.
    rewrite <- seq_shift. rewrite map_map. monoid_rw. auto.
  Qed.

  (** v * 0 = 0 *)
  Lemma vdot_0_r : forall {n} (v : vec n), (v ⋅ vec0 == A0)%A.
  Proof. intros. rewrite vdot_comm, vdot_0_l. easy. Qed.

End ring_vector_theory.

Section test.
  Import ZArith.
  Open Scope Z_scope.
  Open Scope vec_scope.

  Infix "+" := (vadd (Aadd:=Z.add)) : vec_scope.
  Notation "- v" := (vopp (Aopp:=Z.opp) v) : vec_scope.
  Infix "-" := (vsub (Aadd:=Z.add)(Aopp:=Z.opp)) : vec_scope.
  Infix "c*" := (vcmul (Amul:=Z.mul)) : vec_scope.
  Infix "⋅" := (vdot (A0:=0) (Aadd:=Z.add) (Amul:=Z.mul)) : vec_scope.

  Let v1 := l2v 0 3 [1;2;3].
  Let v2 := l2v 0 3 [4;5;6].
  (* Compute v2l (-v1). *)
  (* Compute v2l (v1 + v2). *)
  (* Compute v2l (v2 - v1). *)
  (* Compute v2l (3 c* v1). *)
  (* Compute v1⋅v2. *)

End test.

(* ######################################################################### *)
(** * Decidable-field vector theory implemented with SafeNatFun  *)

Section decidable_vector_theory.

  Context `{Dec_Aeq : @Decidable A Aeq} {A0:A}.

  Open Scope mat_scope.
  Open Scope vec_scope.

  (** veq is decidable *)
  Lemma veq_dec : forall (n : nat), Decidable (@veq A Aeq n).
  Proof. intros. apply meq_dec. Qed.

  Global Existing Instance veq_dec.

  (** It is decidable that if a vector is zero vector. *)
  Lemma vzero_dec : forall {n} (v : vec n),
      {vzero (A0:=A0)(Aeq:=Aeq) v} + {vnonzero (A0:=A0)(Aeq:=Aeq) v}.
  Proof.
    intros. apply veq_dec.
  Qed.

End decidable_vector_theory.

(** ** Others, later ... *)
(*

  Lemma vec_eq_vcmul_imply_coef_neq0 : forall {n} (v1 v2 : V n) k,
    vnonzero v1 -> vnonzero v2 -> v1 = k c* v2 -> k <> X0.
  Proof.
    intros. intro. subst. rewrite vcmul_0_l in H. destruct H. easy.
  Qed.

  (* ==================================== *)
  (** ** 2-dim vector operations *)

  Definition vlen2 (v : V 2) : X :=
    let '(x,y) := v2t_2 v in
      (x * x + y * y)%X.

  (* ==================================== *)
  (** ** 3-dim vector operations *)

  Definition vlen3 (v : V 3) : X :=
    let '(x,y,z) := v2t_3 v in
      (x * x + y * y + z * z)%X.

  Definition vdot3 (v0 v1 : V 3) : X :=
    let '(a0,b0,c0) := v2t_3 v0 in
    let '(a1,b1,c1) := v2t_3 v1 in
      (a0 * a1 + b0 * b1 + c0 * c1)%X.
 *)


Require Import Category.
Require Import PreorderAsCategory.
Require Import natAsPreorder.

Definition NatPreorderCategory : Category (Mor NatPreorder) :=
    toCategory NatPreorder.


From Coqprime Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma primo43 : prime 401928217.
Proof.
 apply (Pocklington_refl
         (Pock_certif 401928217 5 ((1109, 1)::(2,3)::nil) 9814)
        ((Proof_certif 1109 prime1109) ::
         (Proof_certif 2 prime2) ::
          nil)).
 native_cast_no_check (refl_equal true).
Qed.


(** * Exploring equality via homotopy and proof assistants - Day 3 - Inductive types and their equalities *)
(** This file contains the exercises for Day 3.  Some are explicitly marked as "Homework"; the rest can be done either in class or for homework.

  If the Macs in the computer lab do not have CoqIDE installed, you can go to https://coq.inria.fr/coq-85, download CoqIDE_8.5beta2.dmg, open it, and run CoqIDE directly, without installing it.

  When doing exercises on your own, feel free to skip around; there are some interesting puzzles near the bottom.

  If you feel like you know exactly how a proof will go, but find it painful and tedious to write out the proof terms explicitly, come find me.  Coq has a lot of support for automation and taking care of things that are easy and verbose, so you don't have to. Proving should feel like a game.  If it doesn't, I can probably help you with that.  *)

(** The following are placeholders; [admit] indicates that something should be filled in later. *)

Axiom admit : forall {T}, T.

(** Compatibility between Coq 8.5 and 8.4 *)
Set Universe Polymorphism.
Set Asymmetric Patterns.

(* begin hide *)
(** Some filled in exercises from yesterday; feel free to paste more here. *)

Notation refl := eq_refl.
Definition sym : forall A (x y : A), x = y -> y = x := eq_sym.
(** We allow writing [sym p] to mean [sym _ _ _ p] *)
Arguments sym {A x y} p, A x y p.
Definition trans : forall A (x y z : A), x = y -> y = z -> x = z
  := eq_trans.
Arguments trans {A x y z} p q, A x y z p q.
Definition J : forall (A : Type) (x : A) (y : A)
                      (H : x = y)
                      (P : forall (y' : A) (H' : x = y'), Type),
                 P x refl -> P y H
  := fun A x y H P k => match H with
                          | refl => k
                        end.
Arguments J {A} {x} {y} H P _.
Definition ap : forall A B (f : A -> B) (x y : A), x = y -> f x = f y
  := fun A B f x y p
     => match p with
          | refl => refl
        end.

Arguments ap {A B} f {x y} p, {A B} f x y p, A B f x y p.

(** A polymorphic definition of sigma types *)
Record sigT {A} P := existT { projT1 : A ; projT2 : P projT1 }.
Arguments projT1 {A P} _.
Arguments projT2 {A P} _.
Arguments existT {A} P _ _.
Notation "{ x : A  & P }" := (sigT (A:=A) (fun x => P)) : type_scope.

(* end hide *)

(** ** Guiding Puzzles *)

(** There are three guiding questions for today:

 1. What are (inductive) types?
 2. What does it mean to say that two inhabitants of a given type are equal?
 3. Where is equality under-specified, and how can we extend the patterns we see to fill in these areas? *)

(** *** Puzzle 1: contractibility of based path spaces *)

(** We use the notation [{ x : T | P x }] to denote the type of pairs [(x; p)] which consist of an inhabitant [x : T] and a proof [p : P x]. *)

Notation "{ x  |  P }" := ({ x : _ & P }) : type_scope.
Notation "{ x : A  |  P }" := ({ x : A & P }) : type_scope.
Notation "( x ; p )" := (existT _ x p).
Notation "x .1" := (projT1 x) (at level 3, format "x '.1'").
Notation "x .2" := (projT2 x) (at level 3, format "x '.2'").

(** A type is called contractible if there is a (continuous!) function showing that all inhabitants are equal to a particular one. *)

Definition is_contractible : Type -> Type
  := fun A => { center : A | forall y : A, center = y }.

(** Puzzle: The following theorem is provable.  Prove it. *)

Definition contractible_pointed
: forall (A : Type) (y : A),
    is_contractible { x : A | x = y }.
Proof.
  refine (fun A y => _).
  refine ((y; refl); _).
  refine (fun y' => _).
  refine admit.
Defined.

(** Note that [x = y :> T] means [x : T], [y : T], and [x = y].  It is the notation for [@eq T x y].  It is how we write $x =_T y$ #x =T y# in Coq. *)

(** Since equals are inter-substitutable, we should be able to prove: *)

Definition contractible_to_UIP
: forall (A : Type) (y : A)
         (x : A)
         (p p' : y = x),
    ((x; p) = (x; p') :> { x : A | y = x })
    -> p = p'
  := admit.

(** But it turns out that we can't prove this.  Why not?  Give both a formal, type theoretic reason (what terms don't typecheck?), and a topological reason. *)

(** *** Puzzle 2: understanding the encode-decode method *)

(** Here is a concrete puzzle for the second question:

  To classify the equality of a given type, we give a "code" for each pair of elements.  We must say how to "encode" equality proofs, and how to "decode" codes into equality proofs.  We want this to be an isomorphism, i.e., [encode ∘ decode] and [decode ∘ encode] should both be the identity function.  It turns out that we don't need to know anything about [encode] or [decode] other than their existance to ensure this; we can always adjust [decode] to create an inverse to [encode], as long as a particular property holds of [code].  What is that property?

  More concretely, the puzzle is to fill in the following holes. *)

Section general_classification.

  Definition code_correct_P
  : forall {A : Type} (code : A -> A -> Type), Type
    := admit.

  (** We assume we are given a type, a [code], an [encode], and a [decode].  We introduce the assumptions as we get to definitions that should need them. *)

  Context {A : Type} (code : A -> A -> Type)
          (decode' : forall x y, code x y -> x = y).

  Definition decode
  : forall {x y}, code x y -> x = y
    := admit.

  Context (encode : forall x y, x = y -> code x y).

  Definition deencode
  : forall {x y} (p : x = y),
      decode (encode _ _ p) = p
    := admit.

  (** For this last one, we'll need the correctness property on codes. *)

  Context (code_correct : code_correct_P code).

  Definition endecode
  : forall {x y} (p : code x y),
      encode _ _ (decode p) = p
    := admit.

End general_classification.

(** The following sanity check on the classification should be provable: *)

Section sanity_checks.

  (** [x = y] should be a valid code *)

  Definition eq_is_valid_code
  : forall {A : Type},
      code_correct_P (fun x y : A => x = y)
    := admit.

  (** If you didn't choose a silly correctness property like [code = (fun x y => x = y)], then your proof should generalize to the following: *)

  (** Suppose we are given a valid encoding. *)

  Context {A : Type} (code : A -> A -> Type)
          (encode : forall x y, x = y -> code x y)
          (decode : forall x y, code x y -> x = y)
          (endecode : forall x y (p : code x y), encode _ _ (decode _ _ p) = p)
          (deencode : forall x y (p : x = y), decode _ _ (encode _ _ p) = p).

  (** Then it should satisfy your validity principle. *)

  Definition valid_code_is_valid : code_correct_P code
    := admit.

End sanity_checks.

(** *** Puzzle 3 *)

(** Classify the equalities of types.  That is, fill in the following: *)

Definition Type_code
: forall (x y : Type), Type
  := admit.

Definition Type_encode
: forall {x y : Type}, x = y -> Type_code x y
  := admit.

(** The following are unprovable in Coq, currently.  They are collectively known as the "univalence axiom". *)

Axiom Type_decode
: forall {x y : Type}, Type_code x y -> x = y.
Axiom Type_endecode
: forall {x y : Type} (p : Type_code x y),
    Type_encode (Type_decode p) = p.
Axiom Type_deencode
: forall {x y : Type} (p : x = y),
    Type_decode (Type_encode p) = p.

(** This was all very abstract.  Let's drill down with some exmples. *)

(** * Class Notes *)

(** *** Provable equalities *)

(** What equalities of types are provable? *)

Definition some_type_equality : unit = unit
  := refl.

Inductive unit1 : Type := tt1.
Inductive unit2 : Type := tt2.

Fail Definition unit1_equals_unit2 : unit1 = unit2
  := refl.

(** Can you prove other ones? *)

(** *** Provable inequalities *)

(** What equalities of types are provably absurd? *)

Definition unit_ne_empty_set
 : unit = Empty_set -> Empty_set.
Proof.
  refine (fun P => _).
  refine (J P (fun x _ => x) _).
  refine tt.
Defined.

Definition true_ne_false
: true = false -> Empty_set.
Proof.
  refine (fun P => _).
  refine (J P (fun f _ => if f then unit else Empty_set) _).
  refine tt.
Defined.

Definition unit_ne_bool
 : bool = unit -> Empty_set.
Proof.
  refine (fun P => _).
  refine (let alleq : forall x y : unit, x = y := _ in _).
  { refine (fun x y => match x, y with
                         | tt, tt => refl
                       end). }
  refine (J P (fun T _ => (forall x y : T, x = y) -> Empty_set) _ alleq).
  refine (fun alleq_bool => _).
  refine (true_ne_false (alleq_bool true false)).
Defined.

(** *** Isomorphisms *)

(** We can define a notion of isomorphism: *)

Class IsIsomorphism {A B} (f : A -> B)
  := { iso_inv : B -> A;
       right_inv : forall x : B, f (iso_inv x) = x;
       left_inv : forall x : A, iso_inv (f x) = x }.

Arguments iso_inv {A B} f {_} _.
Arguments right_inv {A B f _ _}, {A B} f {_} _.
Arguments left_inv {A B f _ _}, {A B} f {_} _.

Record Isomorphic A B
  := { iso_fun : A -> B;
       iso_isiso : IsIsomorphism iso_fun }.

Arguments iso_fun {A B} _ _.

(** Let us use an object of type [Isomorphic] as a function: *)

Coercion iso_fun : Isomorphic >-> Funclass.

(** Tell Coq that the function associated to an [Isomorphic] object is always an isomorphism. *)

Existing Instance iso_isiso.

Notation "A <~=~> B" := (Isomorphic A B) (at level 70).
Notation "A ≅ B" := (Isomorphic A B) (at level 70).

(** We can prove the standard properties about isomorphisms: *)

Definition Isomorphic_refl : forall {A}, A ≅ A
  := fun A => {| iso_fun x := x;
                 iso_isiso := {| iso_inv x := x;
                                 right_inv x := refl : (fun x => x) x = x;
                                 left_inv x := refl |} |}.

Definition Isomorphic_inverse : forall {A B}, A ≅ B -> B ≅ A
  := fun A B e =>
       {| iso_fun := iso_inv e;
          iso_isiso := {| iso_inv := iso_fun e;
                          right_inv := left_inv e;
                          left_inv := right_inv e |} |}.

Definition Isomorphic_compose : forall {A B C}, A ≅ B -> B ≅ C -> A ≅ C.
Proof.
  refine (fun A B C e1 e2 =>
            {| iso_fun x := iso_fun e2 (iso_fun e1 x);
               iso_isiso := {| iso_inv x := iso_inv e1 (iso_inv e2 x) |} |}).
  { refine (fun x => trans (ap e2 (right_inv e1 (iso_inv e2 x)))
                           (right_inv e2 x)). }
  { refine (fun x => trans (ap (iso_inv e1) (left_inv e2 (e1 x)))
                           (left_inv e1 x)). }
Defined.

(** We would like to prove the last corresponding law: *)

Definition Isomorphic_ap : forall (f : Type -> Type) {A B}, A ≅ B -> f A ≅ f B
  := admit.

(** But it's not provable!  Here's a counter-example: *)

(** Recall the taboo from earlier; we can't prove equality of two identical types defined separately.  But if we could prove [Isomorphic_ap], then we could prove this! *)

Definition iso_unit2_unit1 : unit2 ≅ unit1.
Proof.
  refine {| iso_fun := fun x => tt1;
            iso_isiso := {| iso_inv := fun x => tt2 |} |}.
  { refine (fun x => match x with tt1 => refl end). }
  { refine (fun x => match x with tt2 => refl end). }
Defined.

Definition taboo1 : unit1 = unit2 :> Type
  := Isomorphic_ap (fun T => T = unit2) iso_unit2_unit1 refl.

(** Ooops!  We'll be coming back to this soon. *)

(** Before dealing with the taboo above, let's classify the equality space of isomorphisms. *)

(** Two isomorphisms should be equal if the underlying functions are equal. *)

Definition iso_code : forall {A B} (x y : A ≅ B), Type
  := fun A B x y => iso_fun x = iso_fun y.

Definition iso_encode : forall {A B} {x y : A ≅ B}, x = y -> iso_code x y
  := fun A B x y H => match H with
                       | refl => refl
                      end.

Definition iso_decode : forall {A B} {x y : A ≅ B}, iso_code x y -> x = y
  := admit.

(** Ooops.  Turns out this isn't provable.  Challenge: Figure out why. *)

(** *** Equivalences *)

(** We can define a slight variation on isomorphisms, called "contractible fibers", which generalizes the notion of injective+surjective.  If you're interested in the various ways of formulating equivalences, Chapter 4 of the HoTT Book (http://homotopytypetheory.org/book/) is an excellent resource. *)

Class Contr (A : Type)
  := { center : A;
       contr : forall y, center = y }.

Arguments center A {_}.

Class IsEquiv {A B} (f : A -> B)
  := Build_IsEquiv : forall b, Contr { a : A | f a = b }.

Record Equiv A B
  := { equiv_fun : A -> B;
       equiv_isequiv : IsEquiv equiv_fun }.

Arguments equiv_fun {A B} _ _.
Arguments equiv_isequiv {A B} _ _.

(** Let us use an object of type [Equiv] as a function: *)

Coercion equiv_fun : Equiv >-> Funclass.

(** Tell Coq that the function associated to an [Equiv] object is
    always an equivalence. *)

Existing Instance equiv_isequiv.

Notation "A <~> B" := (Equiv A B) (at level 70).
Notation "A ≃ B" := (Equiv A B) (at level 70).

Definition Equiv_refl : forall A, A ≃ A.
Proof.
  refine (fun A => {| equiv_fun := fun x => x;
                      equiv_isequiv := fun b => _ |}).
  refine ({| center := (b; refl) |}).
  refine (fun y => match y with
                     | existT a p => _
                   end).
  refine (match p with
            | refl => refl
          end).
Defined.

(** We can now state univalence; take on faith for now that all proofs of "f is an equivalence are equal"; there is a homework problem to prove it below. *)

(** Now that we have a "good" type of isomorphism/equivalence (one with the right equality type), we can go back to the question of [Isomorphic_ap]; Recall that we want to prove:

<<
Definition Isomorphic_ap : forall (f : Type -> Type) {A B}, A ≅ B -> f A ≅ f B.
>> *)

(** We can prove this by axiomatizing the codes for types: *)

Definition Type_code' : forall (x y : Type), Type
  := fun x y => x ≃ y.

Definition Type_encode' : forall {x y : Type}, x = y -> Type_code' x y
  := fun x y H => match H with
                    | refl => Equiv_refl x
                  end.

(** The following are unprovable in Coq, currently.  They are collectively known as the "univalence axiom". *)

Axiom Type_decode' : forall {x y : Type}, Type_code' x y -> x = y.
Axiom Type_endecode' : forall {x y : Type} (p : Type_code' x y),
                         Type_encode' (Type_decode' p) = p.
Axiom Type_deencode' : forall {x y : Type} (p : x = y),
                         Type_decode' (Type_encode' p) = p.

(** We can collect these together into a single axiom: *)

Axiom Univalence : forall {x y : Type}, IsEquiv (@Type_encode' x y).

(** * Homework (Optional) *)

(** Now we go back and see these things in more detail.  The goal of these exercises is to make the above seem obvious. *)

(** ** Inductive Types *)

(** First, we must understand the types which we are classifying the path-spaces of. *)

(** An inductive type is specified by introduction and elimination rules; introduction rules tell you how to create inhabitants (elements) of a type, and elimination rules tell you how to use such inhabitants.  Coq generate eliminations rules automatically, but we will try to come up with the first few without peeking. *)

(** Here are some examples. *)

Inductive unit : Type := tt.

(** To prove a property of any unit, it suffices to prove that property of [tt]. *)

Definition unit_elim : forall (P : unit -> Type) (x : unit), P tt -> P x
  := fun P x Ptt => match x with
                      | tt => Ptt
                    end.

Inductive bool : Type := true | false.

(** To prove a property of any boolean, it suffices to prove that property of [true] and [false]. *)

Definition bool_elim : forall (P : bool -> Type) (x : bool), P true -> P false -> P x
  := fun P x Pt Pf => match x with
                        | true => Pt
                        | false => Pf
                      end.

(** A notational helper. *)

Add Printing If bool.

(** Coq has special syntax for [nat], so we don't overwrite it. *)

Inductive nat' : Type := zero | successor (x : nat').

(** We use [Fixpoint] to allow recursion. *)

Fixpoint nat'_elim (P : nat' -> Type) (x : nat')
: P zero
  -> (forall n, P n -> P (successor n))
  -> P x
  := fun Pz Ps => match x with
                    | zero => Pz
                    | successor x' => Ps x' (nat'_elim P x' Pz Ps)
                  end.

Inductive Empty_set : Type := .

(** How can you prove this one? *)

Definition Empty_set_elim : forall (P : Empty_set -> Type) (x : Empty_set), P x
  := admit.

(** Anecdote: Proving [unit -> Empty_set] (i.e., [True -> False]) by recursion on [unit], if we assume that [True = (False -> False)] *)

Inductive prod (A B : Type) : Type := pair (a : A) (b : B).

(** Some notational helpers *)

Arguments pair {A B} _ _.

Add Printing Let prod.

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

Example prod_1 := (1, 1) : nat * nat.
Example prod_2 := (1, 2) : nat * nat.
Example prod_3 := (true, true) : bool * bool.
Example prod_4 := (1, true) : nat * bool.

(** We use curlie braces so that we don't have to pass the arguments explicitly all the time. *)

(** Try filling these in. *)

(**
<<
Definition prod_elim : admit
  := admit.

Definition fst : forall {A B}, A * B -> A
:= admit.

Definition snd : forall {A B}, A * B -> B
:= admit.

>> *)

(** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *)

(** Inductive sum (A B : Type) : Type := ... *)

(** Notational helpers *)

(**
<<
Notation "x + y" := (sum x y) : type_scope.

Arguments inl {A B} _ , [A] B _.
Arguments inr {A B} _ , A [B] _.
>> *)

Example sum_1 := inl tt : unit + nat.
Example sum_2 := inr 0 : unit + nat.

(** Inductive sigT A (B : A -> Type) : Type := ... *)

(** Notational helpers *)

(**
<<
Arguments sigT {A} B.
Arguments existT {A} B _ _.
Notation "{ a : A  & B }" := (sigT (A:=A) (fun a => B)) : type_scope.
>> *)

Notation "{ a  |  B }" := ({ a : _ & B }) : type_scope.
Notation "{ a : A  |  B }" := ({ a : A & B }) : type_scope.
Notation "( a ; b )" := (existT _ a b).

Example non_dependent_pair_1 :=
  (true; 0) : sigT (fun a : bool => nat).
Example non_dependent_pair_2 :=
  (true; 1) : { a : bool | nat }.
Example non_dependent_pair_3 :=
  (false; 1) : { a : bool | nat }.
Example dependent_pair_1 :=
  (true; 1) : { a : bool | if a then nat else unit }.
Example dependent_pair_2 :=
  (true; 0) : { a : bool | if a then nat else unit }.
Example dependent_pair_3 :=
  (false; tt) : { a : bool | if a then nat else unit }.
Fail Example dependent_pair_4 :=
  (false; 0) : { a : bool | if a then nat else unit }.

(** The projections *)

(**
<<
Definition projT1 : forall {A B}, { a : A | B a } -> A
  := admit.

Definition projT2 : forall {A B} (x : { a : A | B a}), B (projT1 x)
  := admit.
>> *)

(** Notational helpers for the projections *)

Notation "x .1" := (projT1 x) (at level 3, format "x '.1'").
Notation "x .2" := (projT2 x) (at level 3, format "x '.2'").

(** Inductive option (A : Type) : Type := ... *)

(** Inductive list (A : Type) : Type := ... *)

(** Function types also have intro and elim rules, though they don't have syntactic forms.  Can you describe them? *)

(** Note well: [J] is the eliminator for the equality type. *)

(** ** Equality classification *)

(** We can classify the equality types.  For each type, we come up with a simpler type that represents ("codes for") its equality type.  Then we prove that this type is isomorphic to the given equality type. *)

(** *** [unit] *)

Definition unit_code : forall (x y : unit), Type
  := admit.

(** We use curlie braces to not have to pass the [x] and [y] around all the time. *)

Definition unit_encode : forall {x y : unit}, x = y -> unit_code x y
  := admit.

Definition unit_decode : forall {x y : unit}, unit_code x y -> x = y
  := admit.

Definition unit_endecode : forall {x y} (p : unit_code x y),
                             unit_encode (unit_decode p) = p
  := admit.

Definition unit_deencode : forall {x y} (p : x = y),
                             unit_decode (unit_encode p) = p
  := admit.

(** *** [bool] *)

Definition bool_code : forall (x y : bool), Type
  := admit.

Definition bool_encode : forall {x y : bool}, x = y -> bool_code x y
  := admit.

Definition bool_decode : forall {x y : bool}, bool_code x y -> x = y
  := admit.

Definition bool_endecode : forall {x y : bool} (p : bool_code x y),
                             bool_encode (bool_decode p) = p
  := admit.

Definition bool_deencode : forall {x y : bool} (p : x = y),
                             bool_decode (bool_encode p) = p
  := admit.

(** *** [prod] *)

Definition prod_code : forall {A B} (x y : A * B), Type
  := admit.

Definition prod_encode : forall {A B} {x y : A * B}, x = y -> prod_code x y
  := admit.

Definition prod_decode : forall {A B} {x y : A * B}, prod_code x y -> x = y
  := admit.

Definition prod_endecode : forall {A B} {x y : A * B} (p : prod_code x y),
                             prod_encode (prod_decode p) = p
  := admit.

Definition prod_deencode : forall {A B} {x y : A * B} (p : x = y),
                             prod_decode (prod_encode p) = p
  := admit.

(** *** [Empty_set] *)

Definition Empty_set_code : forall (x y : Empty_set), Type
  := admit.

Definition Empty_set_encode : forall {x y : Empty_set},
                                x = y -> Empty_set_code x y
  := admit.

Definition Empty_set_decode : forall {x y : Empty_set},
                                Empty_set_code x y -> x = y
  := admit.

Definition Empty_set_endecode : forall {x y : Empty_set} (p : Empty_set_code x y),
                                  Empty_set_encode (Empty_set_decode p) = p
  := admit.

Definition Empty_set_deencode : forall {x y : Empty_set} (p : x = y),
                                  Empty_set_decode (Empty_set_encode p) = p
  := admit.

(** *** [sum] *)

Definition sum_code : forall {A B} (x y : A + B), Type
  := admit.

Definition sum_encode : forall {A B} {x y : A + B}, x = y -> sum_code x y
  := admit.

Definition sum_decode : forall {A B} {x y : A + B}, sum_code x y -> x = y
  := admit.

Definition sum_endecode : forall {A B} {x y : A + B} (p : sum_code x y),
                             sum_encode (sum_decode p) = p
  := admit.

Definition sum_deencode : forall {A B} {x y : A + B} (p : x = y),
                             sum_decode (sum_encode p) = p
  := admit.

(** *** [sigma] (dependent pairs) *)

Definition sigma_code : forall {A B} (x y : { a : A | B a }), Type
  := admit.

Definition sigma_encode : forall {A B} {x y : { a : A | B a }}, x = y -> sigma_code x y
  := admit.

Definition sigma_decode : forall {A B} {x y : { a : A | B a }}, sigma_code x y -> x = y
  := admit.

Definition sigma_endecode : forall {A B} {x y : { a : A | B a }} (p : sigma_code x y),
                             sigma_encode (sigma_decode p) = p
  := admit.

Definition sigma_deencode : forall {A B} {x y : { a : A | B a }} (p : x = y),
                             sigma_decode (sigma_encode p) = p
  := admit.

(** *** [nat] *)

(** Homework: *)

(** Warmup: *)

Definition zero_ne_one : 0 = 1 -> Empty_set
  := admit.

(** Hint for the above: Use [J]. *)

Definition zero_ne_succ : forall n, 0 = S n -> Empty_set
  := admit.

Definition nat_code : forall (x y : nat), Type
  := admit.

Definition nat_encode : forall {x y : nat},
                                x = y -> nat_code x y
  := admit.

Definition nat_decode : forall {x y : nat},
                                nat_code x y -> x = y
  := admit.

Definition nat_endecode : forall {x y : nat} (p : nat_code x y),
                                  nat_encode (nat_decode p) = p
  := admit.

Definition nat_deencode : forall {x y : nat} (p : x = y),
                                  nat_decode (nat_encode p) = p
  := admit.

(** *** [option] *)

(** Homework: *)

Definition option_code : forall {A} (x y : option A), Type
  := admit.

Definition option_encode : forall {A} {x y : option A}, x = y -> option_code x y
  := admit.

Definition option_decode : forall {A} {x y : option A}, option_code x y -> x = y
  := admit.

Definition option_endecode : forall {A} {x y : option A} (p : option_code x y),
                             option_encode (option_decode p) = p
  := admit.

Definition option_deencode : forall {A} {x y : option A} (p : x = y),
                             option_decode (option_encode p) = p
  := admit.

(** *** [list] *)

(** Homework: *)

Definition list_code : forall {A} (x y : list A), Type
  := admit.

Definition list_encode : forall {A} {x y : list A}, x = y -> list_code x y
  := admit.

Definition list_decode : forall {A} {x y : list A}, list_code x y -> x = y
  := admit.

Definition list_endecode : forall {A} {x y : list A} (p : list_code x y),
                             list_encode (list_decode p) = p
  := admit.

Definition list_deencode : forall {A} {x y : list A} (p : x = y),
                             list_decode (list_encode p) = p
  := admit.

(** *** arrow types *)

Definition arrow_code : forall {A B} (f g : A -> B), Type
  := fun A B f g => forall a, f a = g a.

Definition arrow_encode : forall {A B} {f g : A -> B}, f = g -> arrow_code f g
  := fun A B f g H
       => match H with
           | refl => fun a => refl (f a)
          end.

(** The rest aren't currently provable in Coq; it's the axiom of functional extensionality. *)

Axiom arrow_decode : forall {A B} {f g : A -> B}, arrow_code f g -> f = g.
Axiom arrow_endecode : forall {A B} {f g : A -> B} (p : arrow_code f g),
                         arrow_encode (arrow_decode p) = p.
Axiom arrow_deencode : forall {A B} {f g : A -> B} (p : f = g),
                         arrow_decode (arrow_encode p) = p.

(** *** Pi types (dependent function types) *)

Definition function_code : forall {A B} (f g : forall a : A, B a), Type
  := fun A B f g => forall a, f a = g a.

Definition function_encode : forall {A B} {f g : forall a : A, B a}, f = g -> function_code f g
  := fun A B f g H
       => match H with
           | refl => fun a => refl (f a)
          end.

(** The rest aren't currently provable in Coq; it's the axiom of functional extensionality. *)

Axiom function_decode : forall {A B} {f g : forall a : A, B a}, function_code f g -> f = g.
Axiom function_endecode : forall {A B} {f g : forall a : A, B a} (p : function_code f g),
                            function_encode (function_decode p) = p.
Axiom function_deencode : forall {A B} {f g : forall a : A, B a} (p : f = g),
                            function_decode (function_encode p) = p.

(** **** Homework: mere propositions *)

(** Homework; challenging problem *)

(** Recall the definition of contractibility above.  The reason that we can safely call this contractible is that all of the higher structure collapses.  That is, if all inhabitants of [A] are (continuously) equal, then all inhabitants of [x = y] for [x : A] and [y : A] are also equal.  Prove this, as follows. *)

(** First we define what it means for a type to be a "mere proposition", or to satisfy the uniqueness of identity proofs. *)

Definition is_prop : Type -> Type
  := fun A => forall x y : A, x = y.

(** We classify the equality type of propositions. *)

Definition prop_code : forall {A} (allpaths : is_prop A) (x y : A), Type
  := fun A allpaths x y => unit.

Definition prop_encode : forall {A} (allpaths : is_prop A) {x y : A},
                           x = y -> prop_code allpaths x y
  := admit.

Definition prop_decode : forall {A} (allpaths : is_prop A) {x y : A},
                           prop_code allpaths x y -> x = y
  := admit.

Definition prop_endecode : forall {A} (allpaths : is_prop A) {x y : A} (p : prop_code allpaths x y),
                            prop_encode allpaths (prop_decode allpaths p) = p
  := admit.

(** If you find this proof hard, and can't figure out why, think about the proof of [dec_deencode].  If you're still having trouble, look a bit further down for a hint. *)

Definition prop_deencode : forall {A} (allpaths : is_prop A) {x y : A} (p : x = y),
                             prop_decode allpaths (prop_encode allpaths p) = p
  := admit.

(** Hint: you may need to rewrite your [prop_decode] function.  The following lemmas may prove helpful. *)

(** Try to write an "adjuster" for [is_prop] that will always return something equal to [refl] (provably) when handed two judgmentally equal things. *)

Definition adjust_allpaths : forall {A}, is_prop A -> is_prop A
  := admit.

Definition adjust_allpaths_refl : forall {A} (allpaths : is_prop A) x,
                                   adjust_allpaths allpaths x x = refl
  := admit.

(** Now move these lemmas above [prop_decode] and try re-writing the codes so that you expect [prop_deencode] to work. *)

(** *** decidable types *)

(** Homework; challenging problem *)

(** More generally, we can do this for any type with decidable equality. *)

(** First we define what it means for a type to have decidable equality: it means that we have a (continuous!) function from pairs of inhabitants to proofs that either they are equal, or that their equality is absurd. *)

Definition decidable : Type -> Type
  := fun A => forall x y : A, (x = y) + (x = y -> Empty_set).

Definition dec_code : forall {A} (dec : decidable A) (x y : A), Type
  := admit.

Definition dec_encode : forall {A} (dec : decidable A) {x y : A},
                          x = y -> dec_code dec x y
  := admit.

Definition dec_decode : forall {A} (dec : decidable A) {x y : A},
                          dec_code dec x y -> x = y
  := admit.

Definition dec_endecode : forall {A} (dec : decidable A) {x y : A} (p : dec_code dec x y),
                            dec_encode dec (dec_decode dec p) = p
  := admit.

(** If you find this proof hard, and can't figure out why, look a bit further down for a hint. *)

Definition dec_deencode : forall {A} (dec : decidable A) {x y : A} (p : x = y),
                             dec_decode dec (dec_encode dec p) = p
  := admit.

(** Hint: you may need to rewrite your [dec_decode], [dec_code], and [dec_encode] functions, just as you did with [prop_decode].  The following lemmas may prove helpful. *)

(** Try to write an "adjuster" for decidable equality that will always return something equal to [refl] (provably) when handed two equal things. *)

Definition adjust_dec : forall {A}, decidable A -> decidable A
  := admit.

Definition adjust_dec_refl : forall {A} (dec : decidable A) (x : A),
                               adjust_dec dec x x = inl refl
  := admit.

(** Now move these lemmas above [dec_code] and try re-writing the codes so that you expect [dec_deencode] to work. *)

(** *** Pushing Further *)

(** Homework: Generalize the above two proofs to solve "Puzzle 2" far above.  (Don't forget to also do puzzle 1 while you're at it.) *)

(** Homework: Using the solution to Puzzle 2, show that it is sufficient to assume [function_decode] an axiom; the endecode and [deencode] proofs follow from puzzle 2. *)

Definition function_code' : forall {A B} (f g : forall a : A, B a), Type
  := admit.

Definition function_encode' : forall {A B} {f g : forall a : A, B a}, f = g -> function_code' f g
  := admit.

Axiom function_decode' : forall {A B} {f g : forall a : A, B a}, function_code' f g -> f = g.

Definition function_decode_adjusted' : forall {A B} {f g : forall a : A, B a}, function_code' f g -> f = g
  := admit.

Definition function_endecode' : forall {A B} {f g : forall a : A, B a} (p : function_code' f g),
                                  function_encode' (function_decode_adjusted' p) = p
  := admit.
Definition function_deencode' : forall {A B} {f g : forall a : A, B a} (p : f = g),
                                  function_decode_adjusted' (function_encode' p) = p
  := admit.

(** ** Isomorphisms *)

(** We can prove that an equivalence gives us an isomorphism very easily. *)

Definition iso_of_equiv : forall {A B}, A ≃ B -> A ≅ B.
Proof.
  refine (fun A B e
          => {| iso_fun x := e x;
                iso_isiso := {| iso_inv x := (@center _ (equiv_isequiv e x)).1 |} |}).
  { intro x.
    refine ((center {a : A | e a = x}).2). }
  { intro x.
    refine (@trans _ _ (existT (fun a => e a = e x) x (refl (e x))).1 _ _ _).
    { refine (ap _ _).
      refine (contr _). }
    { simpl.
      refine (refl x). } }
Defined.

(** We can go the other way with more work. *)

(** Optional Homework: Complete this proof. *)

Definition equiv_of_iso : forall {A B}, A ≅ B -> A ≃ B.
Proof.
  refine (fun A B e
          => {| equiv_fun := e |}).
  refine (fun b => _).
  refine {| center := existT (fun a => e a = b) (iso_inv e b) (right_inv e b);
            contr := _ |}.
  refine admit.
Defined.

(** Now, prove the following helper lemma, which lets us get the right codes for [Equiv].  You will need [function_code] and [sigma_code]. *)

Definition allpath_contr : forall {A} (x y : Contr A), x = y.
Proof.
  refine admit.
Defined.

Definition allpath_isequiv : forall {A B} (f : A -> B) (e1 e2 : IsEquiv f), e1 = e2.
Proof.
  refine admit.
Defined.

Definition equiv_code : forall {A B} (f g : A ≃ B), Type
  := fun A B f g => equiv_fun f = equiv_fun g.

Definition equiv_encode : forall {A B} {f g : A ≃ B}, f = g -> equiv_code f g
  := admit.

Definition equiv_decode : forall {A B} {f g : A ≃ B}, equiv_code f g -> f = g
  := admit.

Definition equiv_endecode : forall {A B} {f g : A ≃ B} (p : equiv_code f g),
                              equiv_encode (equiv_decode p) = p
  := admit.

Definition equiv_deencode : forall {A B} {f g : A ≃ B} (p : f = g),
                              equiv_decode (equiv_encode p) = p
  := admit.

(** *** More Homework: Playing with univalence *)

(** Using univalence, we can prove some things. *)

Definition Empty_set_eq : (Empty_set = Empty_set) = unit :> Type
  := admit.

Definition unit_eq : (unit = unit) = unit :> Type
  := admit.

Definition bool_eq : (bool = bool) = bool :> Type
  := admit.

Definition bool_arrow_bool_eq : (bool -> bool) = (bool * bool)%type
  := admit.

Definition prod_commutes : forall (A B : Type), (A * B = B * A)%type
  := admit.

(** Challenge: Show, without axioms, that univalence implies functional extensionality: *)

Definition univalence_implies_funext
: (forall A B, IsEquiv (@Type_encode' A B))
  -> (forall A B (f g : forall a : A, B a), (forall a, f a = g a) -> f = g)
  := admit.

(** Exercise 2.17 from the HoTT Book (http://homotopytypetheory.org/book/ - don't worry about reading the book):

  Show that if [A ≃ A'] and [B ≃ B'], then [(A * B) ≃ (A' * B')] in two ways: once using univalence, and once without assuming it. *)

Definition equiv_functor_prod_univalence
: (forall A B, IsEquiv (@Type_encode A B))
  -> forall A A' B B',
       A ≃ A' -> B ≃ B' -> (A * B ≃ A' * B')%type
  := admit.

Definition equiv_functor_prod_no_univalence
: forall A A' B B',
    A ≃ A' -> B ≃ B' -> (A * B ≃ A' * B')%type
  := admit.

(** Now prove that these two ways are equal *)

Definition equiv_functor_prod_eq
: forall univalence,
    equiv_functor_prod_univalence univalence = equiv_functor_prod_no_univalence
  := admit.