Require Import WildCat.
Require Import AbelianGroup Biproduct.

(** * Homomorphisms of abelian groups form an abelian group. *)

(** We can add group homomorphisms. *)
Definition ab_homo_add {A : Group} {B : AbGroup} (f g : A $-> B)
  : A $-> B.
Proof.
  refine (grp_homo_compose ab_codiagonal _).
  (** [fun a => f(a) + g(a)] **)
  exact (grp_prod_corec f g).
Defined.

(** We can negate an abelian group homomorphism by composing with ab_homo_negation. *)
Global Instance negate_hom {A : Group} {B : AbGroup}
  : Negate (@Hom Group _ A B) := grp_homo_compose ab_homo_negation.

(** For [A B : AbGroup], homomorphisms [A $-> B] form an abelian group. *)
Definition grp_hom `{Funext} (A : Group) (B : AbGroup) : Group.
Proof.
  nrefine (Build_Group (GroupHomomorphism A B)
             ab_homo_add grp_homo_const negate_hom _).
  repeat split.
  1: exact _.
  all: hnf; intros; apply equiv_path_grouphomomorphism; intro; cbn.
  + apply associativity.
  + apply left_identity.
  + apply right_identity.
  + apply left_inverse.
  + apply right_inverse.
Defined.

Definition ab_hom `{Funext} (A : Group) (B : AbGroup) : AbGroup.
Proof.
  snrapply (Build_AbGroup (grp_hom A B)).
  intros f g; cbn.
  apply equiv_path_grouphomomorphism; intro x; cbn.
  apply commutativity.
Defined.

(** ** The bifunctor [ab_hom] *)

Global Instance is0functor_ab_hom01 `{Funext} {A : Group^op}
  : Is0Functor (ab_hom A).
Proof.
  snrapply (Build_Is0Functor _ AbGroup); intros B B' f.
  snrapply Build_GroupHomomorphism.
  1: exact (fun g => grp_homo_compose f g).
  intros phi psi.
  apply equiv_path_grouphomomorphism; intro a; cbn.
  exact (grp_homo_op f _ _).
Defined.

Global Instance is0functor_ab_hom10 `{Funext} {B : AbGroup@{u}}
  : Is0Functor (flip (ab_hom : Group^op -> AbGroup -> AbGroup) B).
Proof.
  snrapply (Build_Is0Functor (Group^op) AbGroup); intros A A' f.
  snrapply Build_GroupHomomorphism.
  1: exact (fun g => grp_homo_compose g f).
  intros phi psi.
  by apply equiv_path_grouphomomorphism.
Defined.

