Set Universe Polymorphism.
Set Primitive Projections.

Record sig A (P : A -> Type) := exist {
  wit : A;
  prf : P wit;
}.

Arguments wit {_ _} _.
Arguments prf {_ _} _.

Record prod A B := pair { fst : A; snd : B }.

Arguments pair {_ _} _ _.
Arguments fst {_ _} _.
Arguments snd {_ _} _.

Inductive nlist (A : Type) :=
| nil : A -> nlist A
| cons : A -> nlist A -> nlist A.

Definition ret {A} (x : A) := nil A x.

Fixpoint map {A B} (f : A -> B) (l : nlist A) : nlist B :=
match l with
| nil _ x => nil _ (f x)
| cons _ x l => cons _ (f x) (map f l)
end.

Fixpoint pointwise {A} (f : A -> Type) (l : nlist A) : Type :=
match l with
| nil _ x => f x
| cons _ x l => prod (f x) (pointwise f l)
end.

Definition TYPE := nlist (sig Type (fun A => nlist A -> A)).

Definition mkTYPE (A : Type) (alg : nlist A -> A) : TYPE := nil _ (exist _ _ A alg).

Definition El (A : TYPE) : Type := pointwise wit A.

Fixpoint app {A} (l1 l2 : nlist A) :=
match l1 with
| nil _ x => cons _ x l2
| cons _ x l1 => cons _ x (app l1 l2)
end.

Fixpoint bind {A B} (l : nlist A) (f : A -> nlist B) : nlist B :=
match l with
| nil _ x => f x
| cons _ x l => app (f x) (bind l f)
end.

Fixpoint happ {A} : El A -> El A -> El A :=
match A return El A -> El A -> El A with
| nil _ A => fun x y => A.(prf) (cons _ x (nil _ y))
| cons _ A T => fun x y =>
  pair (A.(prf) (cons _ x.(fst) (nil _ y.(fst))))  (happ x.(snd) x.(snd))
end.

(*
Fixpoint hbind {A B} (l : nlist A) (f : A -> El B) {struct l} : El B :=
match l with
| nil _ x => f x
| cons _ x l => happ (f x) (hbind l f)
end.
*)

Definition hbind {A B} (l : nlist A) (f : A -> El B) : El B :=
(fix F l := match l with
| nil _ x => f x
| cons _ x l => happ (f x) (F l)
end) l.

Definition Typeᶫ : TYPE.
Proof.
refine (ret (exist _ _ TYPE _)).
refine (fun T => bind T (fun X => X)).
Defined.

Check Typeᶫ : El Typeᶫ.

Definition free A := mkTYPE (nlist A) (fun b => bind b (fun X => X)).

Definition pointwise_app {A} (f : A -> Type) (l1 l2 : nlist A)
  (p1 : pointwise f l1) (p2 : pointwise f l2) : pointwise f (app l1 l2) :=
(fix F l1 := match l1 return pointwise f l1 -> pointwise f (app l1 l2) with
| nil _ x => fun p1 => pair p1 p2
| cons _ x l1 => fun p1 => pair p1.(fst) (F l1 p1.(snd))
end) l1 p1.

(*
Fixpoint pointwise_app {A} (f : A -> Type) (l1 l2 : nlist A)
  (p1 : pointwise f l1) (p2 : pointwise f l2) {struct l1} : pointwise f (app l1 l2) :=
match l1 return forall l2, pointwise f l1 -> _ -> pointwise f (app l1 l2) with
| nil _ x => fun l2 p1 p2 => pair p1 p2
| cons _ x l1 => fun l2 p1 p2 => pair p1.(fst) (pointwise_app f l1 l2 p1.(snd) p2)
end l2 p1 p2.
*)

Fixpoint pbind {A} {B : A -> El Typeᶫ} (l : nlist A) (f : forall x : A, El (B x)) {struct l} : El (hbind l B) :=
match l return El (hbind l B) with
| nil _ x => f x
| cons _ x l => @pointwise_app _ wit (B x) (hbind l B) (f x) (pbind l f)
end.

Definition Prodᶫ (A : TYPE) (B : El A -> TYPE) : TYPE.
Proof.
refine (nil _ (exist _ _ (forall x : El A, El (B x)) _)).
refine (fun f x => hbind f (fun f => f x)).
Defined.

Notation "A →ᶫ B" := (Prodᶫ A (fun _ => B)) (at level 99, right associativity, B at level 200).
Notation "'Πᶫ'  x .. y , P" := (Prodᶫ _ (fun x => .. (Prodᶫ _ (fun y => P)) ..))
  (at level 200, x binder, y binder, right associativity).

Definition Lamᶫ {A B} (f : forall x : El A, El (B x)) : El (Prodᶫ A B) := f.
Definition Appᶫ {A B} (f : El (Prodᶫ A B)) (x : El A) := f x.

Definition pbind' {A R}
  {B : A -> El (R  →ᶫ Typeᶫ)}
  (l : nlist A) (r : El R) (f : forall x : A, El (B x r)) : El (hbind l B r) :=
(fix F l := match l return El (hbind l B r) with
| nil _ x => f x
| cons _ x l => @pointwise_app _ wit (B x r) (hbind l B r) (f x) (F l)
end) l.

