(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Export Disjoint_Union.
Require Export Inclusion.
Require Export Inverse_Image.
Require Export Lexicographic_Exponentiation.
Require Export Lexicographic_Product.
Require Export Transitive_Closure.
Require Export Union.
Require Export Well_Ordering.


Require Import UniMath.Foundations.PartA.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Functors.
Require Import UniMath.CategoryTheory.EnrichedCats.Enriched.Enriched.

Local Open Scope cat.
Local Open Scope moncat.
Import MonoidalNotations.

Section Change_Of_Base.

Context {Mon_V Mon_V' : monoidal_cat} (F : lax_monoidal_functor Mon_V Mon_V').

Definition change_of_base_enriched_precat_data (A : enriched_precat Mon_V) : enriched_precat_data Mon_V'.
Proof.
  use make_enriched_precat_data.
  - exact A.
  - intros x y.
    exact (F (enriched_cat_mor x y)).
  - intro x.
    exact (mon_functor_unit F · #F (enriched_cat_identity _)).
  - intros x y z.
    exact (mon_functor_tensor F _ _ · #F (enriched_cat_comp _ y _)).
Defined.

Definition change_of_base_enriched_id_ax (A : enriched_precat Mon_V) : enriched_id_ax (change_of_base_enriched_precat_data A).
Proof.
  intros a b.
  split; cbn.
  - rewrite <- (functor_id F).
    rewrite <- (id_left (#F (identity _))).
    rewrite tensor_comp_mor.
    rewrite assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      rewrite tensor_mon_functor_tensor.
      apply idpath.
    }
    rewrite !assoc'.
    rewrite <- (functor_comp F).
    etrans.
    {
      do 3 apply maponpaths.
      apply enriched_id_left.
    }
    rewrite !assoc.
    exact (!(mon_functor_lunitor F _)).
  - rewrite <- (functor_id F).
    rewrite <- (id_left (#F (identity _))).
    rewrite tensor_comp_mor.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      rewrite tensor_mon_functor_tensor.
      apply idpath.
    }
    rewrite !assoc'.
    rewrite <- (functor_comp F).
    etrans.
    {
      do 3 apply maponpaths.
      apply enriched_id_right.
    }
    rewrite !assoc.
    exact (!(mon_functor_runitor F _)).
Qed.

Definition change_of_base_enriched_assoc_ax (A : enriched_precat Mon_V) : enriched_assoc_ax (change_of_base_enriched_precat_data A).
Proof.
  intros a b c d.
  simpl in a, b, c, d.
  cbn.
  rewrite <- (functor_id F).
  rewrite <- (id_left (#F (identity _))).
  rewrite tensor_comp_mor.
  rewrite !assoc'.
  etrans.
  {
    apply maponpaths.
    rewrite !assoc.
    rewrite tensor_mon_functor_tensor.
    rewrite !assoc'.
    rewrite <- functor_comp.
    rewrite enriched_assoc.
    rewrite !functor_comp.
    apply idpath.
  }
  rewrite !assoc.
  apply cancel_postcomposition.
  rewrite mon_functor_lassociator.
  rewrite !assoc'.
  apply maponpaths.
  rewrite tensor_comp_id_l.
  rewrite !assoc'.
  apply maponpaths.
  rewrite <- tensor_mon_functor_tensor.
  rewrite functor_id.
  apply idpath.
Qed.

Definition change_of_base_enriched_precat (A : enriched_precat Mon_V) : enriched_precat Mon_V'.
Proof.
  use make_enriched_precat.
  - exact (change_of_base_enriched_precat_data A).
  - exact (change_of_base_enriched_id_ax A).
  - exact (change_of_base_enriched_assoc_ax A).
Defined.

Definition change_of_base_enriched_functor_data {A B : enriched_precat Mon_V} (G : enriched_functor A B) : enriched_functor_data (change_of_base_enriched_precat A) (change_of_base_enriched_precat B).
Proof.
  use make_enriched_functor_data.
  + exact G.
  + intros x y.
    exact (#F (enriched_functor_on_morphisms G _ _)).
Defined.

Definition change_of_base_enriched_functor_unit_ax {A B : enriched_precat Mon_V} (G : enriched_functor A B) : enriched_functor_unit_ax (change_of_base_enriched_functor_data G).
Proof.
  intro a.
  cbn.
  rewrite assoc'.
  apply cancel_precomposition.
  rewrite <- (functor_comp F).
  apply maponpaths.
  apply enriched_functor_on_identity.
Qed.

Definition change_of_base_enriched_functor_comp_ax {A B : enriched_precat Mon_V} (G : enriched_functor A B) : enriched_functor_comp_ax (change_of_base_enriched_functor_data G).
Proof.
  intros a b c.
  cbn.
  rewrite assoc.
  rewrite tensor_mon_functor_tensor.
  rewrite !assoc'.
  apply cancel_precomposition.
  cbn.
  rewrite <- !(functor_comp F).
  apply maponpaths.
  apply enriched_functor_on_comp.
Qed.

Definition change_of_base_enriched_functor {A B : enriched_precat Mon_V} (G : enriched_functor A B) : enriched_functor (change_of_base_enriched_precat A) (change_of_base_enriched_precat B).
Proof.
  use make_enriched_functor.
  - exact (change_of_base_enriched_functor_data G).
  - exact (change_of_base_enriched_functor_unit_ax G).
  - exact (change_of_base_enriched_functor_comp_ax G).
Defined.

Lemma lax_monoidal_functor_on_postcompose_underlying_morphism {A : enriched_precat Mon_V} (x : A) {y z : A} (f : underlying_morphism y z) : # F (postcompose_underlying_morphism x f) = @postcompose_underlying_morphism _ (change_of_base_enriched_precat _) _ _ _ (mon_functor_unit F · # F f).
Proof.
  unfold postcompose_underlying_morphism.
  do 2 rewrite (functor_comp F).
  cbn.
  rewrite assoc.
  apply cancel_postcomposition.
  rewrite <- (functor_id F).
  rewrite <- (id_left (#F (identity _))).
  rewrite tensor_comp_mor.
  rewrite assoc, assoc'.
  rewrite tensor_mon_functor_tensor.
  rewrite assoc.
  apply cancel_postcomposition.
  change (# F (is_z_isomorphism_mor ?f)) with (is_z_isomorphism_mor (functor_on_is_z_isomorphism F f)).
  change (is_z_isomorphism_mor ?x) with (inv_from_z_iso (_,,x)).
  apply pathsinv0.
  rewrite mon_functor_linvunitor.
  apply idpath.
Qed.

Lemma lax_monoidal_functor_on_precompose_underlying_morphism {A : enriched_precat Mon_V} {x y : A} (z : A) (f : underlying_morphism x y) : # F (precompose_underlying_morphism z f) = @precompose_underlying_morphism _ (change_of_base_enriched_precat _) _ _ _ (mon_functor_unit F · # F f).
Proof.
  unfold precompose_underlying_morphism.
  do 2 rewrite (functor_comp F).
  cbn.
  rewrite assoc.
  apply cancel_postcomposition.
  rewrite <- (functor_id F).
  rewrite <- (id_left (#F (identity _))).
  rewrite tensor_comp_mor.
  rewrite assoc, assoc'.
  apply (transportb (λ g, _ = _ · g) (tensor_mon_functor_tensor F _ _)).
  rewrite assoc.
  apply cancel_postcomposition.
  change (# F (is_z_isomorphism_mor ?f)) with (is_z_isomorphism_mor (functor_on_is_z_isomorphism F f)).
  change (is_z_isomorphism_mor ?x) with (inv_from_z_iso (_,,x)).
  apply pathsinv0.
  rewrite mon_functor_rinvunitor.
  apply idpath.
Qed.

Definition change_of_base_enriched_nat_trans {A B : enriched_precat Mon_V} {G H : enriched_functor A B} (a : enriched_nat_trans G H) : enriched_nat_trans (change_of_base_enriched_functor G) (change_of_base_enriched_functor H).
Proof.
  use make_enriched_nat_trans.
  - intro x.
    exact (mon_functor_unit F · #F (a x)).
  - abstract (intros x y;
    cbn;
    rewrite <- lax_monoidal_functor_on_postcompose_underlying_morphism;
    rewrite <- lax_monoidal_functor_on_precompose_underlying_morphism;
    rewrite <- !(functor_comp F);
    apply maponpaths;
    apply enriched_nat_trans_ax).
Defined.

End Change_Of_Base.


(*|
##############################
Change a function at one point
##############################

:Link: https://stackoverflow.com/q/27106530
|*)

(*|
Question
********

I have two elements ``f : X -> bool`` and ``x : X``.

How to define ``g : X -> bool`` such ``g x = true`` and ``g y = f y``
for ``y != x``.
|*)

(*|
Answer (Vinz)
*************

Following your answer to my comment, I don't think you can define a
"function" ``g``, because you need a constructive way do distinguish
``x`` from other instances of type ``X``. However you could define a
relation between the two, which could be transformed into a function
if you get decidability. Something like:
|*)

Parameter X : Type.
Parameter f : X -> bool.
Parameter x : X.

Inductive gRel : X -> bool -> Prop :=
| is_x : gRel x true
| is_not_x : forall y : X, y <> x -> gRel y (f y).

Definition gdec (h : forall a b : X, {a = b} + {a <> b}) : X -> bool :=
  fun a => if h a x then true else f a.

Lemma gRel_is_a_fun: (forall a b : X, {a = b} + {a <> b}) ->
                     exists g : X -> bool, forall a, gRel a (g a).
Proof.
  intro hdec. exists (gdec hdec).
  unfold gdec. intro a. destruct (hdec a x).
  - now subst; apply is_x.
  - now apply is_not_x.
Qed.

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

Just complementing Vinz's answer, there's no way of defining such a
function for arbitrary ``X``, because it implies that ``X`` has
"almost decidable" equality:
|*)

Section Dec.

  Variable X : Type.

  Variable override : (X -> bool) -> X -> X -> bool.

  Hypothesis Hoverride_eq : forall f x, override f x x = true.
  Hypothesis Hoverride_neq : forall f x x', x <> x' -> override f x x' = f x'.

  Lemma xeq_dec' (x x' : X) : {~ x <> x'} + {x <> x'}.
  Proof using override Hoverride_eq Hoverride_neq.
    destruct (override (fun _ => false) x x') eqn:E.
    - left. intros contra.
      assert (H := Hoverride_neq (fun _ => false) _ _ contra).
      simpl in H. congruence.
    - right. intros contra. subst x'.
      rewrite Hoverride_eq in E. discriminate.
  Qed.

End Dec.

(*|
This lemma says that if there's a way of doing what you asked for for
X, then one can test whether two elements ``x`` and ``x'`` of ``X``
are equal, except that the proof of equality that one gets in the
``true`` case is actually a proof of the double negation of ``x =
x'``.
|*)


Set Implicit Arguments.
Set Maximal Implicit Insertion.
Set Contextual Implicit.

Require Import GHC.Base.

Require Import Fix.Fix.
Require Import Fix.SumE.

From Coq Require Import
  Relation_Definitions
  RelationClasses
  FinFun
.

(** * Theories for ⊕ *)

Definition commMapping {F G : (Set -> Set) -> Set -> Set}
  {E : Set -> Set} {R : Set} (a : (F ⊕ G) E R) : (G ⊕ F) E R :=
  match a with
  | Inl1 f => Inr1 f
  | Inr1 g => Inl1 g
  end.

Lemma Bijective__commMapping :
  forall {F G : (Set -> Set) -> Set -> Set} {E : Set -> Set} {R : Set},
    Bijective (@commMapping F G E R).
Proof.
  intros. exists commMapping. split.
  - destruct x; cbn; reflexivity.
  - destruct y; cbn; reflexivity.
Qed.

Definition assocMapping {F G H : (Set -> Set) -> Set -> Set}
  {E : Set -> Set} {R : Set} (a : ((F ⊕ G) ⊕ H) E R) : (F ⊕ (G ⊕ H)) E R :=
  match a with
  | Inl1 (Inl1 f) => Inl1 f
  | Inl1 (Inr1 g) => Inr1 (Inl1 g)
  | Inr1 h => Inr1 (Inr1 h)
  end.

Lemma Bijective__assocMapping :
  forall {F G H : (Set -> Set) -> Set -> Set} {E : Set -> Set} {R : Set},
    Bijective (@assocMapping F G H E R).
Proof.
  intros.
  exists (fun a => match a with
           | Inl1 f => Inl1 (Inl1 f)
           | Inr1 (Inl1 g) => Inl1 (Inr1 g)
           | Inr1 (Inr1 h) => Inr1 h
           end).
  split.
  - destruct x as [[f | g] | h]; cbn; reflexivity.
  - destruct y as [f | [g | h]]; cbn; reflexivity.
Qed.

Definition equiv1 (F G : (Set -> Set) -> Set -> Set) :=
  forall (E : Set -> Set) (R : Set),
  exists (f : F E R -> G E R), Bijective f.

Instance Equivalence__equiv1 : Equivalence equiv1.
Proof.
  constructor.
  - intros x E R. exists id. exists id.
    split; reflexivity.
  - intros x y Hxy E R.
    specialize (Hxy E R). destruct Hxy as (f & g & Hf & Hg).
    exists g. exists f. tauto.
  - intros x y z Hxy Hyz E R.
    specialize (Hxy E R). specialize (Hyz E R).
    destruct Hxy as (f & g & Hf & Hg).
    destruct Hyz as (h & i & Hh & Hi).
    exists (h ∘ f). exists (g ∘ i). split; unfold "∘"; intros a.
    + rewrite Hh. apply Hf.
    + rewrite Hg. apply Hi.
Qed.

Notation "x ≈ y" := (equiv1 x y) (at level 43, right associativity).

Theorem comm__Sum1 : forall (F G : (Set -> Set) -> Set -> Set),
    F ⊕ G ≈ G ⊕ F.
Proof.
  intros F G E R. eapply ex_intro. apply Bijective__commMapping.
Qed.

Theorem assoc__Sum1 : forall (F G H : (Set -> Set) -> Set -> Set),
    (F ⊕ G) ⊕ H ≈ F ⊕ (G ⊕ H).
Proof.
  intros F G H E R. eapply ex_intro. apply Bijective__assocMapping.
Qed.

(** * Theories for ⊎ *)

Definition equivRel {F : Set -> Set}
  (P Q : (forall (A : Set), relation (F A)) -> forall (A : Set), relation (F A)) :=
  forall (K : forall (A : Set), relation (F A)) (A : Set) (a b : F A),
    P K _ a b <-> Q K _ a b.

Instance Equivalence__equivRel {F : Set -> Set} : Equivalence (@equivRel F).
Proof.
  constructor.
  - intros P K A a b. reflexivity.
  - intros P Q HPQ K A a b. symmetry. apply HPQ.
  - intros P Q R HPQ HQR K A a b. etransitivity.
    + apply HPQ.
    + apply HQR.
Qed.

Notation "P ⇔ Q" := (equivRel P Q) (at level 43, right associativity).

Theorem comm__SumRel {F : Set -> Set} :
  forall (P Q : (forall (A : Set), relation (F A)) -> forall (A : Set), relation (F A)),
    P ⊎ Q ⇔ Q ⊎ P.
Proof.
  intros P Q K A a b. split; destruct 1; (left + right); assumption.
Qed.

Theorem assoc__SumRel {F : Set -> Set} :
  forall (P Q R : (forall (A : Set), relation (F A)) -> forall (A : Set), relation (F A)),
    (P ⊎ Q) ⊎ R ⇔ P ⊎ (Q ⊎ R).
Proof.
  intros P Q R K A a b. split; intros.
  all: repeat match goal with
       | H : context[?P ⊎ ?Q] |- _ =>
           destruct H
         end.
  all: (left + right); (assumption + left + right); assumption.
Qed.

Theorem idem__SumRel {F : Set -> Set} :
  forall (P : (forall (A : Set), relation (F A)) -> forall (A : Set), relation (F A)),
    P ⇔ P ⊎ P.
Proof.
  intros P K A a b. split.
  - left. assumption.
  - destruct 1; assumption.
Qed.


Require Import
        Fiat.BinEncoders.Env.Common.Specs.

Notation "[ n ]" := (exist _ n _) : binencoders.

Lemma sig_equivalence :
  forall (A : Type) (P : A -> Prop) (n m : A) (n_pf : P n) (m_pf : P m),
    n = m <-> exist P n n_pf = exist P m m_pf.
Proof.
  intros A P n m n_pf m_pf. split.
  intro nm_pf. subst.
  pose proof (proof_irrelevance _ n_pf m_pf).
  subst. reflexivity.
  inversion 1. eauto.
Qed.


Require Export Iron.SimplePCFa.Value.Exp.
Require Export Iron.SimplePCFa.Value.Lift.

(* Lowering of references into the environment *)
Fixpoint lowerXV (d: nat) (vv: val) : val :=
  match vv with
  | VVar    O    => vv
  | VVar (S i)   => if le_gt_dec d (S i) then VVar i else vv
  | VConst c     => VConst c
  | VLam t x     => VLam t (lowerXX (S d) x)
  | VFix t v     => VFix t (lowerXV (S d) v)
  end

with    lowerXX (d: nat) (xx: exp) : exp :=
  match xx with
  | XVal v       => XVal   (lowerXV d v)
  | XLet t x1 x2 => XLet t (lowerXX d x1) (lowerXX (S d) x2)
  | XApp v1 v2   => XApp   (lowerXV d v1) (lowerXV d v2)
  | XOp1 o v     => XOp1 o (lowerXV d v)
  | XIf v1 x2 x3 => XIf    (lowerXV d v1) (lowerXX d x2) (lowerXX d x3)
  end.

Lemma lowerXX_liftXX_id
 : forall d x
 , lowerXX d (liftXX d x) = x.
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PV := fun v => forall d, lowerXV d (liftXV d v) = v);
  intros; simpl;
   try (solve [repeat (snorm; rewritess); auto]).

  SCase "VVar".
   snorm.
    omega.
    destruct n; auto.
     snorm. omega.
Qed.