Require Import Coq.Classes.RelationClasses.
Require Import Coq.Program.Wf.
Require Import Omega.

Require Import SepTypes.OrderedType SepTypes.OFuns SepTypes.PChainEmbed.

Notation "f '∘' g" := (compose_ofun g f) (at level 65) : ofun_scope.
Open Scope ofun_scope.

Arguments clos_trans {_}.
Arguments clos_refl_trans {_}.

(** Functors on ordered types. *)
Section functor.
  Definition TypeF :=
    forall X, OType X -> Type.

  Class OTypeF (F : TypeF) : Type :=
    oTypeF :> forall X oX, OType (F X oX).

  Class FMap (F : TypeF) {oF : OTypeF F} : Type :=
    fmap : forall {X Y oX oY}, (X -o> Y) -> F X oX -o> F Y oY.

  Class ChooseF (F : TypeF) : Type :=
    chooseF : F unit _.

  Class Functor (F : TypeF) {oF : OTypeF F} {fm : FMap F} {ch : ChooseF F}
    : Prop :=
    { fmap_id : forall A oA, fmap (@id_ofun A oA) =o= id_ofun
    ; fmap_comp : forall A B C `{OType A} `{OType B} `{OType C}
                    (f : A -o> B) (g : B -o> C),
        fmap (g ∘ f) =o= fmap g ∘ fmap f
    ; fmap_Proper : forall A B `{OType A} `{OType B},
        Proper (@oeq (A -o> B) _ ==> oeq) fmap }.
End functor.

(** The Embed and proj functions from/to unit can be defined uniformly
    for all functors. *)
Definition unitEmbed {F} `{Functor F} : unit -o> F unit _ :=
  const_ofun chooseF.

Definition unitProj {A} `{OType A} : A -o> unit := const_ofun tt.

Lemma unitEmbed_unitProj_id F `{Functor F} :
  unitProj ∘ unitEmbed =o= id_ofun.
Proof. split; intros [] []; reflexivity. Qed.

Lemma compose_pair_ofun A B C D E F `{OType A} `{OType B} `{OType C}
      `{OType D} `{OType E} `{OType F}
      (f : A -o> C) (g : B -o> D) (h : C -o> E) (k : D -o> F) :
  pair_ofun (h ∘ fst_ofun) (k ∘ snd_ofun) ∘
            pair_ofun (f ∘ fst_ofun) (g ∘ snd_ofun) =o=
  pair_ofun (h ∘ f ∘ fst_ofun) (k ∘ g ∘ snd_ofun).
Proof.
  split; intros [] [] [Hleq1 Hleq2]; rewrite Hleq1, Hleq2; reflexivity.
Qed.

(** Mapping a functor over a diagram. Can also be thought of
    postcomposition of a functor. *)
Section pDiagramMap.
  Definition typeSequenceMap (f : nat -> Type) `{OTypeSequence f}
             F `{Functor F} : nat -> Type :=
    fun n => F (f n) _.

  Global Instance OTypeSequenceMap (f : nat -> Type) `{OTypeSequence f}
         F `{Functor F} : OTypeSequence (typeSequenceMap f F) :=
    fun n => oF (f n) _.

  Global Program Instance PDiagramMap (f : nat -> Type) `{G : PDiagram f}
         F `{func : Functor F}
    : PDiagram (typeSequenceMap f F) :=
    {| embed := fun n => fmap (embed n)
     ; proj := fun n => fmap (proj n) |}.
  Next Obligation.
    destruct func.
    etransitivity.
    symmetry. apply fmap_comp0.
    destruct G.
    simpl. rewrite embed_proj_id. apply fmap_id0.
  Qed.
End pDiagramMap.

(** A continuous functor provides fold and unfold morphisms and a
    proof that they are an isomorphism. The type that they unfold to
    is specified by the functor, so it isn't guaranteed to be
    meaningful. E.g., the preorder and PER functors just use the
    identity morphism for fold and unfold, and the proof of
    isomorphism is trivial. *)
Section continuousFunctor.
  Class UnfoldTypeF (F : TypeF) : Type :=
    unfoldTypeF : forall f `{PDiagram f}, Type.

  Class UnfoldOTypeF F {U : UnfoldTypeF F} : Type :=
    unfoldOTypeF :> forall f `{PDiagram f}, OType (unfoldTypeF f).

  Class UnfoldF F `{Functor F} {U : UnfoldTypeF F} {UO : UnfoldOTypeF F}
    : Type :=
    unfoldF : forall f `{PDiagram f},
      PChain (typeSequenceMap f F) -o> unfoldTypeF f.

  Class FoldF F `{Functor F} {U : UnfoldTypeF F} {UO : UnfoldOTypeF F}
    : Type :=
    foldF : forall f `{PDiagram f},
      unfoldTypeF f -o> PChain (typeSequenceMap f F).

  Class ContinuousFunctor F `{Functor F} {U : UnfoldTypeF F}
        {UO : UnfoldOTypeF F} {fold : FoldF F} {unfold : UnfoldF F}
    : Prop :=
    { unfold_fold_id : forall f `{PDiagram f},
        unfoldF f ∘ foldF f =o= id_ofun
    ; fold_unfold_id : forall f `{PDiagram f},
        foldF f ∘ unfoldF f =o= id_ofun }.
End continuousFunctor.

(** Construct a diagram by iterated application of a functor. *)
Section functorPDiagram.
  Context F `{Functor F}.

  Record TypeWithInstances : Type :=
    { TWI_ty :> Type
    ; TWI_OType :> OType TWI_ty
    }.

  Global Instance OType_TypeWithInstances twi : OType (TWI_ty twi) :=
    TWI_OType twi.
  Typeclasses Transparent OType_TypeWithInstances.

  Fixpoint type_n (n : nat) : TypeWithInstances :=
    match n with
    | O => {| TWI_ty := unit |}
    | S n' =>
      let t := type_n n' in
      {| TWI_ty := F (TWI_ty t) _ |}
    end.

  Fixpoint embed_n (n : nat) : type_n n -o> type_n (S n) :=
    match n with
    | O => unitEmbed
    | S n' => fmap (embed_n n')
    end.

  Fixpoint proj_n (n : nat) : type_n (S n) -o> type_n n :=
    match n with
    | O => unitProj
    | S n' => fmap (proj_n n')
    end.

  Lemma embed_n_proj_n_id n :
    proj_n n ∘ embed_n n =o= id_ofun.
  Proof.
    induction n.
    - apply unitEmbed_unitProj_id.
    - simpl.
      destruct H. rewrite <- fmap_comp0.
      rewrite IHn. apply fmap_id0.
  Qed.

  Global Instance FunctorOTypeSequence
    : OTypeSequence type_n := fun n => _.

  Global Program Instance FunctorPDiagram : PDiagram type_n :=
    {| embed := embed_n
       ; proj := proj_n |}.
  Next Obligation. apply embed_n_proj_n_id. Qed.

  Program Definition functorUnfold
    : PChain type_n -o> PChain (typeSequenceMap type_n F) :=
    {| ofun_app := fun f => {| chain := fun n => chain f (S n) |} |}.
  Next Obligation.
    destruct f as [c Hc]; simpl; specialize (Hc (S n)); auto.
  Qed.
  Next Obligation.
    intros c1 c2 Hleq n; specialize (Hleq (S n)); auto.
  Qed.

  Program Definition functorFold
    : PChain (typeSequenceMap type_n F) -o> PChain type_n :=
    {| ofun_app :=
         fun f =>
           {| chain := fun n => match n with
                             | O => tt
                             | S n' => chain f  n'
                             end |} |}.
  Next Obligation.
    destruct n. reflexivity. destruct f as [c Hc]; apply Hc.
  Qed.
  Next Obligation.
    intros c1 c2 Hleq n; destruct n. reflexivity. apply Hleq.
  Qed.

  Lemma functor_unfold_fold :
    functorUnfold ∘ functorFold =o= id_ofun.
  Proof. split; intros c1 c2 Hleq; apply Hleq. Qed.

  Lemma functor_fold_unfold :
    functorFold ∘ functorUnfold =o= id_ofun.
  Proof.
    split; intros c1 c2 Hleq []; simpl;
      destruct (chain c1 0), (chain c2 0);
      try reflexivity; apply (Hleq (S n)).
  Qed.
End functorPDiagram.

(** The constant functor for some fixed ordered type T. *)
Section constantFunctor.
  Context T `{OType T} (el : T).
  Definition ConstantF : TypeF := fun _ _ => T.
  Global Instance ConstantOTypeF : OTypeF ConstantF := fun _ _ => _.
  Global Instance ConstantFMap : FMap ConstantF :=
    fun _ _ _ _ _ => id_ofun.
  Global Instance ConstantChooseF : ChooseF ConstantF := el.
  Global Program Instance ConstantFunctor : Functor ConstantF.
  Solve Obligations with firstorder.
  Global Instance ConstantUnfoldTypeF : UnfoldTypeF ConstantF :=
    fun _ _ _ => T.
  Global Instance ConstantUnfoldOTypeF
    : UnfoldOTypeF ConstantF := fun _ _ _ => _.
  Global Program Instance ConstantUnfoldF : UnfoldF ConstantF :=
    fun _ _ _ => {| ofun_app := fun f => chain f 0 |}.
  Next Obligation. firstorder. Qed.
  Global Program Instance ConstantFoldF : FoldF ConstantF :=
    fun _ _ _ => {| ofun_app := fun x => {| chain := fun n => x |} |}.
  Next Obligation. reflexivity. Qed.
  Next Obligation. firstorder. Qed.
  Global Instance ConstantContinuousFunctor : ContinuousFunctor ConstantF.
  Proof.
    constructor; intros f o G.
    - split; firstorder.
    - split; simpl; intros x y Heq n.
      + induction n.
        * apply Heq.
        * destruct y as [y Hy]; simpl in *; rewrite <- Hy; auto.
      + induction n.
        * apply Heq.
        * destruct x as [x Hx]; simpl in *; rewrite <- Hx; auto.
  Qed.
End constantFunctor.

(** The identity functor. *)
Section identityFunctor.
  Definition IdentityF : TypeF := fun X _ => X.
  Global Instance IdentityOTypeF : OTypeF IdentityF := fun _ oX => oX.
  Global Instance IdentityFMap : FMap IdentityF :=
    fun _ _ _ _ => id.
  Global Instance IdentityChooseF : ChooseF IdentityF := tt.
  Global Program Instance IdentityFunctor : Functor IdentityF.
  Solve Obligations with reflexivity.
  Global Instance IdentityUnfoldTypeF : UnfoldTypeF IdentityF :=
    fun f _ _ => PChain f.
  Global Instance IdentityUnfoldOTypeF : UnfoldOTypeF IdentityF :=
    fun _ _ _ => _.

  (* :( *)
  (* Global Program Instance IdentityFoldF : FoldF IdentityF := *)
  (*   fun _ _ _ _ _ => id_ofun. *)

  (* This works and is good enough for the identity functor, but a
     similar problem appears in the product functor which is more
     annoying. *)
  (* Global Program Instance IdentityUnfoldF : UnfoldF IdentityF := *)
  (*   fun _ _ _ => {| ofun_app := fun c => {| chain := fun n => chain c n |} |}. *)
  (* Next Obligation. destruct c as [? Hc]; apply Hc. Qed. *)
  (* Next Obligation. firstorder. Qed. *)

  Global Program Instance IdentityFoldF : FoldF IdentityF :=
    fun _ _ _ => {| ofun_app := fun c => {| chain := fun n => chain c n |} |}.
  Next Obligation. destruct c as [? Hc]; apply Hc. Qed.
  Next Obligation. intros ? ? ?; assumption. Qed.

  Global Instance IdentityContinuousFunctor : ContinuousFunctor IdentityF.
  Proof. firstorder. Qed.
  (* constructor. *)
  (*   - intros f o e p G; split; unfold oleq; simpl; *)
  (*       unfold oleq; simpl; firstorder. *)
  (*   - firstorder. *)
  (* Qed. *)
End identityFunctor.

(** The product functor. *)
Section productFunctor.
  Context F1 {oF1 : OTypeF F1} {fm1 : FMap F1} {ch1 : ChooseF F1}
          {func1 : Functor F1} {uF1 : UnfoldTypeF F1}
          {uoF1 : UnfoldOTypeF F1} {foldF1 : FoldF F1}
          {unfoldF1 : UnfoldF F1} {cFunc1 : ContinuousFunctor F1}
          F2 {oF2 : OTypeF F2} {fm2 : FMap F2} {ch2 : ChooseF F2}
          {func2 : Functor F2} {uF2 : UnfoldTypeF F2}
          {uoF2 : UnfoldOTypeF F2} {foldF2 : FoldF F2}
          {unfoldF2 : UnfoldF F2} {cFunc2 : ContinuousFunctor F2}.

  Definition ProductF : TypeF := fun X oX => prod (F1 X oX) (F2 X oX).

  Global Instance ProductOTypeF : OTypeF ProductF := fun _ _ => OTpair _ _ _ _.

  Global Program Instance ProductFMap : FMap ProductF :=
    fun _ _ _ _ => fun f => pair_ofun (fmap f ∘ fst_ofun)
                                (fmap f ∘ snd_ofun).

  Global Instance ProductEmbedF : ChooseF ProductF :=
    (chooseF, chooseF).

  Global Instance ProductFunctor : Functor ProductF.
  Proof.
    constructor.
    - intros A oA.
      split; simpl.
      + intros [] [] []; split; simpl; try rewrite H; try rewrite H0;
          destruct func1, func2; try rewrite fmap_id0;
            try rewrite fmap_id1; reflexivity.
      + split; destruct func1, func2; simpl; try rewrite fmap_id0;
          try rewrite fmap_id1; apply H.
    - intros A B C oA oB oC f g.
      split; split; simpl; destruct func1, func2;
        solve [rewrite fmap_comp0, H; reflexivity |
               rewrite fmap_comp1, H; reflexivity].
    - intros A B oA oB f g Heq.
      unfold fmap, ProductFMap.
      destruct func1, func2.
      rewrite Heq. reflexivity.
  Qed.

  Global Instance ProductUnfoldTypeF : UnfoldTypeF ProductF :=
  fun f _ _ => prod (@unfoldTypeF F1 uF1 f _ _)
                 (@unfoldTypeF F2 uF2 f _ _).
  Global Instance ProductUnfoldOTypeF :
    UnfoldOTypeF ProductF := fun _ _ _ => _.

  Global Program Instance ProductUnfoldF : UnfoldF ProductF :=
    fun f _ _ =>
      (* pair_ofun (unfoldF f ∘ fst_ofun) (unfoldF f ∘ snd_ofun) ∘ unzipPChain. *)
      {| ofun_app :=
           fun x =>
             (pair_ofun (unfoldF f ∘ fst_ofun) (unfoldF f ∘ snd_ofun) ∘ unzipPChain) @@ x |}.
  Global Program Instance ProductFoldF : FoldF ProductF :=
    fun f _ _ =>
      zipPChain ∘ pair_ofun (foldF f ∘ fst_ofun) (foldF f ∘ snd_ofun).

  (* A couple convenience lemmas. *)
  Lemma compose_ofun_assoc_4 A B C D E `{OType A} `{OType B} `{OType C} `{OType D}
        `{OType E} (f : A -o> B) (g : B -o> C) (h : C -o> D) (k : D -o> E) :
    (k ∘ h) ∘ (g ∘ f) =o= k ∘ (h ∘ g) ∘ f.
  Proof. split; intros ? ? Hleq; rewrite Hleq; reflexivity. Qed.

  Lemma compose_ofun_middle_id A B C `{OType A} `{OType B} `{OType C} (f : A -o> B)
        (g : B -o> C) (h : C -o> B) (k : B -o> A) :
    h ∘ g =o= id_ofun ->
    k ∘ (h ∘ g) ∘ f =o= k ∘ f.
  Proof.
    intros Hid; rewrite Hid; rewrite id_compose_ofun; reflexivity.
  Qed.

  (* Lemma compose_pair_ofun A B C D E F `{OType A} `{OType B} `{OType C}
        `{OType D} `{OType E} `{OType F}
        (f : A -o> C) (g : B -o> D) (h : C -o> E) (k : D -o> F) :
    pair_ofun (h ∘ fst_ofun) (k ∘ snd_ofun) ∘
              pair_ofun (f ∘ fst_ofun) (g ∘ snd_ofun) =o=
    pair_ofun (h ∘ f ∘ fst_ofun) (k ∘ g ∘ snd_ofun).
  Proof.
    split; intros [] [] [Hleq1 Hleq2];rewrite Hleq1, Hleq2; reflexivity.
  Qed. *)

  Global Instance ProductContinuousFunctor : ContinuousFunctor ProductF.
  Proof.
    constructor; intros f o G.
    - unfold unfoldF, ProductUnfoldF, foldF, ProductFoldF.
      rewrite compose_ofun_assoc_4, unzip_zip_PChain, id_compose_ofun.
      etransitivity. apply compose_pair_ofun.
      destruct cFunc1 as [Huf1 _], cFunc2 as [Huf2 _]; rewrite Huf1;
        rewrite Huf2; rewrite 2!compose_id_ofun; apply pair_fst_snd_eta.
    - unfold unfoldF, ProductUnfoldF, foldF, ProductFoldF.
      rewrite compose_ofun_assoc_4, compose_ofun_middle_id.
      + (* Why won't zip_unzip_PChain apply here? *)
        split; intros c1 c2 Hleq n; apply Hleq.
      + etransitivity. apply compose_pair_ofun.
        destruct cFunc1 as [_ Hfu1], cFunc2 as [_ Hfu2]; rewrite Hfu1;
          rewrite Hfu2; rewrite 2!compose_id_ofun; apply pair_fst_snd_eta.
  Qed.
End productFunctor.

(* This is the basic core of fmap for both the preorder and PER
   functors. *)
Definition fmapRel {A B} `{OType A} `{OType B} (f : A -o> B)
           (R : relation A) : relation B :=
  fun y1 y2 => exists x1 x2, f @@ x1 =o= y1 /\ f @@ x2 =o= y2 /\ R x1 x2.

(* The class of proper preorders. *)
Class Preorder {A} `{OType A} (R : relation A) : Prop :=
  { Proper_Preorder :> Proper (oeq ==> oeq ==> oleq) R
  ; PreOrder_Preorder :> PreOrder R }.