Global Instance isbifunctor_ab_hom `{Funext}
  : IsBifunctor (ab_hom : Group^op -> AbGroup -> AbGroup).
Proof.
  snrapply Build_IsBifunctor.
  1-2: exact _.
  intros A A' f B B' g phi; cbn.
  by apply equiv_path_grouphomomorphism.
Defined.


(* Prove some properties of System F by dinaturality axiom
  with Coq's internal type system.
  System F's type is encoded as a Prop. *)

(* According to
  A Logic for Parametric Polymorphism, Plotkin and Abadi (LNCS 1993),
  which introduces dinaturality as an axiom.
*)
Require Import Coq.Logic.FunctionalExtensionality.

Definition one := forall (X: Prop), (X -> X).

Definition compose {X Y Z} (f: Y -> Z) g (x: X) := f (g x).

Axiom dinaturality0one:
  forall (X Y: Prop) (f: X -> Y), forall (u: one),
  compose f (u X) = compose (u Y) f.

Theorem one_singleton:
  forall u: one, u = id.
intro u.
apply functional_extensionality_dep.
intro X.
apply functional_extensionality.
intro x.
generalize (dinaturality0one one X (fun _ => x) u); intro H.
unfold compose in H.
apply equal_f in H.
symmetry.
auto.
exact id.
Qed.

Definition prod (X: Prop) (Y: Prop): Prop :=
  forall Z: Prop, (X -> Y -> Z) -> Z.

Axiom dinaturality0Prod:
  forall (X Y Z Z': Prop) (f: Z -> Z') (u: prod X Y),
  compose f (u Z) = fun g => u Z' (fun x y => f (g x y)).

Definition pair {X Y: Prop} (x: X) (y: Y): prod X Y :=
  fun _ f => f x y.

Definition fst {X Y: Prop} (p: prod X Y): X :=
  p X (fun x _ => x).

Definition snd {X Y: Prop} (p: prod X Y): Y :=
  p Y (fun _ y => y).

Lemma p_pair: forall X Y (p: prod X Y), p _ pair = p.
Admitted.

Theorem prod_ok:
  forall X Y (p: prod X Y), p = pair (fst p) (snd p).
intros X Y p.
apply functional_extensionality_dep; intro Z.
apply functional_extensionality; intro q.
unfold pair.
generalize (dinaturality0Prod X Y (prod X Y) Z (fun r => q (fst r) (snd r)) p); intro H.
unfold compose in H.
generalize (equal_f H pair); intro H0.
repeat rewrite (p_pair _ _ p) in H0.
rewrite H0.
unfold fst, snd, pair.
reflexivity.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.

Variable defparallelogram_1 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_2 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).
Variable lemma_parallelflip_3 : (forall A B C D : Universe, (par_ A B C D -> (par_ B A C D /\ (par_ A B D C /\ par_ B A D C)))).
Variable lemma_parallelsymmetric_4 : (forall A B C D : Universe, (par_ A B C D -> par_ C D A B)).

Theorem lemma_PGflip_5 : (forall A B C D : Universe, (pG_ A B C D -> pG_ B A D C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.UnivalenceAxiom.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.whiskering.

Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful.

(******************************************************************************)
(** * Isomorphism of (pre)categories *)
(* (as defined in the paper) *)

Definition is_catiso {A B : precategory_data}
  (F : functor A B)
  := (fully_faithful F) × (isweq (functor_on_objects F)).

Definition catiso (A B : precategory_data)
  := total2 (λ F : functor A B, is_catiso F).

Lemma isaprop_is_catiso
  {A B : precategory_data}
  {F : functor A B}
  : isaprop (is_catiso F).
Proof.
  apply isapropdirprod.
  - apply isaprop_fully_faithful.
  - apply isapropisweq.
Defined.

Definition functor_from_catiso (A B : precategory_data)
  (F : catiso A B)
  : functor A B := pr1 F.
Coercion functor_from_catiso :
  catiso >-> functor.

Definition identity_catiso (A : precategory_data)
  : catiso A A.
Proof.
  use tpair.
  - exact (functor_identity A).
  - use tpair.
    + apply identity_functor_is_fully_faithful.
    + apply idisweq.
Defined.

Definition catiso_ob_weq {A B : precategory_data}
  (F : catiso A B)
  : (ob A) ≃ (ob B)
  := make_weq (functor_on_objects F) (pr2 (pr2 F)).

Definition catiso_to_precategory_ob_path {A B : precategory_data}
  (F : catiso A B)
  : ob A = ob B
  := (invmap (univalence _ _) (catiso_ob_weq F)).

Definition catiso_fully_faithful_weq {A B : precategory_data}
  (F : catiso A B)
  : forall a a' : A, (a --> a') ≃ (F a --> F a')
  := λ a a', (make_weq (functor_on_morphisms F) (pr1 (pr2 F) a a')).

Lemma catiso_fully_faithful_path {A B : precategory_data}
  (F : catiso A B)
  : forall a a' : A, (a --> a') = (F a --> F a').
Proof.
  intros a a'.
  apply (invmap (univalence _ _)).
  apply (catiso_fully_faithful_weq F).
Defined.

(******************************************************************************)
(** * Construction of a map (catiso A B) -> (A = B) *)

(* The path "p : ob A = ob B" is clear. The next task is to construct a path
   "A a a' = (transportb p B) a a'" for all a, a' : A. We transport backwards
   because the fully faithfulness of the functor applies more naturally this way  *)

(* Let "w (= eqweqmap) : (X = Y) -> (X -> Y)" be the canonical map *)
(* The path "A a a' = (transportb p B) a a'" is constructed in three pieces. *)
(*     a --> a *)
(*   = F a --> F a' *)
(*   = w(p) a --> w(p) a' *)
(*   = (transportb p B) a a' *)

Lemma correct_hom {A B : precategory_data}
  (F : catiso A B)
  : forall a a' : A,
      F a --> F a'
      = (eqweqmap (catiso_to_precategory_ob_path F) a) -->
        (eqweqmap (catiso_to_precategory_ob_path F) a').
Proof.
  intros a a'.
  assert (W := (!(homotweqinvweq (univalence _ _)) (catiso_ob_weq F))).
  exact (maponpaths (λ T, (pr1weq T) a --> (pr1weq T) a') W ).
Defined.

(* w(p) a = F a *)
Lemma eqweq_ob_path_is_functor_app {A B : precategory_data}
  (F : catiso A B)
  : forall a : A, eqweqmap (catiso_to_precategory_ob_path F) a = F a.
Proof.
  intros a.
  exact (! toforallpaths (λ _ : A, B) F
    (pr1 (eqweqmap (invmap (univalence A B) (catiso_ob_weq F))))
    (maponpaths pr1 (! homotweqinvweq (univalence A B) (catiso_ob_weq F))) a).
Defined.

Lemma eqweq_ob_path_is_functor_app_compute
  (A B : precategory)
  (F : catiso A B)
  (a a' : A)
  (f : B ⟦ F a, F a' ⟧):
  eqweq_ob_path_is_functor_app F a =
  ! toforallpaths (λ _ : A, B) F
      (pr1weq (eqweqmap (invmap (univalence A B) (catiso_ob_weq F))))
      (maponpaths pr1weq (! homotweqinvweq (univalence A B) (catiso_ob_weq F))) a.
Proof.
  unfold eqweq_ob_path_is_functor_app.
Abort.

Lemma eqweq_maponpaths_mor {A B : precategory}
  (F G : A ≃ B) (p : F = G) (a a' : A) (f : F a --> F a')
  : eqweqmap (maponpaths (λ T : A ≃ B, (pr1 T) a --> (pr1 T) a') p) f
    =    (idtomor _ _ (!toforallpaths _ _ _ (maponpaths pr1 p) a))
      · f
      · (idtomor _ _ (toforallpaths _ _ _ (maponpaths pr1 p) a')).
Proof.
  induction p.
  rewrite id_left.
  rewrite id_right.
  reflexivity.
Defined.

Lemma eqweq_correct_hom_is_comp {A B : precategory}
  (F : catiso A B)
  : forall a a' : A, forall f : F a --> F a',
      eqweqmap (correct_hom F _ _) f
    =    (idtomor _ _ (eqweq_ob_path_is_functor_app F a))
      · f
      · (idtomor _ _ (!eqweq_ob_path_is_functor_app F a')).
Proof.
  intros a a' f.
  rewrite (eqweq_maponpaths_mor _ _
             (! homotweqinvweq (univalence A B) (catiso_ob_weq F))
             a a').
  apply maponpaths. apply maponpaths.
  unfold eqweq_ob_path_is_functor_app.
  rewrite pathsinv0inv0.
  reflexivity.
Defined.

Lemma eqweq_fully_faithful_is_functor_app {A B : precategory_data}
  (F : catiso A B)
  : forall a a' : A,
    eqweqmap (catiso_fully_faithful_path F a a')
    = catiso_fully_faithful_weq F _ _.
Proof.
  intros a a'.
  unfold catiso_fully_faithful_path.

  assert (W := (@homotweqinvweq _ _  (univalence (a --> a') (F a --> F a')))).
  simpl in W.
  rewrite W.

  reflexivity.
Defined.

Lemma transport_mor {A B : UU} (B1 : B -> B -> UU) (p : A = B) :
  forall a a' : A,
    B1 (eqweqmap p a) (eqweqmap p a')
  = (transportb (λ T, T -> T -> UU) p B1) a a'.
Proof.
  induction p.
  reflexivity.
Defined.

Lemma catiso_to_precategory_mor_path {A B : precategory_data}
  (F : catiso A B)
  : forall a a',  (precategory_morphisms (C:=A)) a a'
  = transportb (λ T, T -> T -> UU) (catiso_to_precategory_ob_path F)
    (precategory_morphisms (C:=B)) a a'.
Proof.
  intros a.
  intros a'.

  eapply pathscomp0. apply (catiso_fully_faithful_path F).
  eapply pathscomp0. apply correct_hom.
  eapply pathscomp0. apply transport_mor.

  reflexivity.
Defined.

Lemma catiso_to_precategory_mor_path_funext {A B : precategory_data}
  (F : catiso A B)
  : (precategory_morphisms (C:=A))
  = transportb (λ T, T -> T -> UU) (catiso_to_precategory_ob_path F)
    (precategory_morphisms (C:=B)).
Proof.
  apply (pr1 (weqfunextsec _ _ _)).
  intros a.
  apply (pr1 (weqfunextsec _ _ _)).
  intros a'.
  apply (catiso_to_precategory_mor_path F).
Defined.

Definition catiso_to_precategory_ob_mor_path {A B : precategory_data}
  (F : catiso A B)
  : precategory_ob_mor_from_precategory_data A = precategory_ob_mor_from_precategory_data B
  := total2_paths_b (catiso_to_precategory_ob_path F) (catiso_to_precategory_mor_path_funext F).

(* Remains to show that identity and composition transport correctly. *)

Lemma transport_id {A0 B0 : UU} (p0 : A0 = B0)
  (A1 : A0 -> A0 -> UU) (B1 : B0 -> B0 -> UU) (p1 : A1 = transportb _ p0 B1)
  (idB : forall b : B0, B1 b b)
  : forall a : A0,
    (transportb (X := total2 (λ T, T -> T -> UU))
                (λ T, forall a, (pr2 T) a a)
                (total2_paths2_b p0 p1) idB) a
  = (eqweqmap (  (transport_mor B1 p0 _ _)
               @ !weqtoforallpaths _ _ _ (weqtoforallpaths _ _ _ p1 a) a))
    (idB (eqweqmap p0 a)).
Proof.
  intro.
  induction p0.
  change (transportb _ _ _) with B1 in p1.
  induction p1.
  simpl.
  reflexivity.
Defined.

Lemma correct_hom_on_id {A B : precategory}
  (F : catiso A B)
  : forall a,
    identity ((eqweqmap (catiso_to_precategory_ob_path F)) a) =
    (eqweqmap (correct_hom F a a)) (identity (F a)).
Proof.
  intros a.

  apply pathsinv0.
  eapply pathscomp0. apply eqweq_correct_hom_is_comp.

  induction (eqweq_ob_path_is_functor_app F a).
  simpl.
  rewrite 2 id_right.
  reflexivity.
Defined.

Lemma catiso_to_precategory_id_path {A B : precategory}
  (F : catiso A B)
  : forall a : A,
    (transportb (X := total2 (λ T, T -> T -> UU))
                (λ T, forall a, (pr2 T) a a)
                (total2_paths2_b (catiso_to_precategory_ob_path F)
                                 (catiso_to_precategory_mor_path_funext F))
     identity) a
   = identity a.
Proof.
  intros a.

  eapply pathscomp0. apply transport_id.

  (* Cancel funext *)
  unfold catiso_to_precategory_mor_path_funext.
  unfold catiso_to_precategory_mor_path.
  unfold weqfunextsec.
  simpl (pr1 _).
  rewrite !(homotweqinvweq (weqtoforallpaths _ _ _)).

  (* Cancel transport_mor with its inverse *)
  rewrite pathscomp_inv.
  rewrite pathscomp_inv.
  rewrite path_assoc.
  rewrite path_assoc.
  rewrite pathscomp0rid.
  rewrite pathsinv0r.
  simpl.

  (* Get into a form we can apply correct_hom_on_id *)
  apply pathsweq1'.
  rewrite <- pathscomp_inv.
  rewrite eqweqmap_pathsinv0.
  rewrite invinv.

  rewrite <- eqweqmap_pathscomp0.

  rewrite (eqweq_fully_faithful_is_functor_app F a a).
  simpl.

  rewrite functor_id.
  apply correct_hom_on_id.
Defined.

(* We want to prove a similar lemma to transport_mor. The following is
   the type on the RHS of the path. *)
Lemma transport_comp_target {A0 B0 : UU} (p0 : A0 = B0)
  (A1 : A0 -> A0 -> UU) (B1 : B0 -> B0 -> UU) (p1 : A1 = transportb (λ T, T -> T -> UU) p0 B1)
  : forall a a' a'' : A0,
    (   B1 (eqweqmap p0 a) (eqweqmap p0 a')
      -> B1 (eqweqmap p0 a') (eqweqmap p0 a'')
      -> B1 (eqweqmap p0 a) (eqweqmap p0 a''))
  -> ( A1 a a' -> A1 a' a'' -> A1 a a'').
Proof.
  intros a a' a''.
  intros Bhom.
  intros f g.

  set (X := λ a a', (transport_mor B1 p0 a a')
                    @ (! weqtoforallpaths _ _ _ (weqtoforallpaths _ _ _ p1 a) a') ).

  apply (eqweqmap (X a a'')).
  apply Bhom.

  apply (eqweqmap (! X a a')).
  exact f.

  apply (eqweqmap (! X a' a'')).
  exact g.
Defined.

Lemma transport_comp {A0 B0 : UU} (p0 : A0 = B0)
  (A1 : A0 -> A0 -> UU) (B1 : B0 -> B0 -> UU) (p1 : A1 = transportb _ p0 B1)
  (compB : forall b b' b'' : B0, B1 b b' -> B1 b' b'' -> B1 b b'')
  : forall a a' a'' : A0,
      (transportb (X := total2 (λ T, T -> T -> UU))
                  (λ T, forall a b c, (pr2 T) a b -> (pr2 T) b c -> (pr2 T) a c)
                  (total2_paths2_b p0 p1) compB)
        a a' a''
    = transport_comp_target p0 A1 B1 p1 a a' a''
        (compB (eqweqmap p0 a) (eqweqmap p0 a') (eqweqmap p0 a'')).
Proof.
  intros.
  induction p0.
  change (A1 = B1) in p1.
  induction p1.
  reflexivity.
Defined.

Lemma correct_hom_on_comp {A B : precategory}
  (F : catiso A B)
  : forall a a' a'', forall f : F a --> F a', forall g : F a' --> F a'',
       (eqweqmap (correct_hom F _ _)) f
    · (eqweqmap (correct_hom F _ _)) g
    =  (eqweqmap (correct_hom F _ _)) (f · g).
Proof.
  intros a a' a'' f g.
  rewrite !eqweq_correct_hom_is_comp.
  induction (eqweq_ob_path_is_functor_app F a).
  induction (eqweq_ob_path_is_functor_app F a').
  induction (eqweq_ob_path_is_functor_app F a'').
  rewrite 3 id_left.
  simpl.
  rewrite 3 id_right.
  reflexivity.
Defined.

Lemma catiso_to_precategory_comp_path {A B : precategory}
  (F : catiso A B)
  : forall a a' a'' : A,
    (transportb (X := total2 (λ T, T -> T -> UU))
                (λ T, forall a b c : (pr1 T), (pr2 T) a b -> (pr2 T) b c -> (pr2 T) a c)
                (total2_paths2_b (catiso_to_precategory_ob_path F)
                                 (catiso_to_precategory_mor_path_funext F))
     (@compose B)) a a' a''
   = (@compose A a a' a'').
Proof.
  intros a a' a''.

  eapply pathscomp0. apply transport_comp.
  apply funextsec. intros f.
  apply funextsec. intros g.

  unfold transport_comp_target.

  (* Cancel funext *)
  unfold catiso_to_precategory_mor_path_funext.
  simpl.

  set (W := homotweqinvweq
              (weqtoforallpaths (λ _ : A, A -> UU)
                                precategory_morphisms
                                (transportb (λ T, T -> T -> UU)
                                            (catiso_to_precategory_ob_path F)
                                            precategory_morphisms))).
  simpl in W. rewrite !W. clear W.

  set (W := homotweqinvweq
              (weqtoforallpaths (λ _ : A, UU)
                                (precategory_morphisms a)
                                (transportb (λ T, T -> T -> UU)
                                            (catiso_to_precategory_ob_path F)
                                            precategory_morphisms a))).
  simpl in W. rewrite !W. clear W.

  set (W := homotweqinvweq
              (weqtoforallpaths (λ _ : A, UU)
                                (precategory_morphisms a')
                                (transportb (λ T, T -> T -> UU)
                                            (catiso_to_precategory_ob_path F)
                                            precategory_morphisms a'))).
  simpl in W. rewrite !W. clear W.

  (* Cancel as much as possible *)
  unfold catiso_to_precategory_mor_path.
  rewrite !pathscomp0rid.
  rewrite !pathscomp_inv.
  rewrite !pathsinv0inv0.
  rewrite path_assoc.
  rewrite path_assoc.
  rewrite pathsinv0r.
  simpl.
  rewrite <- path_assoc.
  rewrite <- path_assoc.
  rewrite pathsinv0r.
  rewrite pathscomp0rid.
  rewrite <- path_assoc.
  rewrite <- path_assoc.
  rewrite pathsinv0r.
  rewrite pathscomp0rid.
  rewrite <- pathscomp_inv.

  (* Rearrange to get into a form to apply correct_hom_on_comp *)
  apply pathsweq1'.
  rewrite eqweqmap_pathsinv0.
  rewrite invinv.

  rewrite <- !eqweqmap_pathscomp0.
  rewrite !eqweq_fully_faithful_is_functor_app.
  simpl.
  rewrite functor_comp.

  apply (correct_hom_on_comp F).
Defined.

Lemma catiso_to_precategory_data_path {A B : precategory}
  (F : catiso A B)
  : precategory_data_from_precategory A
    = precategory_data_from_precategory B.
Proof.
  destruct A as [[[Ao Am] [Ai Ac]] Aax].
  destruct B as [[[Bo Bm] [Bi Bc]] Bax].

  eapply total2_paths_b. Unshelve.
  2: { simpl. exact (catiso_to_precategory_ob_mor_path F). }
  apply pathsinv0.
  eapply pathscomp0.
  apply (transportb_dirprod _ _ _ _ _ (catiso_to_precategory_ob_mor_path F)).
  apply dirprodeq.
  - apply funextsec.
    intros a.
    apply (catiso_to_precategory_id_path F).
  - apply funextsec.
    intro.
    apply funextsec.
    intro.
    apply funextsec.
    intro.
    apply (catiso_to_precategory_comp_path F).
Defined.

(** If either precategory has homsets, then an isomorphism between them
    becomes a path. This is essentially one half of univalence for categories.
 *)
Lemma catiso_to_precategory_path_f {A B : precategory}
  (hs : has_homsets A)
  (F : catiso A B)
  : A = B.
Proof.
  use total2_paths_b.
  - exact (catiso_to_precategory_data_path F).
  - apply proofirrelevance, isaprop_is_precategory.
    apply hs.
Defined.

Lemma catiso_to_precategory_path_b {A B : precategory}
  (hs : has_homsets B)
  (F : catiso A B)
  : A = B.
Proof.
  use total2_paths_f.
  - exact (catiso_to_precategory_data_path F).
  - apply proofirrelevance, isaprop_is_precategory.
    apply hs.
Defined.

(** A special case is that they both have homsets *)
Corollary catiso_to_category_path {A B : category}
  (F : catiso A B) : A = B.
Proof.
  apply category_eq.
  apply catiso_to_precategory_data_path.
  assumption.
Defined.

Definition inv_catiso
           {C D : category}
           (F : catiso C D)
  : D ⟶ C.
Proof.
  use make_functor.
  - use tpair.
    + exact (invweq (catiso_ob_weq F)).
    + intros X Y f ; cbn.
      refine (invmap
                (catiso_fully_faithful_weq F
                                           (invmap (catiso_ob_weq F) X)
                                           (invmap (catiso_ob_weq F) Y))
                _).
      exact ((idtoiso (homotweqinvweq (catiso_ob_weq F) X))
               · f
               · idtoiso (!(homotweqinvweq (catiso_ob_weq F) Y))).
  - split.
    + intro X ; cbn.
      rewrite id_right.
      etrans.
      {
        apply maponpaths.
        exact (!(maponpaths pr1
                            (idtoiso_concat D _ _ _
                                            (homotweqinvweq (catiso_ob_weq F) X)
                                            (! homotweqinvweq (catiso_ob_weq F) X)))).
      }
      rewrite pathsinv0r ; cbn.
      apply invmap_eq ; cbn.
      rewrite functor_id.
      reflexivity.
    + intros X Y Z f g ; cbn.
      apply invmap_eq ; cbn.
      rewrite functor_comp.
      pose (homotweqinvweq
              (catiso_fully_faithful_weq F
                                         (invmap (catiso_ob_weq F) X)
                                         (invmap (catiso_ob_weq F) Y))) as p.
      cbn in p.
      rewrite p ; clear p.
      pose (homotweqinvweq
              (catiso_fully_faithful_weq F
                                         (invmap (catiso_ob_weq F) Y)
                                         (invmap (catiso_ob_weq F) Z))) as p.
      cbn in p.
      rewrite p ; clear p.
      rewrite <- !assoc.
      repeat (apply (maponpaths (λ z, _ · (f · z)))).
      refine (!(id_left _) @ _).
      rewrite !assoc.
      repeat (apply (maponpaths (λ z, z · _))).
      rewrite idtoiso_inv.
      cbn.
      rewrite z_iso_after_z_iso_inv.
      reflexivity.
Defined.

(* Any adjoint equivalence between univalent categories is an isomorphism of categories *)
Definition adj_equivalence_of_cats_to_cat_iso
      {C D : category}
      {F : functor C D}
      (Fa : adj_equivalence_of_cats F)
      (Cuniv : is_univalent C) (Duniv : is_univalent D)
  : catiso C D.
Proof.
  exists F.
  split.
  - apply fully_faithful_from_equivalence, Fa.
  - apply(weq_on_objects_from_adj_equiv_of_cats C D Cuniv Duniv F Fa).
Defined.


Require Export Imp.

(* First we define syntax of the language *)

(* We could reuse aexp and bexp defined for Imp. *)

(* Redefine commands here. To distinguish them
   from Imp commands, we call them scom *)
(* You need to change it into an inductive definition *)
Inductive scom : Type :=
  | SCSkip : scom
  | SCAss : id -> aexp -> scom
  | SCSeq : scom -> scom -> scom
  | SCIf : bexp -> scom -> scom -> scom
  | SCWhile : bexp -> scom -> scom
  | SCCons : id -> aexp -> aexp -> scom
  | SCLookup : id -> aexp -> scom
  | SCMutation : aexp -> aexp -> scom
  | SCDispose : aexp -> scom.

(* Program states, which is called sstate *)
Definition store := id -> nat.

(* if heap maps a natural number (address) to
   None, we say the address is not a valid address,
   or it is not in the domain of the heap *)
Definition heap := nat -> option nat.

Axiom finite_heap : forall h: heap, exists n: nat,
  forall n' v: nat, h n' = Some v -> n' < n.

Axiom functional_extensionality : forall {X Y: Type} {f g : X -> Y},
    (forall (x: X), f x = g x) ->  f = g.

(* Define an empty heap, which contains no memory cells *)
Definition emp_heap : heap :=
  fun (l: nat) => None.

Definition in_dom (l: nat) (h: heap) : Prop :=
  exists n, h l = Some n.

Definition not_in_dom (l: nat) (h: heap) : Prop :=
  h l = None.

Theorem in_not_in_dec :
  forall l h, {in_dom l h} + {not_in_dom l h}.
Proof.
  intros l h. unfold in_dom. unfold not_in_dom.
  destruct (h l).
  left. exists n. auto.
  right. auto.
Defined.

(* h1 and h2 have disjoint domain *)
Definition disjoint (h1 h2: heap) : Prop :=
  forall l, not_in_dom l h1 \/ not_in_dom l h2.

(* union of two heaps *)
Definition h_union (h1 h2: heap) : heap :=
  fun l =>
    if (in_not_in_dec l h1) then h1 l else h2 l.

(* h1 is a subset of h2 *)
Definition h_subset (h1 h2: heap) : Prop :=
  forall l n, h1 l = Some n -> h2 l = Some n.

(* store update *)
Definition st_update (s: store) (x: id) (n: nat) : store :=
  fun x' => if eq_id_dec x x' then n else s x'.

(* heap update *)
Definition h_update (h: heap) (l: nat) (n: nat) : heap :=
  fun l' => if eq_nat_dec l l' then Some n else h l'.

Definition sstate := (store * heap) %type.

(* since program may abort, we extend our state
   definition to add a special state Abt *)
Inductive ext_state : Type :=
  St:  sstate -> ext_state    (* normal state *)
| Abt: ext_state.             (* abort *)

(* Next we define the operational semantics *)

(* big-step semantics. You should change it into
   an inductive definition *)
Inductive big_step:
  scom * sstate -> ext_state -> Prop :=
| SE_Skip : forall sst,
              big_step (SCSkip, sst) (St sst)
| SE_Ass  : forall st h a1 n x,
             aeval st a1 = n ->
             big_step (SCAss x a1, (st, h)) (St (st_update st x n, h))
| SE_Seq : forall c1 c2 sst sst' est,
            big_step (c1, sst) (St sst') ->
            big_step (c2, sst') est ->
            big_step (SCSeq c1 c2, sst) est
| SE_Seq_Ab : forall c1 c2 sst,
                big_step (c1, sst) Abt ->
                big_step (SCSeq c1 c2, sst) Abt
| SE_IfTrue : forall st h b c1 c2 est,
               beval st b = true ->
               big_step (c1, (st, h)) est ->
               big_step (SCIf b c1 c2, (st, h)) est
| SE_IfFalse : forall st h b c1 c2 est,
               beval st b = false ->
               big_step (c2, (st, h)) est ->
               big_step (SCIf b c1 c2, (st, h)) est
| SE_WhileEnd : forall b st h c,
                 beval st b = false ->
                 big_step (SCWhile b c, (st, h)) (St (st, h))
| SE_WhileLoop : forall st h est b c,
                  beval st b = true ->
                  big_step (SCSeq c (SCWhile b c), (st, h)) est ->
                  big_step (SCWhile b c, (st, h)) est
| SE_Cons : forall st h a1 a2 n1 n2 x l,
              aeval st a1 = n1 ->
              aeval st a2 = n2 ->
              h l = None ->
              h (l + 1) = None ->
              big_step (SCCons x a1 a2, (st, h))
                       (St (st_update st x l,
                            h_update (h_update h (l + 1) n2) l n1))
| SE_Lookup : forall st h x a1 n1 n2,
                aeval st a1 = n1 ->
                h n1 = Some n2 ->
                big_step (SCLookup x a1, (st, h)) (St (st_update st x n2, h))
| SE_Lookup_Ab : forall st a1 n1 h x,
                   aeval st a1 = n1 ->
                   h n1 = None ->
                   big_step (SCLookup x a1, (st, h)) Abt
| SE_Mutation : forall st h a1 a2 n1 n2,
                  aeval st a1 = n1 ->
                  aeval st a2 = n2 ->
                  in_dom n1 h ->
                  big_step (SCMutation a1 a2, (st, h)) (St (st, h_update h n1 n2))
| SE_Mutation_Ab : forall st h a1 a2 n1,
                     aeval st a1 = n1 ->
                     h n1 = None ->
                     big_step (SCMutation a1 a2, (st, h)) Abt
| SE_Dispose : forall st h a1 n1,
                 aeval st a1 = n1 ->
                 in_dom n1 h ->
                 big_step
                   (SCDispose a1, (st, h))
                   (St (st, fun x => if eq_nat_dec x n1 then None else h x))
| SE_Dispose_Ab : forall st h a1 n1,
                    aeval st a1 = n1 ->
                    h n1 = None ->
                    big_step (SCDispose a1, (st, h)) Abt.

(* small-step semantics. Should be inductive too *)
Inductive small_step:
   scom * ext_state -> scom * ext_state -> Prop :=
| S_Ass : forall st h a n x,
            aeval st a = n ->
            small_step (SCAss x a, St (st, h))
                       (SCSkip, St (st_update st x n, h))
| S_SeqStep : forall c1 c1' est est' c2,
                small_step (c1, est) (c1', est') ->
                small_step (SCSeq c1 c2, est) (SCSeq c1' c2, est')
| S_SeqFinish : forall c2 est,
                  small_step (SCSeq SCSkip c2, est) (c2, est)
| S_IfTrue : forall st h b c1 c2,
               beval st b = true ->
               small_step (SCIf b c1 c2, St (st, h)) (c1, St (st, h))
| S_IfFalse : forall st h b c1 c2,
                beval st b = false ->
                small_step (SCIf b c1 c2, St (st, h)) (c2, St (st, h))
| S_WhileEnd : forall st h b c,
                 beval st b = false ->
                 small_step (SCWhile b c, St (st, h)) (SCSkip, St (st, h))
| S_WhileLoop : forall st h b c,
                  beval st b = true ->
                  small_step (SCWhile b c, St (st, h))
                             (SCSeq c (SCWhile b c), St (st, h))
| S_Cons : forall st h x a1 a2 n1 n2 l,
             aeval st a1 = n1 ->
             aeval st a2 = n2 ->
             h l = None ->
             h (l + 1) = None ->
             small_step (SCCons x a1 a2, St (st, h))
                        (SCSkip, St (st_update st x l,
                                     h_update (h_update h l n1)
                                              (l + 1) n2))
| S_Lookup : forall st h x a1 n,
               h (aeval st a1) = Some n ->
               small_step (SCLookup x a1, St (st, h))
                          (SCSkip, St (st_update st x n, h))
| S_Lookup_Ab : forall st h x a1 n1,
                  aeval st a1 = n1 ->
                  h n1 = None ->
                  small_step (SCLookup x a1, St (st, h))
                             (SCSkip, Abt)
| S_Mutation : forall st h a1 a2 n1 n2,
                  aeval st a1 = n1 ->
                  aeval st a2 = n2 ->
                  in_dom n1 h ->
                  small_step (SCMutation a1 a2, St (st, h))
                             (SCSkip, St (st, h_update h n1 n2))
| S_Mutation_Ab : forall st h a1 a2 n1,
                    aeval st a1 = n1 ->
                    h n1 = None ->
                    small_step (SCMutation a1 a2, St (st, h))
                               (SCSkip, Abt)
| S_Dispose : forall st h a1 n1,
                aeval st a1 = n1 ->
                in_dom n1 h ->
                small_step
                  (SCDispose a1, St (st, h))
                  (SCSkip, St
                   (st, fun x => if eq_nat_dec x n1 then None else h x))
| S_Dispose_Ab : forall st h a1 n1,
                   aeval st a1 = n1 ->
                   h n1 = None ->
                   small_step (SCDispose a1, St (st, h))
                              (SCSkip, Abt).

Hint Constructors small_step.

(** Assertions **)
Definition sass := sstate -> Prop.

(* define semantics of assertion emp *)
Definition emp : sass :=
    fun st: sstate =>
      snd st = emp_heap.

(* assertion e1 |-> e2 *)
Definition pto (e1 e2: aexp) : sass :=
    fun st: sstate =>
      match st with
      | (s, h) => h = h_update emp_heap (aeval s e1) (aeval s e2)
      end.
Notation "e1 '|->' e2" := (pto e1 e2) (at level 60).

(* p * q *)
Definition star (p q : sass) : sass :=
    fun st: sstate =>
      match st with
      | (s, h) =>
        exists h1, exists h2,
          disjoint h1 h2 /\ h_union h1 h2 = h /\ p (s, h1) /\ q (s, h2)
      end.
Notation "p '**' q" := (star p q) (at level 70).

(* p --* q *)
Definition simp (p q: sass) : sass :=
  fun (st : sstate) =>
    match st with
    | (s, h) =>
      forall h', disjoint h' h -> p (s, h') -> q (s, h_union h h')
    end.
Notation "p '--*' q" := (simp p q) (at level 80).

Definition pure (p: sass) : Prop :=
  forall s h1 h2, p (s, h1) -> p (s, h2).

Definition precise (p: sass) : Prop :=
  forall h h1 h2 s,
     h_subset h1 h
     -> h_subset h2 h
     -> p (s, h1)
     -> p (s, h2)
     -> h1 = h2.

Definition intuitionistic (p: sass) : Prop :=
  forall s h h', p (s, h) -> disjoint h h' -> p (s, h_union h h').

(* continue here *)

Definition s_conj (p q: sass) : sass :=
  fun (s: sstate) => p s /\ q s.
Notation "p '//\\' q" := (s_conj p q) (at level 75).

Definition s_disj (p q: sass) : sass :=
  fun (s: sstate) => p s \/ q s.
Notation "p '\\//' q" := (s_disj p q) (at level 78).

Definition s_imp (p q: sass) : sass :=
  fun (s: sstate) => p s -> q s.
Notation "p '~~>' q" := (s_imp p q) (at level 85).

Definition strongerThan (p q: sass) : Prop :=
  forall s: sstate, s_imp p q s.
Notation "p '==>' q" := (strongerThan p q) (at level 90).

Definition spEquiv (p q: sass) : Prop :=
  (p ==> q) /\ (q ==> p).
Notation "p '<==>' q" := (spEquiv p q) (at level 90).

(* Prove the following lemmas *)
Lemma disj_star_distr: forall (p q r: sass),
  (p \\// q) ** r <==> (p ** r) \\// (q ** r).
Proof.
  split; unfold strongerThan, s_imp; intros; destruct s.
  destruct H as [h1 [h2 [H1 [H2 [H3 H4]]]]].
  destruct H3. left. exists h1. eauto. right. exists h1. eauto.
  destruct H; destruct H as [h1 [h2 [H1 [H2 [H3 H4]]]]];
  exists h1; exists h2; repeat split; eauto.
  left. auto. right. auto.
Qed.

Lemma conj_star_distr: forall (p q r: sass),
  (p //\\ q) ** r ==> (p ** r) //\\ (q ** r).
Proof.
  unfold strongerThan, s_imp. intros. destruct s.
  destruct H as [h1 [h2 [H1 [H2 [H3 H4]]]]]. destruct H3.
  split; exists h1; exists h2; eauto.
Qed.

Lemma h_union_subst:
  forall h1 h2 h, h_union h1 h2 = h ->
             disjoint h1 h2 ->
              h_subset h2 h.
Proof.
  unfold h_subset, h_union. intros;
  subst; destruct (in_not_in_dec l h1); auto.
  destruct (H0 l); destruct i; unfold not_in_dom in H;
  congruence.
Qed.

Lemma h_union_determ:
  forall h1 h1' h2, h_union h1 h2 = h_union h1' h2 ->
               disjoint h1 h2 ->
               disjoint h1' h2 ->
               h1 = h1'.
Proof.
  intros.
  apply functional_extensionality. intros.
  assert ((h_union h1 h2) x = (h_union h1' h2) x). rewrite H. reflexivity.
  unfold h_union in H2.
  destruct (in_not_in_dec x h1);
  destruct (in_not_in_dec x h1'); eauto.
  destruct i. destruct (H0 x). congruence. rewrite H3 in H2. congruence.
  destruct i. destruct (H1 x). congruence. rewrite H3 in H2. congruence.
  unfold not_in_dom in *. rewrite n. rewrite n0. reflexivity.
Qed.

Hint Resolve h_union_subst.
Hint Resolve h_union_determ.

Lemma precise_conj_distr: forall (p q r: sass),
  precise r -> (p ** r) //\\ (q ** r) ==> (p //\\ q) ** r.
Proof.
  unfold strongerThan, s_imp. intros. destruct s.
  destruct H0.
  destruct H0 as [h1 [h2 [H2 [H3 [H4 H5]]]]].
  destruct H1 as [h1' [h2' [H2' [H3' [H4' H5']]]]].
  unfold precise in H.
  assert (h2 = h2'). eapply H; eauto. subst.
  assert (h1 = h1'). eauto. subst.
  exists h1'. exists h2'. repeat split; eauto.
Qed.

Inductive multiStep :
    scom * ext_state -> scom * ext_state -> Prop :=
| step0: forall c s, multiStep (c, s) (c, s)
| stepn: forall c s c' s' c'' s'',
           small_step (c, s) (c', s')
           -> multiStep (c', s') (c'', s'')
           -> multiStep (c, s) (c'', s'').

Hint Constructors multiStep.

(* c is safe at state s *)
Definition safeAt (c: scom) (s: sstate) : Prop :=
(* ~ multiStep (c, St s) Abt *)

forall c' s',
  multiStep (c, St s) (c', St s')
  -> c' = SCSkip \/ exists c'', exists s'', small_step (c', St s') (c'', St s'').

Lemma small_abt: forall c c' s, small_step (c, Abt) (c', s) ->
                      s = Abt.
Proof.
  induction c; intros; inversion H; subst; eauto.
Qed.

Lemma multi_abt: forall cs cs', multiStep cs cs' ->
                           snd cs = Abt ->
                           snd cs' = Abt.
Proof.
  intros. induction H. auto.
  destruct s.  simpl in H0. inversion H0. inversion H; subst; auto.
  apply small_abt in H3. subst. auto.
Qed.

Definition safeMono (c: scom) : Prop :=
  forall s h h',
    safeAt c (s, h) -> disjoint h h' -> safeAt c (s, h_union h h').

Definition frame (c: scom) : Prop :=
  forall s h1 h2 c' s' h',
    safeAt c (s, h1)
    -> disjoint h1 h2
    -> small_step (c, St (s, h_union h1 h2)) (c', St (s', h'))
    -> exists h1',
         small_step (c, St (s, h1)) (c', St (s', h1'))
         /\ disjoint h1' h2
         /\ h_union h1' h2 = h'.

Lemma multistep_seq: forall cs c2 cs', multiStep cs cs' ->
                        multiStep (SCSeq (fst cs) c2, (snd cs)) (SCSeq (fst cs') c2, (snd cs')).
Proof.
  intros.
  induction H. constructor.
  econstructor; eauto.
Qed.

Lemma safeAt_seq: forall c1 c2 s h, safeAt (SCSeq c1 c2) (s, h) ->
                      safeAt c1 (s, h).
Proof.
  unfold safeAt. intros.
  assert (multiStep (SCSeq c1 c2, St (s, h)) (SCSeq c' c2, St s')).
  remember (c1, St (s, h)) as cs. remember (c', St s') as cs'.
  apply multistep_seq with (c2 := c2) in H0. subst. auto.
  apply H in H1. destruct H1. inversion H1. destruct H1 as [c'' [s'' H_s]].
  inversion H_s; subst. right. eauto. left. auto.
Qed.

Lemma union_none: forall h1 h2 x,
                    h_union h1 h2 x = None ->
                    h1 x = None /\ h2 x = None.
Proof.
  intros. unfold h_union in *. destruct (in_not_in_dec x h1).
  split; auto. destruct i. congruence.
  split; auto.
Qed.

Lemma disjoint_update: forall h1 h2 x n,
                         disjoint h1 h2 ->
                         h2 x = None ->
                         disjoint (h_update h1 x n) h2.
Proof.
  unfold disjoint, not_in_dom. intros.
  unfold h_update. destruct (eq_nat_dec x l). subst.
  auto. auto.
Qed.

Hint Resolve disjoint_update.

Lemma union_update: forall h1 h2 x n,
                      h_union (h_update h1 x n) h2 =
                      h_update (h_union h1 h2) x n.
Proof.
  intros. apply functional_extensionality. intros.
  unfold h_union, h_update.
  destruct (in_not_in_dec x0). destruct i.
  destruct (eq_nat_dec x x0). auto.
  destruct (in_not_in_dec x0 h1). reflexivity. congruence.
  unfold not_in_dom in n0. destruct (eq_nat_dec x x0). congruence.
  destruct (in_not_in_dec x0 h1). destruct i. congruence. reflexivity.
Qed.

Lemma update_disjoint: forall h1 h2 x n,
                         disjoint h1 h2 ->
                         in_dom x h1 ->
                         disjoint (h_update h1 x n) h2.
Proof.
  unfold in_dom, h_update, disjoint, not_in_dom. intros.
  destruct (eq_nat_dec x l). subst. destruct H0. destruct (H l).
  congruence. auto. auto.
Qed.

Hint Resolve update_disjoint.

Lemma locality_frame: forall c : scom, frame c.
Proof with eauto.
  unfold frame. induction c; intros; inversion H1; subst; try solve [exists h1; eauto].
  Case "Seq".
  apply safeAt_seq in H.
  eapply IHc1 in H... destruct H as [h'' [H5 [H6 H7]]].
  exists h''. eauto.
  Case "Cons".
  exists (h_update (h_update h1 l (aeval s a)) (l + 1) (aeval s a0)).
  destruct (union_none h1 h2 l H12).
  destruct (union_none h1 h2 (l+1) H13).
  repeat split. constructor... eapply disjoint_update...
  rewrite union_update. rewrite union_update. reflexivity.
  Case "Lookup".
  assert (multiStep (SCLookup i a, St (s, h1)) (SCLookup i a, St (s, h1))).
  constructor. apply H in H2. destruct H2. inversion H2.
  destruct H2 as [c'' [s'' H_s]]. inversion H_s; subst.
  exists h1. repeat split... unfold h_union in H3.
  destruct (in_not_in_dec (aeval s a) h1). rewrite H3 in H4.
  inversion H4; subst... congruence.
  Case "Mutation".
  assert (multiStep (SCMutation a a0, St (s', h1)) (SCMutation a a0, St (s', h1))).
  constructor. apply H in H2. destruct H2. inversion H2.
  destruct H2 as [c'' [s'' H_s]]. inversion H_s; subst.
  exists (h_update h1 (aeval s' a) (aeval s' a0)).
  repeat split... rewrite union_update...
  Case "Dispose".
  assert (multiStep (SCDispose a, St (s', h1)) (SCDispose a, St (s', h1))).
  constructor. apply H in H2. destruct H2. inversion H2.
  destruct H2 as [c'' [s'' H_s]]. inversion H_s; subst.
  exists (fun x => if eq_nat_dec x (aeval s' a) then None else h1 x).
  repeat split... unfold disjoint, not_in_dom. intros.
  destruct (eq_nat_dec l (aeval s' a))...
  apply functional_extensionality. intros.
  unfold h_union. destruct (in_not_in_dec x)...
  destruct i. destruct (eq_nat_dec x (aeval s' a))...
  destruct (in_not_in_dec x h1)... congruence.
  unfold not_in_dom in n. destruct (eq_nat_dec x (aeval s' a)).
  subst. destruct (H0 (aeval s' a))... destruct H8. congruence.
  destruct (in_not_in_dec x h1)... destruct i. congruence.
Qed.

Lemma small_union: forall c s h c' s' h' h1,
                     small_step (c, St (s, h)) (c', St (s', h')) ->
                     disjoint h h1 ->
                     exists c'', exists sh',
                     small_step (c, St (s, h_union h h1)) (c'', St sh').
Proof with eauto.
  induction c; intros; inversion H; subst;
  try solve [exists c'; eauto]; try solve [exists SCSkip; eauto].
  exists SCSkip. exists (st_update s i (aeval s a), h_union h' h1)...
  destruct (IHc1 s h c1' s' h' h1 H2 H0) as [c'' [sh' H_s]].
  exists (SCSeq c'' c2)...
  exists (SCSeq c (SCWhile b c))...
  Case "Cons".
  destruct (finite_heap (h_union h h1)) as [l'  H_h].
  assert (h_union h h1 l' = None). destruct (in_not_in_dec l' (h_union h h1))...
  destruct i0. apply H_h in H1. omega.
  assert (h_union h h1 (l'+1)= None). destruct (in_not_in_dec (l'+1) (h_union h h1))...
  destruct i0. apply H_h in H2. omega.
  exists SCSkip. exists (st_update s i l',
              h_update (h_update (h_union h h1) l' (aeval s a))
                       (l'+1) (aeval s a0))...
  Case "Lookup".
  exists SCSkip. exists (st_update s i n, h_union h' h1).
  constructor. unfold h_union. destruct (in_not_in_dec (aeval s a) h')...
  congruence.
  Case "Mutation".
  exists SCSkip. exists (s', h_update (h_union h h1) (aeval s' a) (aeval s' a0)).
  constructor... destruct H10. exists x... unfold h_union.
  destruct (in_not_in_dec (aeval s' a) h)... congruence.
  Case "Dispose".
  exists SCSkip. exists (s', fun x =>
                     if eq_nat_dec x (aeval s' a) then None else (h_union h h1 x)).
  constructor... destruct H8. exists x. unfold h_union.
  destruct (in_not_in_dec (aeval s' a) h)... congruence.
Qed.

Lemma safeAt_continues:
  forall c c' s s' h h',
    safeAt c (s, h) -> small_step (c, St (s, h)) (c', St (s', h')) ->
    safeAt c' (s', h').
Proof.
  intros. unfold safeAt. intros.
  assert (multiStep (c, St (s, h)) (c'0, St s'0)). econstructor; eauto.
  apply H in H2. auto.
Qed.

Lemma locality_safeMono: forall c : scom, safeMono c.
Proof with eauto.
  unfold safeMono. intros.
  unfold safeAt. intros.
  remember (c, St (s, h_union h h')) as cs.
  remember (c', St s') as cs'.
  generalize dependent c.
  generalize dependent s.
  generalize dependent h.
  induction H1; intros; inversion Heqcs; subst; inversion Heqcs'; subst;
  clear Heqcs; clear Heqcs'.
  assert (multiStep (c', St (s0, h)) (c', St (s0, h)))...
  apply H in H1. destruct H1... destruct H1 as [c'' [s'' H_s]].
  destruct s''. eapply small_union in H_s...
  assert (frame c0). apply locality_frame.
  destruct s'0. destruct s.
  destruct (H3 s0 h h' c'0 s h0)... destruct H4 as [H41 [H42 H43]].
  assert ((c', St s') = (c', St s'))...
  eapply IHmultiStep in H4...
  eapply safeAt_continues in H2... rewrite H43...
  apply multi_abt in H1... inversion H1.
Qed.

Lemma not_safe : ~ safeMono (SCCons X (ANum 1) (ANum 1)).
Proof.
  intro H. unfold safeMono in H.
  assert (safeAt (SCCons X (ANum 1) (ANum 1)) (fun id => 0, emp_heap)).
  unfold safeAt. intros. inversion H0; subst. right.
  exists SCSkip.
  exists (st_update (fun id => 0) X 1, h_update (h_update emp_heap 1 1) 2 1).
  econstructor; eauto. inversion H4; subst. inversion H6; subst; auto.
  inversion H5.
  assert (disjoint emp_heap (fun n => Some 1)).
  unfold disjoint, not_in_dom. intros. left. reflexivity.
  assert (h_union emp_heap (fun n => Some 1) = fun n => Some 1). reflexivity.
  eapply H in H0; eauto. rewrite H2 in *.
  unfold safeAt in H0.
  assert (multiStep (SCCons X (ANum 1) (ANum 1), St (fun _ => 0, fun _ => Some 1))
                    (SCCons X (ANum 1) (ANum 1), St (fun _ => 0, fun _ => Some 1))). constructor.
  apply H0 in H3. destruct H3. inversion H3.
  destruct H3 as [c'' [s'' H_s]].
  inversion H_s. inversion H12.
Qed.

Theorem locality: forall c : scom, safeMono c /\ frame c.
Proof.
  split. apply locality_safeMono. apply locality_frame.
Qed.


From mathcomp Require Import all_ssreflect.
(*
From mathcomp Require Import fintype.
Print FinMixin.
Check FinMixin.

Print FinType.
Check FinType _ _.

Print UniqFinMixin.
Check UniqFinMixin.
 *)

(* 6. Sub-Types Terms with properties *)
(* 6.3 Finite types and their theory *)

(* Before describing other sub-types we introduce the interface of
types equipped with a finite enumeration.
別のsub-typeを示す前に、有限列挙を備えた型のインターフェースを導入する。
*)

(* 本節には例題が無いので、bool の subtype として false だけからなる型を定義する例を使う。 *)

(* Interface for finite types *)
Notation count_mem x := (count [pred y | y == x]).
Print count_mem.
Check count_mem false [:: false].
Compute (count_mem false [:: false]).       (* 1 : nat *)

(* Module finite. *)
  Definition axiom (T : eqType) (e : seq T) :=
    forall x : T, count_mem x e = 1.

  Record mixin_of (T : eqType) :=
    Mixin {
        enum : seq T;
        a : axiom T enum;
      }.

  Record finType :=
    FinType {
        sort : eqType;
        m : mixin_of sort
      }.

  Lemma UniqFinMixin (T : eqType) (e : seq T) :
    uniq e -> e =i T -> mixin_of T.
  Proof.
  Admitted.
(* End finite. *)

(* mytype を定義する。 *)
Inductive mytype : Set :=
  false : mytype.

Definition eqMytype (x y : mytype) : bool :=
  match x, y with
    | false,  false  => Datatypes.true
  end.

Lemma mytype_eqP : forall (x y : mytype), reflect (x = y) (eqMytype x y).
Proof.
  move=> x y.
    by apply: (iffP idP); case: x; case: y.
Qed.

Definition mytype_eqMixin := @EqMixin mytype eqMytype mytype_eqP.
Canonical mytype_eqType := @EqType mytype mytype_eqMixin.
Print Canonical Projections.
(*
mytype <- sort ( mytype_eqType )
c.f.
bool <- sort ( bool_eqType )
 *)
Check mytype_eqType : eqType.
Check bool_eqType : eqType.
(* boolの要素を与えると、eqType型の暗黙な変数の値をbool_eqTypeとする *)

Definition myenum : seq mytype := [:: false].

Lemma mytype_enumP : axiom mytype_eqType myenum.
Proof.
  rewrite /axiom.
  by case => //=.
Qed.
(* mytype の定義終わり。 *)

(* Declare a fintype *)

(* any fintype is also an eqType (see the parameter of the mixin), and
that to declare a fintype instance one can write: *)

Definition mytype_finMixin := Mixin mytype_eqType myenum mytype_enumP.
Canonical mytype_finType := FinType mytype_eqType mytype_finMixin.
Print Canonical Projections.
(*
mytype_eqType <- sort ( mytype_finType )
mytype <- sort ( mytype_eqType )
 *)
Check false : mytype.
Check false : mytype_eqType.
Check mytype_finType : finType.
(* mytype型の値falseを与えると、
finType型の暗黙な変数の値をmytype_eqTypeとする。 *)

(* Declare a finType *)

Lemma myenum_uniq : uniq myenum.
Proof.
  done.
Qed.

Lemma mem_myenum : forall (x : mytype), x \in myenum.
Proof.
  by case.
Qed.

Check UniqFinMixin : forall (T : eqType) (e : seq T), uniq e -> e =i T -> mixin_of T.

Check mytype_eqType : eqType.
Check myenum : seq mytype.
Check myenum_uniq : uniq myenum.
Check mem_myenum : forall x : mytype, x \in myenum.
Check mem_myenum : myenum =i mytype_eqType. (* e =i T とユニファイできる。 *)

Definition mytype_finMixin' :=
  UniqFinMixin mytype_eqType myenum myenum_uniq mem_myenum.

Unset Printing Implicit.    (* Unset : implicitな引数を表示しない。 D:しない。 A:する。*)
Set Printing Coercions.   (* Unset : コアーションを表示しない     D:しない。 A:する。*)
Unset Printing Notations. (*   Set : Notation を使って表示する。  D:する。  A:しない。*)
Unset Printing Universe.  (* Unset : 高階のTypeを表示しない。     D:しない。 A:- *)
Print Graph. (* Print Coercions. *)
Print Canonical Projections.

Print mytype_finMixin'.
Check mytype_finMixin' : mixin_of mytype_eqType.

(* Some theory for finType *)

(*
Lemma cardT (T : finType) : #|T| = size (enum T).
Proof.
Admitted.

Lemma forallP (T : finType) (P : pred T) : reflect (forall x, P x) [forall x, P x].
Proof.
Admitted.
 *)

(* END *)


Require Export Bedrock.Word.
Require Import Fiat.Common.DecideableEnsembles.

Lemma wordToNat_lt sz
  : forall w w' : word sz,
    wlt w w' ->
    lt (wordToNat w) (wordToNat w').
Proof.
  intros.
  unfold wlt, BinNat.N.lt in H.
  rewrite !wordToN_nat, <- Nnat.Nat2N.inj_compare,
  <- Compare_dec.nat_compare_lt in H.
  eassumption.
Qed.

Lemma natToWord_wlt sz
  : forall n n' : nat,
    BinNat.N.lt (BinNat.N.of_nat n) (Npow2 sz)
    -> BinNat.N.lt (BinNat.N.of_nat n') (Npow2 sz)
    -> lt n n'
    -> wlt (natToWord sz n) (natToWord sz n').
Proof.
  unfold wlt; intros.
  rewrite !wordToN_nat.
  rewrite !wordToNat_natToWord_idempotent; eauto.
  unfold BinNat.N.lt; rewrite <- Nnat.Nat2N.inj_compare.
  eapply Compare_dec.nat_compare_lt; eassumption.
Qed.

Instance Query_eq_word {n} : Query_eq (Word.word n) :=
  {| A_eq_dec := @Word.weq n |}.


Require Import Problem.

Definition failcase (n : nat) : bool := negb (Problem.f n n).

Theorem solution : task.
Proof.
  unfold task.
  destruct (f_surjective failcase).
  specialize (H x).
  unfold failcase in H.
  destruct (f x x); discriminate.
Qed.


Set Implicit Arguments.

Require Import List String Arith Vector.
Require Import Program.Equality.
Import VectorNotations.

Section HVector.

  Fixpoint hvec {n} (ifc: Vector.t Type n) : Type :=
    match ifc with
    | [] => unit
    | t :: ifc' => (t * hvec ifc')%type
    end.

  Definition hvnil: hvec [] := tt.

  Definition hvcons
             {A} (a: A)
             {n} {ifc: Vector.t Type n}
             (vec: hvec ifc): hvec (A :: ifc) :=
    (a, vec).

  Definition hvhead
             {n} {ifc: Vector.t Type (S n)}
             (vec: hvec ifc): Vector.nth ifc (@Fin.F1 n) :=
    Vector.caseS (fun n ifc => hvec ifc -> Vector.nth ifc (@Fin.F1 n))
                 (fun h n t => fst) ifc vec.

  Definition hvtail
             {A} {n} {ifc: Vector.t Type (S n)}
             (vec: hvec (A :: ifc)): hvec ifc :=
    snd vec.

  Definition Vector_caseS'
             {A'} (Q : nat -> Type)
             (P : forall {n} (v : Vector.t A' (S n)), Q n -> Type)
             (H : forall h {n} t q, @P n (h :: t) q) {n} (v: Vector.t A' (S n))
             (q : Q n)
    : P v q.
  Proof.
    specialize (fun h t => H h _ t q).
    change n with (pred (S n)) in H, q |- *.
    set (Sn := S n) in *.
    pose (fun Sn (v : Vector.t A' Sn) (q : Q (pred Sn)) =>
            match Sn return Vector.t A' Sn -> Q (pred Sn) -> Type with
            | S n' => P n'
            | 0 => fun _ _ => True
            end v q) as P'.
    change (match Sn return Type with
            | 0 => True
            | _ => P' Sn v q
            end).
    change (forall h (t : match Sn with
                          | S n' => Vector.t A' n'
                          | 0 => Vector.t A' Sn
                          end),
               P' Sn (match Sn return match Sn with
                                      | S n' => Vector.t A' n'
                                      | 0 => Vector.t A' Sn
                                      end -> Vector.t A' Sn
                      with
                      | S _ => fun t => h :: t
                      | 0 => fun t => t
                      end t) q) in H.
    clearbody P'; clear P.
    clearbody Sn.
    destruct v as [|h ? t].
    { constructor. }
    { apply H. }
  Defined.

  Fixpoint hvec_ith {n} {ifc: Vector.t Type n}
           (vec: hvec ifc) (i: Fin.t n): Vector.nth ifc i :=
    match i in Fin.t n return
          forall (ifc: Vector.t Type n),
            hvec ifc -> Vector.nth ifc i
    with
    | Fin.F1 =>
      fun ifc =>
        Vector.caseS (fun n ifc => hvec ifc -> Vector.nth ifc (@Fin.F1 n))
                     (fun h n t => fst) ifc
    | Fin.FS i' =>
      fun ifc =>
        Vector_caseS' Fin.t
                      (fun n ifc n' => hvec ifc -> Vector.nth ifc (@Fin.FS n n'))
                      (fun h n t m vec => hvec_ith (snd vec) m)
                      ifc i'
    end ifc vec.

  Fixpoint hvec_upd {n} {ifc: Vector.t Type n}
           (vec: hvec ifc) (i: Fin.t n) (v: Vector.nth ifc i): hvec ifc :=
    match i in Fin.t n return
          forall (ifc: Vector.t Type n),
            hvec ifc -> Vector.nth ifc i -> hvec ifc
    with
    | Fin.F1 =>
      fun ifc =>
        Vector.caseS (fun n ifc => hvec ifc -> Vector.nth ifc (@Fin.F1 n) -> hvec ifc)
                     (fun h n t vec v => (v, snd vec)) ifc
    | Fin.FS i' =>
      fun ifc =>
        Vector_caseS' Fin.t
                      (fun n ifc n' => hvec ifc -> Vector.nth ifc (@Fin.FS n n') -> hvec ifc)
                      (fun h n t m vec v => (fst vec, @hvec_upd _ _ (snd vec) m v))
                      ifc i'
    end ifc vec v.

End HVector.

Notation F1 := (Fin.F1).
Notation F2 := (Fin.FS Fin.F1).
Notation F3 := (Fin.FS (Fin.FS Fin.F1)).
Notation F4 := (Fin.FS (Fin.FS (Fin.FS Fin.F1))).
Notation F5 := (Fin.FS (Fin.FS (Fin.FS (Fin.FS Fin.F1)))).
Notation F6 := (Fin.FS (Fin.FS (Fin.FS (Fin.FS (Fin.FS Fin.F1))))).
Notation F7 := (Fin.FS (Fin.FS (Fin.FS (Fin.FS (Fin.FS (Fin.FS Fin.F1)))))).
Notation F8 := (Fin.FS (Fin.FS (Fin.FS (Fin.FS (Fin.FS (Fin.FS (Fin.FS Fin.F1))))))).

Declare Scope hvec_scope.
Notation "HVEC #[ I ]" := (hvec_ith HVEC I) (at level 0): hvec_scope.
Notation "HVEC +#[ I <- V ]" := (hvec_upd HVEC I V) (at level 0): hvec_scope.

Delimit Scope hvec_scope with hvec.


Require Import Setoid Relations Morphisms.

Record TypeWithEquality:Type :=
{
TWE_Type:Type;
TWE_Equality:relation TWE_Type;
TWE_Equivalence:Equivalence TWE_Equality
}.

Record ArrowWithEquality(A B:TypeWithEquality):Type
:=
{
AWE_Arrow:TWE_Type A->TWE_Type B;
AWE_Compat:Proper (TWE_Equality A==> TWE_Equality B)%signature AWE_Arrow
}.

Implicit Arguments Build_ArrowWithEquality[A B].
Implicit Arguments AWE_Arrow[A B].
Implicit Arguments AWE_Compat[A B].

Program Definition MakeArrowWithEquality(A B:TypeWithEquality):TypeWithEquality
:=Build_TypeWithEquality
	(ArrowWithEquality A B)
	(fun f1 f2=> forall x y,TWE_Equality A x y->TWE_Equality B(AWE_Arrow f1 x)(AWE_Arrow f2 y))
	_.

Next Obligation.
destruct A as(AT,AE,AEV).
destruct B as(BT,BE,BEV).
split;
unfold Reflexive,Symmetric,Transitive.
intros (fA,fC);intros.
simpl in *.
rewrite H.
reflexivity.
intros (fA, fC)(gA,gC);
intros.
simpl in *.
rewrite H0.
symmetry.
apply H.
reflexivity.
intros (fA,fC) (gA,gC) (hA,hC);intros.
simpl in *.
rewrite H1.
transitivity (gA y).
apply H.
reflexivity.
apply H0.
reflexivity.
Qed.

Notation "x -> y" :=(x -> y) (at level 90, right
associativity):type_scope.

Delimit Scope TypeWithEquality_scope with TypeWithEquality.
Infix "->":=MakeArrowWithEquality(at level 90, right associativity):TypeWithEquality_scope.
Module Type IsMonad.
 Parameter m:TypeWithEquality -> TypeWithEquality.
 Parameter returnM:  forall {t:TypeWithEquality},TWE_Type (t->m t)%TypeWithEquality.
 Parameter bindM:forall {t1 t2:TypeWithEquality},TWE_Type(m t1->(t1->m t2)->m t2)%TypeWithEquality.
 Axiom monad_bind_return_r:forall (t1 t2:TypeWithEquality) (a:TWE_Type t1)
  (k:TWE_Type (t1-> m t2)%TypeWithEquality),
  TWE_Equality (m t2)(AWE_Arrow (AWE_Arrow bindM(AWE_Arrow returnM a))k)(AWE_Arrow k a).

Axiom monad_bind_return_l:forall{t:TypeWithEquality}(ma:TWE_Type (m t)),
TWE_Equality(m t) (AWE_Arrow(AWE_Arrow bindM ma)returnM)ma.

Axiom monad_bind_assoc:forall{t1 t2 t3:TypeWithEquality}
(ma:TWE_Type (m t1))(k:TWE_Type(t1->m t2)%TypeWithEquality)(h:TWE_Type(t2->m t3)%TypeWithEquality),
TWE_Equality(m t3)
(AWE_Arrow(AWE_Arrow bindM ma)
(Build_ArrowWithEquality(fun x=>AWE_Arrow(AWE_Arrow bindM (AWE_Arrow k x))h)
(fun(x y:TWE_Type t1)(Hxy:TWE_Equality t1 x y)=>AWE_Compat bindM
(AWE_Arrow k x)(AWE_Arrow k y)(AWE_Compat k x y Hxy)h h
(Equivalence_Reflexive(Equivalence:=TWE_Equivalence _)h
)
)
)
)
(AWE_Arrow(AWE_Arrow bindM(AWE_Arrow(AWE_Arrow bindM ma)k))h).
End IsMonad.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Require Export Iterator.
Require Import ZArith.
Require Import Lia.
Require Export UList.
Open Scope Z_scope.

Theorem next_n_Z: forall n m,  next_n Z.succ n m = n + Z_of_nat m.
intros n m; generalize n; elim m; clear n m.
intros n; simpl; auto with zarith.
intros m H n.
replace (n + Z_of_nat (S m)) with (Z.succ n + Z_of_nat m).
rewrite <- H; auto with zarith.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zprogression_end:
 forall n m,
  progression Z.succ n (S m) =
  app (progression Z.succ n m) (cons (n + Z_of_nat m) nil).
intros n m; generalize n; elim m; clear n m.
simpl; intros; apply f_equal2 with ( f := @cons Z ); auto with zarith.
intros m1 Hm1 n1.
apply trans_equal with (cons n1 (progression Z.succ (Z.succ n1) (S m1))); auto.
rewrite Hm1.
replace (Z.succ n1 + Z_of_nat m1) with (n1 + Z_of_nat (S m1)). auto.
replace (Z_of_nat (S m1)) with (1 + Z_of_nat m1). auto with zarith.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zprogression_pred_end:
 forall n m,
  progression Z.pred n (S m) =
  app (progression Z.pred n m) (cons (n - Z_of_nat m) nil).
intros n m; generalize n; elim m; clear n m.
simpl; intros; apply f_equal2 with ( f := @cons Z ); auto with zarith.
intros m1 Hm1 n1.
apply trans_equal with (cons n1 (progression Z.pred (Z.pred n1) (S m1))); auto.
rewrite Hm1.
replace (Z.pred n1 - Z_of_nat m1) with (n1 - Z_of_nat (S m1)). auto.
replace (Z_of_nat (S m1)) with (1 + Z_of_nat m1). auto with zarith.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zprogression_opp:
 forall n m,
  rev (progression Z.succ n m) = progression Z.pred (n + Z_of_nat (pred m)) m.
intros n m; generalize n; elim m; clear n m.
simpl; auto.
intros m Hm n.
rewrite (Zprogression_end n); auto.
rewrite distr_rev.
rewrite Hm; simpl; auto.
case m.
simpl; auto.
intros m1;
 replace (n + Z_of_nat (pred (S m1))) with (Z.pred (n + Z_of_nat (S m1))); auto.
rewrite inj_S; simpl; (unfold Z.pred; unfold Z.succ); auto with zarith.
Qed.

Theorem Zprogression_le_init:
 forall n m p, In p (progression Z.succ n m) ->  (n <= p).
intros n m; generalize n; elim m; clear n m; simpl; auto.
intros; contradiction.
intros m H n p [H1|H1]; auto with zarith.
generalize (H _ _ H1); auto with zarith.
Qed.

Theorem Zprogression_le_end:
 forall n m p, In p (progression Z.succ n m) ->  (p < n + Z_of_nat m).
intros n m; generalize n; elim m; clear n m; auto.
intros; contradiction.
intros m H n p H1; simpl in H1 |-; case H1; clear H1; intros H1.
lia.
apply Z.lt_le_trans with (Z.succ n + Z_of_nat m).
apply H; assumption.
lia.
Qed.

Theorem ulist_Zprogression: forall a n,  ulist (progression Z.succ a n).
intros a n; generalize a; elim n; clear a n; simpl; auto with zarith.
intros n H1 a; apply ulist_cons; auto.
intros H2; absurd (Z.succ a <= a); auto with zarith.
apply Zprogression_le_init with ( 1 := H2 ).
Qed.

Theorem in_Zprogression:
 forall a b n, ( a <= b < a + Z_of_nat n ) ->  In b (progression Z.succ a n).
intros a b n; generalize a b; elim n; clear a b n; auto with zarith.
simpl; auto with zarith.
intros n H a b.
replace (a + Z_of_nat (S n)) with (Z.succ a + Z_of_nat n).
intros [H1 H2]; simpl; auto with zarith.
case (Zle_lt_or_eq _ _ H1); auto with zarith.
rewrite inj_S; auto with zarith.
Qed.


(**
Here we define the signature for the set truncation

Given a 1-type `A`, we define its set truncation as the following HIT

HIT ∥A∥₀ :=
| inc : A → ∥A∥₀
| trunc : ∏ (x y : ∥A∥₀) (p q : x = y), p = q

To encode the fact that we have two path variables, we rewrite it as follows

HIT ∥A∥₀ :=
| inc : A → ∥A∥₀
| trunc : ∏ (x y : ∥A∥₀) (p : (x , x) = (y , y)), ap π₁ p = ap π₂ p
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import signature.hit.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.one_types_homotopies.
Require Import displayed_algebras.displayed_algebra.

Local Open Scope cat.

Definition set_trunc_point_constr
           (A : one_type)
  : poly_code
  := C A.

Definition set_trunc_signature
           (A : one_type)
  : hit_signature.
Proof.
  simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _  ,, _ ,, _ ,, _ ,, _).
  - exact (set_trunc_point_constr A).
  - exact empty.
  - intro x ; induction x.
  - intro x ; induction x.
  - intro x ; induction x.
  - exact unit.
  - exact (λ _, I * I).
  - exact (λ _, I * I).
  - exact (λ _, pair (π₁ _ _) (π₁ _ _)).
  - exact (λ _, pair (π₂ _ _) (π₂ _ _)).
  - exact (λ _, π₁ _ _).
  - exact (λ _, π₂ _ _).
  - exact (λ _, path_pr1 path_arg).
  - exact (λ _, path_pr2 path_arg).
Defined.

Section SetTruncAlgebraProjections.
  Variable (A : one_type)
           (X : hit_algebra_one_types (set_trunc_signature A)).

  Definition set_trunc_carrier
    : one_type
    := pr111 X.

  Definition set_trunc_base
    : A → set_trunc_carrier
    := pr211 X.

  Definition set_trunc_surface
    : ∏ (a b : set_trunc_carrier) (p q : a = b), p = q
    := λ a b p q,
       !(maponpaths_pr1_pathsdirprod p q)
       @ !(pathscomp0rid _)
       @ pr2 X tt (a ,, b) (pathsdirprod p q)
       @ pathscomp0rid _
       @ maponpaths_pr2_pathsdirprod p q.
End SetTruncAlgebraProjections.

Section SetTruncInduction.
  Context (A : one_type)
          (X : hit_algebra_one_types (set_trunc_signature A))
          (Y : alg_carrier X → one_type)
          (Ybase : ∏ (a : A), Y (set_trunc_base A X a))
          (Yisaset : ∏ (x : alg_carrier X), isaset (Y x)).

  Definition make_set_trunc_disp_algebra
    : disp_algebra X.
  Proof.
    use make_disp_algebra.
    - exact Y.
    - intros x xx.
      exact (Ybase x).
    - intros j x y.
      induction j.
    - intro j.
      induction j.
      intros z zz p pp.
      apply path_globe_over_hset.
      exact Yisaset.
  Defined.

  Variable (HX : is_HIT _ X).

  (** Induction principle *)
  Definition set_trunc_ind_disp_algebra_map
    : disp_algebra_map make_set_trunc_disp_algebra
    := HX make_set_trunc_disp_algebra.

  Definition set_trunc_ind
    : ∏ (x : alg_carrier X), Y x
    := pr1 set_trunc_ind_disp_algebra_map.

  Definition set_trunc_ind_base
             (a : A)
    : set_trunc_ind (set_trunc_base A X a) = Ybase a
    := pr12 set_trunc_ind_disp_algebra_map a.
End SetTruncInduction.


Require Import Coq.Classes.Equivalence.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Lists.List.
Require Import Coq.QArith.QArith.
Require Import Coq.QArith.Qminmax.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Unicode.Utf8.
Require Import Iteration.Lattice.
Require Import Iteration.QInf.
Require Import Iteration.Selection.

Generalizable All Variables.

Import ListNotations.
Local Open Scope Q_scope.
Local Open Scope QInf_scope.
Local Open Scope equiv_scope.

Definition g1 x := (x + 2.5) ⊔ -5.
Definition g2 x := (x + 0.5) ⊔ -3.
Definition g3 x := (x - 3) ⊔ 1.
Definition g4 x := (x - 4) ⊔ 1.5.
Definition g5 x := (x - 4.5) ⊔ 2.5.

Definition G := [g1; g2; g3; g4; g5].

Definition f := inf G.

(* We register the g's as morphisms (ie. respect QInf.eq) *)
Ltac g_mor :=
  intros x y H;
  destruct x; destruct y; inversion H as [H1]; try reflexivity;
  apply Qeq_bool_iff in H1;
  unfold QInf.eq, QInf.eqb;
  simpl;
  rewrite H1;
  apply Qeq_bool_iff;
  reflexivity.

Add Morphism g1 with signature QInf.eq ==> QInf.eq as g1_mor.
Proof. g_mor. Qed.

Add Morphism g2 with signature QInf.eq ==> QInf.eq as g2_mor.
Proof. g_mor. Qed.

Add Morphism g3 with signature QInf.eq ==> QInf.eq as g3_mor.
Proof. g_mor. Qed.

Add Morphism g4 with signature QInf.eq ==> QInf.eq as g4_mor.
Proof. g_mor. Qed.

Add Morphism g5 with signature QInf.eq ==> QInf.eq as g5_mor.
Proof. g_mor. Qed.

Add Morphism f with signature QInf.eq ==> QInf.eq as f_mor.
Proof. g_mor. Qed.

(* This is extremely annoying to prove, there has to be a better way
   to show that G admits a lower selection *)
Lemma g1_matches : ∀ x, x ≤ -5.5 → g1 x === f x.
Proof.
  intros x H.
  destruct x; try reflexivity.
  destruct (Qcompare_spec (q + 2.5) (-5)).
  - setoid_replace (-5)%Q with (-7.5 + 2.5)%Q in H0; try reflexivity.
    rewrite Qplus_inj_r in H0.
    unfold Equivalence.equiv, QInf.eq, QInf.eqb.
    simpl.
    apply Qeq_bool_iff.
    rewrite H0.
    reflexivity.
  - unfold QInf.le, QInf.leb in H.
    rewrite Qle_bool_iff in H.
    setoid_replace (-5)%Q with (-7.5 + 2.5)%Q in H0; try reflexivity.
    rewrite Qplus_lt_l in H0.
    unfold Equivalence.equiv, QInf.eq, QInf.eqb.
    simpl.
    apply Qeq_bool_iff.
    assert (Qmax (q + 2.5) (-5) == (-5))%Q.
    { apply Q.max_r.
      setoid_replace (-5)%Q with (-7.5 + 2.5)%Q; try reflexivity.
      apply Qplus_le_l.
      apply Qlt_le_weak.
      assumption. }
    setoid_rewrite H1.
    assert (Qmax (q + 0.5) (-3) == -3)%Q.
    { apply Q.max_r.
      setoid_replace (-3)%Q with (-3.5 + 0.5)%Q; try reflexivity.
      apply Qplus_le_l.
      assert (Qle (-5.5) (-3.5)). { apply Qle_bool_iff. reflexivity. }
      apply (Qle_trans _ _ _ H H2). }
    setoid_rewrite H2.
Admitted.

Section PI.
  (* Algorithm PI example (Example 2) *)

  (* Step 1: Set k = 1 and select g ∈ G *)
  (* We choose g5 *)

  (* Step 2: Find a fixed point for g5 *)
  (* We compute the least fixed point xᵏ of g5 *)

  Definition x1 := 2.5.

  Lemma x1_g5_least_fixed_point : least_fixed_point g5 x1.
  Proof.
    unfold x1.
    split.
    - reflexivity.
    - intros y H.
      unfold fixed_point in H.
      destruct y.
      + inversion H.
      + reflexivity.
      + unfold Lattice.le_meet, meet, Equivalence.equiv, QInf.eq, QInf.eqb in *.
        simpl in *.
        apply Qeq_bool_iff.
        apply Qeq_bool_iff in H.
        apply Q.min_l.
        destruct (Qcompare_spec (2.5) q).
        * rewrite H0. apply Qle_refl.
        * apply Qlt_le_weak in H0. assumption.
        * apply Qlt_not_le in H0.
          unfold Qmax, GenericMinMax.gmax in H.
          destruct (Qcompare_spec (q - 4.5) 2.5).
          -- rewrite (Qeq_trans _ _ _ H H1).
             apply Qle_refl.
          -- rewrite H.
             apply Qle_refl.
          -- rewrite H in H0.
             apply Qlt_le_weak in H1.
             contradiction.
  Qed.

  (* Step 3: Compute f(xₖ) *)
  (* Step 4: If xᵏ = f(xᵏ), return xᵏ *)
  (* This fails in our example *)

  Lemma x1_not_f_fixpoint : ¬ (fixed_point f x1).
  Proof. intros H. inversion H. Qed.

  (* Step 5: Choose g ∈ G st f(xᵏ) = g(xᵏ) *)
  (* We choose g3 *)

  Lemma g3_matches : f x1 == g3 x1.
  Proof. reflexivity. Qed.

  (* Repeat: find fixed point for g3 *)

  Definition x2 := 1.

  Lemma x2_g3_least_fixed_point : least_fixed_point g3 x2.
  Proof.
    split.
    - reflexivity.
    - intros y H.
      unfold x2.
      unfold fixed_point in H.
      destruct y.
      + inversion H.
      + reflexivity.
      + unfold Lattice.le_meet, meet, Equivalence.equiv, QInf.eq, QInf.eqb in *.
        simpl in *.
        apply Qeq_bool_iff.
        apply Qeq_bool_iff in H.
        apply Q.min_l.
        destruct (Qcompare_spec 1 q).
        * rewrite H0. apply Qle_refl.
        * apply Qlt_le_weak in H0. assumption.
        * apply Qlt_not_le in H0.
          unfold Qmax, GenericMinMax.gmax in H.
          destruct (Qcompare_spec (q - 3) 1).
          -- rewrite (Qeq_trans _ _ _ H H1).
             apply Qle_refl.
          -- rewrite H.
             apply Qle_refl.
          -- rewrite H in H0.
             apply Qlt_le_weak in H1.
             contradiction.
  Qed.

  Lemma x2_f_fixed_point : fixed_point f x2.
  Proof. reflexivity. Qed.

End PI.

(* Some monotone definitions *)
Definition monotone `{PreOrder A R} (f : A → A) :=
  Proper (R ==> R) f.

