From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq fintype.
From mathcomp
Require Import path.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Ordered.

Section RawMixin.

Structure mixin_of (T : eqType) :=
  Mixin {ordering : rel T;
         _ : irreflexive ordering;
         _ : transitive ordering;
         _ : forall x y, [|| ordering x y, x == y | ordering y x]}.

End RawMixin.

(* the class takes a naked type T and returns all the *)
(* relatex mixins; the inherited ones and the added ones *)
Section ClassDef.

Record class_of (T : Type) := Class {
   base : Equality.class_of T;
   mixin : mixin_of (Equality.Pack base T)}.

Local Coercion base : class_of >-> Equality.class_of.

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

(* produce an ordered type out of the inherited mixins *)
(* equalize m0 and m by means of a phantom; will be exploited *)
(* further down in the definition of OrdType *)
Definition pack b (m0 : mixin_of (EqType T b)) :=
  fun m & phant_id m0 m => Pack (@Class T b m) T.

Definition eqType := Equality.Pack class cT.

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Canonical Structure eqType.
Notation ordType := Ordered.type.
Notation OrdMixin := Mixin.
Notation OrdType T m := (@pack T _ m _ id).
Definition ord T : rel (sort T) := (ordering (mixin (class T))).
Notation "[ 'ordType' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'ordType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'ordType' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'ordType'  'of'  T ]") : form_scope.
End Exports.
End Ordered.
Export Ordered.Exports.

Definition oleq (T : ordType) (t1 t2 : T) := ord t1 t2 || (t1 == t2).

Prenex Implicits ord oleq.

Section Lemmas.
Variable T : ordType.

Lemma irr : irreflexive (@ord T).
Proof. by case: T=>s [b [m]]. Qed.

Lemma trans : transitive (@ord T).
Proof. by case: T=>s [b [m]]. Qed.

Lemma total (x y : T) : [|| ord x y, x == y | ord y x].
Proof. by case: T x y=>s [b [m]]. Qed.

Lemma nsym (x y : T) : ord x y -> ord y x -> False.
Proof. by move=>E1 E2; move: (trans E1 E2); rewrite irr. Qed.

Lemma otrans : transitive (@oleq T).
Proof.
move=>x y z /=; case/orP; last by move/eqP=>->.
rewrite /oleq; move=>T1; case/orP; first by move/(trans T1)=>->.
by move/eqP=><-; rewrite T1.
Qed.

Lemma sorted_oleq s : sorted (@ord T) s -> sorted (@oleq T) s.
Proof. by elim: s=>[|x s IH] //=; apply: sub_path=>z y; rewrite /oleq=>->. Qed.

End Lemmas.

Section Totality.
Variable K : ordType.

CoInductive total_spec (x y : K) : bool -> bool -> bool -> Type :=
| total_spec_lt of ord x y : total_spec x y true false false
| total_spec_eq of x == y : total_spec x y false true false
| total_spec_gt of ord y x : total_spec x y false false true.

Lemma totalP x y : total_spec x y (ord x y) (x == y) (ord y x).
Proof.
case H1: (x == y).
- by rewrite (eqP H1) irr; apply: total_spec_eq.
case H2: (ord x y); case H3: (ord y x).
- by case: (nsym H2 H3).
- by apply: total_spec_lt H2.
- by apply: total_spec_gt H3.
by move: (total x y); rewrite H1 H2 H3.
Qed.
End Totality.

(* Monotone (i.e. strictly increasing) functions for Ord Types *)
Section Mono.
Variables (A B :ordType).

Definition strictly_increasing f x y := @ord A x y -> @ord B (f x) (f y).

Structure mono : Type := Mono
           {fun_of: A -> B; _: forall x y, strictly_increasing fun_of x y}.

End Mono.
Arguments strictly_increasing {A B} f x y.
Arguments Mono {A B _} _.

Section NatOrd.
Lemma irr_ltn_nat : irreflexive ltn. Proof. by move=>x; rewrite /= ltnn. Qed.
Lemma trans_ltn_nat : transitive ltn. Proof. by apply: ltn_trans. Qed.
Lemma total_ltn_nat : forall x y, [|| x < y, x == y | y < x].
Proof. by move=>*; case: ltngtP. Qed.

Definition nat_ordMixin := OrdMixin irr_ltn_nat trans_ltn_nat total_ltn_nat.
Canonical Structure nat_ordType := OrdType nat nat_ordMixin.
End NatOrd.

Section ProdOrd.
Variables K T : ordType.

(* lexicographic ordering *)
Definition lex : rel (K * T) :=
  fun x y => if x.1 == y.1 then ord x.2 y.2 else ord x.1 y.1.

Lemma irr_lex : irreflexive lex.
Proof. by move=>x; rewrite /lex eq_refl irr. Qed.

Lemma trans_lex : transitive lex.
Proof.
move=>[x1 x2][y1 y2][z1 z2]; rewrite /lex /=.
case: ifP=>H1; first by rewrite (eqP H1); case: eqP=>// _; apply: trans.
case: ifP=>H2; first by rewrite (eqP H2) in H1 *; rewrite H1.
case: ifP=>H3; last by apply: trans.
by rewrite (eqP H3)=>R1; move/(nsym R1).
Qed.

Lemma total_lex : forall x y, [|| lex x y, x == y | lex y x].
Proof.
move=>[x1 x2][y1 y2]; rewrite /lex /=.
case: ifP=>H1.
- rewrite (eqP H1) eq_refl -pair_eqE /= eq_refl /=; exact: total.
rewrite (eq_sym y1) -pair_eqE /= H1 /=.
by move: (total x1 y1); rewrite H1.
Qed.

Definition prod_ordMixin := OrdMixin irr_lex trans_lex total_lex.
Canonical Structure prod_ordType := Eval hnf in OrdType (K * T) prod_ordMixin.
End ProdOrd.

Section FinTypeOrd.
Variable T : finType.

Definition ordf : rel T :=
  fun x y => index x (enum T) < index y (enum T).

Lemma irr_ordf : irreflexive ordf.
Proof. by move=>x; rewrite /ordf ltnn. Qed.

Lemma trans_ordf : transitive ordf.
Proof. by move=>x y z; rewrite /ordf; apply: ltn_trans. Qed.

Lemma total_ordf : forall x y, [|| ordf x y, x == y | ordf y x].
Proof.
move=>x y; rewrite /ordf; case: ltngtP=>//= H; rewrite ?orbT ?orbF //.
have [H1 H2]: x \in enum T /\ y \in enum T by rewrite !mem_enum.
by rewrite -(nth_index x H1) -(nth_index x H2) H eq_refl.
Qed.

Definition fin_ordMixin := OrdMixin irr_ordf trans_ordf total_ordf.
End FinTypeOrd.

(* notation to let us write I_n instead of (ordinal_finType n) *)
Notation "[ 'fin_ordMixin' 'of' T ]" :=
  (fin_ordMixin _ : Ordered.mixin_of [eqType of T]) (at level 0).