Inductive clos_refl_trans {A} `{OType A} (R : relation A) (x : A) : A -> Prop :=
    | rt_step y : R x y -> clos_refl_trans R x y
    | rt_refl y : x =o= y -> clos_refl_trans R x y
    | rt_trans y z :
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

(** The preorder functor. *)
Section preorderFunctor.
  Definition PreOrderF : TypeF := fun X oX => {R : relation X | Preorder R}.

  Global Instance PreOrderOTypeF : OTypeF PreOrderF := fun _ _ => _.

  Global Instance Proper_clos_refl_trans {A} `{OType A} (R : relation A) :
    Proper (oeq ==> oeq ==> oleq) R ->
    Proper (oeq ==> oeq ==> oleq) (clos_refl_trans R).
  Proof.
    intros Hprop x y Heq1 z w Heq2 Hclos.
    revert y w Heq1 Heq2.
    induction Hclos; intros.
    - apply rt_step; rewrite <- Heq1, <- Heq2; auto.
    - apply rt_refl. rewrite <- Heq1. rewrite H0; auto.
    - apply rt_trans with y. apply IHHclos1; auto; reflexivity.
      apply IHHclos2; auto; reflexivity.
  Qed.

  Global Instance Proper_fmapRel {A B} `{OType A} `{OType B}
           (f : A -o> B) (R : relation A) :
    Proper (oeq ==> oeq ==> oleq) R ->
    Proper (oeq ==> oeq ==> oleq) (fmapRel f R).
  Proof.
    intros Hprop ? ? Heq1 ? ? Heq2 (x1 & x2 & ? & ? & ?).
    exists x1, x2; split.
    - rewrite <- Heq1; auto.
    - split; auto; rewrite <- Heq2; auto.
  Qed.

  Program Definition fmapPreOrder {A B} `{OType A} `{OType B} (f : A -o> B)
          (R : PreOrderF A _) : PreOrderF B _ :=
    clos_refl_trans (fmapRel (fmap f) (proj1_sig R)).
  Next Obligation.
    constructor.
    - apply Proper_clos_refl_trans, Proper_fmapRel;
        destruct R as [R HR]; destruct HR; auto.
    - constructor.
      + intros ?; apply rt_refl; reflexivity.
      + intros ?; apply rt_trans.
  Qed.

  Global Program Instance PreOrderFMap : FMap PreOrderF :=
    fun _ _ _ _ => fun f => {| ofun_app := fun r => fmapPreOrder f r |}.
  Next Obligation.
    intros R1 R2 Heq1 x y Heq2.
    simpl in *.
    revert R2 Heq1.
    induction Heq2; intros.
    - apply rt_step.
      destruct H3 as (x1 & x2 & ? & ? & ?).
      exists x1, x2. split; auto. split; auto.
      apply Heq1; auto. (* TODO: factor out? *)
    - apply rt_refl; auto.
    - eapply rt_trans; eauto.
  Qed.

  Global Program Instance PreOrderChooseF : ChooseF PreOrderF :=
    fun _ _ => True.
  Next Obligation. firstorder. Qed.

  Global Program Instance PreOrderFunctor : Functor PreOrderF.
  Next Obligation.
    split.
    - intros R1 R2 Hleq x y Hclos.
      induction Hclos.
      + destruct H as (x1 & x2 & ? & ? & ?). simpl.
        apply Hleq; destruct R1; rewrite <- H, <- H0; auto.
      + apply Hleq; destruct R1 as [R HR]; rewrite H; apply HR.
      + destruct R2; etransitivity; eauto.
    - intros R1 R2 Hleq1 x y Hleq2.
      apply rt_step; exists x, y; split.
      reflexivity. split. reflexivity. apply Hleq1; auto.
  Qed.
  Next Obligation.
    split.
    - intros R1 R2 Hleq x y Hclos; simpl in *.
      revert R2 Hleq.
      induction Hclos; intros.
      + destruct H2 as (x1 & x2 & ? & ? & ?).
        apply rt_step. exists (fmap f @@ x1), (fmap f @@ x2).
        split; simpl; auto. split; auto.
        apply rt_step; exists x1, x2. split. reflexivity.
        split. reflexivity. apply Hleq; auto.
      + apply rt_refl; auto.
      + eapply rt_trans; eauto.
    - intros R1 R2 Hleq1 x y Hclos; simpl in *.
      revert R2 Hleq1; induction Hclos; intros.
      + destruct H2 as (x1 & x2 & H2 & H3 & Hclos).
        revert x y H2 H3.
        induction Hclos; intros.
        * destruct H2 as (x1 & x2 & H2 & H5 & H6).
          rewrite <- H2 in H3; rewrite <- H5 in H4.
          apply rt_step; exists x1, x2.
          split; auto. split; auto. apply Hleq1; auto.
        * rewrite H2 in H3; rewrite H3 in H4; apply rt_refl; auto.
        * eapply rt_trans. apply IHHclos1; auto. reflexivity.
          apply IHHclos2; auto. reflexivity.
      + apply rt_refl; auto.
      + eapply rt_trans; eauto.
  Qed.

  Global Instance PreOrderUnfoldTypeF : UnfoldTypeF PreOrderF :=
    fun f _ _ => PChain (typeSequenceMap f PreOrderF).
  Global Instance PreOrderUnfoldOTypeF :
    UnfoldOTypeF PreOrderF := fun _ _ _ => _.
  Global Instance PreOrderUnfoldF : UnfoldF PreOrderF := fun _ _ _ => id_ofun.
  Global Instance PreOrderFoldF : FoldF PreOrderF := fun _ _ _ => id_ofun.
  Global Instance PreOrderContinuousFunctor : ContinuousFunctor PreOrderF.
  Proof. constructor; intros; apply id_compose_ofun. Qed.
End preorderFunctor.

(* The class of partial equivalence relations (PERs). *)
Class PER {A} `{OType A} (R : relation A) : Prop :=
  { Proper_PER :> Proper (oeq ==> oeq ==> oleq) R
  ; Symmetric_PER :> Symmetric R
  ; Transitive_PER :> Transitive R }.

(** The PER functor. *)
Section perFunctor.
  Definition PERF : TypeF := fun X oX => {R : relation X | PER R}.

  Global Instance PEROTypeF : OTypeF PERF := fun _ _ => _.

  Global Instance Proper_clos_trans {A} `{OType A} {R : relation A} :
    Proper (oeq ==> oeq ==> oleq) R ->
    Proper (oeq ==> oeq ==> oleq) (clos_trans R).
  Proof.
    intros Hprop x y Heq1 z w Heq2 Hclos.
    revert y w Heq1 Heq2.
    induction Hclos; intros.
    - apply t_step. rewrite <- Heq1. rewrite <- Heq2. auto.
    - apply t_trans with y. apply IHHclos1; auto; reflexivity.
      apply IHHclos2; auto; reflexivity.
  Qed.

  Instance Symmetric_clos_trans A (R : relation A) :
    Symmetric R ->
    Symmetric (clos_trans R).
  Proof.
    intros Hsym x y Hclos; induction Hclos.
    - apply t_step. apply Hsym; auto.
    - eapply t_trans; eauto.
  Qed.

  Instance Symmetric_fmapRel A B `{OType A} `{OType B} (f : A -o> B) (R : relation A) :
    Symmetric R ->
    Symmetric (fmapRel f R).
  Proof.
    intros Hsym x y (x1 & x2 & ? & ? & ?).
    exists x2, x1. split; auto.
  Qed.

  Program Definition fmapPER {A B} `{OType A} `{OType B} (f : A -o> B)
          (R : PERF A _) : PERF B _ :=
    clos_trans (fmapRel (fmap f) (proj1_sig R)).
  Next Obligation.
    constructor.
    - apply Proper_clos_trans. apply Proper_fmapRel.
      destruct R; auto. simpl. destruct p; auto.
    - apply Symmetric_clos_trans.
      apply Symmetric_fmapRel.
      destruct R, p; auto.
    - intros ?; eapply t_trans; eauto.
  Qed.

  Global Program Instance PERFMap : FMap PERF :=
    fun _ _ _ _ => fun f => {| ofun_app := fun r => fmapPER f r |}.
  Next Obligation.
    intros R1 R2 Hleq1 x y Hclos. simpl in *.
    induction Hclos.
    - apply t_step.
      destruct H3 as (x1 & x2 & ? & ? & ?).
      exists x1, x2. split; auto. split; auto.
      apply Hleq1; auto.
    - eapply t_trans; eauto.
  Qed.

  Global Program Instance PERChooseF : ChooseF PERF :=
    fun _ _ => True.
  Next Obligation. firstorder. Qed.

  (* This is mostly a copy of the preorder functor proof. There's
     probably a way to factor out the common parts but it's much
     easier to just do this. *)
  Global Program Instance PERFunctor : Functor PERF.
  Next Obligation.
    split.
    - intros R1 R2 Hleq x y Hclos.
      induction Hclos.
      + destruct H as (x1 & x2 & ? & ? & ?).
        apply Hleq; destruct R1; rewrite <- H, <- H0; auto.
      + destruct R2; etransitivity; eauto.
    - intros R1 R2 Hleq1 x y Hleq2.
      apply t_step; exists x, y; split.
      reflexivity. split. reflexivity.
      apply Hleq1; auto.
  Qed.
  Next Obligation.
    split.
    - intros R1 R2 Hleq x y Hclos; simpl in *.
      revert R2 Hleq.
      induction Hclos; intros.
      + destruct H2 as (x1 & x2 & ? & ? & ?).
        apply t_step. exists (fmap f @@ x1), (fmap f @@ x2).
        split;  auto.
        split; auto. apply t_step.
        exists x1, x2. split. reflexivity.
        split. reflexivity. apply Hleq; auto.
      + eapply t_trans; eauto.
    - intros R1 R2 Hleq1 x y Hclos; simpl in *.
      revert R2 Hleq1; induction Hclos; intros.
      + destruct H2 as (x1 & x2 & H2 & H3 & Hclos).
        revert x y H2 H3.
        induction Hclos; intros.
        * destruct H2 as (x1 & x2 & H2 & H5 & H6).
          rewrite <- H2 in H3; rewrite <- H5 in H4.
          apply t_step; exists x1, x2.
          split; auto. split; auto. apply Hleq1; auto.
        * eapply t_trans. apply IHHclos1; auto. reflexivity.
          apply IHHclos2; auto. reflexivity.
      + eapply t_trans; eauto.
  Qed.

  Global Instance PERUnfoldTypeF : UnfoldTypeF PERF :=
    fun f _ _ => PChain (typeSequenceMap f PERF).
  Global Instance PERUnfoldOTypeF : UnfoldOTypeF PERF := fun _ _ _ => _.
  Global Program Instance PERUnfoldF : UnfoldF PERF := fun _ _ _ => id_ofun.
  Global Program Instance PERFoldF : FoldF PERF := fun _ _ _ => id_ofun.
  Global Instance PERContinuousFunctor : ContinuousFunctor PERF.
  Proof. constructor; intros; apply id_compose_ofun. Qed.
End perFunctor.

(** A simple inductive type for binary trees with an order relation
    and an fmap operation. *)