Definition boolᶫ : TYPE.
Proof.
refine (nil _ (exist _ _ (nlist bool) _)).
refine (fun b => bind b (fun b => b)).
Defined.

Definition trueᶫ : El boolᶫ := nil _ true.
Definition falseᶫ : El boolᶫ := nil _ false.

Definition bool_caseᶫ (P : TYPE) (Pt : El P) (Pf : El P) (b : El boolᶫ) : El P :=
  hbind b (fun b => if b then Pt else Pf).

Check (eq_refl : (fun P Pt Pf => bool_caseᶫ P Pt Pf trueᶫ) = (fun P Pt Pf => Pt)).
Check (eq_refl : (fun P Pt Pf => bool_caseᶫ P Pt Pf falseᶫ) = (fun P Pt Pf => Pf)).

Definition θ_bool (n : El boolᶫ) : (El boolᶫ -> El Typeᶫ) -> El Typeᶫ :=
  bool_caseᶫ ((boolᶫ →ᶫ Typeᶫ) →ᶫ Typeᶫ) (fun k => k trueᶫ) (fun k => k falseᶫ) n.

Definition bool_recᶫ (P : El boolᶫ -> TYPE)
  (Pt : El (P trueᶫ)) (Pf : El (P falseᶫ)) (b : El boolᶫ) : El (θ_bool b P) :=
  @pbind' bool (boolᶫ →ᶫ Typeᶫ) _ b P (bool_rec _ Pt Pf).

Check (eq_refl : (fun P Pt Pf => bool_recᶫ P Pt Pf trueᶫ) = (fun P Pt Pf => Pt)).
Check (eq_refl : (fun P Pt Pf => bool_recᶫ P Pt Pf falseᶫ) = (fun P Pt Pf => Pf)).

Inductive nat_ :=
| O_ : nat_
| S_ : nlist nat_ -> nat_.

Definition natᶫ : TYPE := mkTYPE (nlist nat_) (fun l => bind l (fun n => n)).

Definition Oᶫ : El natᶫ := ret O_.
Definition Sᶫ : El (natᶫ →ᶫ natᶫ) := fun n => ret (S_ n).

Definition nat_caseᶫ (P : TYPE) (P0 : El P) (PS : El natᶫ -> El P -> El P) (n : El natᶫ) : El P.
Proof.
refine (hbind n (fun n => _)).
refine ((fix F n := match n return El P with O_ => P0 | S_ n => PS n (hbind n F) end) n).
Defined.

Check (eq_refl : (fun P P0 PS n => nat_caseᶫ P P0 PS Oᶫ) = (fun P P0 PS n => P0)).
Check (eq_refl : (fun P P0 PS n => nat_caseᶫ P P0 PS (Sᶫ n)) = (fun P P0 PS n => PS n (nat_caseᶫ P P0 PS n))).

Definition θ_nat (n : El natᶫ) : (El natᶫ -> El Typeᶫ) -> El Typeᶫ :=
  nat_caseᶫ ((natᶫ →ᶫ Typeᶫ) →ᶫ Typeᶫ) (fun k => k Oᶫ) (fun _ r k => r (fun n => k (Sᶫ n))) n.

Definition nat_rectᶫ (P : El natᶫ -> TYPE) (P0 : El (P Oᶫ)) (PS : forall n : El natᶫ, El (θ_nat n P) -> El (θ_nat (Sᶫ n) P)) (n : El natᶫ) :
  El (θ_nat n P).