Definition ordinal_ordMixin n := [fin_ordMixin of 'I_n].
Canonical Structure ordinal_ordType n := OrdType 'I_n (ordinal_ordMixin n).

Section SeqOrd.
Variable (T : ordType).

Fixpoint ords x  : pred (seq T) :=
  fun y => match x , y with
                 | [::] , [::] => false
                 | [::] ,  t :: ts => true
                 | x :: xs , y :: ys => if x == y then ords xs ys
                                        else ord x y
                 | _ :: _ , [::] => false
             end.

Lemma irr_ords : irreflexive ords.
Proof. by elim=>//= a l ->; rewrite irr; case:eqP=> //=. Qed.

Lemma trans_ords : transitive ords.
Proof.
elim=>[|y ys IHy][|x xs][|z zs]//=.
case:eqP=>//[->|H0];case:eqP=>//H; first by move/IHy; apply.
- by case:eqP=>//; rewrite -H; first (by move/H0).
case:eqP=>//[->|H1] H2; first by move/(nsym H2).
by move/(trans H2).
Qed.

Lemma total_ords : forall x y, [|| ords x y, x == y | ords y x].
Proof.
elim=>[|x xs IH][|y ys]//=; case:eqP=>//[->|H1];
 (case:eqP=>//= H; first (by rewrite orbT //=)).
- by case:eqP=>//H3 ; case: (or3P (IH ys))=> [-> | /eqP H0 | ->];
 [ rewrite orTb // | apply: False_ind; apply: H; rewrite H0 | rewrite orbT //].
case:eqP; first by move/(esym)/H1.
by move=>_ ;case: (or3P (total x y))=>[-> //| /eqP /H1 //| -> //=]; rewrite orbT.
Qed.

Definition seq_ordMixin := OrdMixin irr_ords trans_ords total_ords.
Canonical Structure seq_ordType := Eval hnf in OrdType (seq T) seq_ordMixin.
End SeqOrd.

(* A trivial total ordering for Unit *)
Section unitOrd.
Let ordtt (x y : unit ) := false.

Lemma irr_tt : irreflexive ordtt.
Proof. by []. Qed.

Lemma trans_tt : transitive ordtt.
Proof. by []. Qed.

Lemma total_tt : forall x y, [|| ordtt x y, x == y | ordtt y x ].
Proof. by []. Qed.

Let unit_ordMixin := OrdMixin irr_tt trans_tt total_tt.
Canonical Structure unit_ordType := Eval hnf in OrdType unit unit_ordMixin.
End unitOrd.


Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Logic.Eqdep.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

Require Import Containers.
Require Import Functors.

Inductive Code : Set :=
| U : Code
| I : Code
| C : Code -> Code -> Code
| P : Code -> Code -> Code.

Inductive ExtP (A : Set) : Code -> Set :=
| eu : ExtP A U
| ei : A -> ExtP A I
| el : forall {c1} {c2}, ExtP A c1 -> ExtP A (C c1 c2)
| er : forall {c1} {c2}, ExtP A c2 -> ExtP A (C c1 c2)
| ep : forall {c1} {c2}, ExtP A c1 -> ExtP A c2 -> ExtP A (P c1 c2).

Inductive FixP (c : Code) : Set := fixp : ExtP (FixP c) c -> FixP c.

Fixpoint pmap {A : Set} {B : Set} (f : A -> B) {c} (x : ExtP A c) : ExtP B c :=
  match x in ExtP _ c return ExtP B c with
    | eu         => eu _
    | ei x       => ei _ (f x)
    | el _ _ x   => el _ (pmap f x)
    | er _ _ y   => er _ (pmap f y)
    | ep _ _ x y => ep _ (pmap f x) (pmap f y)
  end.

Lemma pmap_fusion {A B D : Set} (f : A -> B) (g : B -> D) {c} (a : ExtP A c) :
  pmap g (pmap f a) = pmap (fun e => g (f e)) a.
Proof.
  induction a; simpl; auto; f_equal; auto.
Qed.

Lemma pmap_reflection {A : Set} {c} (a : ExtP A c) :
  pmap (fun x => x) a = a.
Proof.
  induction a; simpl; auto; f_equal; auto.
Qed.

Section Induction.
  Variable c : Code.
  Variable P0 : FixP c -> Prop.
  Variable P1 : forall d, ExtP (FixP c) d -> Prop.
  Variable ff : forall x, P1 c x -> P0 (fixp c x).
  Variable fu : P1 U (eu _).
  Variable fi : forall x, P0 x -> P1 I (ei _ x).
  Variable fl : forall c1 c2 x, P1 c1 x -> P1 (C c1 c2) (el _ x).
  Variable fr : forall c1 c2 y, P1 c2 y -> P1 (C c1 c2) (er _ y).
  Variable fp : forall c1 c2 x y, P1 c1 x -> P1 c2 y -> P1 _ (ep _ x y).

  Fixpoint fixp_ind (x : FixP c) : P0 x :=
    let fix extp_ind (d : Code) (x : ExtP _ d) : P1 _ x :=
        match x in ExtP _ d return P1 _ x with
          | eu => fu
          | ei x => fi x (fixp_ind x)
          | el c1 c2 x => fl c1 c2 x (extp_ind _ x)
          | er c1 c2 y => fr c1 c2 y (extp_ind _ y)
          | ep c1 c2 x y => fp c1 c2 x y (extp_ind _ x) (extp_ind _ y)
        end
    in
      match x return P0 x with
        | fixp x => ff x (extp_ind _ x)
      end.

End Induction.

Section Fold.
  Context {c : Code}.
  Context {A : Set}.
  Variable f : ExtP A c -> A.

  Fixpoint fixpfold (x : FixP c) : A :=
    let fix extfold (d : Code) (x : ExtP (FixP c) d) : ExtP A d :=
        match x in ExtP _ d return ExtP A d with
          | eu => eu _
          | ei x => ei _ (fixpfold x)
          | el _ _ x => el _ (extfold _ x)
          | er _ _ y => er _ (extfold _ y)
          | ep _ _ x y => ep _ (extfold _ x) (extfold _ y)
        end
    in match x with
         | fixp x => f (extfold _ x)
       end.

  Fixpoint extfold (d : Code) (x : ExtP (FixP c) d) : ExtP A d :=
    match x in ExtP _ d return ExtP A d with
      | eu => eu _
      | ei x => ei _ (fixpfold x)
      | el _ _ x => el _ (extfold _ x)
      | er _ _ y => er _ (extfold _ y)
      | ep _ _ x y => ep _ (extfold _ x) (extfold _ y)
    end.

  Lemma extfold_computation (d : Code) (g : ExtP A d -> A) :
    forall a, g (extfold _ a) = g (pmap fixpfold a).
  Proof.
    induction a; simpl; try reflexivity.
    apply (IHa (fun x => g (el A x))).
    apply (IHa (fun x => g (er A x))).
    rewrite (IHa1 (fun x => g (ep A x (extfold _ a2)))).
    rewrite (IHa2 (fun x => g (ep A (pmap fixpfold a1) x))).
    reflexivity.
  Qed.

  Lemma fixfold_computation :
    forall a, fixpfold (fixp _ a) = f (pmap fixpfold a).
  Proof.
    apply extfold_computation.
  Qed.

  Variable h : FixP c -> A.
  Variable H : forall (e : ExtP (FixP c) c), h (fixp _ e) = f (pmap h e).

  Fixpoint fixfold_uniqueness y : h y = fixpfold y.
    assert (forall (d : Code) (g : ExtP A d -> A)
                   (x : ExtP (FixP c) d), g (pmap h x) = g (extfold _ x))
           as extfold_uniqueness.
    induction x; simpl; auto.
    rewrite fixfold_uniqueness; reflexivity.
    rewrite (IHx (fun x => g (el A x))); reflexivity.
    rewrite (IHx (fun x => g (er A x))); reflexivity.
    rewrite (IHx1 (fun x => g (ep A x (pmap h x2)))).
    rewrite (IHx2 (fun x => g (ep A (extfold _ x1) x))).
    reflexivity.
    destruct y.
    rewrite H.
    apply extfold_uniqueness.
  Qed.
End Fold.

Lemma fixfold_reflection (c : Code) (x : FixP c) :
  fixpfold (fixp _) x = x.
Proof.
  apply sym_eq.
  apply (fixfold_uniqueness (fixp _) id).
  intro.
  unfold id at 1.
  apply sym_eq.
  f_equal.
  apply pmap_reflection.
Qed.

Class Polynomial (F : Set -> Set) :=
  { PCode             : Code;
    pto               : forall {A : Set}, ExtP A PCode -> F A;
    pfrom             : forall {A : Set}, F A -> ExtP A PCode;
    pto_pfrom_inverse : forall {A : Set} (a : F A), pto (pfrom a) = a;
    pfrom_pto_inverse : forall {A : Set} (a : ExtP A PCode), pfrom (pto a) = a
  }.

Section Sums.

  Variable F : Set -> Set.
  Context {poly_F : Polynomial F}.

  Variable G : Set -> Set.
  Context {poly_G : Polynomial G}.

  Definition ptoSum (A : Set) (x : ExtP A (C (@PCode F _) (@PCode G _))) : (F :+: G) A.
    inversion x; subst.
    left; apply pto; auto.
    right; apply pto; auto.
  Defined.

  Definition pfromSum (A : Set) (x : (F :+: G) A) : ExtP A (C (@PCode F _) (@PCode G _)).
    destruct x.
    apply (el _ (pfrom f)).
    apply (er _ (pfrom g)).
  Defined.

  Global Instance PolynomialSum : Polynomial (F :+: G) | 6 :=
  {| PCode    := C (@PCode F _) (@PCode G _);
     pto      := ptoSum;
     pfrom    := pfromSum |}.
  Proof.
    (* to_from *)
    intros;
    destruct a as [x|x];
    simpl;
    f_equal;
    apply pto_pfrom_inverse.
    (* from_to *)
    intros;
    dependent destruction a;
    simpl;
    f_equal;
    apply pfrom_pto_inverse.
  Defined.

End Sums.

Section Fold2.

  Variable c : Code.
  Variable A : Set.
  Variable B : Code -> Set.
  Variable ff : B c -> A.
  Variable fu : B U.
  Variable fi : A -> B I.
  Variable fl : forall c1 c2 : Code, B c1 -> B (C c1 c2).
  Variable fr : forall c1 c2 : Code, B c2 -> B (C c1 c2).
  Variable fp : forall c1 c2 : Code, B c1 -> B c2 -> B (P c1 c2).

  Fixpoint fixpfold2 (x : FixP c) : A :=
    let fix extpfold2 (d : Code) (y : ExtP (FixP c) d) : B d :=
        match y in ExtP _ d return B d with
          | eu           => fu
          | ei x         => fi (fixpfold2 x)
          | el c1 c2 x   => fl c1 c2 (extpfold2 c1 x)
          | er c1 c2 y   => fr c1 c2 (extpfold2 c2 y)
          | ep c1 c2 x y => fp c1 c2 (extpfold2 c1 x) (extpfold2 c2 y)
        end
    in
      match x with
        | fixp x => ff (extpfold2 c x)
      end.

  Definition extpfold2 :=
    fix extpfold2 (d : Code) (y : ExtP (FixP c) d) : B d :=
    match y in ExtP _ d return B d with
      | eu           => fu
      | ei x         => fi (fixpfold2 x)
      | el c1 c2 x   => fl c1 c2 (extpfold2 c1 x)
      | er c1 c2 y   => fr c1 c2 (extpfold2 c2 y)
      | ep c1 c2 x y => fp c1 c2 (extpfold2 c1 x) (extpfold2 c2 y)
    end.

  (*
  Fixpoint alg (d : Code) (x : ExtP A d) : B d :=
    match x in ExtP _ d return B d with
      | eu           => fu
      | ei x         => fi x
      | el c1 c2 x   => fl c1 c2 (alg c1 x)
      | er c1 c2 y   => fr c1 c2 (alg c2 y)
      | ep c1 c2 x y => fp c1 c2 (alg c1 x) (alg c2 y)
    end.

  Definition algebra (x : ExtP A c) : A := ff (alg c x).
  *)

End Fold2.

(* Section Equality. *)

(*   Class Eq (A : Set) := *)
(*     { eq                     :  A -> A -> bool; *)
(*       eq_propositional_true  : forall (x y : A), eq x y = true  -> x = y; *)
(*       eq_propositional_false : forall (x y : A), eq x y = false -> x <> y *)
(*     }. *)

(*   Variable c : Code. *)

(*   Definition EQA := FixP c -> bool. *)
(*   Definition EQB (d : Code) := ExtP (FixP c) d -> bool. *)

(*   (* *)
(*   Fixpoint eqalg (d : Code) (x : ExtP EQA d) : EQB d. *)
(*   Proof. *)
(*     destruct x; intro y. *)
(*     apply true. *)
(*     inversion y. *)
(*     apply (e H). *)
(*     inversion y; subst. *)
(*     apply (eqalg _ _ H0). *)
(*     unfold *)
(*   *) *)

(*   Definition eqf (eq : EQB c) : EQA := *)
(*     fun x => match x with *)
(*                | fixp e => eq e *)
(*              end. *)
(*   Definition equ (x : ExtP (FixP c) U) : bool := true. *)
(*   Definition eqi (f : EQA) : EQB I := *)
(*     fun x => match x with *)
(*                | ei x => f x *)
(*                | _     => false *)
(*              end. *)
(*   Definition eql (c1 c2 : Code) (eq : EQB c1) : EQB (C c1 c2). *)
(*     intro x; inversion x; subst. *)
(*     apply (eq H0). *)
(*     apply false. *)
(*   Defined. *)
(*   Definition eqr (c1 c2 : Code) (eq : EQB c2) : EQB (C c1 c2). *)
(*     intro x; inversion x; subst. *)
(*     apply false. *)
(*     apply (eq H0). *)
(*   Defined. *)
(*   Definition eqp (c1 c2 : Code) (eq1 : EQB c1) (eq2 : EQB c2) : EQB (P c1 c2). *)
(*     intro x; inversion x; subst. *)
(*     apply (andb (eq1 H1) (eq2 H2)). *)
(*   Defined. *)

(*   Definition eqfix : FixP c -> FixP c -> bool := *)
(*     fixpfold2 c EQA EQB eqf equ eqi eql eqr eqp. *)
(*   Definition eqext : forall d, ExtP (FixP c) d -> ExtP (FixP c) d -> bool := *)
(*     extpfold2 c EQA EQB eqf equ eqi eql eqr eqp. *)

(*   Lemma eqfix_propositional_true : *)
(*     forall u v, eqfix u v = true -> u = v. *)
(*   Proof. *)
(*     apply (fixp_ind c *)
(*             (fun u   => forall v, eqfix u v = true -> u = v) *)
(*             (fun d u => forall v, eqext d u v = true -> u = v)); *)
(*       intros; *)
(*       dependent destruction v; *)
(*       try (f_equal; apply (H _ H0)); *)
(*       try discriminate. *)
(*     (* ep *) *)
(*     unfold eqext in H1. *)
(*     unfold extpfold2 in H1. *)
(*     simpl in H1. *)
(*     apply andb_true_iff in H1. *)
(*     destruct H1. *)
(*     f_equal. *)
(*     apply (H _ H1). *)
(*     apply (H0 _ H2). *)
(*   Qed. *)

(*   Lemma eqfix_propositional_false : *)
(*     forall u v, eqfix u v = false -> u <> v. *)
(*   Proof. *)
(*     apply (fixp_ind c *)
(*             (fun u   => forall v, eqfix u v = false -> u <> v) *)
(*             (fun d u => forall v, eqext d u v = false -> u <> v)); *)
(*       intros; *)
(*       dependent destruction v; *)
(*       try discriminate; *)
(*       intro Heq; inversion Heq; subst. *)
(*     apply (H e); auto. *)
(*     apply (H f); auto. *)
(*     apply inj_pairT2 in H2. *)
(*     apply (H _ H0); auto. *)
(*     apply inj_pairT2 in H2. *)
(*     apply (H _ H0); auto. *)
(*     apply inj_pairT2 in H3. *)
(*     apply inj_pairT2 in H4. *)
(*     subst. *)
(*     unfold eqext in H1. *)
(*     unfold extpfold2 in H1. *)
(*     simpl in H1. *)
(*     apply andb_false_iff in H1. *)
(*     destruct H1. *)
(*     apply (H _ H1); auto. *)
(*     apply (H0 _ H1) ; auto. *)
(*   Qed. *)

(*   Global Instance Eq_FixP : Eq (FixP c) := *)
(*     {| eq := eqfix; *)
(*        eq_propositional_true := eqfix_propositional_true; *)
(*        eq_propositional_false := eqfix_propositional_false |}. *)

(* End Equality. *)

Section Container.

  Fixpoint PShape (c : Code) : Set :=
    match c with
     | U     => unit
     | I     => unit
     | C c d => PShape c + PShape d
     | P c d => PShape c * PShape d
    end%type.

  Fixpoint PPos (c : Code) : PShape c -> Set :=
    match c return PShape c -> Set with
     | U     => fun s => Empty_set
     | I     => fun s => unit
     | C c d => fun s => match s with
                           | inl s1 => PPos c s1
                           | inr s2 => PPos d s2
                         end
     | P c d => fun s => match s with
                           | (s1 , s2) => PPos c s1 + PPos d s2
                         end
    end%type.

  Fixpoint fromPolynomial (A : Set) (c : Code) (x : ExtP A c) : Ext (PShape c) (PPos c) A.
  Proof.
    destruct x; simpl.
    constructor.
    constructor.
    intros.
    destruct H.
    constructor.
    constructor.
    intros.
    apply a.
    destruct (fromPolynomial A c1 x).
    constructor 1 with (s := inl _ s).
    apply pf.
    destruct (fromPolynomial A c2 x).
    constructor 1 with (s := inr _ s).
    apply pf.
    destruct (fromPolynomial A c1 x1) as [s1 pf1].
    destruct (fromPolynomial A c2 x2) as [s2 pf2].
    constructor 1 with (s := (s1 , s2)).
    intro p.
    destruct p.
    apply (pf1 p).
    apply (pf2 p).
  Defined.

  Lemma fromPolynomial_natural (c : Code) (A B : Set) (f : A -> B) :
    forall (x : ExtP A c),
      gmap _ _ f (fromPolynomial _ _ x) = fromPolynomial _ _ (pmap f x).
  Proof.
    induction x; simpl.
    f_equal; extensionality x; destruct x.
    reflexivity.
    destruct (fromPolynomial A c1 x).
    inversion IHx.
    reflexivity.
    destruct (fromPolynomial A c2 x).
    inversion IHx.
    reflexivity.
    destruct (fromPolynomial A c1 x1).
    destruct (fromPolynomial A c2 x2).
    inversion IHx1.
    inversion IHx2.
    simpl in *.
    f_equal.
    extensionality x; destruct x; reflexivity.
  Qed.

  Fixpoint toPolynomial' (A : Set) (c : Code) : forall (s : PShape c) (pf : PPos c s -> A), ExtP A c.
    destruct c; simpl; intros s pf.
    constructor.
    constructor. auto.
    destruct s as [s|s].
    apply el.
    apply (toPolynomial' A c1 s pf).
    apply er.
    apply (toPolynomial' A c2 s pf).
    destruct s as [s1 s2].
    constructor.
    apply (toPolynomial' A c1 s1).
    intro p.
    apply pf.
    left.
    apply p.
    apply (toPolynomial' A c2 s2).
    intro p.
    apply pf.
    right.
    apply p.
  Defined.

  Definition toPolynomial (A : Set) (c : Code) (x : Ext (PShape c) (PPos c) A) :=
    match x with
      | ext s pf => toPolynomial' A c s pf
    end.

  Lemma toPolynomial_natural (c : Code) (A B : Set) (f : A -> B) :
    forall (x : Ext (PShape c) (PPos c) A),
      pmap f (toPolynomial _ _ x) = toPolynomial _ _ (gmap _ _ f x).
  Proof.
    destruct x; simpl.
    induction c; try reflexivity.
    destruct s; simpl.
    rewrite IHc1; reflexivity.
    rewrite IHc2; reflexivity.
    destruct s; simpl.
    rewrite IHc1.
    rewrite IHc2.
    reflexivity.
  Qed.

  Lemma toPolynomial_fromPolynomial_inverse (A : Set) (c : Code) :
    forall (x : ExtP A c),
      toPolynomial A c (fromPolynomial A c x) = x.
  Proof.
    unfold toPolynomial in *.
    induction c; simpl.
    intros x.
    dependent destruction x.
    reflexivity.
    intros x.
    dependent destruction x.
    reflexivity.
    intros x.
    dependent destruction x; simpl.
    remember (fromPolynomial A c1 x).
    destruct e; simpl.
    rewrite <- (IHc1 x).
    rewrite <- Heqe.
    reflexivity.
    remember (fromPolynomial A c2 x).
    destruct e; simpl.
    rewrite <- (IHc2 x).
    rewrite <- Heqe.
    reflexivity.
    intros x.
    dependent destruction x; simpl.
    remember (fromPolynomial A c1 x1) as e1.
    remember (fromPolynomial A c2 x2) as e2.
    destruct e1; destruct e2; simpl.
    rewrite <- (IHc1 x1).
    rewrite <- (IHc2 x2).
    rewrite <- Heqe1.
    rewrite <- Heqe2.
    repeat rewrite <- eta_expansion.
    reflexivity.
  Qed.

  Lemma fromPolynomial_toPolynomial_inverse (A : Set) (c : Code) :
    forall (x : Ext (PShape c) (PPos c) A),
      fromPolynomial A c (toPolynomial A c x) = x.
  Proof.
    unfold toPolynomial in *.
    induction c; destruct x; simpl.
    destruct s; f_equal; extensionality x; destruct x; auto.
    destruct s; f_equal; extensionality x; destruct x; auto.
    destruct s as [s|s]; simpl.
    rewrite (IHc1 (ext _ _ s pf)); reflexivity.
    rewrite (IHc2 (ext _ _ s pf)); reflexivity.
    destruct s as [s1 s2]; simpl.
    remember (fun p : PPos c1 s1 => pf (inl (PPos c2 s2) p)) as pf1.
    remember (fun p : PPos c2 s2 => pf (inr (PPos c1 s1) p)) as pf2.
    rewrite (IHc1 (ext _ _ s1 pf1)).
    rewrite (IHc2 (ext _ _ s2 pf2)).
    f_equal; extensionality x; destruct x; subst; auto.
  Qed.

  Definition fromFixP (c : Code) : FixP c -> W _ (PPos c) :=
    fixpfold (fun x => sup _ _ (fromPolynomial _ _ x)).

  Definition toFixP (c : Code) : W _ (PPos c) -> FixP c :=
    gfold _ _ (fun x => fixp _ (toPolynomial _ _ x)).

  Lemma fromFixP_toFixP_inverse (c : Code) :
    forall (x : W _ _), fromFixP c (toFixP c x) = x.
  Proof.
    intro x.
    rewrite (gfold_uniqueness _ _ (sup _ _) (fun x => fromFixP c (toFixP c x))).
    apply gfold_reflection.
    intros.
    unfold toFixP.
    rewrite gfold_computation.
    unfold fromFixP.
    rewrite fixfold_computation.
    rewrite toPolynomial_natural.
    rewrite fromPolynomial_toPolynomial_inverse.
    rewrite gmap_fusion.
    reflexivity.
  Qed.

  Lemma toFixP_fromFixP_inverse (c : Code) :
    forall (x : FixP c), toFixP c (fromFixP c x) = x.
  Proof.
    intro x.
    rewrite (fixfold_uniqueness (fixp c) (fun x => toFixP c (fromFixP c x))).
    apply fixfold_reflection.
    intros.
    unfold fromFixP.
    rewrite fixfold_computation.
    unfold toFixP.
    rewrite gfold_computation.
    rewrite fromPolynomial_natural.
    rewrite toPolynomial_fromPolynomial_inverse.
    rewrite pmap_fusion.
    reflexivity.
  Qed.

  Instance PolynomialContainer (F : Set -> Set) {poly_F : Polynomial F} :
    Container F :=
  {| Shape    := PShape PCode;
     Position := PPos PCode;
     from     := fun A x => fromPolynomial A PCode (pfrom x);
     to       := fun A x => pto (toPolynomial A PCode x) |}.
  Proof.
    intros.
    rewrite toPolynomial_fromPolynomial_inverse.
    apply pto_pfrom_inverse.
    intros.
    rewrite pfrom_pto_inverse.
    apply fromPolynomial_toPolynomial_inverse.
  Defined.

  Global Instance WF_Functor_plus_poly_inl
    {F G H : Set -> Set}
    {Fun_F : Functor F}
    {Poly_G : Polynomial G}
    {Poly_H : Polynomial H}
    {subfg : F :<: G}
    {WF_Fun_F : WF_Functor F _ subfg}
    :
    WF_Functor F (G :+: H) (Sub_Functor_inl F G H _ ) (Fun_G := ContainerFunctor (G :+: H)) | 1.
  Proof.
    constructor; simpl; intros.
    rewrite <- wf_functor; simpl.
    destruct (fromPolynomial A PCode (pfrom (inj fa))).
    reflexivity.
  Defined.

  Global Instance WF_Functor_plus_poly_inr
    {F G H : Set -> Set}
    {Fun_F : Functor F}
    {Poly_G : Polynomial G}
    {Poly_H : Polynomial H}
    {subfh : F :<: H}
    {WF_Fun_F : WF_Functor F _ subfh}
    :
    WF_Functor F (G :+: H) (Sub_Functor_inr F G H _ ) (Fun_G := ContainerFunctor (G :+: H)) | 1.
  Proof.
    constructor; simpl; intros.
    rewrite <- wf_functor; simpl.
    destruct (fromPolynomial A PCode (pfrom (inj fa))).
    reflexivity.
  Defined.

  (* Global Instance WF_Functor_plus_poly_inl' *)
  (*   {F G H : Set -> Set} *)
  (*   {Cont_F : Polynomial F} *)
  (*   {Cont_G : Polynomial G} *)
  (*   {Fun_H : Functor H} *)
  (*   {sub_FG_H : (F :+: G) :<: H} *)
  (*   {WF_Fun_FG_H : WF_Functor _ _ sub_FG_H (Fun_F := ContainerFunctor (F :+: G))} *)
  (*   : *)
  (*   WF_Functor _ _ (Sub_Functor_inl' sub_FG_H). *)
  (* Proof. *)
  (*   constructor; intros; simpl. *)
  (*   rewrite wf_functor; simpl. *)
  (*   destruct (fromPolynomial A PCode (pfrom fa)). *)
  (*   reflexivity. *)
  (* Defined. *)

  (* Global Instance WF_Functor_plus_cont_inr' *)
  (*   {F G H : Set -> Set} *)
  (*   {Cont_F : Container F} *)
  (*   {Cont_G : Container G} *)
  (*   {Fun_H : Functor H} *)
  (*   {sub_FG_H : (F :+: G) :<: H} *)
  (*   {WF_Fun_FG_H : WF_Functor _ _ sub_FG_H (Fun_F := ContainerFunctor (F :+: G))} *)
  (*   : *)
  (*   WF_Functor _ _ (Sub_Functor_inr' sub_FG_H). *)
  (* Proof. *)
  (*   constructor; intros; simpl. *)
  (*   rewrite wf_functor; simpl. *)
  (*   destruct (from fa). *)
  (*   reflexivity. *)
  (* Defined. *)

End Container.

Infix "*" := (P) : polynomial_scope.
Infix "+" := (C) : polynomial_scope.
Notation "1" := U : polynomial_scope.
Arguments ExtP A%type_scope C%polynomial_scope.
Delimit Scope polynomial_scope with poly.


Require Import HoTT.
Require Import polynomial.
Require Import hit_structure.
Require Import colim.
Require Import pcoeq.

(* We formulate the main theorem, which states that all signatures have a HIT provided that several HITs do.
*)
Section hit_existence.
  Variable (Σ : hit_signature).

  (* To build the approximating sequence, we first need to be able to construct types in which the endpoints of Σ can be interpreted.
     For the Three-HITs theorem we assume all endpoints have at most depth `n`, so it suffices to interpret endpoints of depth `n`.
     We first define a type `Hcon A n` in which endpoints of depth `n` with parameters in `A` can be interpreted.
     In addition, we show that whenever we have a map `Hcon A n -> B`, then in `B`, we can interpret endpoints of depth `n` with parameters from `A` as well.
  *)
  Section add_constructors.
    Definition Hrec (A : Type)
      := {i : sig_point_index Σ & poly_act (sig_point Σ i) A}.

    Fixpoint Hcon (n : nat) (A : Type) : Type :=
      match n with
      | 0 => A
      | S n => A + Hrec (Hcon n A)
      end.

    (* We have inclusions from `Hcon n A` to `Hcon (n.+1) A`. *)
    Fixpoint incl_con
             {Q : Type} (n : nat)
             {struct n}
      : Hcon n Q -> Hcon (n.+1) Q
      := match n with
         | 0 => inl
         | S n =>
           fun x =>
             match x with
             | inl x => inl x
             | inr(i;x) => inr (i;poly_map (sig_point Σ i) (incl_con n) x)
             end
         end.

    (* `Hcon n` acts on maps. *)
    Fixpoint Hcon_map {A B : Type} (n : nat) (f : A -> B) : Hcon n A -> Hcon n B
      := match n with
         | 0 => f
         | S n =>
           fun x =>
             match x with
             | inl x => inl(f x)
             | inr (i;x) => inr(i;poly_map (sig_point Σ i) (Hcon_map n f) x)
             end
         end.

    (* Inclusions of `A` into `Hcon n` *)
    Definition Hcon_inA {A : Type} {n : nat} : A -> Hcon n A :=
      match n with
      | 0 => idmap
      | S n => inl
      end.

    (* Interpretation of constructors in `Hcon (n.+1)` with arguments from `A` *)
    Definition Hcon_constr
               {A : Type} {n : nat}
               (i : sig_point_index Σ) (x : poly_act (sig_point Σ i) A)
      : Hcon (n.+1) A
      := inr(i;poly_map (sig_point Σ i) Hcon_inA x).

    (* Intepretation of constructors in `Hcon (n.+1)` with arguments from `Hcon n A` *)
    Definition Hcon_C
               {A : Type} {n : nat}
               {i : sig_point_index Σ} (x : poly_act (sig_point Σ i) (Hcon n A))
      : Hcon (n.+1) A
      := inr(i;x).

    (* Endpoints of rank `n` can be interpreted in `Hcon A` *)
    Fixpoint interpret_endpoint
             {A : Type} {P Q : polynomial} {n : nat}
             (e : endpoint (sig_point Σ) P Q)
             (H : endpoint_rank (sig_point Σ) e n)
      : poly_act P A -> poly_act Q (Hcon n A)
      := match H with
         | rank_var P _ => poly_map P Hcon_inA
         | rank_const _ _ t _ => fun _ => t
         | rank_constr _ _ _ e H => fun x => Hcon_C (interpret_endpoint e H x)
         | rank_fst _ _ _ _ e H => fun x => fst(interpret_endpoint e H x)
         | rank_snd _ _ _ _ e H => fun x => snd(interpret_endpoint e H x)
         | rank_inl _ _ _ _ e H => fun x => inl(interpret_endpoint e H x)
         | rank_inr _ _ _ _ e H => fun x => inr(interpret_endpoint e H x)
         end.

    (* Endpoints of rank `n` can be interpreted in `B` given `Hcon A -> B` *)
    Definition interpret_endpoint_all
               {A B : Type} {P Q : polynomial} {n : nat}
               (e : endpoint (sig_point Σ) P Q)
               (H : endpoint_rank (sig_point Σ) e n)
               (f : Hcon n A -> B) (x : poly_act P A)
      : poly_act Q B
      := poly_map Q f (interpret_endpoint e H x).

    (* Next we show that interpreting endpoints is natural.
       First, we show that `Hcon_inA` is a natural transformation.
     *)
    Definition Hcon_inA_natural
          {A B : Type} {n : nat}
          (f : A -> B)
      : Hcon_inA o f = Hcon_map n f o Hcon_inA
      := match n with
         | 0 => idpath
         | S n => idpath
         end.

    (* Before showing interpreting endpoints is natural, we need one more lemma. *)
    Lemma poly_map_Hcon_inA
          {A B : Type} {P : polynomial} {n : nat}
          (f : A -> B) (x : poly_act P A)
      : poly_map P Hcon_inA (poly_map P f x)
        =
        poly_map P (Hcon_map n f) (poly_map P Hcon_inA x).
    Proof.
      refine ((poly_map_compose _ _ _ _)^ @ _ @ poly_map_compose _ _ _ _).
      refine (ap (fun f => f x) _).
      refine (ap (poly_map P) _).
      apply Hcon_inA_natural.
    Defined.

    Definition interpret_natural
               {A B : Type} {P Q : polynomial} {n : nat}
               (e : endpoint (sig_point Σ) P Q)
               (H : endpoint_rank (sig_point Σ) e n)
               (f : A -> B) (x : poly_act P A)
      : interpret_endpoint e H ((poly_map P f) x)
        =
        poly_map Q (Hcon_map n f) (interpret_endpoint e H x).
    Proof.
      induction H as
          [ | | ? ? ? ? ? IHe | ? ? ? ? ? ? IHe | ? ? ? ? ? ? IHe
            | ? ? ? ? ? ? IHe | ? ? ? ? ? ? IHe] ; simpl.
      - apply poly_map_Hcon_inA.
      - reflexivity.
      - refine (ap Hcon_C (IHe x)).
      - refine (ap fst (IHe x)).
      - refine (ap snd (IHe x)).
      - refine (ap inl (IHe x)).
      - refine (ap inr (IHe x)).
    Defined.

    (* The map `interpret_endpoint_all` is natural as well.
       For this we need an extra coherency as given in `coh`.
    *)
    Definition interpret_all_natural
               {A B C D : Type} {P : polynomial} {n : nat}
               (e : endpoint (sig_point Σ) P poly_var)
               (H : endpoint_rank (sig_point Σ) e n)
               (f : Hcon n A -> B)
               (g : Hcon n B -> C)
               (h : C -> D)
               (x : poly_act P A)
               (coh : forall p,
                   h (g (Hcon_inA (f p)))
                   =
                   h (g (Hcon_map n (f o Hcon_inA) p))
               )
      : h ((g o Hcon_inA) (interpret_endpoint_all e H f x))
        =
        h (interpret_endpoint_all e H g (poly_map P (f o Hcon_inA) x))
      := coh (interpret_endpoint e H x)
             @ ap h (ap g (interpret_natural e H (f o Hcon_inA) x)^).

    (* Coherency relating `Hcon_inA` and `Hcon_map` *)
    Definition coherency_map_in {Q R : Type} n (f : Hcon (n.+1) R -> Q) (x : R) :
      Hcon_inA (f (inl x)) = Hcon_map n (f o inl) (Hcon_inA x)
      := match n with
         | 0 => reflexivity _
         | S n => idpath
         end.
  End add_constructors.

  (* Now let us assume the HIT has a certain rank `r.+1`. *)
  Variable (r : nat) (H : hit_rank Σ r.+1).
  (* We assume function extensionality, which we use to prove
     `inc seq constr_seq_map n.+2
       =
      inc seq constr_seq_map n.+3 o constr_seq_map n.+2`
     This requires function extensionality since `com` only gives the equality for all points.
     Function extensionality can be avoided by using 'strong colimits' where the path `com` has the type `forall n, inc n = inc n.+1 o f n`.*)
  Context `{Funext}.

  (* We start by defining what an approximating sequence for `Σ` is and for that, we follow the ideas in Adamek's theorem.
     At every stage new constructors are added.
     For the path constructors, we need to be able to use constructor terms and that is where `Hcon` comes into play.
     This leads to the notion of `step_data`.
     However, to guarantee the colimit is indeed a HIT for `Σ`, the constructors needs to be added in a coherent way.
     We give several invariants which can directly be used to prove the colimit satisfies the requirements for being a HIT for `Σ`.
     To make the development more modular, we use type classes for the invariants.
  *)
  Section approximating_sequence.
    (* We have stages `P` and `Q` (these represent `F(n.+1)` and `F n` respectively).
       The constructors of the HIT with arguments in `Q`, should be interpreted in `P`.
       This gives a constructor `constrH` for the points and a constructor `path` for the paths.
    *)
    Class step_data (P Q : Type) :=
      {
        constrH : Hcon (r.+1) Q -> P ;
        path : forall (i : sig_path_index Σ)
                      (x : poly_act (sig_path_param Σ i) Q),
            interpret_endpoint_all (sig_path_lhs Σ i) (fst H i) constrH x
            =
            interpret_endpoint_all (sig_path_rhs Σ i) (snd H i) constrH x
      }.

    Arguments constrH {_} {_} _ _.
    Arguments path {_} {_} _ _ _.

    (* A constructor sequence is a sequence with `step_data` at every stage. *)
    Class constr_seq (F : nat -> Type)
      := constr : forall (n : nat), step_data (F(n.+1)) (F n).

    (* We work with an arbitrary constructor sequence in the remainder of this section. *)
    Variable (seq : nat -> Type).
    Context `{constr_seq seq}.

    (* In order to take the colimit, we need maps `F n -> F(n.+1)`.
       These can be built from `step_data`.
       This is the composition `F n -> Hcon (F n) -> F(n.+1)`.
       The first map is the inclusion `Hcon_inA` and the second map `constrH`.
       So, we first make step data inclusions `sd_i` and then the maps of the sequence.
    *)
    Definition sd_i {P Q : Type} (Hstep : step_data P Q) : Q -> P
      := constrH Hstep o Hcon_inA.

    Definition constr_seq_map (n : nat) : seq n -> seq (n.+1)
      := sd_i (constr n).

    (* Now we define a candidate for the HIT. *)
    Definition colim_constr_seq := colim_N seq constr_seq_map.

    (* From `step_data`, we define the point and path constructors. *)
    Definition point_constr
               (n : nat) (i : sig_point_index Σ)
               (x : poly_act (sig_point Σ i) (seq n))
      := constrH (constr n) (Hcon_constr i x).

    Definition path_constr
               (n : nat) (i : sig_path_index Σ)
               (x : poly_act (sig_path_param Σ i) (seq n))
      : interpret_endpoint_all (sig_path_lhs Σ i) (fst H i) (constrH (constr n)) x
        =
        interpret_endpoint_all (sig_path_rhs Σ i) (snd H i) (constrH (constr n)) x
      := path (constr n) i x.

    (* Next we need to show this type is indeed a HIT for `Σ`.
       For this, the sequence needs to satisfy several coherencies.
    *)
    Section coherencies.
      (* The coherency for the points says that `point_constr` is a natural transformation from `poly_act (sig_point Σ i) seq` to `seq`.
         We have this coherency for all levels `n`, indices `i`, and arguments `x`.
      *)
      Section pt_intro_coh.
        Variable (n : nat) (i : sig_point_index Σ)
                 (x : poly_act (sig_point Σ i) (seq n)).

        Definition pt_coh_left : seq (n.+2)
          := point_constr (n.+1) i (poly_map (sig_point Σ i) (constr_seq_map n) x).

        Definition pt_coh_right : seq (n.+2)
          := constr_seq_map (n.+1) (point_constr n i x).
      End pt_intro_coh.

      Class point_intro_coherent :=
        pt_coh :
            forall (n : nat) (i : sig_point_index Σ)
                   (x : poly_act (sig_point Σ i) (seq n)),
              pt_coh_left n i x = pt_coh_right n i x.

      (* If we want to talk about path constructors, we first need to be able to interpret endpoints in the type.
          For the endpoints, the coherencies say that it does not matter whether we interpret it on level `n` or level `n+1`.
          This gives two extra coherencies: one for the left and one for the right.
          The endpoint coherencies are for all endpoints, so we take an arbitrary level `n`, index `i`, and parameter `x`.
      *)
      Section endpoint_coh.
        Variable (n : nat) (i : sig_path_index Σ)
                 (x : poly_act (sig_path_param Σ i) (seq n)).

        Definition endpointl_coh_left
          := interpret_endpoint_all
               (sig_path_lhs Σ i)
               (fst H i)
               (constrH (constr n.+1))
               (poly_map (sig_path_param Σ i) (constr_seq_map n) x).

        Definition endpointl_coh_right
          := constr_seq_map
               n.+1
               (interpret_endpoint_all (sig_path_lhs Σ i) (fst H i) (constrH (constr n)) x).

        Definition endpointr_coh_left
          := interpret_endpoint_all
               (sig_path_rhs Σ i)
               (snd H i)
               (constrH (constr n.+1))
               (poly_map (sig_path_param Σ i) (constr_seq_map n) x).

        Definition endpointr_coh_right
          := constr_seq_map
               n.+1
               (interpret_endpoint_all (sig_path_rhs Σ i) (snd H i) (constrH (constr n)) x).
      End endpoint_coh.

      Class endpoint_coherent :=
        {
          endpointl_coh :
            forall (n : nat) (i : sig_path_index Σ)
                   (x : poly_act (sig_path_param Σ i) (seq n)),
              endpointl_coh_left n i x = endpointl_coh_right n i x ;
          endpointr_coh :
            forall (n : nat) (i : sig_path_index Σ)
                   (x : poly_act (sig_path_param Σ i) (seq n)),
              endpointr_coh_left n i x = endpointr_coh_right n i x
        }.

      (* For the paths, we also need coherencies.
         To formulate these, we need that the sequence is `endpoint_coherent`.
         The coherency holds for arbitrary levels `n`, indices `i`, and parameters `x`.
         Basically, this says that interpreting the path constructor on level `n` and `n+1` is the same.
         However, the endpoints of the two paths are not definitionally equal, so we use the endpoint coherencies to compare them.
         Furthermore, the paths are only required to be equal in the stage `n+2`, so we apply `ap (constr_seq_map n.+2)` to it.
      *)
      Section pth_intro_coh.
        Variable (n : nat) (i : sig_path_index Σ)
                 (x : poly_act (sig_path_param Σ i) (seq n)).
        Context `{endpoint_coherent}.

        Definition path_coherent_left :=
          ap (constr_seq_map n.+2)
             ((endpointl_coh n i x)^
              @ (path_constr
                   n.+1 i
                   (poly_map (sig_path_param Σ i) (constr_seq_map n) x)
                   @ endpointr_coh n i x)).

        Definition path_coherent_right :=
          ap (constr_seq_map n.+2) (ap (constr_seq_map n.+1) (path_constr n i x)).
       End pth_intro_coh.

      Class path_intro_coherent `{endpoint_coherent} :=
        pth_coh : forall (n : nat) (i : sig_path_index Σ)
                         (x : poly_act (sig_path_param Σ i) (seq n)),
          path_coherent_left n i x = path_coherent_right n i x.
    End coherencies.

    (* If the sequence is `point_intro_coherent`, then the introduction rule for the point constructor holds.
       We start by defining the sequence `point_constr_seq` which is `(sig_point Σ i)` applied to `seq n` at every level `n`.
       The point introduction rule maps from the colimit of this sequence to the colimit of the constructor sequence.
    *)
    Section pt_intro.
      Variable (i : sig_point_index Σ).
      Context `{point_intro_coherent}.

      (* The colimit sequence of the arguments of the point constructor. *)
      Definition point_constr_seq (n : nat) := poly_act (sig_point Σ i) (seq n).
      Definition point_constr_map (n : nat) := poly_map (sig_point Σ i) (constr_seq_map n).
      Definition colim_point_constr_seq := colim_N point_constr_seq point_constr_map.

      Theorem pt_intro : colim_point_constr_seq -> colim_constr_seq.
      Proof.
        simple refine (colim_N_rec _ _ _).
        - simpl ; intros n x.
          apply (inc (n.+1) (point_constr _ i x)).
        - simpl ; intros n x.
          refine (ap _ _ @ com _ _).
          apply pt_coh.
      Defined.
    End pt_intro.

    (* Before we show the introduction rule for the paths, we need to lift the endpoints.
       We do this for arbitrary indices `i`.
    *)
    Section lift_endpoints.
      Variable (i : sig_path_index Σ).
      Context `{endpoint_coherent}.

      (* The colimit sequence of the parameters of the path constructors. *)
      Definition path_constr_seq (n : nat)
        := poly_act (sig_path_param Σ i) (seq n).
      Definition path_constr_seq_map (n : nat)
        := poly_map (sig_path_param Σ i) (constr_seq_map n).
      Definition colim_path_constr_seq
        := colim_N path_constr_seq path_constr_seq_map.

      Definition endpoint_lhs : colim_path_constr_seq -> colim_constr_seq.
      Proof.
        simple refine (colim_N_rec _ _ _).
        - simpl ; intros n x.
          apply (inc (n.+1)).
          refine (interpret_endpoint_all (sig_path_lhs Σ i) (fst H i) (constrH (constr _)) x).
        - simpl ; intros n x.
          refine (_ @ com _ _).
          refine (ap (@inc seq constr_seq_map n.+2) _).
          apply endpointl_coh.
      Defined.

      Definition endpoint_rhs : colim_path_constr_seq -> colim_constr_seq.
      Proof.
        simple refine (colim_N_rec _ _ _).
        - simpl ; intros n x.
          apply (inc (n.+1)).
          refine (interpret_endpoint_all (sig_path_rhs Σ i) (snd H i) (constrH (constr _)) x).
        - simpl ; intros n x.
          refine (_ @ com _ _).
          refine (ap (@inc seq constr_seq_map n.+2) _).
          apply endpointr_coh.
      Defined.
    End lift_endpoints.

    (* If the sequence is `path_intro_coherent`, then we can prove the introduction rule for the paths. *)
    Section pth_intro.
      Context `{endpoint_coherent} `{path_intro_coherent}.

      (* Move to colimit. *)
      (* Computation of `ap (inc F f (k.+1)) p`. *)
      Definition ap_inc
                 (F : nat -> Type) (f : forall n, F n -> F n.+1)
                 (k : nat) (x y : F k.+1) (p : x = y)
        : (com (k.+1) x)^
          @ ap (inc (k.+2)) (ap (f (k.+1)) p)
            @ com (k.+1) y
          = ap (inc (k.+1)) p
        := match p with
           | idpath => ap (fun z => z @ _) (concat_p1 _) @ concat_Vp _
           end.

      (* Move to colimit. *)
      (* With functional extensionaltiy, `com` gives an equality of functions. *)
      Definition strong_com
                 (F : nat -> Type) (f : forall n, F n -> F(n.+1))
                 (k : nat)
        : inc k = inc k.+1 o f k
        := path_forall _ _ (fun z => (com k z)^).

      (* Introduction rule for paths. *)
      Theorem pth_intro (i : sig_path_index Σ) :
        forall (x : colim_path_constr_seq i), endpoint_lhs i x = endpoint_rhs i x.
      Proof.
        simple refine (colim_N_ind _ _ _).
        - simpl ; intros n x.
          apply (ap (inc (n.+1)) (path_constr _ i x)).
        - simpl ; intros n x.
          rewrite transport_paths_FlFr.
          rewrite !(colim_N_rec_beta_com).
          rewrite inv_pp.
          rewrite concat_p_pp.
          rewrite (concat_pp_p _ _ (ap (inc n.+2) (endpointr_coh n i x))).
          rewrite <- (ap_pp (inc n.+2)).
          rewrite ?concat_pp_p.
          rewrite (concat_p_pp (ap (inc n.+2) (endpointl_coh n i x))^).
          rewrite <- ap_V.
          rewrite <- (ap_pp (inc n.+2)).
          rewrite <- (ap_inc seq constr_seq_map n).
          rewrite concat_pp_p.
          f_ap ; f_ap.
          rewrite strong_com.
          refine (ap_compose _ _ _ @ _).
          refine (ap _ _ @ (ap_compose _ _ _)^).
          apply pth_coh.
      Defined.
    End pth_intro.
  End approximating_sequence.

  Arguments constrH {_} {_}.
  Arguments path {_} {_}.
  Arguments sd_i {_} {_}.

  (* An approximating sequence is thus a constructing sequence satisfying several invariants.
     These invariants are coherencies and thus, beside adding constructors, we need to add coherencies during the construction.
     This leads to the notion of `coherent_step_data`: this is `step_data` with some extra coherencies.
     From `coherent_step_data` we get all the required rules.
  *)
  Section coherent_step_data.
    (* Here we give the required coherencies for `coherent_step_data`.
       These are mostly similar to the invariants except for the fact they are translated to requirements on `step_data`.
       Only the point coherency is slightly changed, but we can deduce the actual desired coherency from it.
    *)
    Section coherencies.
      Variable (S P Q R : Type)
               (HSP : step_data S P) (HPQ : step_data P Q) (HQR : step_data Q R).

      (* Coherency for the points *)
      Section point_coherency.
        Variable (x : Hcon (r.+1) R).

        Definition coh_pt_l := constrH HPQ (Hcon_map (r.+1) ((constrH HQR) o inl) x).
        Definition coh_pt_r := constrH HPQ (Hcon_inA (constrH HQR x)).
      End point_coherency.

      (* Since we need this coherency for the others, we put it in a type class. *)
      Class sd_pt_coh :=
        coh_pt : forall (x : Hcon (r.+1) R), coh_pt_l x = coh_pt_r x.

      (* Coherency for the endpoints*)
      Section endpoint_coherency.
        Variable (i : sig_path_index Σ)
                 (x : poly_act (sig_path_param Σ i) R).
        Context `{sd_pt_coh}.

        Definition sd_endpointl
          : sd_i
              HPQ
              (interpret_endpoint_all
                 (sig_path_lhs Σ i)
                 (fst H i)
                 (constrH HQR)
                 x)
            =
            interpret_endpoint_all
              (sig_path_lhs Σ i)
              (fst H i)
              (constrH HPQ)
              (poly_map (sig_path_param Σ i) (sd_i HQR) x).
        Proof.
          simple refine (interpret_all_natural _ _ _ _ idmap _ _).
          intros.
          refine (ap _ (coh_pt _)^).
        Defined.

        Definition sd_endpointr
          : sd_i
              HPQ
              (interpret_endpoint_all
                 (sig_path_rhs Σ i)
                 (snd H i)
                 (constrH HQR)
                 x)
            =
            interpret_endpoint_all
              (sig_path_rhs Σ i)
              (snd H i)
              (constrH HPQ)
              (poly_map (sig_path_param Σ i) (sd_i HQR) x).
        Proof.
          simple refine (interpret_all_natural _ _ _ _ idmap _ _).
          intros.
          refine (ap _ (coh_pt _)^).
        Defined.
      End endpoint_coherency.

      (* Coherency for the paths. *)
      Section path_coherency.
        Variable (i : sig_path_index Σ)
                 (x : poly_act (sig_path_param Σ i) R).
        Context `{sd_pt_coh}.

        Definition coh_pth_l
          := ap (sd_i HSP)
                ((sd_endpointl i x)
                   @ (path HPQ i (poly_map (sig_path_param Σ i) (sd_i HQR) x))
                   @ (sd_endpointr i x)^).

        Definition coh_pth_r
          := ap (sd_i HSP) (ap (sd_i HPQ) (path HQR i x)).
      End path_coherency.
    End coherencies.

    Arguments sd_pt_coh {_} {_} {_} _ _.
    Arguments coh_pth_l {_} {_} {_} {_} _ _ _ _ _.
    Arguments coh_pth_r {_} {_} {_} {_} _ _ _ _.

    (* We have `S` `P`, `Q` and `R` such that we can interpret constructors in `S`, `P`, and `Q` with arguments from `P`, `Q`, and `R` respectively.
       Or, more briefly, we have `step_data S P`, `step_data P Q`, and `step_data Q R`.
       We also need `sd_pt_coh HPQ HQR` to formulate the path coherency.
     *)
    Class coherent_step_data
          {S P Q R : Type}
          (HSP : step_data S P)
          (HPQ : step_data P Q)
          (HQR : step_data Q R)
          {coh_pt : sd_pt_coh HPQ HQR}
      := coh_pth :
           forall (i : sig_path_index Σ)
                  (x : poly_act (sig_path_param Σ i) R),
             coh_pth_l HSP HPQ HQR i x coh_pt
             =
             coh_pth_r HSP HPQ HQR i x.

    Variable (S P Q R : Type)
             (HSP : step_data S P)
             (HPQ : step_data P Q)
             (HQR : step_data Q R)
             (coh_pt : sd_pt_coh HPQ HQR).

    (* The coherency needed for the point introduction rule.
       The point coherency in `coherent_step_data` was changed a bit, but it is still strong enough to acquire the right coherency rule.
    *)
    Lemma point_coherency (C : coherent_step_data HSP HPQ HQR)
          (i : sig_point_index Σ) (x : poly_act (sig_point Σ i) R)
      : (constrH HPQ)
          (Hcon_constr i (poly_map (sig_point Σ i) ((constrH HQR) o inl) x))
        =
        (constrH HPQ)
          (inl ((constrH HQR) (Hcon_constr i x))).
    Proof.
      unfold sd_pt_coh, coh_pt_l, coh_pt_r in coh_pt.
      refine (_ @ coh_pt _).
      simpl.
      unfold Hcon_constr.
      refine (ap _ (ap _ _)).
      refine (path_sigma' _ idpath _) ; simpl.
      apply poly_map_Hcon_inA.
    Defined.
  End coherent_step_data.

  Arguments sd_endpointl {_} {_} {_} _ _ _ _ _.
  Arguments sd_endpointr {_} {_} {_} _ _ _ _ _.
  Arguments sd_pt_coh {_} {_} {_} _ _.
  Arguments coh_pt_l {_} {_} {_}.
  Arguments coh_pt_r {_} {_} {_}.
  Arguments coh_pth_l {_} {_} {_} _ _ _ _ _.
  Arguments coh_pth_r {_} {_} {_} _ _ _ _.
  Arguments coh_pth {_} {_} {_} {_} {_} {_} {_} _ _.
  Arguments point_coherency {_} {_} {_} {_}.

  (* Now we got `coherent_step_data`, which contains the data needed to prove the invariants.
     A `construction_sequence` is a sequence such that at each level we have `step_data`.
     A `coherent_construction_sequence` is a sequence such that at each level we have `coherent_step_data`.
  *)
  Section coherent_construction_sequence.
    Class coh_constr_seq
          (F : nat -> Type)
          `{constr_seq F}
          `{forall n, sd_pt_coh (constr n.+1) (constr n)}
      := coh_constr : forall (n : nat),
          coherent_step_data (constr n.+2) (constr n.+1) (constr n).

    (* We work with an arbitrary coherent construction sequence. *)
    Variable (seq : nat -> Type).
    Context `{constr_seq seq}
            `{forall n, sd_pt_coh (constr n.+1) (constr n)}.
    Variable (coh_seq : coh_constr_seq seq).

    (* The invariant for the introduction rule for the points is satisfied. *)
    Global Instance point_intro_coherent_coh : point_intro_coherent seq.
    Proof.
      intros n.
      refine (point_coherency _ _ _ _ _).
      apply coh_seq.
    Defined.

    (* The invariant for interpreting the endpoints is satisfied. *)
    Global Instance endpoint_coherent_coh : endpoint_coherent seq.
    Proof.
      split.
      - intros.
        refine (sd_endpointl _ _ _ _ _)^.
      - intros.
        refine (sd_endpointr _ _ _ _ _)^.
    Defined.

    (* The invariant the introduction rule for the paths is satisfied. *)
    Global Instance path_intro_coherent_coh : path_intro_coherent seq.
    Proof.
      intros n i x.
      pose (@coh_pth _ _ _ _ _ _ _ _ (coh_seq n) i x) as p.
      unfold coh_pth_l, coh_pth_r in p.
      unfold path_coherent_left, path_coherent_right, constr_seq_map.
      simpl.
      refine (_ @ p).
      unfold constr_seq_map.
      refine (ap _ _).
      refine (concat_p_pp _ _ _ @ _).
      refine (ap (fun z => z @ _ @ _) _).
      apply inv_V.
    Defined.
  End coherent_construction_sequence.

  (* Hence, a `coherent_construction_sequence` satisfies all invariants, so we get the introduction rules for it.
     For an approximating sequence, it suffices to build a coherent construction sequence.
     That is done by adding a data in a coherent way.
     First, we add step data.
     Then using coequalizers and path coequalizers we get the coherencies.
     This gives coherent step data.
     The approximator does all these steps.
  *)
  Section approximator.
    (* First, we add `step_data`.
       This requires one argument.
       To acquire the point constructors, we use `Hcon`.
       To acquire the path constructors, we use a coequalizer.
       This way we get a type with `step_data` over `P`.
    *)
    Section add_constructors.
      Variable (P : Type).

      Definition params : Type
        := {i : sig_path_index Σ & poly_act (sig_path_param Σ i) P}.

      Definition path_1 (y : params) : Hcon (r.+1) P
        := interpret_endpoint (sig_path_lhs Σ y.1) (fst H y.1) y.2.

      Definition path_2 (y : params) : Hcon (r.+1) P
        := interpret_endpoint (sig_path_rhs Σ y.1) (snd H y.1) y.2.

      Definition add_cons : Type :=
        Coeq path_1 path_2.

      Global Instance H_add_cons_P : step_data add_cons P
        := {|constrH := coeq ; path := fun i x => cp (i;x)|}.
    End add_constructors.

    (* Furthermore, we can add `step_data` together with the point coherency.
       This requires two arguments.
       We first use the previous construction to add `step_data` and then we obtain the coherency with a coequalizer.
    *)
    Section add_point_coherency.
      Variable (P Q : Type)
               (HPQ : step_data P Q).

      Definition add_pt_coherency : Type
        := Coeq (coh_pt_l (H_add_cons_P P) HPQ) (coh_pt_r (H_add_cons_P P) HPQ).

      (* We still have `step_data`. *)
      Global Instance H_pt_coh_P : step_data add_pt_coherency P.
      Proof.
        simple refine {|constrH := coeq o (constrH _) ; path := _|}.
        intros.
        refine (ap coeq (cp (i;x))).
      Defined.

      Global Instance pt_coh_PQR : sd_pt_coh H_pt_coh_P HPQ
        := fun x => cp x.
    End add_point_coherency.

    (* Lastly, we can add `step_data`, the point coherency and the path coherency.
       This requires three arguments.
       The path coherency is added with a path coequalizer.
       This gives `coherent_step_data`.
    *)
    Section add_path_coherency.
      Variable (P Q R : Type)
               (HPQ : step_data P Q)
               (HQR : step_data Q R).
      Context `{@sd_pt_coh _ _ _ HPQ HQR}.

      (* Next we add coherencies for the paths *)
      Definition path_coherencies :
        {i : sig_path_index Σ & poly_act (sig_path_param Σ i) R}
        ->
        {b1 : add_pt_coherency P Q HPQ &
              {b2 : add_pt_coherency P Q HPQ & (b1 = b2) * (b1 = b2)}}.
      Proof.
        intros [i x].
        refine (_;(_;(_,_))).
        - simple refine (coh_pth_l _ _ HPQ HQR i x _).
        - refine (coh_pth_r _ _ _ _ i x).
      Defined.

      (* This type has all the coherencies. *)
      Definition add_pth_coherencies : Type
        := pcoeq path_coherencies.

      (* We have step data. *)
      Global Instance H_pth_coherencies_P : step_data add_pth_coherencies P.
      Proof.
        simple refine {|constrH := inP _ o (constrH _) ; path := _|}.
        intros i x.
        refine (ap (inP _) (path _ i x)).
      Defined.

      (* We have the point coherency. *)
      Global Instance pt_coh_SPQ : sd_pt_coh H_pth_coherencies_P HPQ
        := fun x => ap (inP _) (cp _).

      (* We have coherent step data. *)
      Global Instance coherent_step_data_PSQR
        : coherent_step_data H_pth_coherencies_P HPQ HQR.
      Proof.
        intros i x.
        unfold coh_pth_l, coh_pth_r, sd_i, constrH.
        simpl.
        refine (ap_compose _ _ _ @ _).
        refine (glueP path_coherencies (i;x) @ _).
        refine (ap_compose _ _ _)^.
      Defined.
    End add_path_coherency.
  End approximator.

  (* From the approximator, we can build a `coherent_construction_sequence`. *)
  Section coherent_construction_sequence_existence.
    (* Let's start with the base cases. *)
    Definition seq_z : Type := Empty.
    Definition seq_o : Type := add_cons seq_z.
    Definition seq_t : Type := add_pt_coherency seq_o seq_z _.

    (* We want to build the sequence inductively, but that gives a problem.
       If we want to use the approximator, we need structure relating `F(n+2)`, `F(n+1)`, and `F(n)` and this structure, is not present automatically.
       To solve this, we first build a sequence sending `n` to `(F n;F(n+1);F(n+2);_;_;_)`.
       The last three coordinates give `step_data F(n+2) F(n+1)`, `step_data F(n+1) (F n)` and the point coherency respectively.
       This allows us to use the approximator and then we can build the sequence.
    *)
    Definition help_seq (n : nat)
      : {R : Type &
             {Q : Type &
                  {P : Type &
                       {HPQ : step_data P Q &
                              {HQR : step_data Q R & sd_pt_coh HPQ HQR}}}}}.
    Proof.
      induction n as [ | n IHn].
      - refine (seq_z;(seq_o;(seq_t;(_;(_;_))))).
        apply _.
      - destruct IHn as [R [Q [P [HPQ [HQR Hcoh]]]]].
        refine (Q;(P;((add_pth_coherencies _ _ _ _ _);(_;(_;_))))).
        apply _.
    Defined.

    (* The desired sequence is the the first coordinate of the help sequence. *)
    Definition seq (n : nat) := (help_seq n).1.

    (* We show it is indeed a `coherent_constructor_sequence`. *)
    Global Instance seq_is_constr_seq : constr_seq seq
      := fun n => (help_seq n).2.2.2.2.1.

    Definition seq_point_coh : forall n, sd_pt_coh (constr n.+1) (constr n)
      := fun n => (help_seq n).2.2.2.2.2.

    Global Instance seq_is_coh_constr_seq : @coh_constr_seq seq _ seq_point_coh
      := fun _ => _.
  End coherent_construction_sequence_existence.

    (* `Hcon n A` is a minimal extension of `A` in which we can interpret constructor terms.
      For that we show how to extend maps `(x : A) -> Y x` to `Hcon n A`.
  *)
  Section extend_Hcon.
    (* First, we define the pullback of a family. *)
    Definition pullback
               {P Q : Type}
               (Y : P -> Type)
               (g : Q -> P)
      : Q -> Type
      := Y o g.

    (* Now we extend `Hrec`.
       For this we start with types `P` and `Q` and an inclusion `inc : Q -> P`.
       Since we need a family for both `Q` and `Hrec Q`, we require a map `constrQ : Hrec Q -> P`.
       This map interprets constructors with arguments from `Q` in the type `P`.
       For the family `Y`, we require that it has a lift of `c`.
    *)
    Definition extend_rec
               {P Q : Type}
               (YP : P -> Type)
               (inc : Q -> P)
               (constrQ : Hrec Q -> P)
               (c : forall (i : sig_point_index Σ)
                           (x : poly_act (sig_point Σ i) Q),
                   poly_fam (sig_point Σ i) (pullback YP inc) x
                   -> YP (constrQ(i;x)))
               (f : forall (x : Q), YP (inc x))
               (x : Hrec Q)
      : pullback YP constrQ x
      := match x with
         | (i;x) => c i x (poly_dmap (sig_point Σ i) f x)
         end.

    (* To extend maps to `Hcon (S n) A` there are two cases.
       Either the element is in `A` or it is in `Hrec (Hcon n A)`.
       In the first case, we use the given map.
       In the second case, we use `extend_rec`.
    *)
    Definition extend_con_S'
               {P Q : Type}
               (YP : P -> Type)
               (n : nat)
               (x : Hcon (S n) Q)
      : forall (g : Hcon (S n) Q -> P)
               (c : forall (i : sig_point_index Σ)
                           (x : poly_act (sig_point Σ i) (Hcon n Q)),
                   poly_fam (sig_point Σ i) (pullback YP (g o incl_con n)) x
                   -> YP (g (inr (i; x))))
               (f : forall (x : Hcon n Q), YP (g(incl_con n x))),
        pullback YP g x
      := match x with
         | inl q =>
           match n with
           | 0 => fun g c f => f q
           | S _ => fun g c f => f(inl q)
           end
         | inr q => fun g c f => extend_rec YP (g o incl_con n) (g o inr) c f q
         end.

    (* Move to polynomial.v *)
    Fixpoint fam_compose
          {P : polynomial}
          {A B : Type}
          (f : A -> B)
          {Y : B -> Type}
      : forall (y : poly_act P A),
        poly_fam P (Y o f) y -> poly_fam P Y (poly_map P f y)
      := match P with
         | poly_var => fun y z => z
         | poly_const _ => fun y z => z
         | poly_times _ _ =>
           fun y z =>
             (fam_compose f (fst y) (fst z), fam_compose f (snd y) (snd z))
         | poly_plus _ _ =>
           fun y =>
             match y with
             | inl y => fam_compose f y
             | inr y => fam_compose f y
             end
         end.

    (* We can also extend a map to `Hcon (S n) Q` if we just start with the part on `Q` by repeatedly applying `extend_con_S`. *)
    Fixpoint extend_con_Z
               {P Q : Type}
               (YP : P -> Type)
               (n : nat)
      : forall (g : Hcon (S n) Q -> P)
               (c : forall (i : sig_point_index Σ)
                           (x : poly_act (sig_point Σ i) (Hcon n Q)),
                   poly_fam (sig_point Σ i) (pullback YP (g o incl_con n)) x
                   -> YP (g (inr (i; x))))
               (f : forall (x :Q), YP (g(Hcon_inA x)))
               (x : Hcon (S n) Q),
        pullback YP g x
      := match n with
         | 0 =>
           fun g c f x => extend_con_S' YP 0 x g c f
         | S n =>
           fun g c f x =>
             extend_con_S' YP (n.+1) x g c
                           (extend_con_Z YP n
                                         (g o incl_con (n.+1))
                                         (fun i y z => c i _ (fam_compose _ y z)) f)
         end.

    (* The extension is indeed an extension. *)
    Definition extend_con_S_is_extension
               {P Q : Type}
               (YP : P -> Type)
               (n : nat)
               (g : Hcon (n.+2) Q -> P)
               (c : forall (i : sig_point_index Σ)
                           (x : poly_act (sig_point Σ i) (Hcon (n.+1) Q)),
                   poly_fam (sig_point Σ i) (pullback YP (g o incl_con (n.+1))) x
                   -> YP (g (inr (i; x))))
               (f : forall (x : Hcon (n.+1) Q), YP (g(incl_con (n.+1) x)))
               (x : Q)
      : extend_con_S' YP (n.+1) (Hcon_inA x) g c f = f(Hcon_inA x)
      := idpath.

    (* The extension is indeed an extension. *)
    Definition extend_con_Z_is_extension
               {P Q : Type}
               (YP : P -> Type)
               (n : nat)
               (g : Hcon (n.+1) Q -> P)
               (c : forall (i : sig_point_index Σ)
                           (x : poly_act (sig_point Σ i) (Hcon n Q)),
                   poly_fam (sig_point Σ i) (pullback YP (g o incl_con n)) x
                   -> YP (g (inr (i; x))))
               (f : forall (x : Q), YP (g(Hcon_inA x)))
               (x : Q)
      : extend_con_Z YP n g c f (Hcon_inA x) = f x.
    Proof.
      induction n.
      - reflexivity.
      - refine (_ @ (IHn
                      (g o (incl_con (n.+1)))
                      (fun i y z => c i _ (fam_compose _ y z)) _)).
        apply extend_con_S_is_extension.
    Defined.

    (* There are two computation rules for `extend_con_Z` telling what it does on constructors.
       One computation rule is for zero and the other for succesors.
    *)
    Definition extend_con_Z_constr_zero
               {P Q : Type}
               (YP : P -> Type)
               (g : Hcon 1 Q -> P)
               (c : forall (i : sig_point_index Σ)
                           (x : poly_act (sig_point Σ i) (Hcon 0 Q)),
                   poly_fam (sig_point Σ i) (pullback YP (g o incl_con 0)) x
                   -> YP (g (inr (i; x))))
               (f : forall (x : Q), YP (g(Hcon_inA x)))
               (i : sig_point_index Σ)
               (x : poly_act (sig_point Σ i) Q)
      : extend_con_Z YP 0 g c f (Hcon_constr i x)
        =
        c i (poly_map (sig_point Σ i) Hcon_inA x)
          (poly_dmap (sig_point Σ i) f (poly_map (sig_point Σ i) _ x))
      := idpath.

    Definition extend_con_Z_constr_succ
               {P Q : Type}
               (YP : P -> Type)
               (n : nat)
               (g : Hcon (n.+2) Q -> P)
               (c : forall (i : sig_point_index Σ)
                           (x : poly_act (sig_point Σ i) (Hcon (n.+1) Q)),
                   poly_fam (sig_point Σ i) (pullback YP (g o incl_con (n.+1))) x
                   -> YP (g (inr (i; x))))
               (f : forall (x : Q), YP (g(Hcon_inA x)))
               (i : sig_point_index Σ)
               (x : poly_act (sig_point Σ i) (Hcon (n.+1) Q))
      : extend_con_Z YP (n.+1) g c f (Hcon_C x)
        =
        c i x (poly_dmap
                 (sig_point Σ i)
                 (extend_con_Z YP n
                               (g o incl_con (n.+1))
                               (fun i' y z => c i' _ (fam_compose _ y z)) f)
                 x)
      := idpath.
  End extend_Hcon.
End hit_existence.


Set Implicit Arguments.
Require Import Prelude.
Require Export Autosubst.Autosubst.

Set Boolean Equality Schemes.
Scheme Equality for nat.

Definition name := nat.

Inductive exp : Type :=
  Bind : var -> exp
| Sort : nat -> exp
| Free : name -> exp

| Pi : exp -> {bind 1 of exp} -> exp
(* | Lam : exp -> {bind exp} -> exp *)
| Lam : {bind 1 of exp} -> exp
| App  : exp -> exp -> exp

| Sigma : exp -> {bind exp} -> exp
| Pair__sigma : exp ->  exp -> exp
| Rec__sigma : {bind 2 of exp} -> exp -> exp

| Path : exp -> exp -> exp
| Rec__path : exp -> exp -> exp
| Refl__path : exp -> exp

(* | Empty :  exp *)
(* | empty_rec : exp -> exp *)

| Desc : exp
| Ind__desc : exp
| Sum__desc : exp -> exp -> exp
| Prd__desc : exp -> exp -> exp
| Unit__desc : exp
| Fix__desc : exp -> exp
| Rec__desc : exp
            -> {bind 4 of exp} -> {bind 4 of exp}
            -> exp
            -> {bind 2 of exp}
            -> exp -> exp

| Mu : exp -> exp -> exp
| Wrap__mu : exp -> exp
| Inl__mu : exp -> exp
| Inr__mu : exp -> exp
| Pair__mu : exp -> exp -> exp
| Unit__mu : exp
| Fix__mu : exp -> exp
| Rec__mu : {bind 2 of exp}
          -> {bind 2 of exp} -> {bind 2 of exp}
          -> {bind 4 of exp}
          -> exp
          -> {bind 2 of exp}
          -> exp -> exp.

Hint Resolve internal_nat_dec_lb internal_nat_dec_bl.

Lemma exp_dec_lb : forall x y, x = y -> exp_beq x y. destruct 1; induction x; simpl; f_equal; rewrite asms; auto. Qed.
Hint Resolve exp_dec_lb.

Hint Extern 1 => match goal with [H: (_ && _)        |- _] => apply andb_prop in H; destruct H end.
Hint Extern 1 => match goal with [H: (_ && _) = true |- _] => apply andb_prop in H; destruct H end.

Lemma exp_dec_bl : forall x y, exp_beq x y -> x = y. unfold is_true; induction x; destruct y; simpl; intros;
                                               discriminate || f_equal; destr bands; auto. Qed.
Hint Resolve exp_dec_bl.

Lemma exp_eqnP : Equality.axiom exp_beq.
Proof. intros x y; apply (iffP idP); auto. Qed.

Canonical exp_eqMixin := EqMixin exp_eqnP.
Canonical exp_eqType := EqType exp exp_eqMixin.

Instance Ids_exp : Ids exp. derive. Defined.
Instance Rename_exp : Rename exp. derive. Defined.
Instance Subst_exp : Subst exp. derive. Defined.
Instance SubstLemmas_exp : SubstLemmas exp. derive. Qed.

Tactic Notation "arewrite" := autorewrite with autosubst.

Infix ":>>" := Pi (at level 20, right associativity).
Infix ":#>" := Lam (at level 30, right associativity).
Infix ":$:" := App (at level 50, left associativity).
Notation "<< a ;; b >>" := (Pair__sigma a b).

(* Notation Prd A B := (Sigma A (B.[ren (+1)])). *)
(* Infix ":*:" := Prd (at level 10). *)

Notation wk n := (ren (+ n)).

Notation S_p1 e := (Rec__sigma (Bind 1) e).
Notation S_p2 e := (Rec__sigma (Bind 0) e).

(* Fixpoint All (d : desc) (P : {bind exp}) (e : exp) := *)
(*   match d with  *)
(*       d_One => Unit *)
(*     | d_Ind => P.[e/] *)
(*     | d_Sum d1 d2 => Split *)
(*                       (All d1 P.[up (wk 1)] (Bind 0)) *)
(*                       (All d2 P.[up (wk 1)] (Bind 0)) *)
(*                       e *)
(*     | d_Prd d1 d2 => S_rec (Prd (All d1 P.[up (wk 2)] (Bind 1)) (All d2 P.[up (wk 2)] (Bind 0))) e *)
(*   end. *)

(* Fixpoint rall (d : desc) (r : {bind exp}) (e : exp) := *)
(*   match d with *)
(*       d_One => unit *)
(*     | d_Ind => r.[e/] *)
(*     | d_Sum d1 d2 => Split *)
(*                       (* (All (d_Sum d1 d2) P (Bind 0))  *) *)
(*                       (rall d1 r.[up (wk 1)] (Bind 0)) *)
(*                       (rall d2 r.[up (wk 1)] (Bind 0)) *)
(*                       e *)
(*     | d_Prd d1 d2 => S_rec (S_mk (rall d1 r.[up (wk 2)] (Bind 1)) (rall d2 r.[up (wk 2)] (Bind 0))) e *)
(*   end. *)


Require Import FunctionalExtensionality.
Require Import coqrel.LogicalRelations.
Require Import structures.Lattice.
Require Import structures.Completion.
Require Import lattices.Downset.

(** * Interface *)

(** The upset lattice over a poset is a completely distributive
  completion that is meet dense and completely meet prime. We use it
  as an intermediate step in the construction of the free completely
  distributive lattice (see [Morris, 2005]). *)

Module Inf <: LatticeCategory.

  Class Morphism {L M : cdlattice} (f : L -> M) :=
    mor : forall {I} (x : I -> L), f (linf x) = inf i, f (x i).

  Lemma mor_meet `{Morphism} x y :
    f (x && y) = f x && f y.
  Proof.
    Local Transparent meet. unfold meet.
    rewrite (mor (f := f)). f_equal.
    apply functional_extensionality. intros b.
    destruct b; auto.
  Qed.

  Lemma mor_ref {L M : cdlattice} (f : L -> M) :
    Morphism f ->
    PosetMorphism f.
  Proof.
    intros Hf. split.
    intros x y Hxy.
    apply ref_meet in Hxy.
    rewrite <- Hxy, mor_meet.
    apply meet_lb_r.
  Qed.

  Lemma id_mor {L : cdlattice} :
    Morphism (fun x:L => x).
  Proof.
    red. auto.
  Qed.

  Lemma compose_mor {A B C : cdlattice} (g : B -> C) (f : A -> B) :
    Morphism f ->
    Morphism g ->
    Morphism (fun a => g (f a)).
  Proof.
    intros Hf Hg I x.
    rewrite (mor (f:=f)), (mor (f:=g)).
    reflexivity.
  Qed.

  Hint Immediate mor_ref : typeclass_instances.

End Inf.

(** * Construction *)

Module Upset : LatticeCompletion Inf.

  (** ** Opposite order *)

  (** To avoid redundancies, we define the opposite order and lattice,
    and construct upsets by dualizing the [Downset] completion. This
    may or may not result in a lower complexity than copy-and-pasting,
    so we should evaluate once the [Downset] proofs are completed. *)

  Program Definition opp_poset (C : poset) : poset :=
    {|
      poset_carrier := C;
      ref x y := y [= x;
    |}.
  Next Obligation.
    split.
    - intros x. reflexivity.
    - intros x y z Hyz Hxy. etransitivity; eauto.
  Qed.
  Next Obligation.
    intros x y Hxy Hyx.
    apply antisymmetry; auto.
  Qed.

  Program Definition opp_cdlat (L : cdlattice) : cdlattice :=
    {|
      cdl_poset := opp_poset L;
      lsup I x := linf x;
      linf I x := lsup x;
    |}.
  Next Obligation. eapply (inf_lb i). Qed.
  Next Obligation. apply inf_glb; auto. Qed.
  Next Obligation. apply sup_ub; auto. Qed.
  Next Obligation. apply sup_lub; auto. Qed.
  Next Obligation. apply inf_sup. Qed.

  (*
  Definition opp_map {A B} (f : A -> B) : opp A -> opp B :=
    fun '(opp_in a) => opp_in (f a).

  Instance opp_map_ref {A B} `{Poset A} `{Poset B} (f : A -> B) :
    PosetMorphism f ->
    PosetMorphism (opp_map f).
  Proof.
    intros Hf. split. intros [x] [y] Hxy. cbn in *. rauto.
  Qed.
   *)

  (** ** Upsets *)

  Definition F (C : poset) := opp_cdlat (downset (opp_poset C)).

  Section DEFS.
    Context {C : poset}.

    Definition emb (c : C) : F C :=
      Downset.emb (c : opp_poset C).

    Lemma emb_mor c1 c2 : emb c1 [= emb c2 <-> c1 [= c2.
    Proof.
      split; intro Hc; cbn in *.
      - rewrite Downset.emb_mor in Hc. assumption.
      - rewrite Downset.emb_mor. assumption.
    Qed.

    Context {L : cdlattice}.

    Definition ext (f : C -> L) (x : F C) : L :=
      Downset.ext (f : opp_poset C -> opp_cdlat L) (x : downset (opp_poset C)).

    Context {f : C -> L} `{Hf : !PosetMorphism f}.

    Instance ext_mor :
      Inf.Morphism (ext f).
    Proof.
      intros I x. unfold ext. cbn.
      rewrite Sup.mor. cbn. auto.
    Qed.

    Lemma ext_ana :
      (forall x, ext f (emb x) = f x).
    Proof.
      intros x. unfold ext, emb. cbn.
      rewrite @Downset.ext_ana. cbn. auto.
      firstorder.
    Qed.

    Lemma ext_unique (g : F C -> L) `{Hg : !Inf.Morphism g} :
      (forall x, g (emb x) = f x) -> forall x, g x = ext f x.
    Proof.
      intros Hgf x.
      unfold emb, ext in *. cbn in *.
      erewrite <- @Downset.ext_unique; eauto.
      firstorder.
    Qed.
  End DEFS.

  Include (LatticeCompletionDefs Inf).

End Upset.

Notation upset := Upset.F.
Notation up := Upset.emb.


Require Export ZArith.
Require Export Zwf.
Require Export Inverse_Image.
Require Export Wellfounded.
Require Import Extraction.

Section little_abstract_semantics.
Variables
  (Var aExp bExp state : Set)
  (evalA : state -> aExp -> option Z)
  (evalB : state -> bExp -> option bool)
  (update : state -> Var -> Z -> option state).

Inductive inst : Set :=
  | Skip : inst
  | Assign : Var -> aExp -> inst
  | Scolon : inst -> inst -> inst
  | WhileDo : bExp -> inst -> inst.

Arguments Some [A] _.

(* The semantics of the language is given in chapter 7. *)

Inductive exec : state -> inst -> state -> Prop :=
  | execSkip : forall s:state, exec s Skip s
  | execAssign :
      forall (s s1:state) (v:Var) (n:Z) (a:aExp),
        evalA s a = Some n ->
        update s v n = Some s1 -> exec s (Assign v a) s1
  | execScolon :
      forall (s s1 s2:state) (i1 i2:inst),
        exec s i1 s1 -> exec s1 i2 s2 -> exec s (Scolon i1 i2) s2
  | execWhileFalse :
      forall (s:state) (i:inst) (e:bExp),
        evalB s e = Some false -> exec s (WhileDo e i) s
  | execWhileTrue :
      forall (s s1 s2:state) (i:inst) (e:bExp),
        evalB s e = Some true ->
        exec s i s1 -> exec s1 (WhileDo e i) s2 -> exec s (WhileDo e i) s2.
(* We need to use the evaluation functions as if they were total.  extract_option
   makes them total by adding a default value. *)

Definition extract_option {A:Type} (x:option A) (def:A) : A :=
  match x with
  | None => def
  | Some v => v
  end.

(* When a while loop contains a variable that is decreased at each
  step and tested against a bound, it is obvious that this loop will
  terminate.  We consider such loops are "for" loops.*)

Inductive forLoops : inst -> Prop :=
  | aForLoop :
      forall (e:bExp) (i:inst) (variant:aExp),
        (forall s s':state,
           evalB s e = Some true ->
           exec s i s' ->
           Zwf 0 (extract_option (evalA s' variant) 0%Z)
             (extract_option (evalA s variant) 0%Z)) ->
        forLoops i -> forLoops (WhileDo e i)
  | assignFor : forall (v:Var) (e:aExp), forLoops (Assign v e)
  | skipFor : forLoops Skip
  | scolonFor :
      forall i1 i2:inst,
        forLoops i1 -> forLoops i2 -> forLoops (Scolon i1 i2).

(* Following a suggestion by C. McBride and J. McKinna in "The view from the left. "
  we use an auxillary function to perform case analysis instead of using dependent
  pattern-matching construct.  This relies on a "sister type" where pattern matching
  information is gathered in an equality. *)

Inductive inst_cases_type (i:inst) : Set :=
  | is_Skip : i = Skip -> inst_cases_type i
  | is_assign : forall (v:Var) (e:aExp), i = Assign v e -> inst_cases_type i
  | is_seq : forall i1 i2:inst, i = Scolon i1 i2 -> inst_cases_type i
  | is_while :
      forall (b:bExp) (i':inst), i = WhileDo b i' -> inst_cases_type i.

(* We avoid dependent pattern matching in the main function, but of course
  this auxillary function has to do the dirty work. *)

Definition inst_cases (i:inst) : inst_cases_type i :=
  match i as x return inst_cases_type x with
  | Assign v e => is_assign (Assign v e) v e (refl_equal (Assign v e))
  | Scolon i1 i2 => is_seq (Scolon i1 i2) i1 i2 (refl_equal (Scolon i1 i2))
  | WhileDo b i => is_while (WhileDo b i) b i (refl_equal (WhileDo b i))
  | Skip => is_Skip Skip (refl_equal Skip)
  end.

(* We are going to use recursion on an ad-hoc predicate to define our function.
  This requires that we prove inversion lemmas by case analysis and make sure
  these lemmas are transparent. *)

Theorem forLoops_Inv_seq1 :
 forall i:inst,
   forLoops i -> forall i1 i2:inst, i = Scolon i1 i2 -> forLoops i1.
Proof.
intros i h; case h; try (intros; discriminate).
intros i1 i2 H H0 i0 i3 H1; injection H1.
intros heq2 heq1; rewrite <- heq1; assumption.
Defined.

Theorem forLoops_Inv_seq2 :
 forall i:inst,
   forLoops i -> forall i1 i2:inst, i = Scolon i1 i2 -> forLoops i2.
Proof.
intros i h; case h; try (intros; discriminate).
intros i1 i2 H H0 i0 i3 H1; injection H1.
intros heq2 heq1; rewrite <- heq2; assumption.
Defined.

Theorem forLoops_Inv_while2 :
 forall i:inst,
   forLoops i -> forall (b:bExp) (i':inst), i = WhileDo b i' -> forLoops i'.
Proof.
 intros i h; case h; try (intros; discriminate).
 intros e i0 variant H H0 b i' H1; injection H1.
 intros heq2 heq1; rewrite <- heq2; assumption.
Defined.

Inductive exec_or_not (s:state) (i:inst) : Set :=
  | result : forall s':state, exec s i s' -> exec_or_not s i
  | no_result : (forall s':state, ~ exec s i s') -> exec_or_not s i.

Parameter
  exec_det :
    forall (s s' s'':state) (i:inst), exec s i s' -> exec s i s'' -> s' = s''.

(* We invent a new relation indexed by instructions and boolean expressions.
  If the indexes are i and b, we say that two states s1 and s2 are related if
  s1 is the result of executing i from state s2 and if b evaluates to true in b.
  Intuitively, i will be used as the body of a while loop construct and b as the
  halting condition for this loop.  In general, this relation is NOT well-founded.*)

Definition state_loop_order (i:inst) (b:bExp) (s1 s2:state) : Prop :=
  evalB s2 b = Some true /\ exec s2 i s1.

(* If the loop (WhileDo b i) is a "for" loop, then there is something
  that decreases each time the loop body is executed (by definition).
  This makes it possible to prove that the relation (state_loop_order i b) is
  well-founded.*)

Theorem state_loop_order_wf :
 forall (b:bExp) (i:inst),
   forLoops (WhileDo b i) -> well_founded (state_loop_order i b).
Proof.
  intros b i h; inversion h.
  apply wf_incl with
  (fun s1 s2:state =>
     Zwf 0 (extract_option (evalA s1 variant) 0%Z)
         (extract_option (evalA s2 variant) 0%Z)).
   unfold Relation_Definitions.inclusion in |- *.
   unfold state_loop_order in |- *; intros x y [H3 H4].
   apply H1.
   apply H3.
   apply H4.
   apply
     (wf_inverse_image state Z (Zwf 0)
                       (fun s:state => extract_option (evalA s variant) 0%Z)
                       (Zwf_well_founded 0)).
Qed.

(* If i is the Skip instruction, it is always possible to decide whether
   executing i will succeed or not.*)

Lemma exec_skip : forall (i:inst) (s:state), i = Skip -> exec_or_not s i.
Proof.
  intros i s heq;
 exact (result s i s (eq_ind_r (fun j:inst => exec s j s) (execSkip s) heq)).
Defined.

(* If i is an assignment, it is always possible to decide whether
  executing i will succeed or not.*)

Lemma exec_assign :
 forall (i:inst) (s:state) (v:Var) (e:aExp),
   i = Assign v e -> exec_or_not s i.
Proof.
 intros i s v e heq; case_eq (evalA s e).
 - intros v' heqa; case_eq (update s v v').
   + intros s' Hequ; apply (result s i s').
     rewrite heq.
     apply execAssign with v'; assumption.
   + intros heq_None; apply no_result.
     rewrite heq; intros s' H; inversion H.
     rewrite heqa in H3; injection H3.
     intros heqv'; rewrite heqv' in heq_None; rewrite H5 in heq_None.
     discriminate.
 - intros heq_None; apply no_result.
   rewrite heq; intros s' H; inversion H.
   rewrite H3 in heq_None; discriminate.
Defined.

(* If i is a sequence of two instructions and we already have two functions
   that can decide the success of execution for these instructions, then
   deciding the success for these instructions is an easy matter.*)

Lemma exec_sequence :
 forall (i:inst) (s:state) (i1 i2:inst),
   i = Scolon i1 i2 ->
   forall (f1:forall s:state, exec_or_not s i1)
     (f2:forall s:state, exec_or_not s i2), exec_or_not s i.
Proof.
 intros i s i1 i2 heq f1 f2.
 case (f1 s).
 - intros s1 Hexec1; case (f2 s1).
   + intros s2 Hexec2; apply (result s i s2).
     rewrite heq; apply execScolon with s1; assumption.
   + intros Hnot; apply no_result.
     rewrite heq.
     intros s'; red in |- *; intros H; inversion H.
     elim (Hnot s').
     rewrite (exec_det s s1 s2 i1); assumption.
 - intros Hnot; apply no_result.
   rewrite heq.
   intros s' H; inversion H.
   elim (Hnot s1); assumption.
Defined.

(** Now comes the difficult part.  If i is a loop, the body of which is i',
  then it is in general not possible to decide whether the execution will
  succeed or not.  On the other hand, if the loop is a "for" loop and we
  are given a function that can decide whether executing i' succeeds, then
  we can use well-founded recursion to define a function that repeats
  the body as many times until execution fails or succeeds.  This is
  guaranteed to terminate thanks to the proof of state_loop_order_wf. *)

Lemma exec_forLoop :
 forall (i i':inst) (b:bExp) (s:state),
   i = WhileDo b i' ->
   forLoops (WhileDo b i') ->
   forall f:forall s:state, exec_or_not s i', exec_or_not s i.
Proof.
 intros i i' b s heq h' f;
  apply
    (well_founded_induction (state_loop_order_wf b i' h')
                            (fun s:state => exec_or_not s i)).
 intros s0 loop_again.
 case_eq (evalB s0 b).
 -  intros vb; case vb.
    + intros heqCond; elim (f s0).
      * intros s1 Hexeci'; elim (loop_again s1).
       intros s2 Hexeci; apply (result s0 i s2).
       rewrite heq.
       apply execWhileTrue with (s1 := s1); try assumption.
       rewrite <- heq.
       apply Hexeci.
       intros Hnot; apply no_result.
       rewrite heq; intros s' H; inversion H.
       rewrite H2 in heqCond.
       rewrite heqCond in H4.
       discriminate H4.
       elim (Hnot s').
       rewrite (exec_det s0 s1 s3 i'); try assumption.
       rewrite heq.
       assumption.
       split; assumption.
    * intros Hnot; apply no_result.
      rewrite heq; intros s' H; inversion H.
      rewrite H2 in heqCond; rewrite H4 in heqCond.
      discriminate.
      elim (Hnot s2); assumption.
    + intros heqCond; apply (result s0 i s0).
      rewrite heq.
      apply execWhileFalse; assumption.
 - intros heqCond; apply no_result.
   rewrite heq.
   intros s' H; inversion H.
   rewrite H2 in heqCond.
   rewrite H4 in heqCond; discriminate heqCond.
   rewrite H2 in heqCond.
discriminate heqCond.
Defined.

(*This is the main recursive function.  Note that its definition relies on
  the advanced technique of recursion on an ad-hoc predicate.  In fact, the
  whole execution process relies on a nested recursion, since loops are
  executed using well-founded recursion inside the exec_forLoop function.*)

Definition exl : forall i:inst, forLoops i -> forall s:state, exec_or_not s i.
refine
 (fix exl (i:inst) (h:forLoops i) {struct h} :
    forall s:state, exec_or_not s i :=
    fun s =>
      match inst_cases i with
      | is_Skip _ heq => exec_skip i s heq
      | is_assign _ v e heq => exec_assign i s v e heq
      | is_seq _ i1 i2 heq => exec_sequence i s i1 i2 heq _ _
      | is_while _ b i' heq => exec_forLoop i i' b s heq _ _
      end).
Proof.
  exact (exl i1 (forLoops_Inv_seq1 i h i1 i2 heq)).
  exact (exl i2 (forLoops_Inv_seq2 i h i1 i2 heq)).
  rewrite <- heq; assumption.
  exact (exl i' (forLoops_Inv_while2 i h b i' heq)).
Defined.
(* This function has the type required in the exercise. *)

Definition execute_loops :
  forall (s:state) (i:inst),
    forLoops i ->
    {s' : state | exec s i s'} + {(forall s':state, ~ exec s i s')}.
Proof.
  intros s i h; elim (exl i h s).
  - left; exists s'; assumption.
  -right; assumption.
Defined.

End little_abstract_semantics.

(* This is not part of the exercise. *)

(* Here we want to instantiate the various types to build a minimal
   programming language and show we can build a program that satisfies
   the "forLoops" predicate. *)

Arguments Some [A] _.

Require Export List.
Require Export Arith.
Require Export Compare_dec.
Require Export Lia.

Inductive aExp : Set :=
  | aPlus : aExp -> aExp -> aExp
  | aNum : Z -> aExp
  | aVar : nat -> aExp.

Inductive bExp : Set :=
    bGt : aExp -> aExp -> bExp.

Definition state := list Z.

Fixpoint lookup (idx:nat) (s:state) {struct idx} :
 option Z :=
  match idx, s with
  | O, a :: _ => Some a
  | S p, _ :: tl => lookup p tl
  | _, _ => None (A:=Z)
  end.

Fixpoint evalA (s:state) (e:aExp) {struct e} : option Z :=
  match e with
  | aPlus e1 e2 =>
      match evalA s e1, evalA s e2 with
      | Some n1, Some n2 => Some (n1 + n2)%Z
      | _, _ => None (A:=Z)
      end
  | aNum n => Some n
  | aVar n => lookup n s
  end.

Definition evalB (s:state) (e:bExp) : option bool :=
  match e with
  | bGt e1 e2 =>
      match evalA s e1, evalA s e2 with
      | Some n1, Some n2 =>
          match Z_le_gt_dec n1 n2 with
          | left _ => Some false
          | right _ => Some true
          end
      | _, _ => None (A:=bool)
      end
  end.

Fixpoint update (s:state) (n:nat) (x:Z) {struct n} :
 option state :=
  match s, n with
  | a :: tl, O => Some (x :: tl)
  | a :: tl, S p =>
      match update tl p x with
      | Some tl' => Some (a :: tl')
      | _ => None (A:=state)
      end
  | _, _ => None (A:=state)
  end.

Arguments Assign [Var aExp bExp].
Arguments WhileDo [Var aExp bExp].
Arguments Scolon [Var aExp bExp].

Example fact3 :=
  Scolon (Assign 1 (aNum 3))
    (Scolon (Assign 2 (aNum 1))
       (WhileDo (bGt (aVar 1) (aNum 0))
          (Scolon (Assign 0 (aVar 1))
             (Scolon (Assign 1 (aPlus (aVar 1) (aNum (-1))))
                (Scolon (Assign 3 (aVar 2))
                   (Scolon (Assign 2 (aNum 0))
                      (WhileDo (bGt (aVar 0) (aNum 0))
                         (Scolon (Assign 0 (aPlus (aVar 0) (aNum (-1))))
                            (Assign 2 (aPlus (aVar 2) (aVar 3))))))))))).

Fixpoint noAssign (n:nat) (i:inst nat aExp bExp) {struct i} : bool :=
  match i with
  | Skip _ _ _  => true
  | Scolon  i1 i2 =>
      match noAssign n i1 with
      | true => noAssign n i2
      | false => false
      end
  | WhileDo b i' => noAssign n i'
  | Assign v e =>
      match eq_nat_dec v n with
      | left _ => false
      | right _ => true
      end
  end.

Theorem lookup_update_eq :
 forall (n:nat) (s s':state) (v:Z),
   update s n v = Some s' -> lookup n s' = Some v.
Proof.
simple induction n.
- intros s; case s.
  + intros; discriminate.
  + simpl in |- *; intros z tl s' v Heq; injection Heq; intros Heq1;
    rewrite <- Heq1; trivial.
- intros p Hrec s; case s; simpl in |- *; try (intros; discriminate).
  intros z l s' v; generalize (fun s':state => Hrec l s' v).
  case (update l p v); simpl in |- *; try (intros; discriminate).
  intros s'0 Hrec' Heq; injection Heq; intros Heq1; rewrite <- Heq1;
 simpl in |- *; rewrite Hrec'; auto.
Qed.

Theorem lookup_update_diff :
 forall (n m:nat) (s s':state) (v:Z),
   update s n v = Some s' -> n <> m -> lookup m s' = lookup m s.
Proof.
 simple induction n.
 - intros m; case m.
   + intros s s' v H H1; elim H1; auto.
   + intros m' s; case s; simpl in |- *; try (intros; discriminate).
     * intros z tl s' v Heq; injection Heq; intros Heq1; now rewrite <- Heq1.
 - intros p Hrec m; case m; simpl in |- *.
   + intros s; case s; simpl in |- *; try (intros; discriminate).
     intros z l s' v; case (update l p v); simpl in |- *;
     try (intros; discriminate).
     intros s'0 Heq; injection Heq; intros Heq1; now rewrite <- Heq1.
   + intros m' s; case s; simpl in |- *; try (intros; discriminate).
     intros z l s' v; generalize (fun s':state => Hrec m' l s' v);
     case (update l p v); try (intros; discriminate).
     intros s'0 Hrec' Heq; injection Heq; intros Heq1; rewrite <- Heq1.
     intros Hneq; apply Hrec'; auto with arith.
Qed.

Theorem noAssign_noChange :
 forall (n:nat) (i:inst nat aExp bExp),
   noAssign n i = true ->
   forall s s':state,
     exec nat aExp bExp state evalA evalB update s i s' ->
     evalA s (aVar n) = evalA s' (aVar n).
Proof.
  intros n i Heq s s' Hexec; generalize n Heq; clear Heq n;  elim Hexec.
  -  auto.
  - simpl in |- *;
    intros s0 s1 v n' a Heval Hupdate n; case (eq_nat_dec v n).
    + discriminate.
    + intros; symmetry  in |- *; apply lookup_update_diff with v n'; auto.
  - simpl in |- *; intros s0 s1 s2 i1 i2 Hex1 Hrec1 Hex2 Hrec2 n.
    generalize (Hrec1 n) (Hrec2 n); clear Hrec1 Hrec2.
    case (noAssign n i1); simpl in |- *; try (intros; discriminate).
    case (noAssign n i2); simpl in |- *; try (intros; discriminate).
    transitivity (lookup n s1); auto.
 - auto.
 - simpl in |- *; intros s0 s1 s2 i' b Heval Hex1 Hrec1 Hex2 Hrec2 n;
   generalize (Hrec1 n) (Hrec2 n); clear Hrec1 Hrec2.
   intros; transitivity (lookup n s1); auto.
Qed.

Theorem forLoops_fact3 :
 forLoops nat aExp bExp state evalA evalB update fact3.
Proof.
 unfold fact3 in |- *; repeat constructor.
 apply aForLoop with (aVar 1).
 intros s; case s.
 -  intros s' Hevgt1 Hexec1; inversion Hexec1.
    inversion H2; simpl in H10; discriminate.
 -  intros v0 s0; case s0.
    +  intros s' Hevgt1 Hexec1; inversion Hexec1.
       inversion H2.
       simpl in H8; discriminate.
    +  intros v1 s1 s' Hevgt1 Hexec1; inversion Hexec1.
       inversion H2.
       simpl in H8.
       simpl in H10.
       injection H8; clear H8; intros H8.
       subst v1; clear Hexec1; inversion H4.
       rewrite <- noAssign_noChange with (2 := H15).
       *  inversion H13.
          simpl in H19.
          injection H10.
          intros Heq1.
          rewrite <- Heq1 in H19, H21.
          injection H19; clear H19; intros H19.
          rewrite <- H19 in H21; simpl in H21; injection H21.
          intros Heq2; rewrite <- Heq2; simpl in |- *.
          unfold Zwf in |- *; auto with zarith.
          inversion Hevgt1.
          generalize H23;
            case (Z_le_gt_dec n 0); simpl in |- *; try (intros; discriminate).
          intros; lia.
       *  simpl in |- *; auto.
 - repeat constructor.
   apply aForLoop with (aVar 0).
  +  intros s s'; lazy beta iota zeta delta [evalB] in |- *; fold evalB in |- *.
     intros Hevgt Hexec; inversion Hexec.
     inversion H2.
     rewrite <- noAssign_noChange with (2 := H4).
     *  lazy beta iota zeta delta [evalA] in H8; fold evalA in H8.
        generalize H8; clear H8; case_eq (lookup 0 s).
        intros z Hlk H8; injection H8; clear H8; intros H8.
        lazy beta iota zeta delta [evalA] in |- *.
        rewrite lookup_update_eq with (1 := H10).
        rewrite Hlk; rewrite <- H8.
        generalize Hevgt; lazy beta iota zeta delta [evalA] in |- *.
        rewrite Hlk.
        case (Z_le_gt_dec z 0); simpl in |- *; try (intros; discriminate).
        unfold Zwf in |- *; intros; lia.
        intros; discriminate.
     * simpl in |- *; auto.
+ repeat constructor.
Qed.

Definition execute_loops2 :=
  execute_loops nat aExp bExp state evalA evalB update.

Definition value :=
  execute_loops2 (0%Z :: 0%Z :: 0%Z :: 0%Z :: nil) fact3 forLoops_fact3.

(* We use extracted code to test the value of our program instead of
  evaluating inside Coq *)

Extraction "execute_loops" execute_loops2 fact3 value.