Require Import Coq.QArith.QArith.

Instance PreOrder_Qle : PreOrder Qle := {|
  PreOrder_Reflexive := Qle_refl;
  PreOrder_Transitive := Qle_trans;
|}.

Definition succ (n : Q) := n + 1.

Definition monotone_succ : monotone succ.
Proof.
  intros x y.
  apply Qplus_le_l.
Qed.

Lemma monotone_respectful `{PartialOrder A equ R} (f : A → A) :
  monotone f → Proper (equ ==> equ) f.
Proof.
  intros M x y Eq.
  apply partial_order_equivalence.
  split.
  - apply M.
    apply partial_order_equivalence.
    symmetry.
    assumption.
  - apply M.
    apply partial_order_equivalence.
    assumption.
Qed.


Require Import HoTT.
Require Import polynomial.

Open Scope poly_scope.

(* The action of a polynomial on a map is functorial. *)
Fixpoint poly_map_id (P : polynomial) {A : Type}
  : forall (x : poly_act P A), poly_map P idmap x = x
  := match P with
     | [-] => fun _ => idpath
     | const A => fun _ => idpath
     | P₁ * P₂ => fun x => path_prod' (poly_map_id P₁ (fst x)) (poly_map_id P₂ (snd x))
     | P₁ + P₂ =>
       fun x =>
         match x with
         | inl xl => ap inl (poly_map_id P₁ xl)
         | inr xr => ap inr (poly_map_id P₂ xr)
         end
     end.

Fixpoint poly_map_compose
           {P : polynomial} {A B C : Type}
           (g : B -> C) (f : A -> B)
  : forall (x : poly_act P A), poly_map P (g o f) x = poly_map P g (poly_map P f x)
  := match P with
     | [-] => fun _ => idpath
     | const A => fun _ => idpath
     | P₁ * P₂ =>
       fun x => path_prod' (poly_map_compose g f (fst x))
                           (poly_map_compose g f (snd x))
     | P₁ + P₂ =>
       fun x =>
         match x with
         | inl xl => ap inl (poly_map_compose g f xl)
         | inr xr => ap inr (poly_map_compose g f xr)
         end
     end.

Definition transport_pr2
           {A : Type} {F : A -> Type}
           {x z : {z : A & F z}} y
           (p : x.1 = y) (q : x = z)
  : transport F p x.2 = transport F (ap pr1 q^ @ p) z.2
  := match q with
     | idpath => ap (fun z => transport F z x.2) (concat_1p p)^
     end.

Fixpoint fam_const
         {A B : Type}
         {P : polynomial}
  : forall (p : poly_act P A), poly_fam P (fun _ : A => B) p -> poly_act P B
  := match P with
     | [-] => fun _ x => x
     | const A => fun _ => idmap
     | P₁ * P₂ =>
       fun p x => (fam_const (fst p) (fst x), fam_const (snd p) (snd x))
     | P₁ + P₂ =>
       fun p =>
         match p with
         | inl pl => fun x => inl(fam_const pl x)
         | inr pr => fun x => inr(fam_const pr x)
         end
     end.

Fixpoint fam_const_map
           {A B : Type}
           {P : polynomial}
           (f : A -> B)
  : forall (x : poly_act P A), fam_const x (poly_dmap P f x) = poly_map P f x
  := match P with
     | [-] => fun _ => idpath
     | const A => fun _ => idpath
     | P₁ * P₂ =>
       fun x => path_prod' (fam_const_map f (fst x)) (fam_const_map f (snd x))
     | P₁ + P₂ =>
       fun x =>
         match x with
         | inl xl => ap inl (fam_const_map f xl)
         | inr xr => ap inr (fam_const_map f xr)
         end
     end.

Fixpoint fam_eq
           {A B : Type}
           {P : polynomial}
           (f g : A -> B)
  : forall (y : poly_act P A)
           (z : poly_fam P (fun x : A => f x = g x) y),
    poly_map P f y = poly_map P g y
  := match P with
     | [-] => fun _ z => z
     | const A => fun _ _ => idpath
     | P₁ * P₂ =>
       fun y z => path_prod' (fam_eq f g (fst y) (fst z)) (fam_eq f g (snd y) (snd z))
     | P₁ + P₂ =>
       fun y => match y with
                    | inl yl => fun z => ap inl (fam_eq f g yl z)
                    | inr yr => fun z => ap inr (fam_eq f g yr z)
                end
     end.

Fixpoint fam_sum
           {P : polynomial}
           {A : Type}
           {B : A -> Type}
  : forall (x : poly_act P {x : A & B x}),
    poly_fam P (fun z : {x : A & B x} => B z.1) x -> poly_fam P B (poly_map P pr1 x)
  := match P with
     | [-] => fun x z => z
     | const A => fun _ => idmap
     | P₁ * P₂ => fun x z => (fam_sum (fst x) (fst z), fam_sum (snd x) (snd z))
     | P₁ + P₂ => fun x =>
       match x with
       | inl xl => fun z => fam_sum xl z
       | inr xr => fun z => fam_sum xr z
       end
     end.

Fixpoint const_dmap
           {P : polynomial}
           {A B : Type}
           (f : A -> B)
  : forall (x : poly_act P A),
    fam_const x (poly_dmap P f x) = poly_map P f x
  := match P with
     | [-] => fun _ => idpath
     | const A => fun _ => idpath
     | P₁ * P₂ => fun x => path_prod' (const_dmap f (fst x)) (const_dmap f (snd x))
     | P₁ + P₂ =>
       fun x =>
         match x with
         | inl xl => ap inl (const_dmap f xl)
         | inr xr => ap inr (const_dmap f xr)
         end
     end.


From Coq Require Import Program List.

Require Export init.

(* Utilities *)

(* A1 -> .. -> An -> B *)
Fixpoint nary_fn (n : nat) (A B : Type) :=
  match n with
  | O => B
  | S n' => A -> nary_fn n' A B
  end.

(*** Vectors ***)

Inductive vec (A : Type) : nat -> Type :=
  | vnil : vec A O
  | vcons : forall n, A -> vec A n -> vec A (S n).

(* induction scheme for vectors, taken from coq stdlib *)
Definition rectS {A} (P : forall {n}, vec A (S n) -> Type)
  (bas : forall a : A, P (vcons a vnil))
  (rect: forall a {n} (v : vec A (S n)), P v -> P (vcons a v)) :=
  fix rectS_fix {n} (v : vec A (S n)) : P v :=
  match v with
  |@vcons _ 0 a v =>
      match v with
      | vnil => bas a
      | _ => fun devil => False_ind (@IDProp) devil
      end
  |@vcons _ (S nn') a v => rect a v (rectS_fix v)
  |_ => fun devil => False_ind (@IDProp) devil
  end.

(* tail *)
Definition vtl (A : Type) (n : nat) (v : vec A (S n)) : vec A n :=
  match v with
  | vcons _ tl' => tl'
  end.

(* head *)
Definition vhd (A : Type) (n : nat) (v : vec A (S n)) : A :=
  match v with
  | vcons a _ => a
  end.

(* quantify a vector to express arity-genericity *)
Fixpoint quantify (A : Type) (n : nat)
  : (vec A n -> Type) -> Type :=
    match n return (vec A n -> Type) -> Type with
    | O => fun f => f vnil
    | S n' => fun f => forall a : A,
                quantify (fun As => f (vcons a As))
    end.

(* curry for arity-genericity *)
Fixpoint curry (A : Type) (n : nat)
  : forall (G : vec A n -> Type), (forall X : vec A n, G X) -> quantify G :=
    match n return forall (G : vec A n -> Type),
    (forall X : vec A n, G X) -> quantify G with
    | O => fun _ f => f vnil
    | S n' => fun _ f => (fun a:A =>
                curry _ (fun As => f (vcons a As)))
    end.

Definition vec_nil_case {A : Type} (v : vec A 0) : v = vnil :=
  match v with vnil => eq_refl end.

Definition veq_hdtl {A : Type} {n : nat} (v : vec A (S n)) :
  v = vcons (vhd v) (vtl v).
Proof.
  apply rectS with (v := v).
  - intros. simpl. reflexivity.
  - intros. simpl. reflexivity.
Defined.

Definition veq_add {A : Type} {n : nat} (v1 v2 : vec A n) (a : A) :
  v1 = v2 -> vcons a v1 = vcons a v2.
Proof.
  intros eq.
  rewrite eq; reflexivity.
Defined.

Lemma vec_cons_case {A : Type} {n : nat} (v : vec A (S n)) :
  {x : A & {u : vec A n | v = vcons x u}}.
Proof.
  apply existT with (x:=vhd v).
  apply exist with (x:=vtl v).
  apply veq_hdtl.
Defined.

Fixpoint uncurry' (n : nat) (A : Type) {struct n}
  : forall (G : vec A n -> Type), quantify G -> forall (va : vec A n), G va.
Proof.
  intros G f va. induction n as [| n' IH].
  - hnf in f. pose proof vec_nil_case (v := va) as H. rewrite H. exact f.
  - hnf in f.
    pose proof vec_cons_case (v := va) as H. destruct H as [a [As H]].
    rewrite H. exact (uncurry' _ _ _ (f a) As). Defined.

(* apply a vector of functions to a vector *)
Fixpoint zap (A B : Type) (n : nat) (vf : vec (A -> B) n)
  : vec A n -> vec B n :=
  match vf in vec _ n return vec _ n -> vec _ n with
  | vnil => fun _ => vnil
  | vcons f vf' => fun m => vcons (f (vhd m)) (zap vf' (vtl m))
  end.

(* construct a vector with n elements of a:A *)
Fixpoint repeat (n : nat) (A : Type) (a : A) : vec A n :=
  match n with
  | O => vnil
  | S n' => vcons a (repeat a)
  end.


Require Import Memory.
Require Import ZArith.
Require Import FunctionalExtensionality.
Module LinearMemory <: Memory.
Definition adr := nat.
Definition first := 0.
Definition next := S.

Definition Mem := adr -> nat.

Definition get r (m : Mem) := m r.
Definition set r v (m : Mem) r' :=
  if beq_nat r' r then v else m r'.

Definition empty : Mem := fun _ => 0.

Definition free : adr -> Mem -> Mem :=
  fun r m => set r 0 m.

Definition isFreeFrom : adr -> Mem -> Prop :=
  fun r m => forall r', r <= r' -> m r' = 0.

Lemma isFreeFrom_free : forall (r : adr) (m : Mem) (n : nat), isFreeFrom r m -> free r (set r n m) = m.
Proof.
  intros. unfold free, isFreeFrom, set in *. apply functional_extensionality. intros.
  remember (beq_nat x r) as b. destruct b.
  - symmetry in Heqb. apply beq_nat_true in Heqb. subst. erewrite H;auto.
  - reflexivity.
Qed.

Lemma isFreeFrom_set : forall (r : adr) (m : Mem) (n : nat), isFreeFrom r m  ->  isFreeFrom (next r) (set r n m).
Proof.
  unfold isFreeFrom, set, next. intros.  remember (beq_nat r' r) as b. destruct b;symmetry in Heqb.
  - apply beq_nat_true in Heqb. omega.
  - apply beq_nat_false in Heqb. apply H. omega.
Qed.

Lemma get_set : forall (r : adr) (m : Mem) (n : nat), get r (set r n m) = n.
Proof.
  intros. unfold get, set. rewrite <- beq_nat_refl. reflexivity.
Qed.

Lemma isFreeFrom_first : isFreeFrom first empty.
Proof.
  unfold isFreeFrom, first, empty. auto.
Qed.
End LinearMemory.

Module LinearMemoryExt <: MemoryExt.
Include LinearMemory.

Lemma get_set' : forall (r : adr) (r' : adr) (m : Mem) (n : nat),
    r <> r' -> get r (set r' n m) = get r m.
Proof.
  intros.
  unfold get, set. remember (r =? r') as b. destruct b.
  - symmetry in Heqb. apply beq_nat_true in Heqb. contradiction.
  - reflexivity.
Qed.

Lemma next_fresh : forall (r r' : adr), lta adr next r r' -> r <> r'.
Proof.
  intros. apply Nat.lt_neq.
  intros. induction H; auto.
Qed.

End LinearMemoryExt.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils list_bool pos vec
                 subcode sss compiler_correction.

From Undecidability.StackMachines.BSM
  Require Import bsm_defs.

From Undecidability.MinskyMachines.MM
  Require Import mm_defs mm_utils.

Set Implicit Arguments.
Set Default Goal Selector "!".

(* ** BSM reduces to MM *)

Tactic Notation "rew" "length" := autorewrite with length_db.

Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).

Local Notation "I '/BSM/' s -1> t" := (bsm_sss I s t) (at level 70, no associativity).
Local Notation "P '/BSM/' s -+> t" := (sss_progress (@bsm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/BSM/' s ->> t" := (sss_compute (@bsm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/BSM/' s ~~> t" := (sss_output (@bsm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/BSM/' s ↓" := (sss_terminates (@bsm_sss _) P s)(at level 70, no associativity).

Local Notation "P '/MM/' s -+> t" := (sss_progress (@mm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/MM/' s ->> t" := (sss_compute (@mm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/MM/' s '~~>' t" := (sss_output (@mm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/MM/' s ↓" := (sss_terminates (@mm_sss _) P s)(at level 70, no associativity).

Section bsm_mm0_simulator.

  Ltac dest x y := destruct (pos_eq_dec x y) as [ | ]; [ subst x | ]; rew vec.

  Variables (m : nat).

  (** We consider BSM with m stacks and build a compiler to MM with 2+m registers.
      Each stack i : pos m is encoded in registers 2+i : pos (2+m) using stack_enc.
      The extra registers are tmp1 := pos0 and tmp2 := pos1. *)

  (* The registers of the MM *)

  Let n := 2+m.
  Let tmp1 :  pos n := pos0.
  Let tmp2 :  pos n := pos1.
  Let reg p : pos n := pos_nxt (pos_nxt p).

  Local Fact Hv12 : tmp1 <> tmp2.             Proof. discriminate. Qed.
  Local Fact Hvr1 : forall p, reg p <> tmp1.  Proof. discriminate. Qed.
  Local Fact Hvr2 : forall p, reg p <> tmp2.  Proof. discriminate. Qed.
  Local Fact Hreg : forall p q, reg p = reg q -> p = q.
  Proof. intros ? ? H; do 2 apply pos_nxt_inj; apply H. Qed.

  Hint Resolve Hv12 Hvr1 Hvr2 Hreg : core.

  (* The encoding of BSM states *)

  Definition bsm_state_enc (v : vec _ m) := 0##0##vec_map stack_enc v.

  Definition bsm_state_equiv (v : vec _ m) w :=
            w#>tmp1 = 0
         /\ w#>tmp2 = 0
         /\ forall p, w#>(reg p) = stack_enc (v#>p).

  Infix "⋈" := bsm_state_equiv (at level 70, no associativity).

  Fact bsm_state_enc_spec v : v ⋈ bsm_state_enc v.
  Proof.
    red; unfold tmp1, tmp2; repeat split; rew vec.
    intros p; unfold reg; simpl.
    rewrite vec_pos_map; trivial.
  Qed.

  (* The compiler from the generic one: we only need to
     explain how to simulate each individual instruction *)

  Section bsm_mm_compiler.

    Implicit Type ρ : bsm_instr m.

    Local Definition bsm_instr_compile lnk i ρ :=
      match ρ with
        | PUSH s Zero => mm_push_Zero (reg s) tmp1 tmp2 (lnk i)
        | PUSH s One  => mm_push_One  (reg s) tmp1 tmp2 (lnk i)
        | POP  s j k  => mm_pop (reg s) tmp1 tmp2 (lnk i) (lnk j) (lnk (1+i)) (lnk k)
      end.

    Local Definition bsm_instr_compile_length ρ :=
      match ρ with
        | PUSH _ Zero => 7
        | PUSH _ One  => 8
        | POP  _ _ _  => 16
      end.

    Local Fact bsm_instr_compile_length_eq lnk i ρ :
          length (bsm_instr_compile lnk i ρ) = bsm_instr_compile_length ρ.
    Proof. destruct ρ as [ | ? [] ]; simpl; auto. Qed.

    Hint Resolve bsm_instr_compile_length_eq : core.

    (* This main soundness lemma per simulated instruction *)

    Lemma bsm_instr_compile_sound :
        instruction_compiler_sound bsm_instr_compile
                                   (@bsm_sss _)
                                   (@mm_sss _)
                                   bsm_state_equiv.
    Proof.
      intros lnk ρ i1 v1 i2 v2 w1 H; revert H w1.
      change v1 with (snd (i1,v1)) at 2.
      change i1 with (fst (i1,v1)) at 2 3 4 6 7 8.
      change v2 with (snd (i2,v2)) at 2.
      change i2 with (fst (i2,v2)) at 2.
      generalize (i1,v1) (i2,v2); clear i1 v1 i2 v2.
      induction 1 as    [ i p j k v Hv
                        | i p j k v ll Hll
                        | i p j k v ll Hll
                        | i p [] v
                        ]; simpl; intros w1 H0 H; generalize H; intros (H1 & H2 & H3).

      + exists w1; split; auto.
        apply mm_pop_void_progress; auto using Hv12, Hvr1, Hvr2.
        rewrite H3, Hv; auto.

      + exists (w1[(stack_enc ll)/reg p]); repeat split; auto; rew vec.
        * apply mm_pop_Zero_progress; auto using Hv12, Hvr1, Hvr2.
          rewrite H3, Hll; auto.
        * intros q; dest p q.
          assert (reg p <> reg q); rew vec.

      + exists (w1[(stack_enc ll)/reg p]); repeat split; auto; rew vec.
        * apply mm_pop_One_progress; auto using Hv12, Hvr1, Hvr2.
          rewrite H3, Hll; auto.
        * intros q; dest p q.
          assert (reg p <> reg q); rew vec.

      + exists (w1[(stack_enc (One::v#>p))/reg p]); repeat split; auto; rew vec.
        1: rewrite H0; apply mm_push_One_progress; auto using Hv12, Hvr1, Hvr2.
        intros q; dest p q.
        assert (reg p <> reg q); rew vec.

      + exists (w1[(stack_enc (Zero::v#>p))/reg p]); repeat split; auto; rew vec.
        1: rewrite H0; apply mm_push_Zero_progress; auto using Hv12, Hvr1, Hvr2.
        intros q; dest p q.
        assert (reg p <> reg q); rew vec.
    Qed.

    Hint Resolve bsm_instr_compile_sound : core.

    Theorem bsm_mm_compiler : compiler_t (@bsm_sss _) (@mm_sss _) bsm_state_equiv.
    Proof.
      apply generic_compiler
        with (icomp := bsm_instr_compile)
             (ilen := bsm_instr_compile_length); auto.
      + apply bsm_sss_total'.
      + apply mm_sss_fun.
    Qed.

  End bsm_mm_compiler.

  (* Using the compiler, we can simulate any BSM with a MM *)

  Theorem bsm_mm_simulator i (P : list (@bsm_instr m)) :
         { Q : list (@mm_instr (pos n))
         | forall v w, v ⋈ w
         ->   (forall i' v', (i,P) /BSM/ (i,v) ~~> (i',v') -> exists w', (1,Q) /MM/ (1,w) ~~> (1+length Q,w') /\ v' ⋈ w')
           /\ ((1,Q) /MM/ (1,w) ↓  -> (i,P) /BSM/ (i,v) ↓)
         }.
  Proof.
    exists (gc_code bsm_mm_compiler (i,P) 1).
    intros v w Hw; split.
    + intros ? ?; now apply (compiler_t_output_sound' bsm_mm_compiler).
    + apply compiler_t_term_equiv; auto.
  Qed.

  (* We simulate a BSM (i,P) with a MM (1,Q) such that
        (i,P) terminates iff (1,Q) terminates iff (1,Q) terminates on zero *)

  Section bsm_mm0_sim.

    Variables (i : nat) (P : list (bsm_instr m)).

    Let Q := proj1_sig (bsm_mm_simulator i P).
    Let HQ := proj2_sig (bsm_mm_simulator i P).

    Definition bsm_mm0_sim := Q ++ mm_zeroify tmp1 (code_end (1,Q)).

    Notation R := bsm_mm0_sim.

    Theorem bsm_mm0_sim_spec v w :
           v ⋈ w
        -> ((i,P) /BSM/ (i,v) ↓ -> (1,R) /MM/ (1,w) ~~> (0,vec_zero))
        /\ ((1,R) /MM/ (1,w) ~~> (0,vec_zero) -> (1,R) /MM/ (1,w) ↓)
        /\ ((1,R) /MM/ (1,w) ↓ -> (i,P) /BSM/ (i,v) ↓).
    Proof.
      intros Hw; split; [ | split ].
      + intros ((i',v') & H).
        apply (HQ Hw) in H as (w' & (H1 & H2) & H3); fold Q in H1, H2; unfold fst in H2.
        unfold bsm_mm0_sim; split; [ | simpl; lia ].
        apply subcode_sss_compute_trans with (2 := H1); auto.
        unfold code_end, fst, snd.
        assert (w'#>tmp1 = 0) by apply H3.
        apply sss_progress_compute, subcode_sss_progress with (2 := mm_zeroify_spec _ _ _ H); auto.
      + exists (0,vec_zero); auto.
      + intros H2; apply HQ with (1 := Hw).
        revert H2; apply subcode_sss_terminates.
        unfold R, Q; auto.
    Qed.

    Corollary bsm_mm0_terminates v w :
        v ⋈ w -> (i,P) /BSM/ (i,v) ↓ <-> (1,R) /MM/ (1,w) ↓.
    Proof. intros Hw; split; intro; repeat (apply bsm_mm0_sim_spec with (1 := Hw); auto). Qed.

    Corollary bsm_mm0_terminates_on_zero v w :
        v ⋈ w -> (i,P) /BSM/ (i,v) ↓ <-> (1,R) /MM/ (1,w) ~~> (0,vec_zero).
    Proof. intros Hw; split; intro; repeat (apply bsm_mm0_sim_spec with (1 := Hw); auto). Qed.

    End bsm_mm0_sim.

End bsm_mm0_simulator.

#[local] Hint Resolve bsm_state_enc_spec : core.

(* Both compilers below produce the same code *)

Theorem bsm_mm_compiler_1 n i (P : list (bsm_instr n)) :
  { Q : list (mm_instr (pos (2+n))) | forall v, (i,P) /BSM/ (i,v) ↓ <-> (1,Q) /MM/ (1,bsm_state_enc v) ↓ }.
Proof. exists (bsm_mm0_sim i P); intro; apply bsm_mm0_terminates; auto. Qed.

Theorem bsm_mm_compiler_2 n i (P : list (bsm_instr n)) :
  { Q : list (mm_instr (pos (2+n))) | forall v, (i,P) /BSM/ (i,v) ↓ <-> (1,Q) /MM/ (1,bsm_state_enc v) ~~> (0,vec_zero) }.
Proof. exists (bsm_mm0_sim i P); intro; apply bsm_mm0_terminates_on_zero; auto. Qed.


(* Some arguments about lists and random values. *)

Require Import FCF.
Require Import FCF.CompFold.
Require Import FCF.RndInList.

Set Implicit Arguments.
Local Open Scope list_scope.

Section RndListIn.

  Variable A : Set.
  Hypothesis eqda : EqDec A.
  Variable c : Comp A.
  Variable a : A.

  Definition RndListIn_G (B : Type)(ls : list B) :=
    x <-$ compMap _ (fun _ => c) ls;
    ret (if (in_dec (EqDec_dec _) a x) then true else false).

  Theorem RndListIn_Prob : forall (B : Type)(ls : list B),
    Pr[RndListIn_G ls] <= (length ls)/1 * (evalDist c a).

    Local Opaque evalDist.

    unfold RndListIn_G in *.
    induction ls; intuition idtac; simpl in *.
    comp_simp.
    match goal with
    | [|- context[if ?a then _ else _] ] =>
      destruct a
    end.
    simpl in *.
    intuition idtac.
    rewrite evalDist_ret_0.
    rattac.
    intuition idtac; discriminate.

    simpl.
    inline_first.
    eapply leRat_trans.
    eapply (evalDist_bind_event_le _ _ (fun z => eqb a z)).
    reflexivity.
    intuition idtac.

    assert (Pr
   [x <-$
    (lsb' <-$ compMap _ (fun _ => c) ls;
     ret (a1 :: lsb')%list);
    ret (if in_dec (EqDec_dec _) a x then true else false)
   ] ==
            Pr
   [x <-$ compMap _ (fun _ => c) ls;
    ret (if in_dec (EqDec_dec _) a x then true else false)
   ]).

    inline_first.
    comp_skip.

    match goal with
    | [|- context[if ?a then _ else _] ] =>
      destruct a
    end.
    simpl in *.
    intuition idtac; subst.
    rewrite eqb_refl in *.
    discriminate.
    match goal with
    | [|- context[if ?a then _ else _] ] =>
      destruct a
    end.
    reflexivity.
    intuition idtac.
    simpl in *.
    intuition idtac.
    match goal with
    | [|- context[if ?a then _ else _] ] =>
      destruct a
    end.
    intuition idtac.
    reflexivity.

    rewrite H1.
    rewrite IHls.
    reflexivity.

    rewrite <- evalDist_event_equiv.

    eapply leRat_trans.
    2:{
      eapply eqRat_impl_leRat.
      symmetry.
      replace (S (length ls)) with (1 + (length ls))%nat.
      rewrite ratAdd_num.
      rewrite ratMult_distrib_r.
      reflexivity.
      trivial.
    }
    eapply eqRat_impl_leRat.
    rewrite ratMult_1_l.
    reflexivity.

    Local Transparent evalDist.

  Qed.

End RndListIn.

Section RndListPred.

  Variable A : Set.
  Hypothesis eqda : EqDec A.
  Variable c : Comp A.
  Variable f : A -> bool.

  Definition RndListPred_G (B : Type)(ls : list B) :=
    x <-$ compMap _ (fun _ => c) ls;
    ret (any_dec f x).

  Theorem RndListPred_Prob : forall (B : Type)(ls : list B),
    Pr[RndListPred_G ls] <= (length ls)/1 * Pr[x <-$c; ret (f x)].

    Local Opaque evalDist.

    unfold RndListPred_G in *.
    induction ls; intuition idtac; simpl in *.
    comp_simp.
    unfold any_dec.
    simpl.
    rewrite evalDist_ret_0.
    eapply rat0_le_all.
    intuition idtac.
    discriminate.

    inline_first.
    eapply leRat_trans.
    eapply (evalDist_bind_event_le _ _ f).
    reflexivity.
    intuition idtac.

    assert (Pr
   [x <-$
    (lsb' <-$ compMap _ (fun _ => c) ls;
     ret (a0 :: lsb')%list);
      ret any_dec f x
   ] ==
            Pr
   [x <-$ compMap _ (fun _ => c) ls;
    ret any_dec f x
   ]).

    inline_first.
    comp_skip.

    rewrite any_dec_cons.
    eapply evalDist_ret_eq.
    rewrite H0.
    trivial.
    rewrite H1.
    eauto.

    eapply leRat_trans.
    2:{
      eapply eqRat_impl_leRat.
      symmetry.
      replace (S (length ls)) with (1 + (length ls))%nat.
      rewrite ratAdd_num.
      rewrite ratMult_distrib_r.
      reflexivity.
      trivial.
    }
    eapply eqRat_impl_leRat.
    rewrite ratMult_1_l.
    reflexivity.

    Local Transparent evalDist.

  Qed.

End RndListPred.

Section RndInList.

  Variable A : Set.
  Hypothesis eqda : EqDec A.
  Variable c : Comp A.
  Hypothesis c_wf : well_formed_comp c.
  Variable r : Rat.
  Hypothesis collProb : forall x,
    evalDist c x <= r.

  Definition RndInList_G (a : list A) :=
    x <-$ c;
    ret (if (in_dec (EqDec_dec _) x a) then true else false).

  Theorem RndInList_Prob : forall (a : list A),
    Pr[RndInList_G a] <= (length a)/1 * r.

    Local Opaque evalDist.

    unfold RndInList_G in *.
    induction a; intuition idtac; simpl in *.
    fcf_irr_l.
    rewrite evalDist_ret_0.
    eapply rat0_le_all.
    intuition idtac.
    discriminate.

    eapply leRat_trans.
    eapply (evalDist_bind_event_le _ _ (fun x => eqb a x || if (in_dec (EqDec_dec _) x a0) then true else false)).
    rewrite evalDist_orb_le.
    rewrite <- evalDist_event_equiv.
    rewrite IHa.
    rewrite collProb.
    reflexivity.
    intros.

    apply orb_false_elim in H0.
    intuition idtac.
    destruct (EqDec_dec eqda a a1).
    subst.
    rewrite eqb_refl in *.
    discriminate.
    destruct (in_dec (EqDec_dec eqda) a1 a0).
    discriminate.
    rewrite evalDist_ret_0.
    eapply rat0_le_all.
    intuition idtac.
    discriminate.
    rewrite <- ratAdd_0_r.
    rewrite ratMult_comm.
    rewrite ratMult_ratAdd_cd.
    simpl.
    rewrite ratMult_comm.
    reflexivity.
  Qed.

End RndInList.

Section DupList.

  Variable A : Set.
  Hypothesis eqda : EqDec A.
  Variable c : Comp A.
  Hypothesis c_wf : well_formed_comp c.
  Variable r : Rat.

  Hypothesis collProb :
    forall a, evalDist c a <= r.

  Definition DupList_G (B : Type)(ls : list B) :=
    x <-$ compMap _ (fun _ => c) ls;
    ret (hasDup _ x).

  Theorem DupList_Prob : forall (B : Type)(ls : list B),
    Pr[DupList_G ls] <= ((length ls) * (length ls))/1 * r.

    Local Opaque evalDist.

    unfold DupList_G in *.
    induction ls; intuition idtac; simpl in *.
    comp_simp.
    simpl.
    rewrite evalDist_ret_0.
    eapply rat0_le_all.
    intuition idtac.
    discriminate.

    assert (Pr [x <-$
    (b <-$ c;
     lsb' <-$ compMap eqda (fun _ : B => c) ls;
     ret b :: lsb'); ret hasDup eqda x ]
      ==
    Pr [lsb' <-$ compMap eqda (fun _ : B => c) ls;
    a0 <-$ c;
    ret hasDup eqda (a0 :: lsb')]
    ).
    fcf_swap rightc.
    fcf_inline_first.
    fcf_skip.
    fcf_inline_first.
    fcf_skip.

    rewrite H.
    clear H.

    eapply leRat_trans.
    eapply (evalDist_bind_event_le _ _ (fun z => hasDup _ z )).
    eauto.
    intros.
    eapply (evalDist_bind_event_le _ _ (fun z => if (in_dec (EqDec_dec _) z a0) then true else false )).
    specialize (@RndInList_Prob _ _ c c_wf r collProb a0); intros.
    unfold RndInList_G in *.
    rewrite H1.
    apply compMap_length in H.
    rewrite H.
    reflexivity.
    intros.
    simpl.
    destruct (in_dec (EqDec_dec eqda) a1 a0).
    discriminate.
    rewrite H0.
    rewrite evalDist_ret_0.
    reflexivity.
    intuition idtac.
    discriminate.

    rewrite <- ratAdd_0_r.
    eapply leRat_trans.
    2:{
    eapply ratMult_leRat_compat.
    eapply leRat_terms.
    eapply Nat.le_succ_diag_r.
    reflexivity.
    reflexivity.
    }
    eapply leRat_trans.
    2:{
    eapply eqRat_impl_leRat.
    symmetry.
    rewrite ratAdd_den_same.
    rewrite ratMult_distrib_r.
    reflexivity.
    }
    rewrite ratAdd_comm.
    eapply ratAdd_leRat_compat.
    reflexivity.
    eapply ratMult_leRat_compat.
    eapply leRat_terms.
    eapply mult_le_compat.
    trivial.
    lia.
    trivial.
    reflexivity.

    Local Transparent evalDist.
  Qed.

End DupList.


(*** ******************************* ***)
(*** LINEAR LOGIC - BASIC DEFINITONS ***)
(*** ******************************* ***)

(* James Power * James.Power@May.ie * http://www.cs.may.ie/~jpower/ *)
(* Dept. of Computer Science, NUI Maynooth, Co. Kildare, Ireland.   *)

(**********************************)
(***** The Linear Connectives *****)
(**********************************)
Inductive ILinProp :=
| Implies : (ILinProp) -> (ILinProp) -> ILinProp
| OfCourse : (ILinProp) -> ILinProp
| One : ILinProp
| Plus : (ILinProp) -> (ILinProp) -> ILinProp
| Times : (ILinProp) -> (ILinProp) -> ILinProp
| Top : ILinProp
| With : (ILinProp) -> (ILinProp) -> ILinProp
| Zero : ILinProp
| Exists (A:Set): (A->ILinProp) -> ILinProp
.

Notation "! c" := (OfCourse c) (at level 2).
Infix "***" := Times (at level 6, right associativity).
Infix "&&&" := With (at level 6, right associativity).
Infix "+++" := Plus (at level 7).
Infix "--o" := Implies (at level 8).

(*******************************************)
(***** The Linear Consequence Operator *****)
(*****               and               *****)
(*****    Natural Deduction Rules      *****)
(*******************************************)

From Coq Require Export List.
Export ListNotations.
Notation Empty := (@nil _).

Reserved Notation "c1 |- c2" (at level 65).

Inductive LinCons : (list ILinProp) -> ILinProp -> Prop :=
(* Structural Rules *)
 Identity (A:ILinProp):
  ([A] |- A)
| Exchange (A B C : ILinProp)(D1 D2 : list ILinProp):
  ((D1 ++ [A] ++ [B] ++ D2 |- C) -> (D1 ++ [B] ++ [A] ++ D2 |- C))
| Cut (A C : ILinProp)(D1 D2 : list ILinProp):
  ((D1 |- A) -> (D2 ++ [A] |- C) -> (D2 ++ D1 |- C))

(* Multiplicative Conjunction *)
| TimesRight (A B : ILinProp)(D1 D2 : list ILinProp):
  ((D1 |- A) -> (D2 |- B) -> (D1 ++ D2 |- A *** B))
| TimesLeft (A B C : ILinProp)(D : list ILinProp):
  ((D ++ [A] ++ [B] |- C) -> (D ++ [A***B] |- C))
| OneRight :
  (Empty |- One)
| OneLeft (C : ILinProp)(D : list ILinProp):
  ((D |- C) -> (D ++ [One] |- C))
(* (Multiplicative) Implication *)
| ImpliesRight (A B : ILinProp)(D : list ILinProp):
  ((D ++ [A] |- B) -> (D |- A --o B))
| ImpliesLeft (A B C : ILinProp)(D1 D2 : list ILinProp):
  ((D1 |- A) -> (D2 ++ [B] |- C) -> (D1 ++ D2 ++ [A --o B]  |- C))

(* Additive Conjunction *)
| WithRight (A B : ILinProp)(D : list ILinProp):
  ((D |- A) -> (D |- B) -> (D |- (A&&&B)))
| WithLeft1 (A B C : ILinProp)(D : list ILinProp):
  ((D ++ [A] |- C) -> (D ++ [A&&&B] |- C))
| WithLeft2 (A B C : ILinProp)(D : list ILinProp):
  ((D ++ [B] |- C) -> (D ++ [A&&&B] |- C))
| TopRight (D : list ILinProp):
  (D |- Top)
(* Additive Disjunction *)
| PlusRight1 (A B : ILinProp)(D : list ILinProp):
  ((D |- A) -> (D |- (A+++B)))
| PlusRight2 (A B : ILinProp)(D : list ILinProp):
  ((D |- B) -> (D |- (A+++B)))
| PlusLeft (A B C : ILinProp)(D : list ILinProp):
  ((D ++ [A] |- C)  -> (D ++ [B] |- C) -> (D ++ [A+++B] |- C))
| ZeroLeft (C : ILinProp)(D : list ILinProp):
  (D ++ [Zero] |- C)

(* Modalities *)
| Weakening (A C : ILinProp)(D : list ILinProp):
  ((D |- C) -> (D ++ [!A] |- C))
| Contraction (A C : ILinProp)(D : list ILinProp):
  ((D ++ [!A] ++ [!A] |- C) -> (D ++ [!A] |- C))
| Dereliction (A C : ILinProp)(D : list ILinProp):
  ((D ++ [A] |- C) -> (D ++ [!A] |- C))
| Promotion (A C : ILinProp)(D : list ILinProp):
  (([!A] |- C) -> ([!A] |- !C))

where "c1 |- c2" := (LinCons c1 c2).


Require Import LanguageUtil.

Import AtomSetProperties.

Lemma notin_subset : forall x s1 s2,
    s1 [<=] s2 -> x `notin` s2 -> x `notin` s1.
Proof.
  intros. intro.
  assert (x `in` s2) by (eapply in_subset; eauto).
  contradiction.
Qed.

Hint Resolve notin_subset : core.

Lemma dom_insert_subset : forall Γ2 Γ1 a (A : expr),
    union (dom Γ2) (dom Γ1) [<=] dom (Γ1 , a : A ,, Γ2).
Proof.
  induction Γ2; simpl; intros.
  - apply subset_add_2. intro. intros.
    now apply empty_union_1 in H.
  - destruct a. intro. intros.
    apply union_add in H.
    assert (add a (union (dom Γ2) (dom Γ1)) [<=] add a (dom (Γ1 , a0 : A ,, Γ2))).
    + apply subset_add_3. auto.
      apply subset_add_2. apply IHΓ2.
    + now apply H0.
Qed.

Lemma fv_subst_inclusion : forall e x v,
    fv_eexpr ([v ⋆/ x] e) [<=] fv_eexpr v `union` fv_eexpr e.
Proof.
  induction e; simpl; intros;
    try solve
        [ auto
        | apply subset_empty
        | destruct (x == x0); simpl;
          solve [apply union_subset_1 | apply union_subset_2]
        ]; (* solves most of the easy cases *)
    (* and here goes the magic *)
    apply union_subset_3; eapply subset_trans; eauto;
      solve
        [ eapply subset_trans;
          [> apply union_subset_1
          |  apply subset_equal; apply union_assoc
          ]
        | eapply subset_trans;
          [> apply union_subset_1
          |  apply subset_equal; eapply equal_trans;
             [> apply union_assoc
             | apply union_equal_2; apply union_sym
             ]
          ]
        ].
Qed.