Proof.
refine (pbind' n _ (fun n => _)).
match goal with [ |- El (?X n P) ] => set (K := X) end.
refine ((fix F n := match n return El (K n P) with O_ => P0 | S_ n => PS n _ end) n).
refine (@pbind' nat_ (Πᶫ _ : El natᶫ, Typeᶫ) _ n P F).
Defined.

Check (eq_refl : (fun P P0 PS n => nat_rectᶫ P P0 PS Oᶫ) = (fun P P0 PS n => P0)).
Check (eq_refl : (fun P P0 PS n => nat_rectᶫ P P0 PS (Sᶫ n)) = (fun P P0 PS n => PS n (nat_rectᶫ P P0 PS n))).

Inductive list_ (A : TYPE) :=
| nil_ : list_ A
| cons_ : El A -> nlist (list_ A) -> list_ A.

Definition listᶫ : El (Typeᶫ →ᶫ Typeᶫ) :=
  fun A => mkTYPE (nlist (list_ A)) (fun l => bind l (fun n => n)).

Definition nilᶫ : El (Πᶫ (A : El Typeᶫ), listᶫ A) := fun A => ret (nil_ A).
Definition consᶫ : El (Πᶫ (A : El Typeᶫ), A →ᶫ listᶫ A →ᶫ listᶫ A) :=
  fun A x l => ret (cons_ A x l).

Definition list_caseᶫ : El (Πᶫ (A : El Typeᶫ) (P : El Typeᶫ) (P0 : El P) (PS : El (A →ᶫ listᶫ A →ᶫ P →ᶫ P)) (l : El (listᶫ A)), P).
Proof.
intros A P P0 PS l.
refine (hbind l (fun l => _)).
refine ((fix F n := match n return El P with nil_ _ => P0 | cons_ _ x l => PS x l (hbind l F) end) l).
Defined.

Check (eq_refl : (fun A P P0 PS => list_caseᶫ A P P0 PS (nilᶫ A)) = (fun A P P0 PS => P0)).
Check (eq_refl : (fun A P P0 PS x l => list_caseᶫ A P P0 PS (consᶫ A x l)) = (fun A P P0 PS x l => PS x l (list_caseᶫ A P P0 PS l))).

Definition θ_list : El (Πᶫ (A : El Typeᶫ), listᶫ A →ᶫ (listᶫ A →ᶫ Typeᶫ) →ᶫ Typeᶫ) :=
  fun A l k => list_caseᶫ A ((listᶫ A →ᶫ Typeᶫ) →ᶫ Typeᶫ) (fun k => k (nilᶫ A)) (fun x _ r k => r (fun l => k (consᶫ A x l))) l k.

Definition list_rectᶫ : El (Πᶫ
    (A : El Typeᶫ) (P : El (listᶫ A →ᶫ Typeᶫ))
    (P0 : El (P (nilᶫ A)))
    (PS : El (Πᶫ (x : El A) (l : El (listᶫ A)), θ_list A l P →ᶫ θ_list A (consᶫ A x l) P))
    (l : El (listᶫ A)),
      θ_list A l P).
Proof.
intros A P P0 PS l.
refine (pbind' l _ (fun l => _)).
match goal with [ |- El (?X l P) ] => set (K := X) end.
refine ((fix F l := match l return El (K l P) with nil_ _ => P0 | cons_ _ x l => PS x l _ end) l).
refine (@pbind' (list_ A) (Πᶫ _ : El (listᶫ A), Typeᶫ) _ l P F).
Defined.

Check (eq_refl : (fun A P P0 PS => list_rectᶫ A P P0 PS (nilᶫ A)) = (fun A P P0 PS => P0)).
Check (eq_refl : (fun A P P0 PS x l => list_rectᶫ A P P0 PS (consᶫ A x l)) = (fun A P P0 PS x l => PS x l (list_rectᶫ A P P0 PS l))).

Inductive eq_ (A : El Typeᶫ) (x : El A) : El A -> Type :=
| refl_ : eq_ A x x.

Definition eqᶫ : El (Πᶫ (A : El Typeᶫ), A →ᶫ A →ᶫ Typeᶫ) :=
  fun A x y => mkTYPE (nlist (eq_ A x y)) (fun l => bind l (fun n => n)).

Definition reflᶫ : El (Πᶫ (A : El Typeᶫ) (x : El A), eqᶫ A x x) :=
  fun A x => ret (refl_ A x).

Definition eq_caseᶫ : El (
  Πᶫ (A : El Typeᶫ) (x : El A) (P : El (A →ᶫ Typeᶫ)),
  P x →ᶫ Πᶫ (y : El A), eqᶫ A x y →ᶫ P y).
Proof.
intros A x P p y e.
refine (hbind e (fun e => _)).
refine (eq__rect A x (fun y _ => El (P y)) p y e).
Defined.

Check (eq_refl : (fun A x P p => eq_caseᶫ A x P p x (reflᶫ A x)) = (fun A x P p => p)).

Definition θ_eq : El (
  Πᶫ (A : El Typeᶫ) (x : El A) (y : El A),
    eqᶫ A x y →ᶫ (Πᶫ (y : El A), eqᶫ A x y →ᶫ Typeᶫ) →ᶫ Typeᶫ
  ) :=
  fun A x y e =>
    eq_caseᶫ A x (fun y => (Πᶫ (y : El A), eqᶫ A x y →ᶫ Typeᶫ) →ᶫ Typeᶫ) (fun k => k x (reflᶫ A x)) _ e.

Definition eq_rectᶫ : El (
  Πᶫ (A : El Typeᶫ) (x : El A)
    (P : El (Πᶫ (y : El A), eqᶫ A x y →ᶫ Typeᶫ))
    (Prefl : El (P x (reflᶫ A x)))
    (y : El A) (e : El (eqᶫ A x y)),
    θ_eq A x y e P
).
Proof.
refine (fun A x P prefl y e => _).
unfold θ_eq, eq_caseᶫ.
refine (
@pbind' (eq_ A x y) _ _ e _ (fun e => _)
).
destruct e; exact prefl.
Defined.

Check (eq_refl : (fun A x P p => eq_rectᶫ A x P p x (reflᶫ A x)) = (fun A x P p => p)).

(** Proving that linear terms commute with storage operators *)

Inductive box (A : TYPE) := Box : El A -> box A.

Definition boxᶫ (A : TYPE) : TYPE :=
  mkTYPE (nlist (box A)) (fun b => bind b (fun b => b)).

Definition Boxᶫ (A : TYPE) (x : El A) : El (boxᶫ A) := ret (Box _ x).

Definition box_rectᶫ (A : TYPE) (P : TYPE) (pb : El A -> El P) (b : El (boxᶫ A)) : El P :=
  hbind b (fun b => box_rect A (fun _ => El P) pb b).

(** Linear definition taken from Paul Blain Levy last POPL article. *)
Definition linear {A B} (f : El (A →ᶫ B)) : Prop :=
  forall b : El (boxᶫ A), f (box_rectᶫ _ _ (fun x => x) b) = box_rectᶫ _ _ f b.

Lemma linear_algebra_compat : forall A B (f : El (free A →ᶫ B)),
  linear f -> forall x, hbind x (fun x => f (ret x)) = f x.
Proof.
intros A B f Hf x.
induction x as [x|x₀ x]; cbn.
+ reflexivity.
+ change (happ (f (ret x₀)) (hbind x (fun x => f (ret x))) = f (cons A x₀ x)).
  rewrite IHx; clear IHx.
  specialize (Hf (cons _ (Box (free A) (ret x₀)) (Boxᶫ (free A) x))).
  symmetry; exact Hf.
Defined.

Lemma nat___rect : forall (P : nat_ -> Type) (Q : nlist nat_ -> Type)
  (p0 : P O_)
  (pS : forall n, Q n -> P (S_ n))
  (qnil : forall n, P n -> Q (nil _ n))
  (qcons : forall n l, P n -> Q l -> Q (cons _ n l)), forall n, P n.
Proof.
intros P Q p0 pS qnil qcons.
refine (
fix nat___rect n := match n return P n with
| O_ => p0
| S_ n =>
  pS _
    ((fix F n := match n return Q n with
    | nil _ x => qnil x (nat___rect x)
    | cons _ x n => qcons x n (nat___rect x) (F n) end) n)
end
).
Defined.

Definition nat___rectl (P : nat_ -> Type) (Q : nlist nat_ -> Type)
  (p0 : P O_)
  (pS : forall n, Q n -> P (S_ n))
  (qnil : forall n, P n -> Q (nil _ n))
  (qcons : forall n l, P n -> Q l -> Q (cons _ n l)) : forall n, Q n :=
fix F n := match n with
| nil _ x => qnil x (nat___rect P Q p0 pS qnil qcons x)
| cons _ x n => qcons x n (nat___rect P Q p0 pS qnil qcons x) (F n)
end.

Lemma hbind_extensional : forall A B f g x,
  (forall x, f x = g x) -> @hbind A B x f = @hbind A B x g.
Proof.
intros A B f g x Heq.
induction x; cbn.
+ apply Heq.
+ f_equal; [apply Heq|apply IHx].
Qed.

Lemma happ_assoc : forall A l1 l2 l3,
  @happ (free A) l1 (happ l2 l3) = happ (happ l1 l2) l3.
Proof.
intros A l1; induction l1 as [x|x l1 IHl]; intros l2 l3; cbn.
+ reflexivity.
+ cbn in IHl; rewrite IHl; reflexivity.
Qed.

Lemma hbind_happ : forall A B l1 l2 f,
  @hbind A (free B) (app l1 l2) f = happ (hbind l1 f) (hbind l2 f).
Proof.
intros A B l1; induction l1 as [x|x l1 IHl]; intros l2 f; cbn.
+ reflexivity.
+ change (happ (f x) (hbind (app l1 l2) f) = happ (happ (f x) (hbind l1 f)) (hbind l2 f)).
  rewrite IHl, happ_assoc; reflexivity.
Qed.

Lemma hbind_assoc : forall A B C l f g,
  @hbind B (free C) (@hbind A (free B) l f) g = hbind l (fun x => hbind (f x) g).
Proof.
intros A B C l f g; revert C g.
induction l as [x|x l IHl]; intros C g; cbn.
+ reflexivity.
+ change (hbind (app (f x) (hbind l f)) g = happ (hbind (f x) g) (hbind l (fun x => hbind (f x) g))).
  rewrite <- IHl, hbind_happ; reflexivity.
Qed.

Lemma linear_bool_storage_compat : forall (P : El (boolᶫ →ᶫ Typeᶫ)),
  linear P -> forall n, θ_bool n P = P n.
Proof.
intros P HP b.
unfold θ_bool, bool_caseᶫ.
match goal with [|- hbind b ?f P = _ ] => set (F := f) end.
induction b as [b₀|b₀ b IHb]; cbn.
+ destruct b₀; reflexivity.
+ change (app (F b₀ P) (hbind b F P) = P (cons _ b₀ b)).
  rewrite IHb.
  specialize (HP (cons _ (Box boolᶫ (ret b₀)) (Boxᶫ boolᶫ b))).
  cbn in HP; rewrite HP; f_equal.
  destruct b₀; reflexivity.
Qed.

(** Not true *)
Lemma linear_nat_storage_compat : forall (P : El (natᶫ →ᶫ Typeᶫ)),
  linear P -> forall n, θ_nat n P = P n.
Proof.
intros P HP n.
unfold θ_nat, nat_caseᶫ.
set (F := (fix F (n : nat_) : El (Πᶫ _ : El (Πᶫ _ : El natᶫ, Typeᶫ), Typeᶫ) :=
      match n with
      | O_ => fun k : El (Πᶫ _ : El natᶫ, Typeᶫ) => k Oᶫ
      | S_ n =>
          fun k : El (Πᶫ _ : El natᶫ, Typeᶫ) =>
          hbind n F (fun n : El natᶫ => k (Sᶫ n))
      end)).
revert P HP.
refine (nat___rectl (fun n => forall P, linear P -> F n P = P (nil nat_ n)) (fun n => forall P, linear P -> hbind n F P = P n) _ _ _ _ n);
cbn; clear n.
+ intros P HP; reflexivity.
+ intros n IHn P HP.
  rewrite IHn; [reflexivity|].
  clear - HP.
  admit. (** That's just not true, because S blocks reduction. *)
(*
  intros b; unfold box_rectᶫ.
  induction b as [[b₀]|[b₀] b]; cbn.
  - reflexivity.
  - change (
      P (Sᶫ (app b₀ (hbind b (fun x => box_rect natᶫ (fun _ : box natᶫ => El natᶫ)
        (fun x : nlist nat_ => x) x)))) =
      app (P (Sᶫ b₀)) (hbind b (fun x => box_rect natᶫ (fun _ : box natᶫ => El Typeᶫ)
        (fun n : nlist nat_ => P (Sᶫ n)) x))
    ).
    admit.
*)
+ intros n IHn P HP.
  apply IHn; assumption.
+ intros n l IHn IHl P HP.
  assert (Hnl := HP (cons _ (Box natᶫ (ret n)) (Boxᶫ natᶫ l))).
  cbn in Hnl. rewrite Hnl; clear Hnl.
  f_equal; [apply IHn, HP|apply IHl, HP].
Abort.


Require Import
  HoTT.Types.Forall
  HoTT.Types.Sigma
  HoTT.Types.Universe
  HoTT.HIT.quotient
  HoTT.Classes.interfaces.abstract_algebra
  HoTTClasses.interfaces.ua_algebra
  HoTTClasses.interfaces.ua_congruence
  HoTTClasses.theory.ua_homomorphism
  HoTTClasses.theory.ua_subalgebra
  HoTTClasses.theory.ua_quotient_algebra
  HoTTClasses.theory.ua_first_isomorphism.

Import algebra_notations quotient_algebra_notations subalgebra_notations.

Definition test {σ} {A B : Algebra σ}
  (g h : Homomorphism A B) (s : Sort σ) (x y : B s) : Type
  := ∀ (Ψ : Congruence B),
    (∀ (t : Sort σ) (a : A t), Ψ t (g t a) (h t a)) → Ψ s x y.

Global Instance meme `{Funext} {σ} {A B : Algebra σ} (g h : Homomorphism A B) (s : Sort σ)
  : is_mere_relation (B s) (test g h s).
Proof.
  intros.
  apply trunc_forall.
Defined.

Global Instance eqeq {σ} {A B : Algebra σ} (g h : Homomorphism A B)
  (s : Sort σ) : Equivalence (test g h s).
Proof.
  constructor.
  - unfold Reflexive.
    intros x Ψ ?. reflexivity.
  - intros x y T Ψ ?. symmetry. apply T.
    apply X.
  - intros x y z. intros T1 T2.
    intros Ψ ?.
    transitivity y.
    apply T1.
    apply X.
    apply T2. apply X.
Defined.

Global Instance haha {σ} {A B : Algebra σ} (g h : Homomorphism A B)
  : HasCongruenceProperty B (test g h).
Proof.
  intro u.
  unfold CongruenceProperty.
  intros a b F Ψ G.
  apply (property_congruence Ψ u).
  induction (σ u).
  - simpl in *. auto.
  - simpl in *.
    split.
    + apply F. apply G.
    + apply IHs. apply F.
Defined.

Definition coco `{Funext} {σ} {A B : Algebra σ} (g h : Homomorphism A B)
  : Congruence B
  := BuildCongruence (test g h).

Definition himm {σ} {A B : Algebra σ} (f : Homomorphism A B) (s : Sort σ)
  : relation (A s)
  := λ x y, f s x = f s y.

Global Instance equ_himm
 {σ} {A B : Algebra σ} (f : Homomorphism A B) (s : Sort σ)
 : Equivalence (himm f s).
Proof.
  constructor.
  - intro x. reflexivity.
  - intros x y F. by symmetry.
  - intros x y z F1 F2. by transitivity y.
Defined.

Global Instance prpr_himm
 {σ} {A B : Algebra σ} (f : Homomorphism A B)
 : HasCongruenceProperty A (himm f).
Proof.
  intro u.
  intros a b F.
  unfold himm.
  rewrite path_homomorphism_ap_operation.
  rewrite path_homomorphism_ap_operation.
  set (bo := u^^B).
  clearbody bo.
  induction (σ u).
  - simpl. reflexivity.
  - simpl in *.
    destruct a as [x a], b as [y b].
    simpl in *.
    destruct F as [F1 F2].
    unfold himm in F1.
    simpl.
    rewrite F1.
    apply IHs.
    assumption.
Defined.

Definition himc
 {σ} {A B : Algebra σ} (f : Homomorphism A B)
 : Congruence A
 := BuildCongruence (himm f).

Lemma prop `{Funext} {σ} {A B C : Algebra σ} (g h : Homomorphism A B)
  (f : Homomorphism B C) (p : hom_compose f g = hom_compose f h)
  : ∀ s x y, test g h s x y → f s x = f s y.
Proof.
  intros.
  specialize (X (himc f)).
  apply X.
  intros t a.
  unfold himc.
  simpl.
  unfold himm.
  change (f t (g t a)) with (hom_compose f g t a).
  rewrite p.
  reflexivity.
Defined.


Require Import Coq.omega.Omega.
Require Import Platform.tests.Thread0 Platform.Bootstrap.

Module Type HIDE.
  Parameter heapSize4 : N -> N.
  Axiom heapSize4_eq : forall n, heapSize4 n = (n * 4)%N.

  Parameter to_nat : N -> nat.
  Axiom to_nat_eq : to_nat = N.to_nat.
End HIDE.

Module Hide : HIDE.
  Definition heapSize4 n := (n * 4)%N.
  Theorem heapSize4_eq : forall n, heapSize4 n = (n * 4)%N.
    auto.
  Qed.

  Definition to_nat := N.to_nat.
  Theorem to_nat_eq : to_nat = N.to_nat.
    auto.
  Qed.
End Hide.

Module Type S.
  Parameter heapSize : N.
End S.

Module Make(M : S).
Import M.

Module M'.
  Definition globalSched : W := ((heapSize + 50) * 4)%N.
End M'.
Import M'.

Module T := Thread0.Make(M').

Section boot.
  Definition heapSize' := Hide.to_nat heapSize.

  Hypothesis heapSizeLowerBound : (3 <= heapSize)%N.

  Let heapSizeLowerBound' : (3 <= heapSize')%nat.
    intros; unfold heapSize'; rewrite Hide.to_nat_eq.
    assert (heapSize >= 3)%N by (apply N.le_ge; auto); nomega.
  Qed.

  Definition size := heapSize' + 50 + 2.
  (* The reserved heap slots are:
   * 1) scheduler
   * 2) saved Bedrock stack pointer for current thread *)

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize' * 4).
    goodSize.
  Qed.

  Lemma heapSizeLowerBound'' : natToW 3 <= NToW heapSize.
    hnf; intros.
    red in H.
    pre_nomega.
    rewrite wordToNat_natToWord_idempotent in H by reflexivity.
    unfold heapSize' in *.
    rewrite Hide.to_nat_eq in *.
    unfold NToW in *.
    rewrite NToWord_nat in *.
    rewrite wordToNat_natToWord_idempotent in H.
    omega.
    rewrite N2Nat.id.
    eapply goodSize_weaken in mem_size.
    2: instantiate (1 := N.to_nat heapSize); unfold size.
    Transparent goodSize.
    unfold goodSize in *.
    rewrite N2Nat.id in *.
    assumption.
    unfold heapSize'.
    rewrite Hide.to_nat_eq.
    omega.
  Qed.

  Hint Immediate heapSizeLowerBound''.

  Definition appmainS := SPEC reserving 49
    PREonly[_] mallocHeap 0.

  Definition bootS := bootS heapSize' 2.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "app"!"main" @ [appmainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%N;;

        Assert [PREmain[_] globalSched =?> 2 * 0 =?> heapSize'];;

        Call "malloc"!"init"(0, heapSize)
        [PREmain[_] globalSched =?> 2 * mallocHeap 0];;

        Goto "app"!"main"
      end
    }}.

  Lemma bootstrap_Sp_nonzero : forall sp : W,
    sp = 0
    -> sp = (heapSize' * 4)%nat
    -> goodSize (heapSize' * 4)
    -> False.
    intros; eapply bootstrap_Sp_nonzero; try eassumption; eauto.
  Qed.

  Lemma bootstrap_Sp_freeable : forall sp : W,
    sp = (heapSize' * 4)%nat
    -> freeable sp 50.
    intros; eapply bootstrap_Sp_freeable; try eassumption; eauto.
  Qed.

  Lemma noWrap : noWrapAround 4 (wordToNat (NToW heapSize) - 1).
    intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize' in *; rewrite Hide.to_nat_eq in *.
    rewrite wordToNat_natToWord_idempotent.
    apply noWrap; eauto.
    eapply goodSize_weaken.
    2: instantiate (1 := (heapSize' * 4)%nat).
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
  Qed.

  Local Hint Immediate bootstrap_Sp_nonzero bootstrap_Sp_freeable noWrap.

  Lemma break : NToW ((heapSize + 50) * 4)%N = ((heapSize' + 50) * 4)%nat.
    intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize'; rewrite N2Nat.inj_mul; auto.
    rewrite Hide.to_nat_eq; rewrite N2Nat.inj_add; auto.
  Qed.

  Lemma times4 : (Hide.heapSize4 heapSize : W) = (heapSize' * 4)%nat.
    rewrite Hide.heapSize4_eq; intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize'; rewrite N2Nat.inj_mul; auto.
    rewrite Hide.to_nat_eq; auto.
  Qed.

  Lemma wordToNat_heapSize : wordToNat (NToW heapSize) = heapSize'.
    unfold heapSize'; rewrite Hide.to_nat_eq.
    unfold NToW.
    rewrite NToWord_nat.
    apply wordToNat_natToWord_idempotent.
    eapply goodSize_weaken.
    2: instantiate (1 := (heapSize' * 4)%nat).
    auto.
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
  Qed.

  Hint Rewrite break times4 wordToNat_heapSize : sepFormula.

  Ltac t := unfold globalSched, localsInvariantMain, globalSched; genesis.

  Theorem ok0 : moduleOk boot.
    unfold boot; rewrite <- Hide.heapSize4_eq; vcgen; abstract t.
  Qed.

  Global Opaque heapSize'.

  Definition m := link boot T.T.m.

  Theorem ok : moduleOk m.
    link ok0 T.T.ok.
  Qed.

  (* No final proof here, because that crucial app.main() function is outside the
   * scope of Bedrock! *)
End boot.

End Make.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model Cross *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition witness_conditions := True.
Definition model_conditions := True.
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW generate_orders generate_cos witness_conditions model_conditions : cat.

Definition valid (c : candidate) := True.

(* End of translation of model Cross *)


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.priority.
Require Import prosa.classic.model.schedule.global.schedulability.
Require Import prosa.classic.model.schedule.global.jitter.job prosa.classic.model.schedule.global.jitter.schedule
               prosa.classic.model.schedule.global.jitter.platform.
Require Import prosa.classic.analysis.global.jitter.workload_bound
               prosa.classic.analysis.global.jitter.interference_bound_edf
               prosa.classic.analysis.global.jitter.bertogna_edf_comp.
Require Import prosa.classic.implementation.global.jitter.job
               prosa.classic.implementation.global.jitter.task
               prosa.classic.implementation.global.jitter.schedule
               prosa.classic.implementation.global.jitter.arrival_sequence.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq bigop div.

Module ResponseTimeAnalysisEDF.

  Import JobWithJitter ScheduleWithJitter SporadicTaskset Priority Schedulability Platform InterferenceBoundEDFJitter WorkloadBoundJitter ResponseTimeIterationEDF.
  Import ConcreteJob ConcreteTask ConcreteArrivalSequence ConcreteScheduler.

  Section ExampleRTA.

    Let tsk1 := {| task_id := 1; task_cost := 2; task_period := 5; task_deadline := 3; task_jitter := 1|}.
    Let tsk2 := {| task_id := 2; task_cost := 4; task_period := 6; task_deadline := 5; task_jitter := 0|}.
    Let tsk3 := {| task_id := 3; task_cost := 2; task_period := 12; task_deadline := 11; task_jitter := 2|}.

    (* Let ts be a task set containing these three tasks. *)
    Program Let ts := Build_set [:: tsk1; tsk2; tsk3] _.

    Section FactsAboutTaskset.

      Fact ts_has_valid_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline ts.
      Proof.
        intros tsk IN.
        repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute); by done.
      Qed.

      Fact ts_has_constrained_deadlines:
        forall tsk,
          tsk \in ts ->
          task_deadline tsk <= task_period tsk.
      Proof.
        intros tsk IN.
        repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute); by done.
      Qed.

    End FactsAboutTaskset.

    (* Assume there are two processors. *)
    Let num_cpus := 2.

    (* Recall the EDF RTA schedulability test. *)
    Let schedulability_test :=
      edf_schedulable task_cost task_period task_deadline task_jitter num_cpus.

    Fact schedulability_test_succeeds :
      schedulability_test ts = true.
    Proof.
      unfold schedulability_test, edf_schedulable, edf_claimed_bounds; desf.
      apply negbT in Heq; move: Heq => /negP ALL.
      exfalso; apply ALL; clear ALL.
      assert (STEPS: \sum_(tsk <- ts) (task_deadline tsk - task_cost tsk) + 1 = 12).
      {
        by rewrite unlock; compute.
      } rewrite STEPS; clear STEPS.

      Ltac f :=
        unfold edf_rta_iteration; simpl;
        unfold edf_response_time_bound, div_floor, total_interference_bound_edf, interference_bound_edf, interference_bound_generic, W_jitter; simpl;
        repeat rewrite addnE;
        repeat rewrite big_cons; repeat rewrite big_nil;
        repeat rewrite addnE; simpl;
        unfold num_cpus, divn; simpl.

      rewrite [edf_rta_iteration]lock; simpl.

      unfold locked at 12; destruct master_key; f.
      unfold locked at 11; destruct master_key; f.
      unfold locked at 10; destruct master_key; f.
      unfold locked at 9; destruct master_key; f.
      unfold locked at 8; destruct master_key; f.
      unfold locked at 7; destruct master_key; f.
      unfold locked at 6; destruct master_key; f.
      unfold locked at 5; destruct master_key; f.
      unfold locked at 4; destruct master_key; f.
      unfold locked at 3; destruct master_key; f.
      unfold locked at 2; destruct master_key; f.
      by unfold locked at 1; destruct master_key; f.
    Qed.

    (* Let arr_seq be the periodic arrival sequence from ts. *)
    Let arr_seq := periodic_arrival_sequence ts.

    (* Let sched be the work-conserving EDF scheduler. *)
    Let sched := scheduler job_arrival job_cost job_jitter num_cpus arr_seq
                           (JLFP_to_JLDP (EDF job_arrival job_deadline)).

    (* Recall the definition of deadline miss. *)
    Let no_deadline_missed_by :=
      task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched.

    (* Next, we prove that ts is schedulable with the result of the test. *)
    Corollary ts_is_schedulable:
      forall tsk,
        tsk \in ts ->
        no_deadline_missed_by tsk.
    Proof.
      intros tsk IN.
      have VALID := periodic_arrivals_valid_job_parameters ts ts_has_valid_parameters.
      have VALIDTS := ts_has_valid_parameters.
      unfold valid_sporadic_job_with_jitter,
             valid_sporadic_job, valid_realtime_job in *; des.
      apply taskset_schedulable_by_edf_rta with (task_cost := task_cost) (task_period := task_period)
               (task_deadline := task_deadline) (ts0 := ts) (task_jitter := task_jitter)
               (job_jitter := job_jitter); try (by done).
      - by apply ts_has_constrained_deadlines.
      - by apply periodic_arrivals_all_jobs_from_taskset.
      - by apply periodic_arrivals_are_sporadic.
      - by apply scheduler_jobs_come_from_arrival_sequence.
      - by apply scheduler_jobs_execute_after_jitter.
      - apply scheduler_completed_jobs_dont_execute.
        -- by apply periodic_arrivals_are_consistent.
        -- by apply periodic_arrivals_is_a_set.
      - apply scheduler_sequential_jobs.
        -- by apply periodic_arrivals_are_consistent.
        -- by apply periodic_arrivals_is_a_set.
      - by apply scheduler_work_conserving, periodic_arrivals_are_consistent.
      - apply scheduler_respects_policy.
        -- by apply periodic_arrivals_are_consistent.
        -- by intros t; apply RM_is_transitive.
        -- by intros t x y; apply leq_total.
      - by apply schedulability_test_succeeds.
    Qed.

  End ExampleRTA.

End ResponseTimeAnalysisEDF.


(** a small plugin to add the contraposition of implications as axiom **)

Require Import MetaCoq.Template.All.

From MetaCoq.PCUIC Require Import
     PCUICAst PCUICAstUtils PCUICInduction
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

From MetaCoq.PCUIC Require Import PCUICToTemplate.

Require Import List String.
Import ListNotations MCMonadNotation Nat.
Require Import MetaCoq.Template.Pretty.
Require Import MetaCoq.PCUIC.PCUICPretty.

Require Import List String.

Open Scope string.

Ltac addContrapos H :=
  match H with
    ?A -> ?B => assert (B->A) by admit
  | _ => fail "wrong structure"
  end.

Definition termNegType t := Ast.tProd nAnon t <% False %>.

Definition addContraposType {A:Type} (H:A) (name:ident) :TemplateMonad unit :=
  p <- tmQuote H;;
  match p with
  | Ast.tProd nAnon t1 t2 =>
    na <- tmFreshName name;;
    q <- tmUnquoteTyped Type (Ast.tProd nAnon (termNegType t2) (termNegType t1));;
    tmAxiomRed na None (q:Type);;
    tmPrint q;;
    tmMsg (append "was added to the environment as axiom " na)
  | Ast.tProd _ _ _ => tmFail "A non dependent implication is expected"
  | _ => tmFail "Invalid argument. Implication expected"
  end.

MetaCoq Run (addContraposType (True -> False) "Contra").
MetaCoq Run (addContraposType (bool -> nat) "Contra").

Definition H := True -> False.
MetaCoq Run (
  p <- tmAbout "H";;
  tmPrint p
).
MetaCoq Run (
  p <- tmQuote H;;
  tmPrint p
).
MetaCoq Run (
  p <- tmQuoteConstant "H" false;;
  q <- tmEval hnf p;;
  tmPrint q
).

Definition computeContrapos (t:Ast.term) (name:ident) : TemplateMonad unit :=
  match t with
  | Ast.tProd nAnon t1 t2 =>
    na <- tmFreshName name;;
    q1 <- tmUnquoteTyped Prop t1;;
    q2 <- tmUnquoteTyped Prop t2;;
    let q := ~q2 -> ~q1 in
    (
      tmAxiomRed na None q;;
      tmPrint q;;
      tmMsg (append "was added to the environment as axiom " na)
    )
  | Ast.tProd _ _ _ => tmFail "A non dependent implication is expected"
  | _ => tmFail "Invalid argument. Implication expected"
  end.

Definition addContrapos (H:Prop) (name:ident) :TemplateMonad unit :=
  p <- tmQuote H;;
  match p with
  | Ast.tConst qual _ =>
    q <- tmQuoteConstant qual false;;
    match Ast.cst_body q with
    | Some t => computeContrapos t name
    | None => tmFail "a constant with an opaque body is not a valid argument"
    end
  | _ => computeContrapos p name
  end.

MetaCoq Run (addContrapos (False -> True) "Contra").
Print Contra1.
MetaCoq Run (addContrapos H "Contra_H").
Print Contra_H.
Fail MetaCoq Run (addContrapos (bool -> nat) "Contra").
Fail MetaCoq Run (addContrapos 0).
Fail MetaCoq Run (addContrapos (forall (x:bool), nat)).

Print Contra1.

Axiom (H2:Type).

Definition H3:Type.
exact (True -> True).
Qed.

Fail MetaCoq Run (addContrapos H2 "T").
Fail MetaCoq Run (addContrapos H3 "T").