Section tree.
  Inductive Tree A :=
  | Leaf : A -> Tree A
  | Node : Tree A -> Tree A -> Tree A.

  Global Arguments Leaf {_}.
  Global Arguments Node {_}.

  Inductive tree_oleq {A} `{OType A} : Tree A -> Tree A -> Prop :=
  | tree_oleq_Leaf : forall x y,
      x <o= y ->
      tree_oleq (Leaf x) (Leaf y)
  | tree_oleq_Node : forall t1 t2 t1' t2',
      tree_oleq t1 t1' ->
      tree_oleq t2 t2' ->
      tree_oleq (Node t1 t2) (Node t1' t2').

  Global Instance Reflexive_tree_oleq {A} `{OType A} : Reflexive tree_oleq.
  Proof. intro x; induction x; constructor; auto; reflexivity. Qed.

  Global Instance Transitive_tree_oleq {A} `{OType A} : Transitive tree_oleq.
  Proof.
    intros x y z Hxy Hyz; revert x z Hxy Hyz.
    induction y; intros; destruct x, z;
      inversion Hxy; inversion Hyz; subst.
    - constructor; etransitivity; eauto.
    - constructor.
      + apply IHy1; auto.
      + apply IHy2; auto.
  Qed.

  Global Program Instance OTtree A `(OType A) : OType (Tree A) :=
    {| oleq := tree_oleq |}.
  Next Obligation.
    constructor.
    - apply Reflexive_tree_oleq.
    - apply Transitive_tree_oleq.
  Qed.

  Inductive isLeaf {A} : Tree A -> Prop :=
  | isLeafLeaf : forall x, isLeaf (Leaf x).

  Inductive isNode {A} : Tree A -> Prop :=
  | isNodeNode : forall t1 t2, isNode (Node t1 t2).

  Definition isLeafb {A} (t : Tree A) : bool :=
    match t with
    | Leaf _ => true
    | Node _ _ => false
    end.

  Definition isNodeb {A} (t : Tree A) : bool :=
    match t with
    | Leaf _ => false
    | Node _ _ => true
    end.

  Lemma isLeaf_isLeafb A (t : Tree A) :
    isLeaf t <-> isLeafb t = true.
  Proof.
    split; intros H; inversion H; auto; destruct t.
    - constructor.
    - simpl in H; congruence.
  Qed.

  Lemma isNode_isNodeb A (t : Tree A) :
    isNode t <-> isNodeb t = true.
  Proof.
    split; intros H; inversion H; auto; destruct t.
    - simpl in H; congruence.
    - constructor.
  Qed.

  (* tree_oleq is reflexive wrt equivalence. *)
  Lemma Reflexive'_tree_oleq A `{OType A} t1 t2 :
    t1 =o= t2 ->
    tree_oleq t1 t2.
  Proof. firstorder. Qed.

  Global Instance Proper_tree_oleq' A `{OType A} :
    Proper (oeq ==> oeq ==> oleq) tree_oleq.
  Proof.
    intros x y Hleq1 z w Hleq2 Hleq3.
    rewrite <- Hleq1.
    etransitivity; eauto.
    apply Reflexive'_tree_oleq; auto.
  Qed.

  Global Instance Proper_Leaf {A} `{OType A} :
    Proper (oleq ==> oleq) Leaf.
  Proof. constructor; auto. Qed.

  Global Instance Proper_Node {A} `{OType A} :
    Proper (oleq ==> oleq ==> oleq) Node.
  Proof. constructor; auto. Qed.

  (* Plain-old fmap for trees. *)
  Fixpoint tree_fmap {A B} `{OType A} `{OType B} (f : A -o> B)
           (t : Tree A) : Tree B :=
    match t with
    | Leaf x => Leaf (f @@ x)
    | Node t1 t2 => Node (tree_fmap f t1) (tree_fmap f t2)
    end.

  Global Instance Proper_tree_fmap {A B} `{OType A} `{OType B} (f : A -o> B) :
    Proper (oleq ==> oleq) (tree_fmap f).
  Proof.
    intros x y Hleq; induction Hleq; simpl.
    + rewrite H1; reflexivity.
    + constructor; auto.
  Qed.

  (* OFun version of fmap. *)
  Program Definition Tree_fmap {A B} `{OType A} `{OType B} (f : A -o> B)
    : Tree A -o> Tree B :=
    {| ofun_app := fun t => tree_fmap f t |}.
  Next Obligation.
    intros t1 t2 Hleq; induction Hleq; simpl.
    - rewrite H1; reflexivity.
    - constructor; auto.
  Qed.

  Global Instance Proper_Tree_fmap {A B} `{OType A} `{OType B} :
    Proper (@oleq (A -o> B) _ ==> oleq) (Tree_fmap).
  Proof.
    intros ? ? ? ? ? Hleq2; induction Hleq2; constructor; auto.
  Qed.

  Global Instance Proper_Tree_fmap' {A B} `{OType A} `{OType B} :
    Proper (@oeq (A -o> B) _ ==> oeq) (Tree_fmap).
  Proof. intros ? ? Heq; split; apply Proper_Tree_fmap; apply Heq. Qed.

  (* tree_fmap satisfies the functor laws. *)
  Lemma tree_fmap_id A `{OType A} x :
    tree_fmap id_ofun x =o= x.
  Proof.
    induction x.
    - reflexivity.
    - simpl; rewrite IHx1, IHx2; reflexivity.
  Qed.

  Lemma Tree_fmap_id A `{OType A} :
    Tree_fmap id_ofun =o= id_ofun.
  Proof.
    generalize (tree_fmap_id A); intros H0; split;
      intros t1 t2 Hleq; simpl; rewrite H0; auto.
  Qed.

  Lemma Tree_fmap_comp A B C `{OType A} `{OType B} `{OType C}
        (f : A -o> B) (g : B -o> C) :
    Tree_fmap (g ∘ f) =o= Tree_fmap g ∘ Tree_fmap f.
  Proof.
    split; intros t1 t2 Hleq; unfold oleq; simpl;
      induction Hleq; constructor; auto; rewrite H2; reflexivity.
  Qed.

  (* Get the element out of a leaf. If the argument isn't a leaf, just
     recurse to the left until one is found. *)
  Fixpoint unLeaf {A} (t : Tree A) : A :=
    match t with
    | Leaf x => x
    | Node t1 _ => unLeaf t1 (* shouldn't happen *)
    end.

  Global Instance Proper_unLeaf {A} `{OType A} :
    Proper (oleq ==> oleq) unLeaf.
  Proof. intros ? ? Heq; induction Heq; auto. Qed.

  Lemma leaf_unleaf A (t : Tree A) :
    isLeaf t ->
    Leaf (unLeaf t) = t.
  Proof. intros Hleaf; inversion Hleaf; auto. Qed.

  (* OFun version of unLeaf *)
  Definition unLeaf' {A} `{OType A} : Tree A -o> A :=
    {| ofun_app := unLeaf; ofun_Proper := Proper_unLeaf |}.

  (* Get the left subtree of a tree. If the argument is a leaf, just
     return it unchanged. *)
  Fixpoint unNodeLeft {A} (t : Tree A) : Tree A :=
    match t with
    | Leaf _ => t (* shouldn't happen *)
    | Node t1 _ => t1
    end.

  Global Instance Proper_unNodeLeft {A} `{OType A} :
    Proper (oleq ==> oleq) unNodeLeft.
  Proof.
    intros ? ? Heq; induction Heq; auto; simpl; rewrite H0; reflexivity.
  Qed.

  (* OFun version of unNodeLeft *)
  Definition unNodeLeft' {A} `{OType A} : Tree A -o> Tree A :=
    {| ofun_app := unNodeLeft; ofun_Proper := Proper_unNodeLeft |}.

  (* Get the right subtree of a tree. If the argument is a leaf, just
     return it unchanged. *)
  Fixpoint unNodeRight {A} (t : Tree A) : Tree A :=
    match t with
    | Leaf _ => t (* shouldn't happen *)
    | Node _ t2 => t2
    end.

  Global Instance Proper_unNodeRight {A} `{OType A} :
    Proper (oleq ==> oleq) unNodeRight.
  Proof.
    intros ? ? Heq; induction Heq; auto; simpl; rewrite H0; reflexivity.
  Qed.

  (* OFun version of unNodeRight *)
  Definition unNodeRight' {A} `{OType A} : Tree A -o> Tree A :=
    {| ofun_app := unNodeRight; ofun_Proper := Proper_unNodeRight |}.
End tree.

(** Map the Tree type constructor and fmap over a diagram. *)
Section mapTreePDiagram.
  Definition mapTreeTypeSequence f `{PDiagram f} : nat -> Type :=
    fun n => Tree (f n).
  Global Instance MapTreeOTypeSequence f `{PDiagram f}
    : OTypeSequence (mapTreeTypeSequence f) := fun n => _.
  Global Instance MapTreePDiagram f `{PDiagram f}
    : PDiagram (mapTreeTypeSequence f) := fun n => Tree_fmap (proj n).
End mapTreePDiagram.

(** Operations and proofs related to chains of trees. *)
Section treePChain.
  Program Definition unLeafPChain {f} `{PDiagram f}
  : PChain (mapTreeTypeSequence f) -o> PChain f :=
    pChainMap (mapTreeTypeSequence f) f
              (fun _ => {| ofun_app := fun x => unLeaf' @@ x |}) _.
  Next Obligation.
    unfold oeq, oleq; split; simpl; intros ? ? Heq;
      induction Heq; simpl; auto; rewrite H0; reflexivity.
  Qed.

  Program Definition unNodeLeftPChain {f} `{PDiagram f}
    : PChain (mapTreeTypeSequence f) -o> PChain (mapTreeTypeSequence f) :=
    pChainMap (mapTreeTypeSequence f) (mapTreeTypeSequence f)
              (fun _ => {| ofun_app := fun x => unNodeLeft' @@ x |}) _.
  Next Obligation.
    split; simpl; intros c1 c2 Hleq; induction Hleq;
      try apply Proper_tree_fmap; auto; constructor;
        rewrite H0; reflexivity.
  Qed.

  Program Definition unNodeRightPChain {f} `{PDiagram f}
    : PChain (mapTreeTypeSequence f) -o> PChain (mapTreeTypeSequence f) :=
    pChainMap (mapTreeTypeSequence f) (mapTreeTypeSequence f)
              (fun _ => {| ofun_app := fun x => unNodeRight' @@ x |}) _.
  Next Obligation.
    split; simpl; intros c1 c2 Hleq; induction Hleq;
      try apply Proper_tree_fmap; auto; constructor;
        rewrite H0; reflexivity.
  Qed.

  Lemma unNodeLeftPChain_oleq {f} `{PDiagram f} (c1 c2 : PChain (mapTreeTypeSequence f)) :
    c1 <o= c2 ->
    unNodeLeftPChain @@ c1 <o= unNodeLeftPChain @@ c2.
  Proof.
    intros Hleq n; simpl; specialize (Hleq n);
      destruct (chain c1 n), (chain c2 n);
      inversion Hleq; subst; auto.
  Qed.

  Lemma unNodeRightPChain_oleq {f} `{PDiagram f} (c1 c2 : PChain (mapTreeTypeSequence f)) :
    c1 <o= c2 ->
    unNodeRightPChain @@ c1 <o= unNodeRightPChain @@ c2.
  Proof.
    intros Hleq n; simpl; specialize (Hleq n);
      destruct (chain c1 n), (chain c2 n);
      inversion Hleq; subst; auto.
  Qed.

  Program Definition treeFold {f} `{PDiagram f} :
    Tree (PChain f) -o> PChain (mapTreeTypeSequence f) :=
    {| ofun_app :=
         fun t =>
           {| chain := fun n => Tree_fmap (chainProj n) @@ t |} |}.
  Next Obligation.
    induction t; simpl.
    - destruct a; apply (Proper_oeq_oleq_op1 _ _ _ Proper_Leaf);
        apply chainCondition0.
    - apply (Proper_oeq_oleq_op2 _ _ _ _ Proper_Node); auto.
  Qed.
  Next Obligation.
    intros x y Heq n. simpl.
    induction Heq; simpl in *.
    - specialize (H0 n). apply Proper_Leaf; auto.
    - apply Proper_Node; auto.
  Qed.

  Fixpoint treeUnfold_f_aux {f} `{PDiagram f}
           (c : PChain (mapTreeTypeSequence f))
           (t : Tree (f 0))
    : Tree (PChain f) :=
    match t with
    | Leaf _ => Leaf (unLeafPChain @@ c)
    | Node t1 t2 => Node (treeUnfold_f_aux (unNodeLeftPChain @@ c) t1)
                        (treeUnfold_f_aux (unNodeRightPChain @@ c) t2)
    end.

  Global Instance Proper_treeUnfold_f_aux f `{PDiagram f} :
    Proper (oeq ==> oeq ==> oeq) treeUnfold_f_aux.
  Proof.
    intros c1 c2 Heq1 x y Heq2.
    split; unfold oleq; simpl.
    - destruct Heq2 as [Heq2 _].
      revert c1 c2 Heq1.
      induction Heq2; intros.
      + constructor; intros n; destruct Heq1; simpl;
          rewrite (H1 n); reflexivity.
      + constructor.
        * apply IHHeq2_1; destruct Heq1 as [Heq1 Heq2]; split;
            unfold oleq; simpl; intros n; try rewrite (Heq1 n);
              try rewrite (Heq2 n); reflexivity.
        * apply IHHeq2_2; destruct Heq1 as [Heq1 Heq2]; split;
            unfold oleq; simpl; intros n; try rewrite (Heq1 n);
              try rewrite (Heq2 n); reflexivity.
    - destruct Heq2 as [_ Heq2].
      revert c1 c2 Heq1.
      induction Heq2; intros.
      + constructor; intros n; destruct Heq1; simpl;
          rewrite (H2 n); reflexivity.
      + constructor.
        * apply IHHeq2_1; destruct Heq1 as [Heq1 Heq2]; split;
            unfold oleq; simpl; intros n; try rewrite (Heq1 n);
              try rewrite (Heq2 n); reflexivity.
        * apply IHHeq2_2; destruct Heq1 as [Heq1 Heq2]; split;
            unfold oleq; simpl; intros n; try rewrite (Heq1 n);
              try rewrite (Heq2 n); reflexivity.
  Qed.

  Definition treeUnfold_f {f} `{PDiagram f}
           (c : PChain (mapTreeTypeSequence f))
    : Tree (PChain f) :=
    treeUnfold_f_aux c (chain c 0).

  Global Instance Proper_treeUnfold_f {f} `{PDiagram f} :
    Proper (oleq ==> oleq) treeUnfold_f.
  Proof.
    intros c1 c2 Hleq.
    unfold oleq in *. simpl in *.
    unfold treeUnfold_f.
    pose proof Hleq as Hleq'.
    specialize (Hleq' 0).
    remember (chain c1 0) as x.
    remember (chain c2 0) as y.
    revert Heqx Heqy. revert c1 c2 Hleq.
    induction Hleq'; intros.
    - simpl. constructor. intros ?. simpl.
      rewrite Hleq. reflexivity.
    - simpl. constructor.
      + assert (H0: t1 = chain (unNodeLeftPChain @@ c1) 0).
        { simpl; destruct (chain c1 0); inversion Heqx; auto. }
        assert (H1: t1' = chain (unNodeLeftPChain @@ c2) 0).
        { simpl; destruct (chain c2 0); inversion Heqy; auto. }
        specialize (IHHleq'1 (unNodeLeftPChain @@ c1)
                             (unNodeLeftPChain @@ c2)
                             (unNodeLeftPChain_oleq _ _ Hleq) H0 H1).
        etransitivity. apply IHHleq'1.
        apply Reflexive'_tree_oleq. reflexivity.
      + assert (H0: t2 = chain (unNodeRightPChain @@ c1) 0).
        { simpl; destruct (chain c1 0); inversion Heqx; auto. }
        assert (H1: t2' = chain (unNodeRightPChain @@ c2) 0).
        { simpl; destruct (chain c2 0); inversion Heqy; auto. }
        specialize (IHHleq'2 (unNodeRightPChain @@ c1)
                             (unNodeRightPChain @@ c2)
                             (unNodeRightPChain_oleq _ _ Hleq) H0 H1).
        etransitivity. apply IHHleq'2.
        apply Reflexive'_tree_oleq. reflexivity.
  Qed.

  Definition treeUnfold {f} `{PDiagram f}
    : PChain (mapTreeTypeSequence f) -o> Tree (PChain f) :=
    {| ofun_app := treeUnfold_f |}.

  Lemma isLeaf_oleq A `{OType A} (t1 t2 : Tree A) :
    isLeaf t1 -> t1 <o= t2 -> isLeaf t2.
  Proof.
    intros Hleaf Hleq; inversion Hleq; subst;
      try constructor; inversion Hleaf.
  Qed.

  Lemma isNode_oleq A `{OType A} (t1 t2 : Tree A) :
    isNode t1 -> t1 <o= t2 -> isNode t2.
  Proof.
    intros Hnode Hleq; inversion Hleq; subst;
      try constructor; inversion Hnode.
  Qed.

  Lemma isLeaf_fmap {A B} `{OType A} `{OType B} (t : Tree A) (f : A -o> B) :
    isLeaf (tree_fmap f t) -> isLeaf t.
  Proof.
    intros Hleaf; destruct t. constructor. inversion Hleaf.
  Qed.

  Lemma isNode_fmap {A B} `{OType A} `{OType B} (t : Tree A) (f : A -o> B) :
    isNode (tree_fmap f t) -> isNode t.
  Proof.
    intros Hnode. destruct t. inversion Hnode. constructor.
  Qed.

  Lemma isLeaf_chain f `{PDiagram f} (c : PChain (mapTreeTypeSequence f)) n :
    isLeaf (chain c 0) -> isLeaf (chain c n).
  Proof.
    intros Hleaf; inversion Hleaf.
    destruct c; simpl in *.
    induction n.
    - rewrite <- H1; constructor.
    - specialize (chainCondition0 n).
      generalize (isLeaf_oleq _ (chain0 n)
                              (tree_fmap (proj n) (chain0 (S n)))
                              IHn (proj1 chainCondition0)); intros Hleaf'.
      apply isLeaf_fmap in Hleaf'; auto.
  Qed.

  Lemma isNode_chain f `{PDiagram f} (c : PChain (mapTreeTypeSequence f)) n :
    isNode (chain c 0) -> isNode (chain c n).
  Proof.
    intros Hnode; inversion Hnode.
    destruct c; simpl in *.
    induction n.
    - rewrite <- H1; constructor.
    - specialize (chainCondition0 n).
      generalize (isNode_oleq _ (chain0 n)
                              (tree_fmap (proj n) (chain0 (S n)))
                              IHn (proj1 chainCondition0)); intros Hnode'.
      apply isNode_fmap in Hnode'; auto.
  Qed.

  Lemma tree_fold_unfold f `{PDiagram f} :
    treeFold ∘ treeUnfold =o= id_ofun.
  Proof.
    split; simpl.
    - intros c1 c2 Hleq n. unfold oleq; simpl.
      unfold treeUnfold_f.
      transitivity (chain c1 n).
      + clear Hleq c2; remember (chain c1 0); revert c1 Heqm.
        induction m; intros; simpl.
        * assert (isLeaf (chain c1 n)).
          { apply isLeaf_chain; rewrite <- Heqm; constructor. }
          rewrite leaf_unleaf; auto; reflexivity.
        * assert (isNode (chain c1 n)).
          { apply isNode_chain; rewrite <- Heqm; constructor. }
          inversion H0; subst; constructor.
          -- assert (H1: m1 = chain (unNodeLeftPChain @@ c1) 0).
             { simpl; destruct (chain c1 0); inversion Heqm; auto. }
             specialize (IHm1 (unNodeLeftPChain @@ c1) H1).
             etransitivity. apply IHm1.
             simpl; rewrite <- H2; reflexivity.
          -- assert (H1: m2 = chain (unNodeRightPChain @@ c1) 0).
            { simpl; destruct (chain c1 0); inversion Heqm; auto. }
            specialize (IHm2 (unNodeRightPChain @@ c1) H1).
            etransitivity. apply IHm2.
            simpl; rewrite <- H2; reflexivity.
      + apply Hleq.
    - intros c1 c2 Hleq n. unfold oleq; simpl.
      transitivity (chain c2 n).
      + apply Hleq.
      + clear Hleq c1; unfold treeUnfold_f; remember (chain c2 0).
        revert c2 Heqm; induction m; intros; simpl.
        * assert (isLeaf (chain c2 n)).
          { apply isLeaf_chain; rewrite <- Heqm; constructor. }
          rewrite leaf_unleaf; auto; reflexivity.
        * assert (isNode (chain c2 n)).
          { apply isNode_chain; rewrite <- Heqm; constructor. }
          inversion H0; subst; constructor.
          -- assert (H1: m1 = chain (unNodeLeftPChain @@ c2) 0).
             { simpl; destruct (chain c2 0); inversion Heqm; auto. }
             specialize (IHm1 (unNodeLeftPChain @@ c2) H1).
             transitivity (chain (unNodeLeftPChain @@ c2) n).
             { simpl. rewrite <- H2. simpl. reflexivity. }
             etransitivity; eauto. reflexivity.
          -- assert (H1: m2 = chain (unNodeRightPChain @@ c2) 0).
             { simpl; destruct (chain c2 0); inversion Heqm; auto. }
             specialize (IHm2 (unNodeRightPChain @@ c2) H1).
             transitivity (chain (unNodeRightPChain @@ c2) n).
             { simpl. rewrite <- H2. simpl. reflexivity. }
             etransitivity; eauto. reflexivity.
  Qed.

  Lemma tree_unfold_fold f `{PDiagram f} :
    treeUnfold ∘ treeFold =o= id_ofun.
  Proof.
    split; unfold oleq; simpl.
    - intros t1 t2 Hleq. unfold oleq; simpl.
      induction Hleq; simpl in *.
      + constructor; auto.
      + unfold treeUnfold_f in *. simpl in *.
        constructor.
        * match goal with
          | [ _ : tree_oleq ?x t1' |- _ ] => transitivity x
          end; auto;
          apply Reflexive'_tree_oleq;
          apply Proper_treeUnfold_f_aux;
          split; simpl; unfold oleq; simpl; reflexivity;
          reflexivity.
        * match goal with
          | [ _ : tree_oleq ?x t2' |- _ ] => transitivity x
          end; auto.
          apply Reflexive'_tree_oleq.
          apply Proper_treeUnfold_f_aux.
          split; simpl; unfold oleq; simpl; reflexivity.
          reflexivity.
    - intros t1 t2 Hleq.
      induction Hleq; simpl in *.
      + transitivity (Leaf y). constructor; auto.
        apply Reflexive'_tree_oleq.
        split; constructor; unfold oleq; simpl; reflexivity.
      + constructor; etransitivity; try apply IHHleq1;
          try apply IHHleq2; apply Reflexive'_tree_oleq;
            unfold treeUnfold_f; simpl; apply Proper_treeUnfold_f_aux;
              split; unfold oleq; simpl; reflexivity.
  Qed.
End treePChain.

(** The tree functor. *)
Section treeFunctor.
  Context F {oF : OTypeF F} {fm : FMap F} {ch : ChooseF F}
          {func : Functor F} {uF : UnfoldTypeF F} {uOF : UnfoldOTypeF F}
          {fF : FoldF F} {ufF : UnfoldF F} {cFunc : ContinuousFunctor F}.

  Definition TreeF : TypeF := fun X oX => Tree (F X oX).

  Global Instance TreeOTypeF : OTypeF TreeF := fun _ _ => _.

  Global Instance TreeFMap : FMap TreeF :=
    fun _ _ _ _ => fun f => Tree_fmap (fmap f).

  Global Instance TreeChooseF : ChooseF TreeF := Leaf chooseF.

  Global Program Instance TreeFunctor : Functor TreeF.
  Next Obligation.
    unfold fmap, TreeFMap; destruct func.
    rewrite fmap_id0; apply Tree_fmap_id.
  Qed.
  Next Obligation.
    unfold fmap, TreeFMap; destruct func.
    rewrite fmap_comp0; apply Tree_fmap_comp.
  Qed.

  Global Instance TreeUnfoldTypeF : UnfoldTypeF TreeF :=
  fun f _ _ => Tree (@unfoldTypeF F uF f _ _).
  Global Instance TreeUnfoldOTypeF : UnfoldOTypeF TreeF := fun _ _ _ => _.
  Global Instance TreeFoldF : FoldF TreeF :=
    fun f _ _ => treeFold ∘ Tree_fmap (foldF f).
  Global Instance TreeUnfoldF : UnfoldF TreeF :=
    fun f _ _ => Tree_fmap (unfoldF f) ∘ treeUnfold.
  Global Instance TreeContinuousFunctor : ContinuousFunctor TreeF.
  Proof.
    constructor.
    - intros f o G.
      unfold unfoldF, TreeUnfoldF, foldF, TreeFoldF.
      rewrite compose_ofun_assoc_4.
      rewrite tree_unfold_fold.
      rewrite id_compose_ofun.
      match goal with
      | [ |- Tree_fmap ?f ∘ Tree_fmap ?g =o= _ ] =>
        transitivity (Tree_fmap (f ∘ g))
      end.
      symmetry.
      apply Tree_fmap_comp.
      destruct cFunc. rewrite unfold_fold_id0.
      apply Tree_fmap_id.
    - intros f o G.
      unfold unfoldF, TreeUnfoldF, foldF, TreeFoldF.
      rewrite compose_ofun_assoc_4.
      rewrite compose_ofun_middle_id.
      apply tree_fold_unfold.
      match goal with
      | [ |- Tree_fmap ?f ∘ Tree_fmap ?g =o= _ ] =>
        transitivity (Tree_fmap (f ∘ g))
      end.
      symmetry; apply Tree_fmap_comp.
      destruct cFunc. rewrite fold_unfold_id0.
      apply Tree_fmap_id.
  Qed.
End treeFunctor.

Section foldUnfoldComposition.
  Context F `{ContinuousFunctor F}.

  Definition unfoldCompose : PChain (type_n F) -o> unfoldTypeF (type_n F) :=
    unfoldF (type_n F) ∘ functorUnfold F.

  Definition foldCompose : unfoldTypeF (type_n F) -o> PChain (type_n F) :=
    functorFold F ∘ foldF (type_n F).

  Lemma unfoldCompose_foldCompose :
    unfoldCompose ∘ foldCompose =o= id_ofun.
  Proof.
    unfold unfoldCompose, foldCompose.
    rewrite compose_ofun_assoc_4.
    rewrite functor_unfold_fold.
    rewrite id_compose_ofun.
    destruct H0. auto.
  Qed.

  Lemma foldCompose_unfoldCompose :
    foldCompose ∘ unfoldCompose =o= id_ofun.
  Proof.
    unfold unfoldCompose, foldCompose.
    rewrite compose_ofun_assoc_4.
    destruct H0. auto.
    rewrite fold_unfold_id0.
    rewrite id_compose_ofun.
    apply functor_fold_unfold.
  Qed.
End foldUnfoldComposition.

Notation "'ϕ'" := unfoldCompose (at level 65) : mem_scope.
Notation "'ψ'" := foldCompose (at level 65) : mem_scope.
Notation "a '×' b" := (ProductF a b) (at level 65) : mem_scope.
Notation "'|' x '|'" := (ConstantF x) (at level 65) : mem_scope.
Notation "'ϒ' x" := (TreeF x) (at level 65) : mem_scope.

Open Scope mem_scope.

(** The recursive type for memory stores. *)
Section mem.
  Context Z `{OType Z}.

  Definition permF : TypeF := PERF × PreOrderF.

  Definition memF : TypeF := |Z| × ϒ permF.

  Definition MemDiag : nat -> Type := type_n memF.
  Definition Mem := PChain (type_n memF).

  Definition MemPERDiag f `{PDiagram f} := typeSequenceMap f PERF.
  Definition MemPER f `{PDiagram f} := PChain (MemPERDiag f).

  Definition MemPreOrderDiag f `{PDiagram f} := typeSequenceMap f PreOrderF.
  Definition MemPreOrder f `{PDiagram f} := PChain (MemPreOrderDiag f).

  Definition Perm f `{PDiagram f} := (MemPER f * MemPreOrder f)%type.

  (* These are a bit slow to typecheck... *)
  (* But at least they verify that the UnfoldF instance generated by
     typeclass resolution is the type we expect. *)
  (* Definition unfoldSanityCheck : Mem -o> Z * Tree Perm := ϕ memF. *)
  (* Definition foldSanityCheck : Z * Tree Perm -o> Mem := ψ memF. *)

  Definition memPEREq {f} `{PDiagram f} (per : MemPER f)
    : relation (PChain f) :=
    fun c1 c2 => forall n, proj1_sig (chain per n) (chain c1 n) (chain c2 n).

  Definition memPreOrderEq {f} `{PDiagram f} (po : MemPreOrder f)
    : relation (PChain f) :=
    fun c1 c2 => forall n, proj1_sig (chain po n) (chain c1 n) (chain c2 n).

  Definition permEq {f} `{PDiagram f} (p : Perm f) : relation (PChain f) :=
    memPEREq (fst p).

  Definition permUpd {f} `{PDiagram f} (p : Perm f) : relation (PChain f) :=
    memPreOrderEq (snd p).

  (* Definition R_true A : relation A := fun _ _ => True. *)
  (* Definition PER_true A `{OType A} : PER (R_true A). *)
  (* Proof. firstorder. Qed. *)

  (* Definition contramap_rel {f} `{PDiagram f} {n} (R : relation (f n))
    : relation (f (S n)) := *)
  (*   fun x y => R (proj n @@ x) (proj n @@ y). *)

  (* Fixpoint test_f (n0 n1 : nat) n : nat := *)
  (*   match n with *)
  (*   | O => n0 *)
  (*   | 1 => n1 *)
  (*   | S n' => 1 + test_f n0 n1 n' *)
  (*   end. *)

  (* Program Fixpoint mkPER1_f {f} `{PDiagram f} n *)
  (*         (R1 : relation (f 1)) {struct n} : relation (f n) := *)
  (*   match n with *)
  (*   | O => fun _ _ => True *)
  (*   | S O => R1 *)
  (*   | S n0 => contramap_rel (mkPER1_f n0 R1) *)
  (*   (* | S n' => fun x y => mkPER1_f n' R0 R1 (proj n' @@ x) (proj n' @@ y) *) *)
  (*   end. *)

  (* Program Fixpoint mkPER1_f {f} `{PDiagram f} *)
  (*         (R1 : relation (f 1)) n : relation (f n) := *)
  (*   match n with *)
  (*   | O => fun _ _ => True *)
  (*   | S n' => match n' with *)
  (*            | O => R1 *)
  (*            | _ => _ (contramap_rel (mkPER1_f R1 n')) *)
  (*            end *)
  (*   end. *)

  Definition contramap_rel {A B} `{OType A} `{OType B} (f : A -o> B)
             (R : relation B) : relation A :=
    fun x y => R (f @@ x) (f @@ y).

  Definition coerce_rel {f} `{PDiagram f} {n m}
             (R : relation (f n)) (pf : n = m) : relation (f m) :=
    match pf with
    | eq_refl => R
    end.

  Program Fixpoint mkPER1_f {f} `{PDiagram f}
          (R1 : relation (f 1)) n {struct n} : relation (f n) :=
    match n with
    | O => fun _ _ => True
    | S n' => match n' with
             | O => R1
             | S n'' => contramap_rel (proj (S n''))
                                     (coerce_rel (mkPER1_f R1 n') _)
             end
    end.

  Program Fixpoint mkPreOrder1_f {f} `{PDiagram f}
          (R1 : relation (f 1)) n {struct n} : relation (f n) :=
    match n with
    | O => fun _ _ => True
    | S n' => match n' with
             | O => R1
             | S n'' => contramap_rel (proj (S n''))
                                     (coerce_rel (mkPreOrder1_f R1 n') _)
             end
    end.

  Program Definition mkPER1 {f} `{PDiagram f} (R : relation (f 1)) {per : PER R}
    : MemPER f :=
    {| chain := mkPER1_f R |}.
  Next Obligation.
    rename x into n.
    constructor.
    - intros x y Heq1 z w Heq2 Hr.
      induction n; auto.
      simpl in *. destruct n.
      + destruct per. rewrite <- Heq1, <- Heq2; auto.
      + eapply IHn; eauto. rewrite Heq1; reflexivity.
        rewrite Heq2; reflexivity.
    - intros x y Hr.
      induction n; auto.
      simpl. destruct n.
      + simpl in *. destruct per; auto.
      + simpl in *.
        apply IHn. auto.
    - intros x y z Hzy Hyz.
      induction n; auto.
      simpl. destruct n. simpl in *.
      destruct per; eapply Transitive_PER0; eauto.
      eapply IHn; eauto.
  Qed.

  Next Obligation.
    split.
    - intros x y Hr. simpl in *.
      induction n.
      apply t_step.
      unfold fmapRel.
      exists chooseF.
      admit.
      simpl in Hr. destruct n; simpl in *.
      + specialize (IHn (proj 0 @@ x) (proj 0 @@ y) I).
        inversion IHn; subst.
        * destruct H1 as (x1 & x2 & ? & ? & ?).

  Admitted.

  Program Definition mkPreOrder1 {f} `{PDiagram f} (R : relation (f 1))
          {po : Preorder R} : MemPreOrder f :=
    {| chain := mkPreOrder1_f R |}.
  Next Obligation.
    rename x into n.
    constructor.
    - intros x y Heq1 z w Heq2 Hr.
      induction n; auto.
      simpl in *. destruct n.
      + destruct po. rewrite <- Heq1, <- Heq2; auto.
      + eapply IHn; eauto. rewrite Heq1; reflexivity.
        rewrite Heq2; reflexivity.
    - constructor.
      + intros x. induction n; simpl; auto.
        destruct n. destruct po as [_ []]; auto.
        apply IHn.
      + intros x y z Hxy Hyz. induction n; auto.
        destruct n; simpl.
        destruct po as [_ []].
        eapply PreOrder_Transitive; eauto.
        eapply IHn; eauto.
  Qed.

  Next Obligation. Admitted.

End mem.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Group_util.
Require Export Abelian_group_facts.
Section Free_abelian_group_def.
Variable V : SET.

Inductive FaG : Type :=
  | Var : V -> FaG
  | Law : FaG -> FaG -> FaG
  | Unit : FaG
  | Inv : FaG -> FaG.

Inductive eqFaG : FaG -> FaG -> Prop :=
  | eqFaG_Var : forall x y : V, Equal x y -> (eqFaG (Var x) (Var y):Prop)
  | eqFaG_law :
      forall x x' y y' : FaG,
      eqFaG x x' -> eqFaG y y' -> (eqFaG (Law x y) (Law x' y'):Prop)
  | eqFaG_law_assoc :
      forall x y z : FaG, eqFaG (Law (Law x y) z) (Law x (Law y z)):Prop
  | eqFaG_law0r : forall x : FaG, eqFaG (Law x Unit) x:Prop
  | eqFaG_inv : forall x y : FaG, eqFaG x y -> eqFaG (Inv x) (Inv y)
  | eqFaG_invr : forall x : FaG, eqFaG (Law x (Inv x)) Unit
  | eqFaG_refl : forall x : FaG, eqFaG x x:Prop
  | eqFaG_sym : forall x y : FaG, eqFaG x y -> (eqFaG y x:Prop)
  | eqFaG_trans :
      forall x y z : FaG, eqFaG x y -> eqFaG y z -> (eqFaG x z:Prop)
  | eqFaG_com : forall x y : FaG, eqFaG (Law x y) (Law y x).
Hint Resolve eqFaG_Var eqFaG_law eqFaG_law_assoc eqFaG_law0r eqFaG_invr
  eqFaG_refl eqFaG_com: algebra.
Hint Immediate eqFaG_sym: algebra.

Lemma eqFaG_Equiv : equivalence eqFaG.
red in |- *.
split; [ try assumption | idtac ].
exact eqFaG_refl.
red in |- *.
split; [ try assumption | idtac ].
exact eqFaG_trans.
exact eqFaG_sym.
Qed.

Definition FaG_set := Build_Setoid eqFaG_Equiv.

Definition FreeAbelianGroup : ABELIAN_GROUP.
apply
 (BUILD_ABELIAN_GROUP (E:=FaG_set) (genlaw:=Law) (e:=Unit) (geninv:=Inv)).
exact eqFaG_law.
exact eqFaG_law_assoc.
exact eqFaG_law0r.
exact eqFaG_inv.
exact eqFaG_invr.
exact eqFaG_com.
Defined.
Section Universal_prop.
Variable G : ABELIAN_GROUP.
Variable f : Hom V G.

Fixpoint FaG_lift_fun (p : FreeAbelianGroup) : G :=
  match p with
  | Var v => f v
  | Law p1 p2 => sgroup_law _ (FaG_lift_fun p1) (FaG_lift_fun p2)
  | Unit => monoid_unit G
  | Inv p1 => group_inverse G (FaG_lift_fun p1)
  end.

Definition FaG_lift : Hom FreeAbelianGroup G.
apply (BUILD_HOM_GROUP (G:=FreeAbelianGroup) (G':=G) (ff:=FaG_lift_fun)).
intros x y H'; try assumption.
elim H'; simpl in |- *; auto with algebra.
intros x0 y0 z H'0 H'1 H'2 H'3; try assumption.
apply Trans with (FaG_lift_fun y0); auto with algebra.
simpl in |- *; auto with algebra.
simpl in |- *; auto with algebra.
Defined.

Definition FaG_var : Hom V FreeAbelianGroup.
apply (Build_Map (A:=V) (B:=FreeAbelianGroup) (Ap:=Var)).
red in |- *.
simpl in |- *; auto with algebra.
Defined.

Lemma FaG_comp_prop :
 Equal f (comp_hom (FaG_lift:Hom (FreeAbelianGroup:SET) G) FaG_var).
simpl in |- *.
red in |- *.
simpl in |- *.
auto with algebra.
Qed.
End Universal_prop.
End Free_abelian_group_def.
Hint Resolve FaG_comp_prop: algebra.


Require Export P06.

(** **** Exercise: 3 stars, optional (CSeq_congruence)  *)
Theorem CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (c1;;c2) (c1';;c2').
Proof.
  unfold cequiv. intros.
  split; intros.
  - inversion H1. subst. apply H in H4. apply H0 in H7. econstructor; eassumption.
  - inversion H1. subst. apply H in H4. apply H0 in H7. econstructor; eassumption.
Qed.


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang.lib.barrier Require Import proof.
From iris.heap_lang Require Import par.
From iris.heap_lang Require Import adequacy proofmode.
Set Default Proof Using "Type".

Definition worker (n : Z) : val :=
  λ: "b" "y", wait "b" ;; !"y" #n.
Definition client : expr :=
  let: "y" := ref #0 in
  let: "b" := newbarrier #() in
  ("y" <- (λ: "z", "z" + #42) ;; signal "b") |||
    (worker 12 "b" "y" ||| worker 17 "b" "y").

Section client.
  Local Set Default Proof Using "Type*".
  Context `{!heapG Σ, !probG Σ, !barrierG Σ, !spawnG Σ}.

  Definition N := nroot .@ "barrier".

  Definition y_inv (q : Qp) (l : loc) : iProp Σ :=
    (∃ f : val, l ↦{q} f ∗ □ ∀ n : Z, WP f #n {{ v, ⌜v = #(n + 42)⌝ }})%I.

  Lemma y_inv_split q l : y_inv q l -∗ (y_inv (q/2) l ∗ y_inv (q/2) l).
  Proof.
    iDestruct 1 as (f) "[[Hl1 Hl2] #Hf]".
    iSplitL "Hl1"; iExists f; by iSplitL; try iAlways.
  Qed.

  Lemma worker_safe q (n : Z) (b y : loc) :
    recv N b (y_inv q y) -∗ WP worker n #b #y {{ _, True }}.
  Proof.
    iIntros "Hrecv". wp_lam. wp_let.
    wp_apply (wait_spec with "Hrecv"). iDestruct 1 as (f) "[Hy #Hf]".
    wp_seq. wp_load.
    iApply (wp_wand with "[]"). iApply "Hf". by iIntros (v) "_".
  Qed.

  Lemma client_safe : WP client {{ _, True }}%I.
  Proof.
    iIntros ""; rewrite /client. wp_alloc y as "Hy". wp_let.
    wp_apply (newbarrier_spec N (y_inv 1 y) with "[//]").
    iIntros (l) "[Hr Hs]". wp_let.
    iApply (wp_par (λ _, True%I) (λ _, True%I) with "[Hy Hs] [Hr]"); last auto.
    - (* The original thread, the sender. *)
      wp_store. iApply (signal_spec with "[-]"); last by iNext; auto.
      iSplitR "Hy"; first by eauto.
      iExists _; iSplitL; [done|]. iIntros "!#" (n). wp_let. by wp_op.
    - (* The two spawned threads, the waiters. *)
      iDestruct (recv_weaken with "[] Hr") as "Hr".
      { iIntros "Hy". by iApply (y_inv_split with "Hy"). }
      iMod (recv_split with "Hr") as "[H1 H2]"; first done.
      iApply (wp_par (λ _, True%I) (λ _, True%I) with "[H1] [H2]"); last auto.
      + by iApply worker_safe.
      + by iApply worker_safe.
Qed.
End client.

Section ClosedProofs.

Let Σ : gFunctors := #[ heapΣ ; barrierΣ ; spawnΣ ].

Lemma client_adequate σ : adequate client σ (λ _, True).
Proof. apply (heap_adequacy' Σ)=> ??. apply client_safe. Qed.

End ClosedProofs.


Require Export StlcFix.SpecSyntax.

(** * Typing *)

Reserved Notation "⟪  i : T ∈ Γ  ⟫"
  (at level 0, i at level 98, Γ at level 98).
Inductive GetEvar : Env → Ix → Ty → Prop :=
  | GetEvarHere {Γ T} :
      ⟪   O : T ∈ Γ ▻ T  ⟫
  | GetEvarThere {Γ T T' i} :
      ⟪   i : T ∈ Γ      ⟫ →
      ⟪ S i : T ∈ Γ ▻ T' ⟫
where "⟪  i : T ∈ Γ  ⟫" := (GetEvar Γ i T).

Reserved Notation "⟪  Γ ⊢ t : T  ⟫"
  (at level 0, Γ at level 98, t at level 98, T at level 98 ).
Inductive Typing (Γ: Env) : Tm → Ty → Prop :=
  | WtVar {i T} :
      ⟪ i : T ∈ Γ ⟫ →
      ⟪ Γ ⊢ var i : T ⟫
  | WtAbs {t τ₁ τ₂} :
      ⟪ Γ ▻ τ₁ ⊢ t : τ₂ ⟫ →
      ⟪ Γ ⊢ abs τ₁ t : tarr τ₁ τ₂ ⟫
  | WtApp {t₁ t₂ τ₁ τ₂} :
      ⟪ Γ ⊢ t₁ : tarr τ₁ τ₂ ⟫ →
      ⟪ Γ ⊢ t₂ : τ₁ ⟫ →
      ⟪ Γ ⊢ app t₁ t₂ : τ₂ ⟫
  | WtUnit :
      ⟪ Γ ⊢ unit : tunit ⟫
  | WtTrue :
      ⟪ Γ ⊢ true : tbool ⟫
  | WtFalse :
      ⟪ Γ ⊢ false : tbool ⟫
  | WtIte {t₁ t₂ t₃ T} :
      ⟪ Γ ⊢ t₁ : tbool ⟫ →
      ⟪ Γ ⊢ t₂ : T ⟫ →
      ⟪ Γ ⊢ t₃ : T ⟫ →
      ⟪ Γ ⊢ ite t₁ t₂ t₃ : T ⟫
  | WtPair {t₁ t₂ τ₁ τ₂} :
      ⟪ Γ ⊢ t₁ : τ₁ ⟫ →
      ⟪ Γ ⊢ t₂ : τ₂ ⟫ →
      ⟪ Γ ⊢ pair t₁ t₂ : tprod τ₁ τ₂ ⟫
  | WtProj1 {t τ₁ τ₂} :
      ⟪ Γ ⊢ t : tprod τ₁ τ₂ ⟫ →
      ⟪ Γ ⊢ proj₁ t : τ₁ ⟫
  | WtProj2 {t τ₁ τ₂} :
      ⟪ Γ ⊢ t : tprod τ₁ τ₂ ⟫ →
      ⟪ Γ ⊢ proj₂ t : τ₂ ⟫
  | WtInl {t τ₁ τ₂} :
      ⟪ Γ ⊢ t : τ₁ ⟫ →
      ⟪ Γ ⊢ inl t : tsum τ₁ τ₂ ⟫
  | WtInr {t τ₁ τ₂} :
      ⟪ Γ ⊢ t : τ₂ ⟫ →
      ⟪ Γ ⊢ inr t : tsum τ₁ τ₂ ⟫
  | WtCaseof {t₁ t₂ t₃ τ₁ τ₂ T} :
      ⟪ Γ ⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ Γ ▻ τ₁ ⊢ t₂ : T ⟫ →
      ⟪ Γ ▻ τ₂ ⊢ t₃ : T ⟫ →
      ⟪ Γ ⊢ caseof t₁ t₂ t₃ : T ⟫
  | WtSeq {t₁ t₂ T} :
      ⟪ Γ ⊢ t₁ : tunit ⟫ →
      ⟪ Γ ⊢ t₂ : T ⟫ →
      ⟪ Γ ⊢ seq t₁ t₂ : T ⟫
  | WtFixt {τ₁ τ₂ t} :
      ⟪ Γ ⊢ t : tarr (tarr τ₁ τ₂) (tarr τ₁ τ₂) ⟫ →
      ⟪ Γ ⊢ fixt τ₁ τ₂ t : tarr τ₁ τ₂ ⟫
where "⟪  Γ ⊢ t : T  ⟫" := (Typing Γ t T).

Reserved Notation "⟪ ⊢ C : Γ₀ , τ₀ → Γ , τ ⟫"
  (at level 0, C at level 98,
   Γ₀ at level 98, τ₀ at level 98,
   Γ at level 98, τ at level 98,
   format "⟪  ⊢  C  :  Γ₀ ,  τ₀  →  Γ ,  τ  ⟫").
Inductive PCtxTyping (Γ₀: Env) (τ₀: Ty) : Env → PCtx → Ty → Prop :=
  | WtPHole :
      ⟪ ⊢ phole : Γ₀, τ₀ → Γ₀, τ₀ ⟫
  | WtPAbs {Γ C τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ ▻ τ₁, τ₂ ⟫ →
      ⟪ ⊢ pabs τ₁ C : Γ₀, τ₀ → Γ, tarr τ₁ τ₂ ⟫
  | WtPAppl {Γ C t₂ τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tarr τ₁ τ₂ ⟫ →
      ⟪ Γ ⊢ t₂ : τ₁ ⟫ →
      ⟪ ⊢ papp₁ C t₂ : Γ₀, τ₀ → Γ, τ₂ ⟫
  | WtPAppr {Γ t₁ C τ₁ τ₂} :
      ⟪ Γ ⊢ t₁ : tarr τ₁ τ₂ ⟫ →
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ⟪ ⊢ papp₂ t₁ C : Γ₀, τ₀ → Γ, τ₂ ⟫
  | WtPIteI {Γ C t₂ t₃ T} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ , tbool ⟫ →
      ⟪ Γ ⊢ t₂ : T ⟫ →
      ⟪ Γ ⊢ t₃ : T ⟫ →
      ⟪ ⊢ pite₁ C t₂ t₃ : Γ₀ , τ₀ → Γ , T ⟫
  | WtPIteT {Γ t₁ C t₃ T} :
      ⟪ Γ ⊢ t₁ : tbool ⟫ →
      ⟪ ⊢ C : Γ₀ , τ₀ → Γ , T ⟫ →
      ⟪ Γ ⊢ t₃ : T ⟫ →
      ⟪ ⊢ pite₂ t₁ C t₃ : Γ₀ , τ₀ → Γ , T ⟫
  | WtPIteE {Γ t₁ t₂ C T} :
      ⟪ Γ ⊢ t₁ : tbool ⟫ →
      ⟪ Γ ⊢ t₂ : T ⟫ →
      ⟪ ⊢ C : Γ₀ , τ₀ → Γ , T ⟫ →
      ⟪ ⊢ pite₃ t₁ t₂ C : Γ₀ , τ₀ → Γ , T ⟫
  | WtPPair₁ {Γ C t₂ τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ⟪ Γ ⊢ t₂ : τ₂ ⟫ →
      ⟪ ⊢ ppair₁ C t₂ : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫
  | WtPPair₂ {Γ t₁ C τ₁ τ₂} :
      ⟪ Γ ⊢ t₁ : τ₁ ⟫ →
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, τ₂ ⟫ →
      ⟪ ⊢ ppair₂ t₁ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫
  | WtPProj₁ {Γ C τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫ →
      ⟪ ⊢ pproj₁ C : Γ₀, τ₀ → Γ, τ₁ ⟫
  | WtPProj₂ {Γ C τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫ →
      ⟪ ⊢ pproj₂ C : Γ₀, τ₀ → Γ, τ₂ ⟫
  | WtPInl {Γ C τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ⟪ ⊢ pinl C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫
  | WtPInr {Γ C τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, τ₂ ⟫ →
      ⟪ ⊢ pinr C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫
  | WtPCaseof₁ {Γ C t₂ t₃ τ₁ τ₂ T} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫ →
      ⟪ Γ ▻ τ₁ ⊢ t₂ : T ⟫ →
      ⟪ Γ ▻ τ₂ ⊢ t₃ : T ⟫ →
      ⟪ ⊢ pcaseof₁ C t₂ t₃ : Γ₀, τ₀ → Γ, T ⟫
  | WtPCaseof₂ {Γ t₁ C t₃ τ₁ τ₂ T} :
      ⟪ Γ ⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ ⊢ C : Γ₀, τ₀ → Γ ▻ τ₁, T ⟫ →
      ⟪ Γ ▻ τ₂ ⊢ t₃ : T ⟫ →
      ⟪ ⊢ pcaseof₂ t₁ C t₃ : Γ₀, τ₀ → Γ, T ⟫
  | WtPCaseof₃ {Γ t₁ t₂ C τ₁ τ₂ T} :
      ⟪ Γ ⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ Γ ▻ τ₁ ⊢ t₂ : T ⟫ →
      ⟪ ⊢ C : Γ₀, τ₀ → Γ ▻ τ₂, T ⟫ →
      ⟪ ⊢ pcaseof₃ t₁ t₂ C : Γ₀, τ₀ → Γ, T ⟫
  | WtPSeq₁ {Γ C t₂ T} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tunit ⟫ →
      ⟪ Γ ⊢ t₂ : T ⟫ →
      ⟪ ⊢ pseq₁ C t₂ : Γ₀, τ₀ → Γ, T ⟫
  | WtPSeq₂ {Γ C t₁ T} :
      ⟪ Γ ⊢ t₁ : tunit ⟫ →
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, T ⟫ →
      ⟪ ⊢ pseq₂ t₁ C : Γ₀, τ₀ → Γ, T ⟫
  | WtPFixt {Γ τ₁ τ₂ C} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tarr (tarr τ₁ τ₂) (tarr τ₁ τ₂) ⟫ →
      ⟪ ⊢ pfixt τ₁ τ₂ C : Γ₀, τ₀ → Γ, tarr τ₁ τ₂ ⟫
where "⟪ ⊢ C : Γ₀ , τ₀ → Γ , τ ⟫" := (PCtxTyping Γ₀ τ₀ Γ C τ).

Lemma pctxtyping_app {Γ₀ t₀ τ₀ Γ C τ} :
  ⟪ Γ₀ ⊢ t₀ : τ₀ ⟫ → ⟪ ⊢ C : Γ₀, τ₀ → Γ , τ ⟫ → ⟪ Γ ⊢ pctx_app t₀ C : τ ⟫.
Proof.
  intros wt₀ wC;
  induction wC; cbn; subst; eauto using Typing.
Qed.

Lemma pctxtyping_cat {Γ₀ τ₀ C₁ Γ₁ τ₁ C₂ Γ₂ τ₂} :
  ⟪ ⊢ C₁ : Γ₀, τ₀ → Γ₁ , τ₁ ⟫ →
  ⟪ ⊢ C₂ : Γ₁, τ₁ → Γ₂ , τ₂ ⟫ →
  ⟪ ⊢ pctx_cat C₁ C₂ : Γ₀, τ₀ → Γ₂ , τ₂ ⟫.
Proof.
  intros wC₁ wC₂.
  induction wC₂; cbn; eauto using PCtxTyping.
Qed.

Definition WtRen (Γ₁ Γ₂: Env) (ξ: Sub Ix) : Prop :=
  ∀ i T, ⟪ i : T ∈ Γ₁ ⟫ → ⟪ (ξ i) : T ∈ Γ₂ ⟫.
Definition WtSub (Γ₁ Γ₂: Env) (ζ: Sub Tm) : Prop :=
  ∀ i T, ⟪ i : T ∈ Γ₁ ⟫ → ⟪ Γ₂ ⊢ (ζ i) : T ⟫.


From mathcomp Require Import all_ssreflect all_algebra finmap.
From Coq Require Import Uint63 PArray.
From Polyhedra Require Import extra_misc inner_product extra_matrix vector_order affine row_submx barycenter.
From Polyhedra Require Import lrel polyhedron poly_base simplex.
Require Import enum_algo enum_proof enum_equiv graph high_graph img_graph extra_array extra_int rat_bigQ diameter refinement.

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

Import Order.Theory Num.Theory.

Local Notation "a .[ i ]" := (PArray.get a i).

Section LexCorrectness.

Context (m' n' : nat).
Local Notation m := m'.+1.
Local Notation n := n'.+1.

Context (A : 'M[rat]_(m,n)) (b : 'cV[rat]_m).
Local Notation b_pert := (Simplex.b_pert b).

Context (G : graph (enum_type m' n')).

Hypothesis enum_h_r : high_enum_algo A b G.
Hypothesis P_compact : forall c, Simplex.bounded A b c.
Hypothesis G_prop0 : G != (graph0 (enum_type m' n')).

Lemma enum_h :
  [forall e : vertices G,
    [&& card_verification (fsval e),
        feas_verification A b (fsval e),
        bas_verification A b (fsval e),
        reg_verification G (fsval e) &
        [forall e' : successors G (fsval e), inter_verification (fsval e) (fsval e')]
    ]
  ].
Proof. by move: enum_h_r; rewrite high_enum_algoE. Qed.

Section ConstructFeasbas.

Context (e : enum_type m' n').
Hypothesis IxG : e \in (vertices G).

Local Notation I := e.1.
Local Notation x := e.2.

Lemma I_prebasis : #|I|==n.
Proof.
move/forallP:enum_h=> /= /(_ [` IxG]).
by case/and5P.
Qed.

Definition prebasis_I := Simplex.Prebasis I_prebasis.
Definition x_inv := -1 *: (row_submx (col' ord0 x)^T I)^T.

Lemma I_basis : Simplex.is_basis A prebasis_I.
Proof.
move/forallP:enum_h=> /= /(_ [` IxG]).
case/and5P=> _ _ + _ _; rewrite /bas_verification /= => /eqP A_Ix.
rewrite /Simplex.is_basis /=; apply/row_freeP.
exists x_inv; rewrite /x_inv -scalemxAr -[X in X *m _]trmxK -trmx_mul tr_col'.
apply/matrixP=> p q; rewrite !mxE.
under eq_bigr => [k _] do rewrite !mxE.
move: A_Ix=> /matrixP /(_ p (lift ord0 (enum_val q))); rewrite mxE.
under eq_bigr=> [k _] do rewrite mxE GRing.mulrC; move=> ->.
rewrite !mxE; case: splitP.
- move=> j /=; rewrite (ord1_eq0 j) /= => /esym /eqP.
  by rewrite (negPf (neq_bump _ _)).
- move=> k; rewrite lift0 [RHS]add1n => /succn_inj /val_inj <-.
  rewrite !mxE -GRing.mulNrn GRing.Theory.mulrnAr GRing.mulrN1 GRing.opprK.
  congr GRing.natmul; congr nat_of_bool.
  by apply/idP/idP=> [/eqP /enum_val_inj ->|/eqP ->].
Qed.

Definition basis_I := Simplex.Basis I_basis.

Lemma x_point_of_I : x = Simplex.point_of_basis b_pert basis_I.
Proof.
rewrite -(@Simplex.basis_subset_active_ineq_eq _ _ _ _ _ _ _ x) //=.
apply/subsetP=> i iI; rewrite inE row_mul.
move/forallP:enum_h=> /= /(_ [` IxG]).
case/and5P=> _ _ /eqP I_bas _ _.
by rewrite -[i](enum_rankK_in iI) // -!row_submx_row -I_bas row_mul.
Qed.

Lemma I_feasible : Simplex.is_feasible b_pert basis_I.
Proof.
move/forallP:enum_h=> /= /(_ [` IxG]).
case/and5P=> _ + _ _ _; rewrite /feas_verification /=.
by rewrite x_point_of_I /Simplex.is_feasible.
Qed.

Definition lexbasis_I := Simplex.FeasibleBasis I_feasible.

End ConstructFeasbas.

Lemma I0_def : exists x, x \in vertices G.
Proof. by move/graph0Pn: G_prop0. Qed.

Definition I0 := lexbasis_I (xchooseP I0_def).

Definition to_feas_bas (e : enum_type m' n'):=
  if @idP (e \in vertices G) is ReflectT h then
  lexbasis_I h else I0.

Definition lex_graph := lex_graph A b.

Lemma to_feas_bas_inj : {in vertices G &, injective to_feas_bas}.
Proof.
move=> e e' eG e'G; rewrite /to_feas_bas.
case: {-}_/idP=> // p; case: {-}_/idP=> // p'.
move=> bas_I_eq; rewrite [e]surjective_pairing [e']surjective_pairing.
apply/pair_equal_spec; split.
+ by move: bas_I_eq; do 3! move/(congr1 val).
+ by rewrite !x_point_of_I; move/(congr1 val):bas_I_eq=> /= ->.
Qed.

Lemma to_feas_bas_edges : {in vertices G &,
  forall x y, edges G x y ->
  edges lex_graph (to_feas_bas x) (to_feas_bas y)}.
Proof.
move=> x y xG yG; rewrite edge_mk_graph ?inE // -in_succE => yx.
rewrite /set_adjacence /=.
move/forallP: enum_h=> /(_ [`xG]) /and5P [_ _ _ _].
move/forallP=> /(_ [`yx]) /=; rewrite /inter_verification.
by rewrite /to_feas_bas; case: {-}_/idP=> // p; case: {-}_/idP.
Qed.

Lemma repr_lex_graph: gisof G lex_graph to_feas_bas.
Proof.
apply/sub_gisof=> //.
- exact: to_feas_bas_inj.
- by apply/fsubsetP=> x; rewrite vtx_mk_graph inE /=.
- exact:to_feas_bas_edges.
- exact:lex_graph_connected.
- move=> x xG; apply/eqP; rewrite eqEfcard; apply/andP; split.
  + apply/fsubsetP=> y' /imfsetP [/= y].
    rewrite in_succE=> /[dup] /edge_vtxr yG /(to_feas_bas_edges xG yG).
    by rewrite -in_succE => /[swap] ->.
  + rewrite lex_graph_regular ?vtx_mk_graph ?inE // card_in_imfset /=.
    * move/forallP: enum_h=> /(_ [`xG]) /and5P [_ _ _ + _].
      by rewrite /reg_verification=> /eqP ->.
    * move=> p q /(fsubsetP (sub_succ _ _)) + /(fsubsetP (sub_succ _ _)).
      exact:to_feas_bas_inj.
Qed.

End LexCorrectness.

(* --------------------------------------------------------------- *)

Section ImgGraph.

Context (m' n' : nat).
Local Notation m := m'.+1.
Local Notation n := n'.+1.

Context (G_lex : graph (enum_type m' n')) (G_vert : graph [choiceType of 'cV[rat]_n]).

Context (A : 'M[rat]_(m,n)) (b : 'cV[rat]_m).

Hypothesis boundA : forall c, Simplex.bounded A b c.
Hypothesis G_lex_verif : high_enum_algo A b G_lex.
Hypothesis G_lex_prop0 : G_lex != graph0 _.

(* Hypothesis G_vert_img : G_vert = ((@phi m' n') @/ G_lex). *)

Definition base_of_syst (C : 'M[rat]_(m,n) * 'cV[rat]_m) :=
  [fset [<(row i C.1)^T, C.2 i 0>] | i : 'I_m].
Definition poly_of_syst C:= 'P(base_of_syst C).

Local Notation P := (poly_of_syst (A,b)).

Lemma feasA : Simplex.feasible A b.
Proof. exact/feas_bas0/(I0 G_lex_verif G_lex_prop0). Qed.

Lemma relA : rel_mat_Po (base_of_syst (A, b)) (A,b).
Proof. by []. Qed.

Lemma high_img : poly_graph P =
  ((fun I => Simplex.point_of_basis b I) @/ (lex_graph A b)).
Proof. by exact/(im_lex_graph_vert_graph boundA feasA relA). Qed.

Lemma G_lex_repr : gisof G_lex (lex_graph A b) (to_feas_bas G_lex_verif G_lex_prop0).
Proof. exact/repr_lex_graph. Qed.

Lemma repr_poly_graph :  poly_graph P = ((@phi m' n') @/ G_lex).
Proof.
apply/esym/(gisof_diagram _ G_lex_repr _ high_img); [|exact:erefl].
move=> x xG_lex /=; rewrite Simplex.rel_points_of_basis.
rewrite /to_feas_bas; case: {-}_/idP=> // ?.
by rewrite -x_point_of_I.
Qed.

End ImgGraph.

(* --------------------------------------------------------------- *)

Section BoundPoly.

Context (m' n' : nat).
Local Notation m := m'.+1.
Local Notation n := n'.+1.

Context (A : 'M[rat]_(m,n)) (b : 'cV[rat]_m).
Context (Y_pos Y_neg : 'M[rat]_(n,m)).

Hypothesis feasA : Simplex.feasible A b.
Hypothesis bound_h : high_poly_bounded A Y_pos Y_neg.

Definition max_bound_i (i : 'I_n):=
  (Order.max '[-(row i Y_pos)^T, b] '[-(row i Y_neg)^T,b]).
Definition max_bound := \big[Order.max/0%R]_(i < n) max_bound_i i.

Lemma max_boundP (i : 'I_n):
  max_bound_i i <= max_bound.
Proof.
rewrite /max_bound.
have: i \in index_enum (ordinal_finType n) by rewrite mem_index_enum.
elim: (index_enum _)=> // h t IH.
rewrite in_cons big_cons le_maxr; case/orP.
- by move/eqP=> ->; rewrite lexx.
- by move/IH=> ->; rewrite orbT.
Qed.

Lemma high_poly_boundedP: forall c, Simplex.bounded A b c.
Proof.
move=> c; rewrite -(boundedE (relA A b)); move: c; apply/compactP.
- case/Simplex.feasibleP: feasA=> x x_in; apply/proper0P; exists x.
  by rewrite (feasE (relA A b)).
- apply/compactP_Linfty; exists max_bound=> x.
  rewrite (feasE (relA A b)) inE => x_Ab i.
  case/andP: bound_h=> /forallP /(_ i) + /forallP /(_ i).
  case/andP=> /eqP Y_pos_A Y_pos_pos.
  case/andP=> /eqP Y_neg_A Y_neg_pos.
  move: (vdot_lev Y_pos_pos x_Ab) (vdot_lev Y_neg_pos x_Ab).
  rewrite !vdot_mulmx -!trmx_mul Y_pos_A Y_neg_A.
  rewrite [X in _ <= X]row_vdot mul_scalar_mx GRing.scale1r.
  move=> x_i_ge; rewrite [X in _ <= X]row_vdot mul_scalar_mx GRing.scaleN1r mxE.
  move=> x_i_le; apply/(le_trans _ (max_boundP i)).
  rewrite ler_norml; apply/andP; split.
  + rewrite ler_oppl le_maxr; apply/orP; left.
    by rewrite vdotNl ler_oppl GRing.opprK.
  + rewrite le_maxr; apply/orP; right.
    by rewrite vdotNl ler_oppr.
Qed.

End BoundPoly.

(* --------------------------------------------------------------- *)

Section FullDim.

Context (m' n' : nat).
Local Notation m := m'.+1.
Local Notation n := n'.+1.

Context (A : 'M[rat]_(m,n)) (b : 'cV[rat]_m).
Context (x0 : 'cV[rat]_n) (s : seq 'cV[rat]_n).

Local Definition base_AB := base_of_syst (A, b).

Hypothesis full_h :
  [/\ x0 \in (vertex_set 'P(base_AB)),
    {subset s <= (vertex_set 'P(base_AB))} &
    \dim (span [seq x - x0 | x <- s]) = n].

Lemma high_dim_fullP: \pdim 'P(base_AB) = n.+1.
Proof.
apply/anti_leq/andP; split; first exact:adim_leSn.
case: full_h=> x0_vtx s_vtx {1}<-.
apply/leq_trans; [|apply/(dim_sub_affine (x0:=x0) (X:=s))].
- by rewrite adimN0_eq ?mk_affine_proper0 // dir_mk_affine.
- exact/vertex_set_subset.
- by move=> x /s_vtx; exact/vertex_set_subset.
Qed.

End FullDim.

(* --------------------------------------------------------------- *)

Section HighHirsch.

Context (m' n' : nat).
Local Notation m := m'.+1.
Local Notation n := n'.+1.

Context (A : 'M[rat]_(m,n)) (b : 'cV[rat]_m).

Context (G_lex : graph (enum_type m' n')) (G_vert : graph [choiceType of 'cV[rat]_n]).

Hypothesis enum_h : high_enum_algo A b G_lex.
Hypothesis img_h : G_vert = ((@phi m' n') @/ G_lex).
Hypothesis boundA : forall c : 'cV_n, Simplex.bounded A b c.
Hypothesis G_lex_prop0 : G_lex != graph0 _.
Hypothesis poly_dim : \pdim (poly_of_syst (A, b)) = n.+1.

Hypothesis G_vert_BFS : (diameter G_vert > m - n)%nat.

Lemma poly_facets: (#|` facets (poly_of_syst (A, b))| <= m)%nat.
Proof.
apply/(leq_trans (@facets_le _ _ (base_of_syst (A, b))))/(leq_trans (leq_imfset_card _ _ _)).
by rewrite size_enum_ord leqnn.
Qed.

Theorem high_algo_Hirsch :
  (diameter (poly_graph (poly_of_syst (A,b))) >
    #|`facets (poly_of_syst (A,b))| -
      (\pdim (poly_of_syst (A,b))).-1)%nat.
Proof.
have G_vert_poly: poly_graph (poly_of_syst (A,b)) = G_vert.
- rewrite img_h; apply: repr_poly_graph.
  + exact: boundA.
  + exact: enum_h.
  + exact: G_lex_prop0.
rewrite poly_dim /=; apply/(leq_ltn_trans (n:=m - n))=> //;first
  apply/leq_sub2r/poly_facets.
by rewrite G_vert_poly.
Qed.

End HighHirsch.

(* --------------------------------------------------------------- *)

Section HirschVerification.

Context (Po : Com.polyType).
Hypothesis Po_format : poly_format Po.
Local Notation m' := (Com.m Po).-1.
Local Notation n' := (Com.n Po).-1.

Context (g_lex : graph.graph) (l_lex : Com.lex_mapping).
Hypothesis gl_lex_format : lex_graph_format Po g_lex l_lex.

Context (g_vert : graph.graph) (l_vert : array (array BigQ.bigQ)).
Hypothesis gl_vert_format : vert_graph_format Po g_vert l_vert.

Context (morph morph' : array Uint63.int).
Context (edge_inv : array (array (Uint63.int * Uint63.int))).

Context (y_pos y_neg : array (array BigQ.bigQ)).
Hypothesis y_pos_format : bound_format Po y_pos.
Hypothesis y_neg_format : bound_format Po y_neg.

Hypothesis enum_h : enum_algo Po g_lex l_lex.
Hypothesis img_h : img_lex_graph morph morph' edge_inv g_lex l_lex g_vert l_vert.
Hypothesis bound_h : @bounded_Po_test Po y_pos y_neg.
Hypothesis graph_h : lex_graph_n0 g_lex.

Local Notation high_poly := (spec_poly m' n' Po).
Local Notation A := high_poly.1.
Local Notation b := high_poly.2.
Local Notation G_lex := (spec_lex_graph m' n' (g_lex,l_lex)).
Local Notation G_vert := (spec_vert_graph n' (g_vert,l_vert)).

Lemma high_enum_h : high_enum_algo A b G_lex.
Proof.
move: (format_poly_precond Po_format) (lex_graph_format_precond Po_format gl_lex_format).
move/spec_func_poly=> + /spec_func_lex_graph.
by move/lex_certif_equiv=> /[apply] /= <-.
Qed.

Lemma high_graph_h : G_lex != graph0 _.
Proof.
move: (lex_graph_format_precond Po_format gl_lex_format).
by move/spec_func_lex_graph/graph_n0_equiv=> <-.
Qed.

Lemma high_img_h:
  G_vert = ((@phi m' n') @/ G_lex).
Proof.
apply/img_lex_graph_equiv; [| |exact:img_h].
- exact/spec_func_lex_graph/lex_graph_format_precond.
- exact/spec_func_vert_graph/vert_graph_format_precond.
Qed.

Lemma high_bound_h:
  forall c, Simplex.bounded A b c.
Proof.
move: (format_poly_precond Po_format)
  (bound_format_precond Po_format y_pos_format)
  (bound_format_precond Po_format y_neg_format).
move/spec_func_poly=> + /spec_func_bound + /spec_func_bound.
move/poly_bounded_equiv=> /[apply] /[apply] /eq_imply bound_eq.
apply/high_poly_boundedP;
  [apply/feasA; [exact/high_enum_h|exact/high_graph_h]|exact/bound_eq].
Qed.

Lemma Validation: poly_graph (poly_of_syst high_poly) = G_vert.
Proof.
rewrite high_img_h.
apply/repr_poly_graph;
  [ exact:high_bound_h|exact:high_enum_h|exact:high_graph_h].
Qed.

Context (origin : Uint63.int) (map_ : array int) (inv : array (array BigQ.bigQ)).
Hypothesis inv_format: inv_format Po inv.

Context (start : Uint63.int).

Hypothesis dim_h : dim_full_test l_vert map_ origin inv Po.
Hypothesis diameter_h : diameter_check g_vert Po start.

Lemma high_dim_h:
  \pdim (poly_of_syst high_poly) = n'.+2.
Proof.
move: (format_poly_precond Po_format)
  (inv_format_precond Po_format inv_format)
  (vert_graph_format_precond Po_format gl_vert_format).
move/spec_func_poly=> + /spec_func_inv + /spec_func_vert_graph.
move/dim_full_vtx_graph=> /[apply] /[apply].
case/(_ _ _ dim_h)=> /= x0 [s].
rewrite high_img_h.
rewrite -(repr_poly_graph high_bound_h high_enum_h high_graph_h).
by rewrite vtx_mk_graph=> /high_dim_fullP.
Qed.

Lemma high_diameter_h:
  (diameter G_vert > m'.+1 - n'.+1)%nat.
Proof.
move: (format_poly_precond Po_format)
  (vert_graph_format_precond Po_format gl_vert_format).
move/spec_func_poly=> + /spec_func_vert_graph.
by move/high_diameter_check_equiv=> /[apply] /(_ _ diameter_h).
Qed.

Local Notation P := (poly_of_syst high_poly).

Lemma disprove_Hirsch:
  ((diameter (poly_graph P)) >
  #|`facets P| - (\pdim P).-1)%nat.
Proof.
apply/high_algo_Hirsch;
  [ exact:high_enum_h|exact:high_img_h|
    exact:high_bound_h|exact:high_graph_h|
    exact:high_dim_h|exact:high_diameter_h].
Qed.

End HirschVerification.

Section ExactDimension.
Context (Po : Com.polyType).
Hypothesis Po_format : poly_format Po.
Local Notation m' := (Com.m Po).-1.
Local Notation n' := (Com.n Po).-1.
Context (g_lex : graph.graph) (l_lex : Com.lex_mapping).
Hypothesis gl_lex_format : lex_graph_format Po g_lex l_lex.

Context (g_vert : graph.graph) (l_vert : array (array BigQ.bigQ)).
Hypothesis gl_vert_format : vert_graph_format Po g_vert l_vert.

Context (morph morph' : array Uint63.int).
Context (edge_inv : array (array (Uint63.int * Uint63.int))).

Context (y_pos y_neg : array (array BigQ.bigQ)).
Hypothesis y_pos_format : bound_format Po y_pos.
Hypothesis y_neg_format : bound_format Po y_neg.

Hypothesis enum_h : enum_algo Po g_lex l_lex.
Hypothesis img_h : img_lex_graph morph morph' edge_inv g_lex l_lex g_vert l_vert.
Hypothesis bound_h : @bounded_Po_test Po y_pos y_neg.
Hypothesis graph_h : lex_graph_n0 g_lex.

Local Notation high_poly := (spec_poly m' n' Po).
Local Notation A := high_poly.1.
Local Notation b := high_poly.2.
Local Notation G_lex := (spec_lex_graph m' n' (g_lex,l_lex)).
Local Notation G_vert := (spec_vert_graph n' (g_vert,l_vert)).

Lemma diameter_of_polyXXdimXX k:
  diameter_exact g_vert Po k ->
  diameter (poly_graph (poly_of_syst high_poly)) = int_to_nat k.
Proof.
move=> diameter_h.
have:= (Validation Po_format gl_lex_format gl_vert_format y_pos_format y_neg_format).
move=> /(_ _ _ _ enum_h img_h bound_h graph_h) ->.
move: (vert_graph_format_precond Po_format gl_vert_format).
move/spec_func_vert_graph=> rel_g_vert.
rewrite -(rel_graph_diameter rel_g_vert) /=.
move: diameter_h=> /eqP diam_h.
apply/nat_to_int_inj; [|exact:int_thresholdP|rewrite int_to_natK //].
rewrite inE.
apply/(@leq_ltn_trans (length g_vert)); last exact/int_thresholdP.
case: rel_g_vert=> -[g' ?] [_ [/= gg' _] _].
rewrite (rel_struct_diameter gg') -(rel_struct_card gg').
apply/bigmax_leqP=> p _; exact: size_path_le.
Qed.

Lemma diameter_of_poly20dim21:
  diameter_exact g_vert Po 21%uint63->
  diameter (poly_graph (poly_of_syst high_poly)) = 21%nat.
Proof. by move/diameter_of_polyXXdimXX=> ->. Qed.

Lemma diameter_of_poly23dim24:
  diameter_exact g_vert Po 24%uint63->
  diameter (poly_graph (poly_of_syst high_poly)) = 24%nat.
Proof. by move/diameter_of_polyXXdimXX=> ->. Qed.

End ExactDimension.


From Coq Require Import Utf8 Setoid ssreflect.
Set Default Proof Using "Type".

Local Set Universe Polymorphism.

(** Telescopes *)
Inductive tele : Type :=
  | TeleO : tele
  | TeleS {X} (binder : X → tele) : tele.

Arguments TeleS {_} _.

(** The telescope version of Coq's function type *)
Fixpoint tele_fun (TT : tele) (T : Type) : Type :=
  match TT with
  | TeleO => T
  | TeleS b => ∀ x, tele_fun (b x) T
  end.

Notation "TT -t> A" :=
  (tele_fun TT A) (at level 99, A at level 200, right associativity).

(** A sigma-like type for an "element" of a telescope, i.e. the data it
  takes to get a [T] from a [TT -t> T]. *)
Inductive tele_arg : tele → Type :=
| TargO : tele_arg TeleO
(* the [x] is the only relevant data here *)
| TargS {X} {binder} (x : X) : tele_arg (binder x) → tele_arg (TeleS binder).

Definition tele_app {TT : tele} {T} (f : TT -t> T) : tele_arg TT → T :=
  λ a, (fix rec {TT} (a : tele_arg TT) : (TT -t> T) → T :=
     match a in tele_arg TT return (TT -t> T) → T with
     | TargO => λ t : T, t
     | TargS x a => λ f, rec a (f x)
     end) TT a f.
Arguments tele_app {!_ _} _ !_ /.

Coercion tele_arg : tele >-> Sortclass.
Coercion tele_app : tele_fun >-> Funclass.

(** Inversion lemma for [tele_arg] *)
Lemma tele_arg_inv {TT : tele} (a : TT) :
  match TT as TT return TT → Prop with
  | TeleO => λ a, a = TargO
  | TeleS f => λ a, ∃ x a', a = TargS x a'
  end a.
Proof. induction a; eauto. Qed.
Lemma tele_arg_O_inv (a : TeleO) : a = TargO.
Proof. exact (tele_arg_inv a). Qed.
Lemma tele_arg_S_inv {X} {f : X → tele} (a : TeleS f) :
  ∃ x a', a = TargS x a'.
Proof. exact (tele_arg_inv a). Qed.

(** Operate below [tele_fun]s with argument telescope [TT]. *)
Fixpoint tele_bind {U} {TT : tele} : (TT → U) → TT -t> U :=
  match TT as TT return (TT → U) → TT -t> U with
  | TeleO => λ F, F TargO
  | @TeleS X b => λ (F : TeleS b → U) (x : X), (* b x -t> U *)
                  tele_bind (λ a, F (TargS x a))
  end.
Arguments tele_bind {_ !_} _ /.

(* Show that tele_app ∘ tele_bind is the identity. *)
Lemma tele_app_bind {U} {TT : tele} (f : TT → U) x :
  (tele_app (tele_bind f)) x = f x.
Proof.
  induction TT as [|X b IH]; simpl in *.
  - rewrite (tele_arg_O_inv x). auto.
  - destruct (tele_arg_S_inv x) as [x' [a' ->]]. simpl.
    rewrite IH. auto.
Qed.

(** Notation-compatible telescope mapping *)
(* This adds (tele_app ∘ tele_bind), which is an identity function, around every
   binder so that, after simplifying, this matches the way we typically write
   notations involving telescopes. *)
Notation "'λ..' x .. y , e" :=
  (tele_app (tele_bind (λ x, .. (tele_app (tele_bind (λ y, e))) .. )))
  (at level 200, x binder, y binder, right associativity,
   format "'[  ' 'λ..'  x  ..  y ']' ,  e").

(* The testcase *)
Lemma test {TA TB : tele} {X} (α' β' γ' : X → Prop) (Φ : TA → TB → Prop) x' :
  (forall P Q, ((P /\ Q) = Q) * ((P -> Q) = Q)) ->
  ∀ a b, Φ a b = (λ.. x y, β' x' ∧ (γ' x' → Φ x y)) a b.
Proof.
intros cheat a b.
rewrite !tele_app_bind.
by rewrite !cheat.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E : Universe, ((wd_ A B /\ (wd_ B D /\ (wd_ D E /\ (wd_ B E /\ (wd_ B C /\ (wd_ A C /\ (col_ A B D /\ col_ A B E))))))) -> col_ B D E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export LogRelIE.PseudoType.
Require Export LogRelIE.InstPTy.
Require Export RecTypes.Contraction.
Require Export LogRelIE.Contraction.

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Max.
Require Import Coq.micromega.Lia.

Fixpoint pNumbFree (τ : PTy) : nat :=
  match τ with
  | ptunit => 0
  | ptbool => 0
  | ptprod τ1 τ2 => max (pNumbFree τ1) (pNumbFree τ2)
  | ptsum τ1 τ2 => max (pNumbFree τ1) (pNumbFree τ2)
  | ptarr τ1 τ2 => max (pNumbFree τ1) (pNumbFree τ2)
  | ptrec τ => pred (pNumbFree τ)
  | ptvar i => S i
  | pEmulDV n p τ => 0
  end.
Arguments pNumbFree !τ.

Lemma pNumbFree_sound τ : innerPClosed τ → ws (pNumbFree τ) τ.
Proof.
  induction τ; cbn; try constructor; dependent destruction H.
  - refine (WsPTy_mono _ (IHτ1 H)); lia.
  - refine (WsPTy_mono _ (IHτ2 H)); lia.
  - refine (WsPTy_mono _ (IHτ1 H)); lia.
  - refine (WsPTy_mono _ (IHτ2 H)); lia.
  - refine (WsPTy_mono _ (IHτ1 H)); lia.
  - refine (WsPTy_mono _ (IHτ2 H)); lia.
  - refine (WsPTy_mono _ (IHτ H)); lia.
  - induction i; constructor; assumption.
  - assumption.
Qed.

Definition pDecideClosed τ := match pNumbFree τ with
                             | 0 => B.true
                             | _ => B.false
                             end.

Arguments pDecideClosed /.
Lemma decidePClosed_sound {τ} : innerPClosed τ → Is_true (pDecideClosed τ) -> ⟨ 0 ⊢ τ ⟩.
Proof.
  unfold pDecideClosed, WsTy.
  remember (pNumbFree τ).
  destruct n; intuition.
  rewrite Heqn.
  now eapply pNumbFree_sound.
Qed.

Lemma pNumbFree_complete {τ n} : ⟨ n ⊢ τ ⟩ -> pNumbFree τ <= n.
Proof.
  induction 1; cbn; try lia.
  induction H; lia.
Qed.

Lemma pNumbFree_complete' {τ} : ⟨ 0 ⊢ τ ⟩ -> pNumbFree τ = 0.
Proof.
  intros cl.
  cut (pNumbFree τ <= 0).
  - lia.
  - now eapply pNumbFree_complete.
Qed.

Lemma pDecideClosed_complete {τ} : ⟨ 0 ⊢ τ ⟩ -> Is_true (pDecideClosed τ).
Proof.
  intros cτ.
  assert (nc := pNumbFree_complete cτ).
  assert (eq : pNumbFree τ = 0) by lia.
  unfold pDecideClosed.
  now rewrite eq.
Qed.

Inductive ClosedPEnv : PEnv → Prop :=
  | PEmptyClosed : ClosedPEnv pempty
  | VarPClosed {Γ τ} :
      ⟨ 0 ⊢ τ ⟩ →
      ClosedPEnv Γ →
      ClosedPEnv (Γ p▻ τ).

#[export]
Hint Constructors wsPTy : cty.
#[export]
Hint Constructors ClosedPEnv : cenv.

Definition ValidPTy : PTy -> Prop := fun τ => ⟨ 0 ⊢ τ ⟩ /\ SimplePContr τ.
Definition ValidPEnv : PEnv -> Prop := fun Γ => ClosedPEnv Γ /\ ContrPEnv Γ.

Lemma ValidPTy_SimplePContr {τ} : ValidPTy τ -> SimplePContr τ.
Proof.
  now destruct 1.
Qed.
#[export]
Hint Resolve ValidPTy_SimplePContr : simple_p_contr_rec.

Lemma ValidPEnv_nil : ValidPEnv pempty.
Proof.
  split; constructor; eauto.
Qed.
#[export]
Hint Resolve ValidPEnv_nil : ptyvalid.

Lemma ValidPEnv_cons {Γ τ} : ValidPEnv Γ -> ValidPTy τ -> ValidPEnv (Γ p▻ τ).
Proof.
  intros [env_cl env_contr] [ty_cl ty_contr].
  split; constructor; eauto.
Qed.
#[export]
Hint Resolve ValidPEnv_cons : ptyvalid.

Lemma ValidPEnv_invert_cons {Γ τ} : ValidPEnv (Γ p▻ τ) → ValidPEnv Γ ∧ ValidPTy τ.
Proof.
  intro vΓ.
  destruct vΓ as (closedΓ & contrΓ).
  inversion closedΓ; inversion contrΓ; subst.
  split; split; assumption.
Qed.

Lemma ValidPEnv_getevar {Γ i τ} : ValidPEnv Γ → ⟪ i : τ p∈ Γ ⟫ → ValidPTy τ.
Proof.
  revert Γ.
  induction i; intros Γ vΓ ev.
  - inversion ev; subst.
    destruct (ValidPEnv_invert_cons vΓ) as (_ & vτ).
    assumption.
  - inversion ev; subst.
    destruct (ValidPEnv_invert_cons vΓ) as (vΓ0 & _).
    apply (IHi Γ0 vΓ0 H1).
Qed.

Lemma ValidPTy_unfold_trec {τ} : ValidPTy (ptrec τ) -> ValidPTy (τ[beta1 (ptrec τ)]).
Proof.
  intros (clτ & crτ).
  inversion clτ; subst.
  split.
  - now eauto using (wsAp (X := PTy)), (wsSub_sub_beta1 (X := PTy)).
  - now eapply (SimplePContr_pUnfoldOnce (ptrec τ)).
Qed.


(*! Definition of a small imperative language !*)

From PresburgerAI Require Export TotalMap EqDec RelationalAbstractDomain Utils.
From Coq Require Export Strings.String ZArith List.

Open Scope list_scope.

(** Variables id **)
Notation Vid n := (Fin n).

(** Location ids **)
Definition Location := list nat.

(** Binary operation codes **)
Inductive BinOpCode := Add | Mul | Le.

(** A Program **)
Inductive Program {n: nat} :=
| PBinop (res: Vid n) (opc: BinOpCode) (op1 op2: Vid n)
| PSeq (p1 p2: Program)
| PIf (cond_var: Vid n) (p_true p_false: Program)
| PWhile (cond: Vid n) (p1: Program).

Arguments Program : clear implicits.

(** A state in the program **)
Notation State n := (Array Z n).

(** Execute a binary operation given both operands values **)
Definition execute_binop (opc: BinOpCode) (v1 v2: Z) :=
  match opc with
  | Add => (v1 + v2)%Z
  | Mul => (v1 * v2)%Z
  | Le => if (v1 <=? v2)%Z then 1%Z else 0%Z
  end.

(** Execute a binary operation on a state **)
Definition execute_binop_state {n: nat} (opc: BinOpCode) (op1 op2: Vid n) (s: State n) :=
  execute_binop opc (array_get s op1) (array_get s op2).

(** Notation for relational semantics **)
Reserved Notation
         "st '=[' c ']=>' st'"
         (at level 40, st constr, st' constr at next level).

(** Relational semantics of a program **)
Inductive semantics {n: nat} : Program n -> State n -> State n -> Prop :=
| EBinop res opc op1 op2 s :
  s =[ PBinop res opc op1 op2 ]=> (array_set s res (execute_binop_state opc op1 op2 s))
| ESeq p1 p2 s s' s'' :
    s =[ p1 ]=> s' ->
    s' =[ p2 ]=> s'' ->
    s =[ PSeq p1 p2 ]=> s''
| EIfTrue var p_true p_false (s s': State n) :
    (array_get s var) <> 0%Z ->
    s =[ p_true ]=> s' ->
    s =[ PIf var p_true p_false ]=> s'
| EIfFalse var p_true p_false (s s': State n) :
    (array_get s var) = 0%Z ->
    s =[ p_false ]=> s' ->
    s =[ PIf var p_true p_false ]=> s'
| EWhileTrue var p (s s' s'': State n) :
    (array_get s var) <> 0%Z ->
    s =[ p ]=> s' ->
    s' =[ PWhile var p ]=> s'' ->
    s =[ PWhile var p ]=> s''
| EWhileFalse var p (s: State n) :
    (array_get s var) = 0%Z ->
    s =[ PWhile var p ]=> s
where "st =[ p ]=> st'" := (semantics p st st').

Section ImpLemmas.

  (** When we are out of the while loop, the condition is false **)
  Lemma while_out_cond n cond p s s' :
    s =[ @PWhile n cond p ]=> s' ->
    array_get s' cond = 0%Z.
  Proof.
    intros.
    remember (PWhile _ _).
    induction H; try discriminate; inversion Heqp0; subst; auto.
  Qed.

  (** equivalence with the denotational semantics**)
  Lemma while_trans_closure n cond p s s' :
    s =[ @PWhile n cond p ]=> s' <->
    transitive_closure (fun (s: State n * State n) => (array_get (fst s) cond <> 0%Z) /\ (fst s) =[ p ]=> (snd s)) (s, s') /\ array_get s' cond = 0%Z.
  Proof.
    split; intros.
    - split; [ | eauto using while_out_cond ].
      remember (PWhile _ _).
      induction H; try discriminate; inversion Heqp0; subst; [ | constructor ].
      specialize (IHsemantics2 eq_refl).
      eapply tc_app; [ | eauto].
      auto.
    - destruct H.
      remember (s, s').
      generalize dependent s'.
      generalize dependent s.
      induction H; intros; inversion Heqp0; subst; [ constructor; auto | ].
      destruct H.
      simpl in *.
      eapply EWhileTrue; eauto.
  Qed.

End ImpLemmas.


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

From QuickChick Require Import QuickChick.
Require Import Arith List. Import ListNotations.

Require Import Stack.Exp.

(* Instructions for our stack machine *)
Inductive sinstr : Type :=
| SPush : nat -> sinstr
| SPlus : sinstr
| SMinus : sinstr
| SMult : sinstr.

(* Execution *)
Fixpoint execute (stack : list nat) (prog : list sinstr) : list nat :=
  match (prog, stack) with
  | (nil,             _           ) => stack
  | (SPush n::prog',  _           ) => execute (n::stack) prog'
  | (SPlus::prog',    m::n::stack') => execute ((m+n)::stack') prog'
  | (SMinus::prog',   m::n::stack') => execute ((m-n)::stack') prog'
  | (SMult::prog',    m::n::stack') => execute ((m*n)::stack') prog'
  | (_::prog',        _           ) => execute stack prog'
  end.

(* Compilation... *)
Fixpoint compile (e : exp) : list sinstr :=
  match e with
  (* TODO: WRITE DURING TUTORIAL! *)
  | _ => nil
  end.

Definition compile_correct (e : exp) := (execute [] (compile e)) = [eval e]?.
(*! QuickChick compile_correct. *)


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.

Module ConcreteTask.

  Import SporadicTaskset.

  Section Defs.

    (* Definition of a concrete task. *)
    Record concrete_task :=
    {
      task_id: nat; (* for uniqueness *)
      task_cost: nat;
      task_period: nat;
      task_deadline: nat;
      task_jitter: nat
    }.

    (* To make it compatible with ssreflect, we define a decidable
       equality for concrete tasks. *)
    Definition task_eqdef (t1 t2: concrete_task) :=
      (task_id t1 == task_id t2) &&
      (task_cost t1 == task_cost t2) &&
      (task_period t1 == task_period t2) &&
      (task_deadline t1 == task_deadline t2) &&
      (task_jitter t1 == task_jitter t2).

    (* Next, we prove that task_eqdef is indeed an equality, ... *)
    Lemma eqn_task : Equality.axiom task_eqdef.
    Proof.
      unfold Equality.axiom; intros x y.
      destruct (task_eqdef x y) eqn:EQ.
      {
        apply ReflectT.
        unfold task_eqdef in *.
        move: EQ => /andP [/andP [/andP [/andP [/eqP ID /eqP COST] /eqP PERIOD] /eqP DL] /eqP JITTER].
        by destruct x, y; simpl in *; subst.
      }
      {
        apply ReflectF.
        unfold task_eqdef, not in *; intro BUG.
        apply negbT in EQ; rewrite negb_and in EQ.
        destruct x, y.
        rewrite negb_and in EQ.
        move: EQ => /orP [/orP [EQ | /eqP DL] | /eqP JITTER]; last by apply JITTER; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP DL]; last by apply DL; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [/eqP ID | /eqP PERIOD]; last by apply PERIOD; inversion BUG.
        by apply ID; inversion BUG.
        by apply DL; inversion BUG.
      }
    Qed.

    (* ..., which allows instantiating the canonical structure. *)
    Canonical concrete_task_eqMixin := EqMixin eqn_task.
    Canonical concrete_task_eqType := Eval hnf in EqType concrete_task concrete_task_eqMixin.

  End Defs.

  Section ConcreteTaskset.

    Definition concrete_taskset :=
      taskset_of concrete_task_eqType.

  End ConcreteTaskset.

End ConcreteTask.


Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

Definition himmilbeau_bmap_list := [Build_varinfo Tdouble 1%positive (-5) (5);Build_varinfo Tdouble 2%positive (-5) (5)].

Definition himmilbeau_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list himmilbeau_bmap_list) in exact z).

Definition himmilbeau (x1 : ftype Tdouble) (x2 : ftype Tdouble) :=
  cast Tdouble (let a := (((x1 * x1)%F64 + x2)%F64 - (11)%F64)%F64 in
  let b := ((x1 + (x2 * x2)%F64)%F64 - (7)%F64)%F64 in
  ((a * a)%F64 + (b * b)%F64)%F64).

Definition himmilbeau_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive]) himmilbeau in exact e').

Derive himmilbeau_b
SuchThat (forall vmap, prove_roundoff_bound himmilbeau_bmap vmap himmilbeau_expr himmilbeau_b)
As jetengine_bound.
Proof.
idtac "Starting himmilbeau".
time "himmilbeau" (
try (subst himmilbeau_b; intro; prove_roundoff_bound);
try (prove_rndval; interval);
try (prove_roundoff_bound2; prune_terms (cutoff 30); do_interval)).
Qed.

Lemma check_himmilbeau_bound: ltac:(CheckBound himmilbeau_b 2.31e-12%F64).
Proof. reflexivity. Qed.

End WITHNANS.
Close Scope R_scope.


Require Import HoTT.
Require Import Categories.Functor Category.Morphisms.
Require Import Category.Core.
From GCTT Require Import quotients categories.
From GCTT Require Export cquot cquot_principles.

(** The definition of the 1type-completion is in the folder cquot. We change the notation here so that it matches the thesis. *)
Notation "'N1'" := cquot.
Notation "'N1_rec'" := cquot_rec.
Notation "'N1_ind'" := cquot_ind.
Notation "'N1_ind_set'" := cquot_ind_set.

(** A simplified version of N1_rec where we don't need to specify that identities are preserved  *)
Definition N1_rec' {C : PreCategory} (Y : Type)
             (cclY : C -> Y)
             (ccleqY : forall {a₁ a₂ : C},
                 C a₁ a₂ -> cclY a₁ = cclY a₂)
             (* (ceY : forall (a : C), ccleqY (identity a) = idpath) *)
             (cconcatY : forall (a₁ a₂ a₃: C) (c₁: C a₁ a₂) (c₂: C a₂ a₃),
                 ccleqY (c₂ o c₁)%morphism = ccleqY c₁ @ ccleqY c₂)
             {truncY : IsTrunc 1 Y}
  : N1 C -> Y.
  Proof.
    refine (N1_rec Y cclY ccleqY _ cconcatY).
    intro c.
    apply (cancelL (ccleqY c c 1%morphism)).
    refine ((cconcatY c c c _ _)^ @ _).
    refine (ap (ccleqY c c) (left_identity C c c _) @ _).
    apply inverse. apply concat_p1.
  Defined.

(** The functor given by the constructors of N1 *)
Definition include_in_N1 (C : PreCategory)
  : Functor C (Core.groupoid_category (N1 C)).
Proof.
  srapply @Build_Functor.
  - apply ccl.
  - apply ccleq.
  - apply cconcat.
  - apply ce.
Defined.

(** N1 is functorial *)
Definition functor_groupoid_category
           (X Y : Type) {istrunc_X : IsTrunc 1 X} {istrunc_Y : IsTrunc 1 Y}
  : (X -> Y) -> Functor (Core.groupoid_category X) (Core.groupoid_category Y).
Proof.
  intro f.
  srapply @Build_Functor.
  + exact f.
  + intros x1 x2. simpl. exact (ap f).
  + intros x1 x2 x3 p1 p2. simpl in *.
    apply ap_pp.
  + reflexivity.
Defined.

(** The universal principle of the 1-type completion *)
Definition univ_N1 (C : PreCategory) (Y : Type) {istrunc_Y : IsTrunc 1 Y}
  : (N1 C -> Y) <~> Functor C (Core.groupoid_category Y).
Proof.
  srapply @equiv_adjointify.
  - intro f.
    refine (_ o (include_in_N1 C))%functor.
    apply functor_groupoid_category. exact f.
  - intro F.
    srapply @cquot_rec.
    + exact (object_of F).
    + apply (morphism_of F).
    + apply (identity_of F).
    + apply (composition_of F).
  - intro F.
    srapply @path_functor'.
    + reflexivity.
    + cbn.
      intros a b f. rewrite concat_p1. rewrite concat_1p.
      apply cquot_rec_beta_ccleq.
  - intro F. apply path_arrow. intro x. revert x.
    srapply @cquot_ind_set.
    + intro c. simpl. reflexivity.
    + intros c1 c2 f. simpl.
      apply path_to_path_over.
      refine (transport_paths_FlFr _ _ @ _).
      simpl. rewrite concat_p1.
      apply moveR_Vp. rewrite concat_p1.
      apply inverse.
      refine (cquot_rec_beta_ccleq _ _ _ _ _ _ _ _ _ _).
Defined.

Definition functor_N1 {C D : PreCategory}
  : Functor C D -> (N1 C -> N1 D).
Proof.
  intro F.
  apply (univ_N1 _ _)^-1.
  refine (include_in_N1 _ o F)%functor.
Defined.

(** Computational rules  *)
Definition univ_N1_beta_ccleq {C : PreCategory}
           (Y : Type) {istrunc_Y : IsTrunc 1 Y}
           (F : Functor C (Core.groupoid_category Y))
           {c1 c2 : C} (f : morphism C c1 c2)
  : ap ((univ_N1 C Y)^-1 F) (ccleq C f) = (morphism_of F f).
Proof.
  unfold univ_N1. simpl.
  apply cquot_rec_beta_ccleq.
Defined.

Definition functor_N1_beta_ccleq {C D : PreCategory}
           (F : Functor C D)
           {c1 c2 : C} (f : morphism C c1 c2)
  : ap (functor_N1 F) (ccleq C f) =
    ccleq D (morphism_of F f).
Proof.
  unfold functor_N1.
  apply univ_N1_beta_ccleq.
Defined.

(** The 1-type completion preserves set truncation.  *)
Definition pi0_cat_N1 (C : PreCategory) :
  pi0_cat C <~> Trunc 0 (N1 C).
Proof.
  srapply @equiv_adjointify.
  - srapply @set_quotient_rec.
    + intro c. apply tr. apply (ccl C c).
    + simpl. intros x y f.
      apply (ap tr).
      apply ccleq. exact f.
  - srapply @Trunc_rec.
    srapply @cquot_rec.
    + apply class_of.
    + intros c d f.
      apply related_classes_eq. exact f.
    + simpl. intro c.
      apply set_quotient_set.
    + simpl. intros.
      apply set_quotient_set.
  - intro x. revert x.
    srefine (Trunc_ind _ _).
    srefine (cquot_ind_prop _ _ _).
    simpl. reflexivity.
  - intro x. revert x.
    srefine (set_quotient_ind_prop _ _ _).
    simpl. reflexivity.
Defined.