Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.Morphisms.
Require Import NatTrans.NatTrans
        NatTrans.Operations
        NatTrans.Func_Cat
        NatTrans.Morphisms
        NatTrans.NatIso.
Require Import Basic_Cons.Terminal.
Require Import PreSheaf.PreSheaf PreSheaf.Terminal.
Require Import Archetypal.Discr.Discr.

(** In this section we show that all components of a monic
morphism of presheaves are monic.

We do this by showing that given a monic morphism of presheaves
N : F ≫–> G we can convert any function from f : A → (F c) to
a morphism of presheaves (PSh(f) : Psh(A) –≻ F) such that this
morphism at c gives exactly f.
*)
Section PreSheaf_Monic_components_Monic.
  Context
    {C : Category}
    {F : PreSheaf C}
  .

  Section PMCM_PreSheaf_representing_d.
    Context (c : C) (d : Type).

    Local Hint Extern 1 => progress cbn.

    Program Definition PMCM_PreSheaf_representing_d : PreSheaf C
      :=
        {|
          FO := fun c' => ((Hom C c' c) * d)%type;
          FA := fun o o' u x => (compose C u (fst x), snd x)
        |}
    .

  End PMCM_PreSheaf_representing_d.

  Context
    {G : PreSheaf C}
    (N : @Monic (PShCat C) F G)
    (c : C)
  .

  Section PreSheaf_Monic_components_Monic_is_Monic.
    Context
      (d : Type)
      (g h : d → (F _o)%object c)
      (H : (fun x => Trans (mono_morphism N) c (g x))
           = (fun x => Trans (mono_morphism N) c (h x)))
    .

(*    Local Hint Extern 1 => progress cbn.*)

    Local Hint Extern 1 =>
    match goal with
      [|- context [(F _a)%morphism (?A ∘ ?B)%morphism] ] =>
      cbn_rewrite (F_compose F A B)
    end.

    Program Definition PMCM_PreSheaf_morph_of_function
            (f : d → (F _o)%object c)
      : (PMCM_PreSheaf_representing_d c d –≻ F)%nattrans
      :=
        {|
          Trans := fun o x => (F _a (fst x))%morphism (f (snd x))
        |}
    .

    Theorem PMCM_N_co_equalizes :
      ((mono_morphism N) ∘ (PMCM_PreSheaf_morph_of_function g))%nattrans
      = ((mono_morphism N) ∘ (PMCM_PreSheaf_morph_of_function h))%nattrans.
    Proof.
      apply NatTrans_eq_simplify.
      extensionality x.
      extensionality y.
      destruct y as [y1 y2].
      cbn in *.
      set (W := equal_f (Trans_com (mono_morphism N) y1)).
      cbn in W.
      do 2 rewrite W.
      rewrite (equal_f H).
      trivial.
    Qed.

    Theorem PreSheaf_Monic_components_is_Monic : g = h.
    Proof.
      extensionality m.
      assert (W :=
                f_equal
                  (fun w : (PMCM_PreSheaf_representing_d c d –≻ F)%nattrans =>
                     Trans w c (id, m))
                  (mono_morphism_monomorphic N _ _ _ PMCM_N_co_equalizes)
             ).
      cbn in W.
      rewrite (F_id F) in W.
      trivial.
    Qed.

  End PreSheaf_Monic_components_Monic_is_Monic.

  Definition PreSheaf_Monic_components_Monic_Monic :
    Monic (F _o c)%object (G _o c)%object
    :=
      {|
        mono_morphism := Trans (mono_morphism N) c;
        mono_morphism_monomorphic :=
          PreSheaf_Monic_components_is_Monic
      |}.

End PreSheaf_Monic_components_Monic.

(** In this section we show that all components of an epic
morphism of presheaves are epic.

We do this by showing that given an epic morphism of presheaves
N : F –≫ G we can convert any function from f : (G c) → A to
a morphism of presheaves (PSh(f) : G –≻ Psh(A)) such that this
morphism at c gives exactly f.
*)
Section PreSheaf_Epic_components_Epic.
  Context
    {C : Category}
    {F G : PreSheaf C}
    (N : @Epic (PShCat C) F G)
    (c : C)
  .

  Section PreSheaf_Epic_components_is_Epic.
    Context
      (d : Type)
      (g h : (G _o)%object c → d)
      (H : (fun x => g (Trans (mono_morphism N) c x)) =
           (fun x => h (Trans (mono_morphism N) c x)))
    .

    Local Hint Extern 1 => progress cbn.

    Local Hint Extern 1 => rewrite assoc.

    Program Definition PECE_PreSheaf_representing_d : PreSheaf C
      :=
        {|
          FO := fun c' => (((Hom C c c') → d))%object%morphism%type;
          FA := fun o o' u x y => (x (compose C y u))
        |}
    .

    Local Hint Extern 1 =>
    match goal with
      [|- context [(G _a)%morphism (?A ∘ ?B)%morphism] ] =>
      cbn_rewrite (F_compose G A B)
    end.

    Program Definition PECE_PreSheaf_morph_of_function
            (f : (G _o)%object c → d)
      : (G –≻ PECE_PreSheaf_representing_d)%nattrans
      :=
        {|
          Trans := fun o x y => f ((G _a y)%morphism x)
        |}
    .

    Theorem PECE_N_co_equalizes :
      ((PECE_PreSheaf_morph_of_function g) ∘ (mono_morphism N))%nattrans =
      ((PECE_PreSheaf_morph_of_function h) ∘ (mono_morphism N))%nattrans.
    Proof.
      apply NatTrans_eq_simplify.
      extensionality x.
      extensionality y.
      extensionality z.
      cbn in *.
      set (W := equal_f (Trans_com (mono_morphism N) z)).
      cbn in W.
      rewrite <- W.
      rewrite (equal_f H).
      trivial.
    Qed.

    Theorem PreSheaf_Epic_components_is_Epic : g = h.
    Proof.
      extensionality m.
      assert (W :=
                f_equal
                  (fun w : (G –≻ PECE_PreSheaf_representing_d)%nattrans =>
                     Trans w c m id)
                  (mono_morphism_monomorphic N _ _ _ PECE_N_co_equalizes)
             ).
      cbn in W.
      rewrite (F_id G) in W.
      trivial.
    Qed.

End PreSheaf_Epic_components_is_Epic.

  Program Definition PreSheaf_Epic_components_Epic :
    Epic (F _o c)%object (G _o c)%object
    :=
      {|
        mono_morphism := Trans (mono_morphism N) c;
        mono_morphism_monomorphic :=
          PreSheaf_Epic_components_is_Epic
      |}.

End PreSheaf_Epic_components_Epic.

Local Hint Extern 1 => match goal with
                        [|- context [(?F _a id)%morphism]] => rewrite (F_id F)
                      end.
Local Hint Extern 1 =>
match goal with
  [|- context [(?F _a (?f ∘ ?g))%morphism]] =>
  cbn_rewrite (F_compose F f g)
end.

Local Hint Extern 1 =>
match goal with
  [|- context [Trans ?f _ ((?F _a)%morphism ?h _)]] =>
  cbn_rewrite (equal_f (Trans_com f h))
end.

Local Hint Extern 1 => progress cbn in *.

(** In this section we show that a monic presheaf morphism can be split
into to presheaf morphisms one iso and one monic.

This result is inherited from that in Type_Cat and is proven similarly.
*)
Section Monic_PreSheaf_Iso_Monic_Factorization.
  Context
    {C : Category}
    {F G : PreSheaf C}
    (N : @Monic (PShCat C) F G)
  .

  Lemma sigT_sig_proof_irrelevance
        {T : Type}
        {P : T → Type}
        {Q : ∀ x, (P x) → Prop}
        (A B : sigT (fun y => sig (Q y)))
        (H : projT1 A = projT1 B)
        (H' :
           (
             proj1_sig
               (
                 match H in _ = u return
                       {x : P u | Q u x}
                 with
                   eq_refl => projT2 A
                 end
               )
           )
           =
           (proj1_sig (projT2 B)))
    :
      A = B
  .
  Proof.
    destruct A as [Ax [Ay HA]].
    destruct B as [Bx [By HB]].
    cbn in *.
    transitivity
      (
        existT
          (fun y : T => {x : P y | Q y x})
          Bx
          match H in _ = u return
                {x : P u | Q u x}
          with
            eq_refl => (exist (Q Ax) Ay HA)
          end
      ).
    {
      destruct H; trivial.
    }
    {
      match goal with
        [|- existT _ ?A ?B = existT _ ?A ?B'] =>
        cutrewrite (B = B');trivial
      end.
      apply sig_proof_irrelevance; trivial.
    }
  Qed.

  Local Hint Extern 1 =>
  match goal with
    [x : {_ : _ & {_ : _ | _}} |- _] =>
    let H :=
        fresh "H"
    in
    let x1 :=
        fresh x "1"
    in
    let x2 :=
        fresh x "2"
    in
    destruct x as [x1 [x2 H]]
  end.

  Local Hint Extern 1 =>
  match goal with
    [x : Monic_Image_of |- _] =>
    let H :=
        fresh "H"
    in
    let x1 :=
        fresh x "1"
    in
    let x2 :=
        fresh x "2"
    in
    destruct x as [x1 [x2 H]]
  end.

  Local Hint Extern 1 =>
  match goal with
    [|- ?A = ?B] =>
    assert (H : (projT1 A) = (projT1 B));
      [|
       apply (sigT_sig_proof_irrelevance _ _ H);
         destruct H
      ]
  end.

  Program Definition Monic_PreSheaf_Image_of : PreSheaf C
    :=
      {|
        FO := fun x => @Monic_Image_of _ _ (Trans (mono_morphism N) x);
        FA := fun c c' h x =>
                existT _ (G _a h (projT1 x))%morphism
                       (exist _ (F _a h (proj1_sig (projT2 x)))%morphism _)
      |}
  .

  Program Definition Monic_PreSheaf_Morph_From_Monic_PreSheaf_Image_of_forward :
    (Monic_PreSheaf_Image_of –≻ G)%nattrans
    :=
      {|
        Trans := fun x => @Monic_From_Image_forward _ _ (Trans (mono_morphism N) x)
      |}.

  Program Definition Monic_PreSheaf_From_Monic_PreSheaf_Image_of_back :
    (Monic_PreSheaf_Image_of –≻ F)%nattrans
    :=
      {|
        Trans := fun x => @Monic_From_Image_back _ _ (Trans (mono_morphism N) x)
      |}.

  Program Definition Monic_PreSheaf_To_Monic_PreSheaf_Image_of :
    (F –≻ Monic_PreSheaf_Image_of)%nattrans
    :=
      {|
        Trans := fun x => @Monic_To_Image _ _ (Trans (mono_morphism N) x)
      |}.

  Definition Monic_PreSheaf_Iso_Monic_Factor_Monic :
    @Monic (PShCat C) Monic_PreSheaf_Image_of G.
  Proof.
    eapply (@is_Monic_Monic
              (PShCat C)
              _
              _
              Monic_PreSheaf_Morph_From_Monic_PreSheaf_Image_of_forward
           )
    .
    apply is_Monic_components_is_Monic.
    intros c.
    set (W := fun A B f H => mono_morphism_monomorphic
                            (@Monic_Iso_Monic_Factor_Monic A B f H)).
    unfold is_Monic in *.
    cbn in *.
    apply W.
    apply PreSheaf_Monic_components_is_Monic.
  Defined.

  Program Definition Monic_PreSheaf_Iso_Monic_Factor_Monic_Iso :
    @Isomorphism (PShCat C) F Monic_PreSheaf_Image_of
    :=
      {|
        iso_morphism := Monic_PreSheaf_To_Monic_PreSheaf_Image_of;
        inverse_morphism := Monic_PreSheaf_From_Monic_PreSheaf_Image_of_back
      |}
  .

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality x.
    extensionality y.
    cbn in *.
    apply (equal_f Monic_To_Image_form_split_epic).
  Qed.

  Theorem split_Epic_Monic_Factorization :
    (mono_morphism N) =
    (
      (mono_morphism Monic_PreSheaf_Iso_Monic_Factor_Monic)
        ∘
        (iso_morphism Monic_PreSheaf_Iso_Monic_Factor_Monic_Iso)
    )%nattrans.
  Proof.
    apply NatTrans_eq_simplify; trivial.
  Qed.

End Monic_PreSheaf_Iso_Monic_Factorization.

(** In this section we show that a presheaf morphism can be split
into to presheaf morphisms one epic and one monic.

This result is inherited from that in Type_Cat and is proven similarly.
The only difference is that in Type_Cat the epimorphism is split epic
while in presheaves, the morphisms back are not guaranteed to form a
natural transformation.
*)
Section PreSheaf_Epic_Monic_Factorization.
  Context
    {C : Category}
    {F G : PreSheaf C}
    (N : (F –≻ G)%nattrans)
  .

  Local Hint Extern 1 =>
  match goal with
    [x : {_ : _ | ∃ _, _} |- _] =>
    let H :=
        fresh "H"
    in
    let x1 :=
        fresh x "1"
    in
    let x2 :=
        fresh x "2"
    in
    destruct x as [x1 [x2 H]]
  end.

  Local Hint Extern 1 =>
  match goal with
    [x : Image_of _ |- _] =>
    let H :=
        fresh "H"
    in
    let x1 :=
        fresh x "1"
    in
    let x2 :=
        fresh x "2"
    in
    destruct x as [x1 [x2 H]]
  end.

  Local Obligation Tactic := basic_simpl; auto 10.

  Program Definition PreSheaf_Image_of : PreSheaf C
    :=
      {|
        FO := fun x => @Image_of _ _ (Trans N x);
        FA := fun c c' h x => exist _ (G _a h (proj1_sig x))%morphism _
      |}
  .

  Next Obligation.
  Proof.
    destruct x as [x [y []]].
    exists (F _a h y)%morphism; auto.
  Qed.

  Program Definition PreSheaf_From_Image_Forward :
    (PreSheaf_Image_of –≻ G)%nattrans
    :=
      {|
        Trans := fun x => @From_Image_forward _ _ (Trans N x)
      |}.

  Definition PreSheaf_Epic_Monic_Factor_Monic :
    @Monic (PShCat C) PreSheaf_Image_of G.
  Proof.
    eapply (@is_Monic_Monic
              (PShCat C)
              _
              _
              PreSheaf_From_Image_Forward
           )
    .
    apply is_Monic_components_is_Monic.
    intros c.
    set (W := fun A B f => mono_morphism_monomorphic
                          (@Epic_Monic_Factor_Monic A B f)).
    unfold is_Monic in *; cbn in *.
    apply W.
  Defined.

  Local Hint Extern 1 => apply sig_proof_irrelevance.

  Program Definition PreSheaf_To_Image :
    (F –≻ PreSheaf_Image_of)%nattrans
    :=
      {|
        Trans := fun x => To_Image (Trans N x)
      |}.

  Definition PreSheaf_Epic_Monic_Factor_Epic :
    @Epic (PShCat C) F PreSheaf_Image_of.
  Proof.
    eapply (@is_Monic_Monic
              ((PShCat C) ^op)
              _
              _
              PreSheaf_To_Image
           )
    .
    apply is_Epic_components_is_Epic.
    set (W := fun A B f => mono_morphism_monomorphic
                          (is_split_Monic_Monic
                             (@Epic_Monic_Factor_split_Epic A B f))).
    unfold is_Epic, is_Monic in *; cbn in *.
    intros c.
    apply W.
  Defined.

End PreSheaf_Epic_Monic_Factorization.


Require Import SpecCert.Equality.
Require Import SpecCert.Memory.Memory_def.
Require Import SpecCert.Memory.Memory_func.
Require Import SpecCert.Address.
Require Import SpecCert.Map.

Lemma update_memory_1
      {S: Type}
      (m: Memory S)
      (k: HardwareAddress)
      (c: S)
  : find_in_memory (update_in_memory m k c) k = c.
Proof.
  unfold find_in_memory, update_in_memory.
  apply add_1.
Qed.

Lemma update_memory_2
      {S:    Type}
      (m:    Memory S)
      (k k': HardwareAddress)
      (c:    S)
      (neq:  ~ eq k k')
  : find_in_memory m k' = find_in_memory (update_in_memory m k c) k'.
Proof.
  unfold find_in_memory, update_in_memory.
  apply (add_2 m k k' c neq).
Qed.


From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** -------------------------------------------- *)
(** #
#
* The algebra library

 - This is a central part of the mathematical components library.
 - This library register a various range of (mathematical) structures.
  - types with decidable equality: eqType
  - types with a finite number of elements: finType
  - finite groups: finGroupType
  - abelian (not possibly finite) groups: zmodType
  - rings: ringType
  - rings with invertible elements: unitRingType
  - commutative rings: comRingType
  - integral domains: idomainType
  - fields: fieldType
  - left modules: lmodType
  - left algebra: lalgType
  - algebra: algType
  - finite dimensional vector spaces: vectType
  - ...

- Some of these structures share operators: e.g. the operator (_ + _),
  introduced for abelian groups (zmodType), is also available for all
  the structures that require it (rings, domains, fields, etc...)

- All of these structures are discrete: they all have decidable
  equality: the operator (_ == _) is available on all of them.

- #  Here is a picture of the begining of the hierarchy#
  Extensive documentation in the header of:
 - #ssralg#
 - #ssrnum#

- In addition there are structures for maps (additive morphisms, ring
  morphisms, etc...), and substructures (subgroup, subsemiring, subring,
  subfield, etc...)
#
# *)
(** -------------------------------------------- *)
(** #
#

* Roadmap for the lesson:
 - introduction of the general definition pattern for algebraic structures
 - instantiation of a structure in the library
 - exploration of the theory provided by this structure and naming
   conventions
 - creation of a subalgebraic structure predicate and use
*)
Module AlgebraicStructures.
(** #
# *)
(** -------------------------------------------- *)
(** #
#
* Defining a mathematical structure in Coq.

This is how mathematical structures are defined in the library.
Unless you need to add a new mathematical structure to the library,
you will only need to read this.
*)

Structure my_struct := My_struct {
(* domain/carrier/sort of the structure *)
  dom  : Type;

(* symbols: constants and operators *)
  c    : dom;
  op   : dom -> dom -> dom;

(* axioms: properties on the symbols *)
  opxc : forall x, op x c = c;
  opC : forall x y, op x y = op y x}.

(* Notations and modifiers for the symbols *)
Arguments op {m} x y.
Arguments c {m}.
Notation "x * y" := (op x y).

Section my_struct_theory.

Variable s : my_struct.

(* Theory of the structure *)
Lemma opcx (x : dom s) : c * x = c.
Proof. by rewrite opC opxc. Qed.

End my_struct_theory.

End AlgebraicStructures.
(**

This packaging is very elementary, and the mathematical components
library uses a refinement of this.

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

* Packaging mathematical structures

We briefly explain how to do inheritance with two structures. This is
another simplified version of what happens in the library.  The
complete process is described in #Packaging
Mathematical Structures (Garillot, Gonthier, Mahboubi, Rideau) and
in the draft book #Book#.

*)
Section AlgebraicStructuresInheritance.

Record my_mixin1 dom := My_mixin1 {
(* symbols: constants and operators *)
  my_c    : dom;
  my_op   : dom -> dom -> dom;
(* axioms: properties on the symbols *)
  my_opxc : forall x, my_op x my_c = my_c;
  my_opC : forall x y, my_op x y = my_op y x}.

Definition my_class1 := my_mixin1.

Structure my_struct1 := My_struct1 {
(* domain/carrier/sort of the structure *)
  dom1 :> Type;
  class1 : my_mixin1 dom1}.

Definition op {s : my_struct1} := my_op (class1 s).
Definition c {s : my_struct1} := my_c (class1 s).
Notation "x * y" := (op x y).

Record my_mixin2 (dom : my_struct1) := My_mixin2 {
(* symbols: constants and operators *)
  my_pred   : pred dom;
(* axioms: properties on the symbols *)
  my_predc : forall x, my_pred (op c x)}.

Record my_class2 dom := My_class2 {
  base2 :> my_class1 dom;
  mixin2 :> my_mixin2 (@My_struct1 dom base2)}.

Structure my_struct2 := My_struct2 {
  dom2  :> Type;
  class2 : my_class2 dom2}.

Definition pr {s : my_struct2} := my_pred (class2 s).

Canonical my_struct1_2 (s : my_struct2) : my_struct1 :=
  @My_struct1 (dom2 s) (class2 s : my_class1 _).

Section my_struct1_theory.

Variable s : my_struct1.

Lemma opC (x y : s) : x * y = y * x.
Proof. by case: s x y => ? []. Qed.

Lemma opxc (x : s) : x * c = c.
Proof. by case: s x => ? []. Qed.

(* Theory of the structure *)
Lemma opcx (x : s) : c * x = c.
Proof. by rewrite opC opxc. Qed.

End my_struct1_theory.

Section my_struct2_theory.

Variable s : my_struct2.

Lemma pr_xc (x : s) : pr (c * x).
Proof. by case: s x => ? [? []]. Qed.

Lemma pr_c : pr (c : s).
Proof. by rewrite -(opcx c) pr_xc. Qed.

End my_struct2_theory.

End AlgebraicStructuresInheritance.
(** #
# *)
(** -------------------------------------------- *)
(** #
#
* Inhabiting the mathematical structures hierarchy.

 - We now show on the example of integers how to instantiate the
   mathematical structures that integers satisfy.

 - As a step to minimize the work of the user, the library provides a
   way to provide only the mixin. The general pattern is to build the
   mixin of a structure, declare the canonical structure associated
   with it and go one with creating the next mixin and creating the new
   structure. Each time we build a new structure, we provide only the
   mixin, as the class can be inferred from the previous canonical
   structures

 - We now show three different ways to build mixins here and an
   additional fourth will be shown in the exercices

  - using a reference structure,
  - building the required mixin from scratch,
  - building a more informative mixin and using it for a weaker structure,
  - (in the example) by subtyping.

*)
Module InstantiationInteger.

From mathcomp Require Import ssralg.
Import GRing.Theory.
Local Open Scope ring_scope.

(** #
# *)
(** -------------------------------------------- *)
(** #
#
** First we define int

*)
CoInductive int : Set := Posz of nat | Negz of nat.
Local Coercion Posz : nat >-> int.

Notation "n %:Z" := (Posz n)
  (at level 2, left associativity, format "n %:Z", only parsing).
(**

** Equality, countable and choice types, by injection

We provide an injection with explicit partial inverse, grom int to nat
+ nat, this will be enough to provide the mixins for equality,
countable and choice types.

*)
Definition natsum_of_int (m : int) : nat + nat :=
  match m with Posz p => inl _ p | Negz n => inr _ n end.

Definition int_of_natsum (m : nat + nat) :=
  match m with inl p => Posz p | inr n => Negz n end.

Lemma natsum_of_intK : cancel natsum_of_int int_of_natsum.
Proof. by case. Qed.
(**

We create the mixins for equality, countable and choice types from
this injection, and gradually inhabit the hierarchy. Try to swap any
of the three blocks to see what happen.

*)
Definition int_eqMixin := CanEqMixin natsum_of_intK.
Canonical int_eqType := EqType int int_eqMixin.

Definition int_choiceMixin := CanChoiceMixin natsum_of_intK.
Canonical int_choiceType := ChoiceType int int_choiceMixin.

Definition int_countMixin := CanCountMixin natsum_of_intK.
Canonical int_countType := CountType int int_countMixin.
(** #
# *)
(** -------------------------------------------- *)
(** #
#
** Abelian group structure, from scratch

We now create the abelian group structure of integers (here called
Z-module), from scratch, introducing the operators and proving exactly
the required properties.

*)
Module intZmod.
Section intZmod.

Definition addz (m n : int) :=
  match m, n with
    | Posz m', Posz n' => Posz (m' + n')
    | Negz m', Negz n' => Negz (m' + n').+1
    | Posz m', Negz n' => if n' < m' then Posz (m' - n'.+1) else Negz (n' - m')
    | Negz n', Posz m' => if n' < m' then Posz (m' - n'.+1) else Negz (n' - m')
  end.

Definition oppz m := nosimpl
  match m with
    | Posz n => if n is (n'.+1)%N then Negz n' else Posz 0
    | Negz n => Posz (n.+1)%N
  end.

Lemma addzC : commutative addz. Admitted.
Lemma add0z : left_id (Posz 0) addz. Admitted.
Lemma oppzK : involutive oppz. Admitted.
Lemma addzA : associative addz. Admitted.
Lemma addNz : left_inverse (Posz 0) oppz addz. Admitted.

Definition Mixin := ZmodMixin addzA addzC add0z addNz.

End intZmod.
End intZmod.

Canonical int_ZmodType := ZmodType int intZmod.Mixin.
(**

Remark: we may develop here a piece of abelian group theory which is
specific to the theory of integers.

*)
Section intZmoduleTheory.

Lemma PoszD : {morph Posz : n m / (n + m)%N >-> n + m}.
Proof. by []. Qed.

End intZmoduleTheory.
(**

*** Ring and Commutative ring structure, the stronger the better

This time, we will build directly a rich commutative ring mixin first
and use it to instanciate both the ring structure and the commutative
ring struture at the same time. This is not only a structural economy
of space, but a mathematical economy of proofs, since the
commutativity property reduces the number of ring axioms to prove.

*)

Module intRing.
Section intRing.

Definition mulz (m n : int) :=
  match m, n with
    | Posz m', Posz n' => (m' * n')%N%:Z
    | Negz m', Negz n' => (m'.+1%N * n'.+1%N)%N%:Z
    | Posz m', Negz n' => - (m' * (n'.+1%N))%N%:Z
    | Negz n', Posz m' => - (m' * (n'.+1%N))%N%:Z
  end.

Lemma mulzA : associative mulz. Admitted.
Lemma mulzC : commutative mulz. Admitted.
Lemma mul1z : left_id (Posz 1) mulz. Admitted.
Lemma mulz_addl : left_distributive mulz (+%R). Admitted.
Lemma onez_neq0 : (Posz 1) != 0. Proof. by []. Qed.

Definition comMixin := ComRingMixin mulzA mulzC mul1z mulz_addl onez_neq0.

End intRing.
End intRing.

Canonical int_Ring := RingType int intRing.comMixin.
Canonical int_comRing := ComRingType int intRing.mulzC.

End InstantiationInteger.
(** #
# *)
(** -------------------------------------------- *)
(** #
#
* Other structures
*)
Module OtherStructures.
From mathcomp Require Import ssralg ssrnum.
Import GRing.Theory.
Local Open Scope ring_scope.
(**
** Extensions of rings

- read the documentation of ssralg and ssrnum (algebraic structures
  with order)

** Structures for morphisms
*)

Search "linear" in ssralg.

Search "raddf" in ssralg.

Search "rmorph" in ssralg.
(**
** Substructures
*)

Print ssralg.GRing.subring_closed.
Print ssralg.GRing.subr_2closed.
Print ssralg.GRing.mulr_2closed.

Search "rpred" in ssralg.

End OtherStructures.
(** #
# *)
(** -------------------------------------------- *)
(** #
#
* Naming conventions.

The two most important things to get your way out of a situation:
 - Knowing your math
 - Searching the library for what you think you know

For that you have the ssreflect Search command. To use its full power, one should combine seach by identifier (Coq definition), pattern (partial terms) and name (a string contained in the name of the theorem).

The two first methods are straightforward to use (except if you instanciate your patterns more than necessary), but searching by name requires to be aware of naming conventions.

*)
(** #
# *)
(** -------------------------------------------- *)
(** #
#
** Names in the library are usually obeying one of following the convention

 - #
(condition_)?mainSymbol_suffixes
#
 - #
mainSymbol_suffixes(_condition)?
#

Or in the presence of a property denoted by a nary or unary predicate:
 - #
naryPredicate_mainSymbol+
#
 - #
mainSymbol_unaryPredicate
#

** Where :

 - "mainSymbol" is the most meaningful part of the lemma. It generally
   is the head symbol of the right-hand side of an equation or the
   head symbol of a theorem. It can also simply be the main object of
   study, head symbol or not. It is usually either

  - one of the main symbols of the theory at hand. For example, it will be #opp#, #add#, #mul#, etc...

  - or a special "canonical" operation, such as a ring morphism or a
    subtype predicate. e.g. #linear#, #raddf#, #rmorph#, #rpred#, etc ...

 - "condition" is used when the lemma applies under some hypothesis.

 - "suffixes" are there to refine what shape and/or what other symbols  the lemma has. It can either be the name of a symbol ("add", "mul",  etc...), or the (short) name of a predicate ("#inj#" for "#injectivity#", "#id#" for "identity", ...) or an abbreviation.

Abbreviations are in the header of the file which introduce them. We list here the main abbreviations.

  - A -- associativity, as in #andbA : associative andb.#
  - AC -- right commutativity.
  - ACA -- self-interchange (inner commutativity), e.g.,
        #orbACA : (a || b) || (c || d) = (a || c) || (b || d).#
  - b -- a boolean argument, as in #andbb : idempotent andb.#
  - C -- commutativity, as in #andbC : commutative andb#,
    or predicate complement, as in #predC.#
  - CA -- left commutativity.
  - D -- predicate difference, as in #predD.#
  - E -- elimination, as in #negbFE : ~~ b = false -> b#.
  - F or f -- boolean false, as in #andbF : b && false = false.#
  - I -- left/right injectivity, as in #addbI : right_injective addb# or predicate  intersection, as in #predI.#
  - l -- a left-hand operation, as #andb_orl : left_distributive andb orb.#
  - N or n -- boolean negation, as in #andbN : a && (~~ a) = false.#
  - n -- alternatively, it is a natural number argument
  - P -- a characteristic property, often a reflection lemma, as in
     #andP : reflect (a /\ b) (a && b)#.
  - r -- a right-hand operation, as #orb_andr : right_distributive orb andb.#
      -- alternatively, it is a ring argument
  - T or t -- boolean truth, as in #andbT: right_id true andb.#
  - U -- predicate union, as in #predU#.
  - W -- weakening, as in #in1W : {in D, forall x, P} -> forall x, P.#
  - 0 -- ring 0, as in #addr0 : x + 0 = x.#
  - 1 -- ring 1, as in #mulr1 : x * 1 = x.#
  - D -- ring addition, as in #linearD : f (u + v) = f u + f v.#
  - B -- ring subtraction, as in #opprB : - (x - y) = y - x.#
  - M -- ring multiplication, as in #invfM : (x * y)^-1 = x^-1 * y^-1.#
  - Mn -- ring by nat multiplication, as in #raddfMn : f (x *+ n) = f x *+ n.#
  - mx -- a matrix argument
  - N -- ring opposite, as in #mulNr : (- x) * y = - (x * y).#
  - V -- ring inverse, as in #mulVr : x^-1 * x = 1.#
  - X -- ring exponentiation, as in #rmorphX : f (x ^+ n) = f x ^+ n.#
  - Z -- (left) module scaling, as in #linearZ : f (a *: v)  = s *: f v.#
  - z -- a int operation

** My most used search pattern

#
Search _ "prefix" "suffix"* (symbol|pattern)* in library.
#

** Examples
*)
Module Conventions.
From mathcomp Require Import ssralg ssrnum.
Import GRing.Theory.
Local Open Scope ring_scope.

Search _ *%R "A" in GRing.Theory.

Search _ "unit" in ssralg.

Search _ "inj" in ssralg.

Search _ "rmorph" "M" in ssralg.

Search _ "rpred" "D" in ssralg.

End Conventions.

(** #
# *)
(** -------------------------------------------- *)
(** #
#
 * A short parenthesis on subtyping.
**)(**

 - In Coq, #sT := {x : T | P x}# is a way to form a
  sigma-type. We say it is a #subtype# if there is only one
  element it #sT# for each element in
  #T#. This happens when #P# is a boolean
  predicate. Another way to form a subtype is to create a record :
  #Record sT := ST {x : T; px : P x}#.

 - In mathcomp, to deal with subtypes independently from how they are
   form, we have a ganonical structure.
*)

Module SubType.
Section SubType.
Variables (T : Type) (P : pred T).
Structure subType : Type := SubType {
  sub_sort :> Type;
  val : sub_sort -> T;
  Sub : forall x, P x -> sub_sort;
  (* elimination rule for sub_sort *)
  _ : forall K (_ : forall x Px, K (@Sub x Px)) u, K u;
  _ : forall x Px, val (@Sub x Px) = x
}.
End SubType.
End SubType.
(**
 - The most important operators to know on subtypes are
  #val : sT -> T#, #insub : T -> option sT# and
  #insubd : sT -> T -> sT#.

- And the most important theorems to know are
  #val_inj, val_eqE, val_insubd, insubdK# and #insub#
*)
About val_inj.
About val_eqE.
About insubK.
About val_insubd.
About insubdK.


Require Export CatSem.CAT.functor.
Require Export CatSem.CAT.prods.
Require Import CatSem.CAT.coproduct.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section bifunctor_def.

Variable obB obC obD : Type.
Variable morB: obB -> obB -> Type.
Variable morC: obC -> obC -> Type.
Variable morD: obD -> obD -> Type.

Variables (B: Cat_struct morB) (C: Cat_struct morC) (D: Cat_struct morD).

(** a bifunctor is a functor from a product category to somewhere *)

Definition Bifunctor := Functor (PROD B C) D.

Variable S: Bifunctor.

(** for any element [c] the "functor"
    - b => S (b, c)
    is a functor
*)

Section Left_Functor.

Variable c:obC.

Obligation Tactic := simpl; intros.

Program Instance Left_Functor_struct : Functor_struct (C:=B) (D:=D)
             (Fobj := fun b => S (b, c))
             (fun (b b':obB) (f:morB b b') =>
                  #S (build_prod_mor B C f (id c))).
Next Obligation.
Proof.
  unfold Proper;
  red.
  intros x y H.
  apply prod_mor_equal;
  cat.
Qed.
Next Obligation.
Proof.
  cat.
Qed.
Next Obligation.
Proof.
  unfold build_prod_mor.
  rewrite <- FComp.
  simpl.
  unfold Prod_comp.
  simpl.
  apply prod_mor_equal;
  cat.
Qed.

Definition Left_Functor : Functor B D := Build_Functor Left_Functor_struct.

End Left_Functor.

Section Right_Functor.

Variable b: obB.

Obligation Tactic := simpl; intros.

Program Instance Right_Functor_struct : Functor_struct (C:=C) (D:=D)
             (Fobj := fun c => S (b, c))
             (fun (c c':obC) (f:morC c c') =>
                  #S (build_prod_mor B C (id b) f )).
Next Obligation.
Proof.
  unfold Proper;
  red.
  intros x y H.
  apply prod_mor_equal;
  cat.
Qed.
Next Obligation.
Proof.
  cat.
Qed.
Next Obligation.
Proof.
  unfold build_prod_mor.
  rewrite <- FComp.
  simpl.
  unfold Prod_comp.
  simpl.
  apply prod_mor_equal;
  cat.
Qed.

Definition Right_Functor : Functor C D :=
                Build_Functor Right_Functor_struct.

End Right_Functor.

End bifunctor_def.

(** product is a bifunctor *)

Section prod_bifunctor.

Variable obC: Type.
Variable morC: obC -> obC -> Type.
Variable C: Cat_struct morC.
Variable H: Cat_Prod C.

Definition PROD_BIF_obj : (PROD C C) -> obC :=
        fun x => product (fst x) (snd x).

Definition PROD_BIF_mor (a b:PROD C C) (f: a ---> b) :
   morC (PROD_BIF_obj a) (PROD_BIF_obj b) :=
 prod_mor (prl (fst a) (snd a) ;;
      (fst f)) (prr (fst a) (snd a) ;; (snd f)).

Program Definition PROD_BIF : Bifunctor C C C := Build_Functor
   (Fobj := fun x => product (fst x) (snd x))
   (Fmor:= fun a b f => prod_mor (prl (fst a) (snd a) ;;
             (fst f)) (prr (fst a) (snd a) ;; (snd f)))  _ .
Next Obligation.
Proof.
  constructor.

  unfold Proper;
  red.
  intros a b x y H'.
  apply prod_mor_unique.
  repeat rewrite prod_prl.
  repeat rewrite prod_prr.
  destruct x; destruct y.
  destruct H' as [h h'].
  cat.

  intro a.
  apply hom_sym.
  apply prod_mor_unique.
  cat.

  intros a b c f g.
  apply hom_sym.
  apply prod_mor_unique.
  destruct a; destruct b; destruct c;
  destruct f; destruct g; simpl in *.
  repeat rewrite assoc.
  repeat rewrite prod_prl.
  repeat rewrite prod_prr.
  repeat rewrite <- assoc.
  cat.
Qed.

End prod_bifunctor.

Section coprod_bifunctor.

Variable obC: Type.
Variable morC: obC -> obC -> Type.
Variable C: Cat_struct morC.
Variable H: Cat_Coprod C.

Definition COPROD_BIF_obj : (PROD C C) -> obC :=
        fun x => coprod (fst x) (snd x).

Definition COPROD_BIF_mor (a b:PROD C C) (f: a ---> b) :
  morC (COPROD_BIF_obj a) (COPROD_BIF_obj b) :=
  coprod_mor ((fst f) ;; inl (fst b) (snd b))
                 ((snd f) ;; inr (fst b) (snd b)).

Program Definition COPROD_BIF : Bifunctor C C C := Build_Functor
   (Fobj := COPROD_BIF_obj) (Fmor:= COPROD_BIF_mor)  _ .
Next Obligation.
Proof.
  constructor.

  unfold Proper,COPROD_BIF_mor; red.
  intros a b x y H'.
  apply coprod_mor_unique.
  repeat rewrite inl_coprod.
  repeat rewrite inr_coprod.
  destruct x; destruct y.
  destruct H' as [h h'].
  simpl in *.
  rewrite h. rewrite h'.
  split; apply hom_refl.

  unfold COPROD_BIF_mor. simpl.
  intro a. apply hom_sym.
  apply coprod_mor_unique.
  repeat rewrite idl. repeat rewrite idr.
  split; apply hom_refl.

  unfold COPROD_BIF_mor, COPROD_BIF_obj.
  intros a b c f g.
  apply hom_sym.
  apply coprod_mor_unique.
  destruct a; destruct b; destruct c;
  destruct f; destruct g; simpl in *.
  repeat rewrite <- assoc.
  rewrite (inl_coprod).
  rewrite inr_coprod.
  repeat rewrite assoc.
  rewrite inl_coprod.
  rewrite inr_coprod.
  split; apply hom_refl.
Qed.

End coprod_bifunctor.

(* is not possible, typing issues *)
(*
Section Bifunctor_from_Functors.

Variable obB obC obD : Type.
Variable morB: obB -> obB -> Type.
Variable morC: obC -> obC -> Type.
Variable morD: obD -> obD -> Type.

Variables (B: Cat morB) (C: Cat morC) (D: Cat morD).

Variable L: forall c:obC, Functor B D.
Variable M: forall b:obB, Functor C D.

Hypothesis H: forall b c, L c b = M b c.

Hypothesis H': forall b b' c c' (f: morB b b') (g: morC c c'),
                  L c <- f o M b' <- g == M b <- g o L c' <- f.

*)


Set Implicit Arguments.
Require Import Lists.List.
Import ListNotations.

Section ListDel.

  Variable E : Set.

  Hypothesis Eeq_dec : forall x y : E, {x = y} + {x <> y}.

  Hypothesis in_cons : forall (e a : E) l, In e (a :: l) -> a = e \/ In e l.

  Definition list_delete : forall (l : list E) (e : E), exists l',
        forall e', In e' l' <-> In e' l /\ e' <> e.
  Proof.
    induction l.
    - intros. eexists. intros. simpl.
      firstorder.
      + eapply in_nil. eassumption.
      + firstorder.
    - intro e.
      edestruct IHl with (e:=e) as [l'].
      intros.
      destruct (Eeq_dec a e).
      + eexists. intros. simpl.
        firstorder.
        * right. apply H. eassumption.
        * firstorder.
        * subst. firstorder.
        * apply H. firstorder.
      + eexists. intros. simpl.
        firstorder.
        * apply in_cons. apply H0.
        * destruct (in_cons H0); try congruence.
          apply H. assumption.


Require Import Coq.Classes.EquivDec.
Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Require Import Coq.omega.Omega.

Require Import BWT.Lib.List.
Require Import BWT.Lib.Sumbool.

Section PermutationCount.
  Context {A : Type} `(ED : EqDec A eq).

  Implicit Type l : list A.

  Definition PermutationCount l l' : Prop :=
    forall x, count_occ equiv_dec l x = count_occ equiv_dec l' x.

  Theorem PermutationCount_iff : forall l l',
      Permutation l l' <-> PermutationCount l l'.
  Proof.
    unfold PermutationCount.
    intros l l'. split.
    - intros P; induction P.
      + reflexivity.
      + intros y; destruct (x == y);
          [rewrite !count_occ_cons_eq|rewrite !count_occ_cons_neq];
          [f_equal|..]; easy.
      + intros z.
        destruct (y == z); destruct (x == z);
          repeat match goal with
          | H : ?a === ?b |- _ => rewrite (count_occ_cons_eq equiv_dec _ H)
          | H : ?a =/= ?b |- _ => rewrite (count_occ_cons_neq equiv_dec _ H)
          end; easy.
      + intros. eapply eq_trans; [apply IHP1|apply IHP2].
    - revert l'. induction l; intros l' HCO.
      + replace l' with (@nil A); [constructor|].
        symmetry. eapply count_occ_inv_nil.
        cbn in HCO. symmetry in HCO. apply HCO.
      + assert (In a l'). {
          eapply (count_occ_In equiv_dec).
          specialize (HCO a).
          cbn in HCO.
          rewrite if_true in HCO by reflexivity.
          rewrite <- HCO. omega.
        }
        edestruct (in_split a l') as [L [R HLR]]; auto.
        eapply Permutation_trans; [|rewrite HLR; apply Permutation_middle].
        constructor. apply IHl.
        intros. destruct (a == x).
        * apply Nat.succ_inj.
          rewrite <- count_occ_remove_eq.
          rewrite <- count_occ_cons_eq with (x := a); [|auto].
          rewrite <- e, <- HLR. apply HCO.
        * rewrite <- @count_occ_remove_neq with (a := a); auto.
          rewrite <- HLR.
          rewrite <- HCO, count_occ_cons_neq; auto.
  Qed.
End PermutationCount.


From discprob.prob Require Export prob countable stochastic_order.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice fintype bigop.
Require Export Reals Psatz.

(* There are some refinements to this that can be proved:
   e.g.: we only needf to assume X x >= 0 for x such that Ω x > 0 *)

Lemma markov {A} {Ω: distrib A} (X: rrvar Ω) a :
  (∀ x, X x >= 0) →
  a > 0 →
  ex_Ex X →
  pr_ge X a <= Ex X / a.
Proof.
  intros Hnonneg Hgt0 Hex.
  cut (a * pr_ge X a <= Ex X).
  {
    intros. apply (Rmult_le_reg_l a); first by nra.
    etransitivity; first eauto. right. field. nra.
  }
  rewrite /pr_ge pr_ge_to_indicator.
  rewrite -Ex_indicator -Ex_scal_l; last apply ex_Ex_indicator.
  apply Ex_ext_le; auto.
  * apply ex_Ex_scal_l, ex_Ex_indicator.
  * intros x. rewrite //=.
    destruct Rge_dec => //=.
    ** nra.
    ** rewrite Rmult_0_r. apply Rge_le; auto.
Qed.

Lemma chebyshev {A} {Ω: distrib A} (X: rrvar Ω) a :
  a > 0 →
  ex_Var X →
  pr_ge (mkRvar Ω (λ a, Rabs (X a - Ex X))) a <= Var X / a^2.
Proof.
  intros Hgt0 Hvar.
  specialize (markov (mkRvar Ω (λ a, (X a - Ex X)^2)) (a^2)).
  intros Hmark. etransitivity; last eapply Hmark.
  * right. rewrite /pr_ge. apply pr_eq_pred'.
    intros i.
    destruct Rge_dec as [Hge1|Hnge1];
    destruct Rge_dec as [Hge2|Hnge2]; try (rewrite //=; done).
    ** exfalso. apply Hnge2.
       apply Rle_ge. rewrite //= ?Rmult_1_r. apply Rsqr_le_abs_1.
       apply Rge_le in Hge1.
       etransitivity; last eapply Hge1.
       rewrite Rabs_right //; nra.
    ** exfalso. apply Hnge1.
       apply Rle_ge. rewrite //=.
       rewrite -(Rabs_right a); last by nra.
       apply Rsqr_le_abs_0.
       apply Rge_le in Hge2.
       rewrite //= ?Rmult_1_r in Hge2. done.
  * rewrite //= => i. rewrite Rmult_1_r.
    apply Rle_ge, Rle_0_sqr.
  * nra.
  * destruct Hvar; auto.
Qed.


(******************************************************************************)
(* Chapter 1.5: Isomorphisms                                                  *)
(******************************************************************************)

(*
(0)
同じディレクトリにある Categories.v と Functor.v を使う。

(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Require Import Morphisms.                   (* coq standard libs. *)
Require Import Aw_0_Notations.              (* same dir. *)
Require Import Aw_1_3_Categories.           (* same dir. *)
Require Import Aw_1_4_Functors.             (* same dir. *)

(* 圏Cにおいて、同型射 f : a ~> b が存在するとき、a と b は同型である。 *)
(* 同型射とは、g \\o f === iid かつ f \\o g === iid なる f *)
Class Isomorphism `{C : Category} {a b : C} (f : a ~> b) (g : b ~> a) : Prop :=
  {
    iso_cmp1  : g \\o f === iid;            (* iid a *)
    iso_cmp2  : f \\o g === iid             (* iid b *)
  }.
(* TO DO: show isos are unique when they exist *)

(* f と g をメンバで定義した版 *)
Class Isomorphic `{C : Category} (a b : C) :=
  {
    iso_forward  :  a ~> b;
    iso_backward :  b ~> a;
    iso_comp1    :  iso_backward \\o iso_forward === iid; (* iid a *)
    iso_comp2    :  iso_forward \\o iso_backward === iid  (* iid b *)
(* TO DO: merge this with Isomorphism *)
}.
(* 同型射 f は、ひとつの同型(な関係にあるaとb)を与えないと決まらない。
   Isomorphic a b をexplicitに与えるようにする。 *)
Check @iso_forward : ∀Obj Hom C a b _, a ~> b.
Check iso_forward : _ ~> _.
Arguments iso_forward  {Obj Hom C a b} i : rename.
Arguments iso_backward {Obj Hom C a b} i : rename.
Arguments iso_comp1    {Obj Hom C a b} i : rename.
Arguments iso_comp2    {Obj Hom C a b} i : rename.
Check iso_forward _ : _ ~> _.                 (* 最初の _ は、Isomorphic a b *)
Check iso_forward : Isomorphic _ _ -> _ ~> _. (* _ は、圏Cの対象 a b *)

Notation "a ≅ b" := (Isomorphic a b) : isomorphism_scope.
(* the sharp symbol "casts" an isomorphism to the morphism in the forward direction *)
Notation "# f" := (iso_forward f) : isomorphism_scope.
Open Scope isomorphism_scope.

(* 同型a,bに対して、同型b,aを求めることができる。 *)
(* aに対してbが同型なら、bに対してaも同型である。 *)
(* the inverse of an isomorphism is an isomorphism *)
Definition iso_inv `{C : Category} (a b : C) (iso : Isomorphic a b) : Isomorphic b a.
Proof.
  Check iso_backward.
  Check @Build_Isomorphic _ _ _ _ _ (iso_backward iso) (iso_forward iso).
  apply (@Build_Isomorphic _ _ _ _ _ (iso_backward iso) (iso_forward iso)).
  - by apply iso_comp2.
  - by apply iso_comp1.
Defined.
Check @iso_inv : ∀Obj Hom C a b _, b ≅ a.
Arguments iso_inv {Obj Hom C a b} f : rename.
Check iso_inv _ : _ ≅ _.                    (* 最初の _ は a ≅ b *)
Check iso_inv : _ ≅ _ -> _ ≅ _.             (* _ は、圏Cの対象 a b *)
Notation "f '⁻¹'" := (iso_inv f) : isomorphism_scope.

(* 同型a,a *)
(* aとaは同型である。 *)
(* identity maps are isomorphisms *)
Definition iso_id `{C : Category} (a : C) : Isomorphic a a.
Proof.
  Check @Build_Isomorphic _ _ C a a iid iid.
  apply (@Build_Isomorphic _ _ C a a iid iid).
  now rewrite left_identity.
  now rewrite left_identity.
Defined.
Check @iso_id.
Arguments iso_id {Obj Hom C a} : rename.
Check iso_id : _ ≅ _.                       (* _ は、圏Cの対象a *)

(* 同型a,b と 同型b,c なら、同型a,c *)
(* the composition of two isomorphisms is an isomorphism *)
Definition iso_comp `{C : Category} {a b c : C}
           (i1 : Isomorphic a b) (i2 : Isomorphic b c) : Isomorphic a c.
Proof.
  Check #i1 : a ~> b.                       (* iso_forward i1 *)
  Check #i2 : b ~> c.                       (* iso_forward i2 *)
  Check #i2 \\o #i1 : a ~> c.
  Check #i1⁻¹ : b ~> a.                     (* iso_inv (iso_forward i1) *)
  Check #i2⁻¹ : c ~> b.                     (* iso_inv (iso_forward i2) *)
  Check iso_comp1 i1 : iso_backward i1 \\o #i1 === iid.
  Check iso_comp2 i1 : #i1 \\o iso_backward i1 === iid.
  Check iso_comp1 i2 : iso_backward i2 \\o #i2 === iid.
  Check iso_comp2 i2 : #i2 \\o iso_backward i2 === iid.

  Check (@Build_Isomorphic _ _ C a c (#i2 \\o #i1) (#i1⁻¹ \\o #i2⁻¹)).
  apply (@Build_Isomorphic _ _ C a c (#i2 \\o #i1) (#i1⁻¹ \\o #i2⁻¹)).
  - rewrite juggle3 (iso_comp1 i2).
    rewrite associativity left_identity (iso_comp1 i1).
    reflexivity.
  - rewrite juggle3 (iso_comp2 i1).
    rewrite associativity left_identity (iso_comp2 i2).
    reflexivity.
Defined.
Check @iso_comp : ∀Obj Hom C a b c _ _, a ≅ c.
Check iso_comp _ _ : _ ≅ _.
Arguments iso_comp {Obj Hom C} a b c i1 i2 : rename.
Check iso_comp : ∀a b c _ _, a ≅ c.
Notation "a >>≅>> b" := (iso_comp a b).

(* 関手は同型を保存する。 *)
Definition functors_preserve_isos `{C1 : Category} `{C2 : Category} {Fo : C1 -> C2}
           (F : Functor Fo) {a b : C1} (i : Isomorphic a b) : Isomorphic (F a) (F b).
Proof.
  (* 圏C1を関手で写した先の圏C2、C2の同型を作る。 *)
  Check F \ (iso_forward i) : F a ~> F b.
  Check F \ #i : F a ~> F b.
  Check F \ (iso_backward i) : F b ~> F a.
  Check {| iso_forward  := F \ (iso_forward  i);
           iso_backward := F \ (iso_backward i)
        |}.
  Check (@Build_Isomorphic).
  Check (@Build_Isomorphic Obj0 Hom0 C2 (F a) (F b)
                           (F \ (# i))
                           (F \ (iso_backward i))).
  Check (@Build_Isomorphic _ _ _ (F a) (F b)
                           (F \ (# i))
                           (F \ (iso_backward i))).
  (* Standard Coq の refine は、SSReflect の apply: である。 *)
  refine {| iso_forward  := F \ (iso_forward  i);
            iso_backward := F \ (iso_backward i)
         |}.
  Undo 1.
  apply: {| iso_forward  := F \ (iso_forward  i);
            iso_backward := F \ (iso_backward i)
         |}.
  Undo 1.
  apply (@Build_Isomorphic _ _ _ _ _
                           (F \ (# i))
                           (F \ (iso_backward i))).
  (* F \ iso_backward i \\o F \ #i === iid *)
  - rewrite fmor_preserves_comp.
    rewrite iso_comp1.
    apply fmor_preserves_id.
  (* F \ #i \\o F \ iso_backward i === iid *)
  - rewrite fmor_preserves_comp.
    rewrite iso_comp2.
    apply fmor_preserves_id.
Defined.

(* 圏Cの対象b,aが同型である（同型射 b ~> c がある）とき、
   圏Cの射f : b ~> c と、射g : a ~> c の関係を示す。
 *)
Lemma iso_shift_right `{C : Category} {a b c : C}
      (f : b ~> c) (g : a ~> c) (i : Isomorphic b a) :
  f \\o #i⁻¹ === g -> f === g \\o #i.
Proof.
  move=> H.
  rewrite -H associativity iso_comp1 right_identity.
  reflexivity.
Qed.

Lemma iso_shift_right' `{C : Category} {a b c : C}
      (f : b ~> c) (g : a ~> c) (i : Isomorphic a b) :
  f \\o #i === g -> f === g \\o #i⁻¹.
Proof.
  move=> H.
  rewrite -H.
  rewrite associativity.                    (* assoc の定義がオリジナルと異なる。 *)
  rewrite iso_comp2 right_identity.         (* あとは、少し証明が変わる。 *)
  reflexivity.
Qed.

Lemma iso_shift_left `{C : Category} {a b c : C}
      (f : a ~> b) (g : a ~> c) (i : Isomorphic c b) :
  #i⁻¹ \\o f === g -> f === #i \\o g.
Proof.
  move=> H.
  rewrite -H -associativity iso_comp2 left_identity.
  reflexivity.
Qed.

Lemma iso_shift_left' `{C : Category} {a b c : C}
      (f : a ~> b) (g : a ~> c) (i : Isomorphic b c) :
  #i \\o f === g -> f === #i⁻¹ \\o g.
Proof.
  move=> H.
  rewrite -H -associativity iso_comp1 left_identity.
  reflexivity.
Qed.

(* 圏Cの対象aとbに対して、a,bの同型（同型射 a ~> b）が同じなら、
b,aの同型（同型射 b ~> a）も同じである。 *)
Lemma isos_forward_equal_then_backward_equal `{C : Category} {a b : C}
      (i1 i2 : Isomorphic a b)  :  #i1 === #i2 ->  #i1⁻¹ === #i2⁻¹.
Proof.
  move=> H.
  rewrite -[#i1 ⁻¹]left_identity.
  rewrite -(iso_comp1 i2).
  rewrite associativity.
  rewrite -H.
  rewrite (iso_comp2 i1).
  rewrite right_identity.
  rewrite /=.
  reflexivity.
Qed.

(* 圏Cの対象aとbに対して、a,bの同型（同型射 a ~> b）の逆の逆は同じ *)
Lemma iso_inv_inv `{C : Category} {a b : C} (i : Isomorphic a b) :
  #(i⁻¹)⁻¹ === #i.
Proof.
  rewrite /iso_inv /=.
  reflexivity.
Qed.

(* the next four lemmas are handy for setoid_rewrite; they let you
avoid having to get the associativities right *)

Lemma iso_comp2_right  `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : b ~> c) :
  g \\o iso_forward i \\o iso_backward i === g.
Proof.
  rewrite associativity.
  rewrite iso_comp2.
  rewrite right_identity.
  reflexivity.
Qed.

Lemma iso_comp2_left `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : c ~> b) :
  iso_forward i \\o (iso_backward i \\o g)  === g.
Proof.
  rewrite -associativity.
  rewrite iso_comp2.
  rewrite left_identity.
  reflexivity.
Qed.

Lemma iso_comp1_right `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : a ~> c) :
  g \\o iso_backward i \\o iso_forward i === g.
Proof.
  rewrite associativity.
  rewrite iso_comp1.
  rewrite right_identity.
  reflexivity.
Qed.

Lemma iso_comp1_left `{C : Category} {a b c : C} (i : Isomorphic a b)  (g : c ~> a) :
  iso_backward i \\o (iso_forward i \\o g)  === g.
Proof.
  rewrite -associativity.
  rewrite iso_comp1.
  rewrite left_identity.
  reflexivity.
Qed.

(* END *)


(* ** Axiomatisation just using membership *)

Require Export Undecidability.FOL.Syntax.Core.
Require Export Undecidability.FOL.Semantics.Tarski.FullFacts.
Require Export Undecidability.FOL.Deduction.FullNDFacts.
Require Export Undecidability.FOL.Sets.Signatures.
Import Vector.VectorNotations.
Require Import List.

(* ** Minimal binary signature only containing membership, no function symbols or equality *)

#[global]
Existing Instance falsity_on.

Import BinSig.
Export BinSig.

Arguments Vector.nil {_}, _.
Arguments Vector.cons {_} _ {_} _, _ _ _ _.

Declare Scope syn'.
Open Scope syn'.

Notation "x ∈' y" := (atom sig_empty sig_binary tt ([x; y])) (at level 35) : syn'.

Definition eq' (x y : term) :=
  ∀ x`[↑] ∈' $0 ↔ y`[↑] ∈' $0.

Notation "x ≡' y" := (eq' x y) (at level 35) : syn'.

(* ** Characterisations of set operations *)

Fixpoint shift `{funcs_signature} `{preds_signature} n (t : term) :=
  match n with
  | O => t
  | S n => subst_term ↑ (shift n t)
  end.

Definition is_eset (t : term) :=
  ∀ ¬ ($0 ∈' t`[↑]).

Definition is_pair (x y t : term) :=
  ∀ $0 ∈' t`[↑] ↔ $0 ≡' x`[↑] ∨ $0 ≡' y`[↑].

Definition is_union (x t : term) :=
  ∀ $0 ∈' t`[↑] ↔ ∃ $0 ∈' shift 2 x ∧ $1 ∈' $0.

Definition sub' (x y : term) :=
  ∀ $0 ∈' x`[↑] → $0 ∈' y`[↑].

Definition is_power (x t : term) :=
  ∀ $0 ∈' t`[↑] ↔ sub' $0 x`[↑].

Definition is_sigma (x t : term) :=
  ∀ $0 ∈' t`[↑] ↔ $0 ∈' x`[↑] ∨ $0 ≡' x`[↑].

Definition is_inductive (t : term) :=
  (∃ is_eset $0 ∧ $0 ∈' t`[↑]) ∧ ∀ $0 ∈' t`[↑] → (∃ is_sigma $1 $0 ∧ $0 ∈' shift 2 t).

Definition is_om (t : term) :=
  is_inductive t ∧ ∀ is_inductive $0 → sub' t`[↑] $0.

(* ** Symbol-free axiomatisation *)

Definition ax_ext' :=
  ∀ ∀ sub' $1 $0 → sub' $0 $1 → $1 ≡' $0.

Definition ax_eq_elem' :=
  ∀ ∀ ∀ ∀ $3 ≡' $1 → $2 ≡' $0 → $3 ∈' $2 → $1 ∈' $0.

Definition ax_eset' :=
  ∃ is_eset $0.

Definition ax_pair' :=
  ∀ ∀ ∃ is_pair $2 $1 $0.

Definition ax_union' :=
  ∀ ∃ is_union $1 $0.

Definition ax_power' :=
  ∀ ∃ is_power $1 $0.

Definition ax_om' :=
  ∃ is_om $0.

Definition binZF :=
  ax_ext' :: ax_eq_elem' :: ax_eset' :: ax_pair' :: ax_union' :: ax_power' :: ax_om' :: nil.

(* ** Problems *)

(* Semantic entailment restricted to extensional models and core axioms (without sep and rep). *)

Definition entailment_binZF phi :=
  forall D (M : @interp sig_empty _ D) (rho : nat -> D), (forall psi, In psi binZF -> rho ⊨ psi) -> rho ⊨ phi.

(* Deductive entailment restricted to intuitionistic rules and core axioms (without sep and rep). *)

Definition deduction_binZF phi :=
  binZF ⊢I phi.


Require Import XR_Rle_dec.
Require Import XR_Rmax.
Require Import XR_Rle_antisym.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma Rmax_comm : forall x y:R, Rmax x y = Rmax y x.
Proof.
  intros x y.
  unfold Rmax.
  destruct (Rle_dec x y) as [ hxyl | hxyr ] ;
  destruct (Rle_dec y x) as [ hyxl | hyxr ].
  {
    apply Rle_antisym.
    { exact hyxl. }
    { exact hxyl. }
  }
  { reflexivity. }
  { reflexivity. }
  {
    apply Rle_antisym.
    {
      left.
      apply Rnot_le_lt.
      exact hyxr.
    }
    {
      left.
      apply Rnot_le_lt.
      exact hxyr.
    }
  }
Qed.


(**************************************************************)
(*   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.

From Undecidability.MinskyMachines.MM
  Require Import mm_defs.

Set Implicit Arguments.

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 "P // s -[ k ]-> t" := (sss_steps (@mm_sss _) P k s t).
Local Notation "P // s -+> t" := (sss_progress (@mm_sss _) P s t).
Local Notation "P // s ->> t" := (sss_compute (@mm_sss _) P s t).

(* ** Simulating Binary Stacks with numbers *)

Section Minsky_Machine_utils.

  Variable (n : nat).

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

  Section mm_null.

    Variable (src zero : pos n) (Hsz : src <> zero).

    Definition mm_null i := DEC src (2+i) :: DEC zero i :: nil.

    Fact mm_null_length i : length (mm_null i) = 2.
    Proof. auto. Qed.

    Let mm_null_spec i k v w : v#>src = k
                               -> v#>zero = 0
                               -> w = v[0/src]
                               -> (i,mm_null i) // (i,v) -+> (2+i,w).
    Proof.
      unfold mm_null.
      revert v w.
      induction k as [ | k IHk ]; intros v w H1 H2 H3; subst w.

      mm sss DEC zero with src (2+i).
      mm sss stop; f_equal.
      apply vec_pos_ext; intros z; dest z src.

      mm sss DEC S with src (2+i) k.
      mm sss DEC zero with zero i; rew vec.
      apply sss_progress_compute.
      apply IHk; rew vec.
    Qed.

    Fact mm_null_progress i v st :
             v#>zero = 0
          -> st = (2+i,v[0/src])
          -> (i,mm_null i) // (i,v) -+> st.
    Proof using Hsz.
      intros; subst.
      apply mm_null_spec with (1 := eq_refl); auto.
    Qed.

  End mm_null.

  Hint Rewrite mm_null_length : length_db.

  Section mm_nullify.

    (* Make every register in the list lr become 0 *)

    Variable (zero : pos n).

    Fixpoint mm_nullify i lr :=
      match lr with
        | nil   => nil
        | x::lr => mm_null x zero i ++ mm_nullify (2+i) lr
      end.

    Fact mm_nullify_length i lr : length (mm_nullify i lr) = 2*length lr.
    Proof.
      revert i; induction lr as [ | x lr IH ]; simpl; intros i; auto.
      rewrite IH; lia.
    Qed.

    Fact mm_nullify_compute i lr v w :
            v#>zero = 0
         -> (forall p, In p lr -> p <> zero)
         -> (forall p, In p lr -> w#>p = 0)
         -> (forall p, ~ In p lr -> w#>p = v#>p)
         -> (i,mm_nullify i lr) // (i,v) ->> (length (mm_nullify i lr)+i,w).
    Proof.
      rewrite mm_nullify_length.
      revert i v w; induction lr as [ | x lr IH ]; intros i v w H1 H2 H3 H4.

      mm sss stop; f_equal.
      apply vec_pos_ext; intros; rewrite H4; auto.

      rew length.
      unfold mm_nullify; fold mm_nullify.
      apply sss_compute_trans with (2+i,v[0/x]).
      apply subcode_sss_compute with (P := (i,mm_null x zero i)); auto.
      apply sss_progress_compute, mm_null_progress; auto.
      apply H2; left; auto.

      apply subcode_sss_compute with (P := (2+i,mm_nullify (2+i) lr)).
      subcode_tac; solve list eq.
      replace (2*S (length lr)+i) with (2*(length lr)+(2+i)) by lia.
      apply IH.
      specialize (H2 x (or_introl eq_refl)); rew vec.
      intros; apply H2; right; auto.
      intros; apply H3; right; auto.
      intros p Hp.
      dest p x.
      apply H3; left; auto.
      apply H4; intros [|]; auto.
    Qed.

  End mm_nullify.

  Section mm_zeroify.

    Variable (zero : pos n) (i : nat).

    Let c p := if pos_eq_dec p zero then false else true.
    Let l := filter c (pos_list n).

    Definition mm_zeroify := mm_nullify zero i l ++ DEC zero 0 :: nil.

    Fact mm_zeroify_spec v : v#>zero = 0 -> (i,mm_zeroify) // (i,v) -+> (0,vec_zero).
    Proof.
      intros H; unfold mm_zeroify.
      apply sss_compute_progress_trans with (length (mm_nullify zero i l)+i,vec_zero).
      + apply subcode_sss_compute with (P := (i,mm_nullify zero i l)); auto.
        apply mm_nullify_compute; auto; unfold l; intros p; rewrite filter_In; unfold c;
          destruct (pos_eq_dec p zero); subst; auto.
        all: try rewrite vec_zero_spec; try rewrite H; auto.
        * intros []; easy.
        * intros []; split; auto; apply pos_list_prop.
      + mm sss DEC zero with zero 0; auto.
        * now rewrite vec_zero_spec.
        * mm sss stop.
    Qed.

  End mm_zeroify.

  Section transfert.

    Variables (src dst zero : pos n).

    Hypothesis (Hsd : src <> dst) (Hsz : src <> zero) (Hdz : dst <> zero).

    Definition mm_transfert i := DEC src (3+i) :: INC dst :: DEC zero i :: nil.

    Fact mm_transfert_length i : length (mm_transfert i) = 3.
    Proof. reflexivity. Qed.

    Let mm_transfert_spec i v w k x :  v#>src = k
                                    -> v#>dst = x
                                    -> v#>zero = 0
                                    -> w = v[0/src][(k+x)/dst]
                                    -> (i,mm_transfert i) // (i,v) -+> (3+i,w).
    Proof.
      unfold mm_transfert.
      revert v w x.
      induction k as [ | k IHk ]; intros v w x H1 H2 H3 H4; subst w.

      mm sss DEC zero with src (3+i).
      mm sss stop; f_equal; auto.
      apply vec_pos_ext; intros p.
      dest p dst; dest p src.

      mm sss DEC S with src (3+i) k.
      mm sss INC with dst.
      mm sss DEC zero with zero i; rew vec.
      replace (S k + x) with (k + S x) by lia.
      apply sss_progress_compute.
      apply IHk with (S x); rew vec.
      apply vec_pos_ext; intros p.
      dest p dst; dest p src.
    Qed.

    Fact mm_transfert_progress i v st :
           v#>dst = 0
        -> v#>zero = 0
        -> st = (3+i,v[0/src][(v#>src)/dst])
        -> (i,mm_transfert i) // (i,v) -+> st.
    Proof using Hdz Hsz Hsd.
      intros H1 H2 ?; subst; apply mm_transfert_spec with (1 := eq_refl) (2 := eq_refl); auto.
      rewrite H1; apply vec_pos_ext; intros p; dest p dst.
    Qed.

  End transfert.

  Hint Rewrite mm_transfert_length : length_db.

  Section div2.

    Variables (src quo rem : pos n)
              (Hsq : src <> quo) (Hsr : src <> rem) (Hqr : quo <> rem)
              (i : nat).

    Definition mm_div2 :=
      DEC src (6+i) ::
      INC rem ::
      DEC src (i+6) ::
      DEC rem (4+i) ::
      INC quo ::
      DEC rem i ::
      nil.

    Fact mm_div2_length : length mm_div2 = 6.
    Proof. reflexivity. Qed.

    Let mm_div2_spec_0 k v w :
         v#>src = 2*k -> v#>rem = 0 -> w = v[0/src][(k+(v#>quo))/quo] -> (i,mm_div2) // (i,v) -+> (6+i,w).
    Proof.
      unfold mm_div2.
      revert v w.
      induction k as [ | k IHk ]; intros v w H1 H4 H3.

      simpl in H1.
      mm sss DEC zero with src (6+i).
      mm sss stop; f_equal; subst.
      apply vec_pos_ext; intros p.
      dest p quo; dest p src.

      replace (2*S k) with (S (S (2*k))) in H1 by lia.
      mm sss DEC S with src (6+i) (S (2*k)).
      mm sss INC with rem.
      mm sss DEC S with src (i+6) (2*k); rew vec.
      mm sss DEC S with rem (4+i) (v#>rem); rew vec.
      mm sss INC with quo; rew vec.
      mm sss DEC zero with rem i; rew vec.
      apply sss_progress_compute.
      apply IHk; auto; rew vec.
      subst; apply vec_pos_ext; intros p.
      dest p quo; try lia.
      dest p src; dest p rem.
    Qed.

    Let mm_div2_spec_1 k v w :
         v#>src = 1+2*k -> v#>rem = 0 -> w = v[0/src][(k+(v#>quo))/quo][1/rem] -> (i,mm_div2) // (i,v) -+> (6+i,w).
    Proof.
      unfold mm_div2.
      revert v w.
      induction k as [ | k IHk ]; intros v w H1 H4 H3.

      simpl in H1.
      mm sss DEC S with src (6+i) 0.
      mm sss INC with rem.
      mm sss DEC zero with src (i+6); rew vec.
      mm sss stop; f_equal; try lia.
      subst; simpl.
      apply vec_pos_ext; intros p.
      dest p rem; dest p quo; dest p src.

      replace (1 + 2*S k) with (S (S (1+2*k))) in H1 by lia.
      mm sss DEC S with src (6+i) (S (1+2*k)).
      mm sss INC with rem.
      mm sss DEC S with src (i+6) (1+2*k); rew vec.
      mm sss DEC S with rem (4+i) (v#>rem); rew vec.
      mm sss INC with quo; rew vec.
      mm sss DEC zero with rem i; rew vec.
      apply sss_progress_compute.
      apply IHk; auto; rew vec.
      subst; apply vec_pos_ext; intros p.
      dest p quo; try lia.
      dest p src; dest p rem.
    Qed.

    Fact mm_div2_progress v :
           v#>quo = 0
        -> v#>rem = 0
        -> let (k,b) := div2 (v#>src)
           in  (i,mm_div2) // (i,v) -+> (6+i,v[0/src][k/quo][(if b then 1 else 0)/rem]).
    Proof using Hsr Hsq Hqr.
      intros H2 H3.
      generalize (div2_spec (v#>src)).
      destruct (div2 (v#>src)) as (k,[]); intros H4.

      apply mm_div2_spec_1 with k; auto.
      lia.
      apply vec_pos_ext; intros p.
      dest p rem; dest p quo; lia.

      apply mm_div2_spec_0 with k; auto.
      apply vec_pos_ext; intros p.
      dest p rem; dest p quo; lia.
    Qed.

    Corollary mm_div2_progress_1 v k st :
           v#>quo = 0
        -> v#>rem = 0
        -> div2 (v#>src) = (k,true)
        -> st = (6+i,v[0/src][k/quo][1/rem])
        -> (i,mm_div2) // (i,v) -+> st.
    Proof using Hsr Hsq Hqr.
      intros H2 H3 H4 ?; subst.
      generalize (mm_div2_progress _ H2 H3).
      rewrite H4; auto.
    Qed.

    Corollary mm_div2_progress_0 v k st :
           v#>quo = 0
        -> v#>rem = 0
        -> div2 (v#>src) = (k,false)
        -> st = (6+i,v[0/src][k/quo][0/rem])
        -> (i,mm_div2) // (i,v) -+> st.
    Proof using Hsr Hsq Hqr.
      intros H2 H3 H4 ?; subst.
      generalize (mm_div2_progress _ H2 H3).
      rewrite H4; auto.
    Qed.

  End div2.

  Hint Rewrite mm_div2_length : length_db.

  Section mul2.

    Variables (src dst zero : pos n)
              (Hsd : src <> dst) (Hsz : src <> zero) (Hdz : dst <> zero)
              (i : nat).

    Let dst' := dst.

    Definition mm_mul2 := DEC src (4+i) :: INC dst :: INC dst' :: DEC zero i :: nil.

    Fact mm_mul2_length : length mm_mul2 = 4.
    Proof. reflexivity. Qed.

    Let mm_mul2_spec k v w :
        v#>src = k -> v#>zero = 0 -> w = v[0/src][(2*k+(v#>dst))/dst] -> (i,mm_mul2) // (i,v) -+> (4+i,w).
    Proof.
      unfold mm_mul2.
      revert v w; induction k as [ | k IHk ]; intros v w H1 H2 H3.

      mm sss DEC zero with src (4+i).
      mm sss stop; f_equal; subst.
      apply vec_pos_ext; intros p.
      dest p dst; dest p src.

      mm sss DEC S with src (4+i) k.
      mm sss INC with dst.
      mm sss INC with dst'.
      mm sss DEC zero with zero i; rew vec.
      unfold dst'; rew vec.
      apply sss_progress_compute.
      apply IHk; unfold dst'; rew vec.
      subst; apply vec_pos_ext; intros p.
      dest p dst.
      lia.
      dest p src.
    Qed.

    Fact mm_mul2_progress v st :
         v#>dst = 0
      -> v#>zero = 0
      -> st = (4+i,v[0/src][(2*(v#>src))/dst])
      -> (i,mm_mul2) // (i,v) -+> st.
    Proof using Hsz Hsd Hdz.
      intros H1 H2 ?; subst.
      apply mm_mul2_spec with (1 := eq_refl); auto.
      rewrite H1; f_equal; lia.
    Qed.

  End mul2.

  Hint Rewrite mm_mul2_length : length_db.

  Fixpoint stack_enc (s : list bool) : nat :=
    match s with
      | nil     => 1
      | One::s  => 1+2*stack_enc s
      | Zero::s =>   2*stack_enc s
    end.

  Fact stack_enc_S s : { k | stack_enc s = S k }.
  Proof.
    induction s as [ | [] s (k & Hk) ].
    + exists 0; auto.
    + exists (2*stack_enc s); auto.
    + exists (S (2*k)); simpl; lia.
  Qed.

  Section push.

    Variables (src tmp zero : pos n)
              (Hst : src <> tmp) (Hsz : src <> zero) (Htz : tmp <> zero)
              (i : nat).

    Definition mm_push_Zero :=
      mm_transfert src tmp zero i ++ mm_mul2 tmp src zero (3+i).

    Fact mm_push_Zero_length : length mm_push_Zero = 7.
    Proof. reflexivity. Qed.

    Fact mm_push_Zero_progress s v :
         v#>tmp  = 0
      -> v#>zero = 0
      -> v#>src  = stack_enc s
      -> (i,mm_push_Zero) // (i,v) -+> (7+i,v[(stack_enc (Zero::s))/src]).
    Proof using Htz Hsz Hst.
      intros H1 H2 H3.
      unfold mm_push_Zero.
      apply sss_progress_trans with (st2 := (3+i,v[0/src][(v#>src)/tmp])).
      apply subcode_sss_progress with (P := (i,mm_transfert src tmp zero i)); auto.
      apply mm_transfert_progress; auto.
      apply subcode_sss_progress with (P := (3+i,mm_mul2 tmp src zero (3 + i))); auto.
      apply mm_mul2_progress; auto; rew vec.
      f_equal.
      apply vec_pos_ext; intros p.
      dest p src.
      rewrite H3; auto.
      dest p tmp.
    Qed.

    Definition mm_push_One := mm_push_Zero ++ INC src :: nil.

    Hint Rewrite mm_push_Zero_length : length_db.

    Fact mm_push_One_length : length mm_push_One = 8.
    Proof. reflexivity. Qed.

    Fact mm_push_One_progress s v :
         v#>tmp  = 0
      -> v#>zero = 0
      -> v#>src  = stack_enc s
      -> (i,mm_push_One) // (i,v) -+> (8+i,v[(stack_enc (One::s))/src]).
    Proof using Htz Hsz Hst.
      intros H1 H2 H3.
      unfold mm_push_One.
      apply sss_progress_trans with (7+i,v[(stack_enc (Zero::s))/src]).
      apply subcode_sss_progress with (P := (i,mm_push_Zero)); auto.
      apply mm_push_Zero_progress; auto.
      mm sss INC with src.
      mm sss stop; f_equal; auto.
      apply vec_pos_ext; intros p.
      dest p src.
    Qed.

  End push.

  Hint Rewrite mm_push_Zero_length mm_push_One_length : length_db.

  Section pop.

    (*

      div2 n a1 a2 addr1 addr2, suppose a1 = 0 et a2 = 0

      H 001001 B -> 001001_1 -> 0 + 01001_1 || 2*n + 0 -> 0 & n si n <> 0
      H 101001 B -> 101001_1 -> 1 + 01001_1 || 2*n + 1 -> 1 & n si n <> 0
      H ø      B -> ø_1      -> ERROR       || n = 0 (impossible) et n = 1 error

    *)

    Variables (src tmp1 tmp2 zero : pos n)
              (Hs1 : src <> tmp1) (Hs2 : src <> tmp2) (Hsz : src <> zero)
              (H12 : tmp1 <> tmp2) (H1z : tmp1 <> zero) (H2z : tmp2 <> zero)
              (i j k e : nat).
     (* e is jump when stack is empty *)
     (* j is jump when pop gives a Zero *)
     (* k is jump when pop gives a One *)

    Let src' := src.

    Definition mm_pop :=
    (*     i *)  mm_transfert src tmp1 tmp2 i ++
    (*   3+i *)  mm_div2 tmp1 src tmp2 (3+i) ++
    (*   9+i *)  DEC src (13+i) ::
    (*  10+i *)  INC src ::
    (*  11+i *)  DEC tmp2 j ::
    (*  12+i *)  DEC tmp1 k ::
    (*  13+i *)  DEC tmp2 k ::
    (*  14+i *)  INC src' ::
    (*  15+i *)  DEC tmp2 e ::
                 nil.

    Fact mm_pop_length : length mm_pop = 16.
    Proof. reflexivity. Qed.

    Fact mm_pop_void_progress v :
         v#>tmp1 = 0
      -> v#>tmp2 = 0
      -> v#>src  = stack_enc nil
      -> (i,mm_pop) // (i,v) -+> (e,v).
    Proof using Hs1 Hs2 H12.
      unfold mm_pop.
      intros H1 H2 H4; simpl in H4.

      apply sss_progress_trans with (3+i,v[0/src][1/tmp1]).
      apply subcode_sss_progress with (P := (i,mm_transfert src tmp1 tmp2 i)); auto.
      apply mm_transfert_progress; auto; f_equal.
      rewrite H4; auto.

      apply sss_progress_trans with (9+i,v[0/tmp1][0/src][1/tmp2]).
      apply subcode_sss_progress with (P := (3+i,mm_div2 tmp1 src tmp2 (3 + i))); auto.
      apply mm_div2_progress_1 with (k := 0); auto; rew vec.
      f_equal.
      apply vec_pos_ext; intros p.
      dest p tmp2; dest p src; dest p tmp1.

      mm sss DEC zero with src (13+i); rew vec.
      mm sss DEC S with tmp2 k 0; rew vec.
      mm sss INC with src'; unfold src'; rew vec.
      mm sss DEC zero with tmp2 e; rew vec.
      mm sss stop; f_equal.
      apply vec_pos_ext; intros p.
      dest p tmp2; dest p src; dest p tmp1.
    Qed.

    Fact mm_pop_Zero_progress v s:
         v#>tmp1 = 0
      -> v#>tmp2 = 0
      -> v#>src  = stack_enc (Zero::s)
      -> (i,mm_pop) // (i,v) -+> (j,v[(stack_enc s)/src]).
    Proof using Hs1 Hs2 H12.
      unfold mm_pop.
      intros H1 H2 H4; unfold stack_enc in H4; fold stack_enc in H4.

      apply sss_progress_trans with (3+i,v[0/src][(2*stack_enc s)/tmp1]).
      apply subcode_sss_progress with (P := (i,mm_transfert src tmp1 tmp2 i)); auto.
      apply mm_transfert_progress; auto; f_equal.
      rewrite H4; auto.

      apply sss_progress_trans with (9+i,v[0/tmp1][(stack_enc s)/src][0/tmp2]).
      apply subcode_sss_progress with (P := (3+i,mm_div2 tmp1 src tmp2 (3 + i))); auto.
      apply mm_div2_progress_0 with (k := stack_enc s); auto; rew vec.
      rewrite div2_2p0; auto.
      f_equal.
      apply vec_pos_ext; intros p.
      dest p tmp2; dest p src; dest p tmp1.

      destruct (stack_enc_S s) as (q & Hq).
      mm sss DEC S with src (13+i) q; rew vec.
      mm sss INC with src; rew vec.
      mm sss DEC zero with tmp2 j; rew vec.
      mm sss stop; f_equal.
      apply vec_pos_ext; intros p.
      dest p src; dest p tmp2; dest p tmp1.
    Qed.

    Fact mm_pop_One_progress v s:
         v#>tmp1 = 0
      -> v#>tmp2 = 0
      -> v#>src  = stack_enc (One::s)
      -> (i,mm_pop) // (i,v) -+> (k,v[(stack_enc s)/src]).
    Proof using Hs1 Hs2 H12.
      unfold mm_pop.
      intros H1 H2 H4; unfold stack_enc in H4; fold stack_enc in H4.

      apply sss_progress_trans with (3+i,v[0/src][(2*stack_enc s+1)/tmp1]).
      apply subcode_sss_progress with (P := (i,mm_transfert src tmp1 tmp2 i)); auto.
      apply mm_transfert_progress; auto; f_equal.
      rewrite H4; f_equal; lia.

      apply sss_progress_trans with (9+i,v[0/tmp1][(stack_enc s)/src][1/tmp2]).
      apply subcode_sss_progress with (P := (3+i,mm_div2 tmp1 src tmp2 (3 + i))); auto.
      apply mm_div2_progress_1 with (k := stack_enc s); auto; rew vec.
      rewrite div2_2p1; auto.
      f_equal.
      apply vec_pos_ext; intros p.
      dest p tmp2; dest p src; dest p tmp1.

      destruct (stack_enc_S s) as (q & Hq).
      mm sss DEC S with src (13+i) q; rew vec.
      mm sss INC with src; rew vec.
      mm sss DEC S with tmp2 j 0; rew vec.
      mm sss DEC zero with tmp1 k; rew vec.
      mm sss stop; f_equal.
      apply vec_pos_ext; intros p.
      dest p src; dest p tmp2; dest p tmp1.
    Qed.

  End pop.

End Minsky_Machine_utils.

#[export] Hint Rewrite mm_push_Zero_length mm_push_One_length mm_pop_length : length_db.


Require Import Coq.Lists.List.
Require Import Rewriter.Util.PrimitiveProd.

Import Primitive.Notations.

Fixpoint hlist {A} (P : A -> Type) (ls : list A) : Type
  := match ls return Type with
     | nil => unit
     | cons x xs => P x * @hlist A P xs
     end%type.
Fixpoint split_list {A P} (ls : list (@sigT A P)) : { ls : list A & hlist P ls }
  := match ls with
     | nil => existT _ nil tt
     | cons x xs => let 'existT ls' hls' := @split_list A P xs in existT _ (cons (projT1 x) ls') (projT2 x, hls')
     end.
Fixpoint combine_hlist {A P} (ls : list A) : hlist P ls -> list (@sigT A P)
  := match ls return hlist P ls -> _ with
     | nil => fun _ => nil
     | cons x xs => fun '(Px, Pxs) => existT P x Px :: @combine_hlist A P xs Pxs
     end.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require real.Real.
Require real.RealInfix.

Parameter pow2: Z -> R.

Axiom Power_0 : ((pow2 0%Z) = 1%R).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p : forall (n:Z), (n <= 0%Z)%Z ->
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_s_all : forall (n:Z), ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p_all : forall (n:Z),
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_1_2 : ((05 / 10)%R = (Rdiv 1%R 2%R)%R).

Axiom Power_1 : ((pow2 1%Z) = 2%R).

Axiom Power_neg1 : ((pow2 (-1%Z)%Z) = (05 / 10)%R).

Axiom Power_non_null_aux : forall (n:Z), (0%Z <= n)%Z -> ~ ((pow2 n) = 0%R).

Axiom Power_neg_aux : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (-n)%Z) = (Rdiv 1%R (pow2 n))%R).

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 2.
Open Scope Z_scope.

(* Why3 goal *)
Theorem Power_non_null : forall (n:Z), ~ ((pow2 n) = 0%R).
intro n.
assert (h:n>=0 \/ n<0) by omega.
destruct h.
ae.
pose (n':=-n).
assert (Hn': n' > 0) by (subst n'; omega).
replace n with (-n') by (subst n'; omega).
rewrite Power_neg_aux; auto with zarith.
unfold Rdiv.
rewrite Rmult_1_l.
apply Rinv_neq_0_compat.
ae.
Qed.


Require Export RTopology ProductTopology Homeomorphisms.
Require Import ContinuousFactorization.
From Coq Require Import FunctionalExtensionality Lra ProofIrrelevance.
From ZornsLemma Require Import EnsembleProduct EnsemblesTactics.

Lemma continuous_at_iff_continuity_pt
  {f : R -> R} {x : R} :
  @continuous_at RTop RTop f x <-> continuity_pt f x.
Proof.
split.
- intros H eps H0.
  assert (neighbourhood (inverse_image f [r : R | Rabs (r - f x) < eps]) x) as H1.
  { apply RTop_neighborhood_is_neighbourhood, H, open_neighborhood_is_neighborhood.
    split.
    - replace [r : R | Rabs (r - f x) < eps] with [r : R | f x - eps < r < f x + eps]
        by (extensionality_ensembles;
            constructor;
            apply Rabs_def1 + apply Rabs_def2 in H1;
            lra).
      apply R_interval_open.
    - constructor.
      apply Rabs_def1; lra.
  }
  destruct H1 as [[alp H1] H2].
  exists alp.
  split; trivial.
  intros x0 [? H3].
  now destruct (H2 _ H3) as [[?]].
- intros H U HU.
  apply RTop_neighborhood_is_neighbourhood.
  pose HU as H0.
  apply RTop_neighborhood_is_neighbourhood in H0.
  destruct H0 as [[eps H0] H1],
          (H eps H0) as [alp [H2 H3]].
  exists (mkposreal alp H2).
  intros x' H'.
  constructor.
  destruct (Req_dec x x').
  + subst.
    destruct HU as [V [[H4 H5] H6]].
    now apply H6.
  + now apply H1, H3.
Qed.

Lemma continuous_iff_continuity
  {f : R -> R} :
  @continuous RTop RTop f <-> continuity f.
Proof.
split;
  intros H ?.
- now apply continuous_at_iff_continuity_pt,
      continuous_func_continuous_everywhere.
- apply pointwise_continuity.
  intro.
  now apply continuous_at_iff_continuity_pt.
Qed.

Lemma Rplus_continuous: continuous_2arg Rplus (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
apply pointwise_continuity_2arg.
intros.
red.
pose proof (RTop_metrization (x+y)).
apply continuous_at_neighborhood_basis with
  (metric_topology_neighborhood_basis R_metric (x+y)).
- apply open_neighborhood_basis_is_neighborhood_basis,
        RTop_metrization.
- intros.
  destruct H0.
  exists (EnsembleProduct (open_ball R_metric x (r/2))
                     (open_ball R_metric y (r/2))).
  repeat split;
    try (rewrite metric_zero; apply R_metric_is_metric + lra).
  + apply ProductTopology2_basis_is_basis.
    constructor;
      apply metric_space_open_ball_open;
      auto using RTop_metrization, R_metric_is_metric.
  + destruct x0 as [x' y'],
             H1 as [[] []].
    unfold R_metric.
    simpl.
    replace (x'+y' - (x+y)) with ((x'-x) + (y'-y)) by ring.
    apply Rle_lt_trans with (Rabs (x'-x) + Rabs(y'-y)).
    * apply Rabs_triang.
    * replace r with (r/2+r/2) by field.
      now apply Rplus_lt_compat.
Qed.

Corollary sum_continuous: forall (X:TopologicalSpace)
  (f g:point_set X -> point_set RTop) (x:point_set X),
  continuous_at f x -> continuous_at g x ->
  continuous_at (fun x:point_set X => f x + g x) x (Y:=RTop).
Proof.
intros.
apply continuous_composition_at_2arg; trivial.
apply continuous_func_continuous_everywhere,
      Rplus_continuous.
Qed.

(* Ropp_continuous was already proved in RTopology *)

Lemma Rminus_continuous: continuous_2arg Rminus
  (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
unfold Rminus.
apply pointwise_continuity_2arg; intros.
red.
pose proof (sum_continuous _
  (fun p:point_set (ProductTopology2 RTop RTop) => fst p)
  (fun p:point_set (ProductTopology2 RTop RTop) => -snd p) (x,y)).
simpl in H.
match goal with |- continuous_at ?f ?q =>
  replace f with (fun p:R*R => fst p + - snd p) end.
- apply sum_continuous.
  + apply continuous_func_continuous_everywhere,
          product2_fst_continuous.
  + eapply (continuous_composition_at (Y:=RTop));
      apply continuous_func_continuous_everywhere.
    * apply Ropp_continuous.
    * apply product2_snd_continuous.
- extensionality p.
  now destruct p.
Qed.

Corollary diff_continuous: forall (X:TopologicalSpace)
  (f g:point_set X -> point_set RTop) (x:point_set X),
  continuous_at f x -> continuous_at g x ->
  continuous_at (fun x:point_set X => f x - g x) x (Y:=RTop).
Proof.
intros.
apply continuous_composition_at_2arg; trivial.
apply continuous_func_continuous_everywhere.
exact Rminus_continuous.
Qed.

Lemma const_multiple_func_continuous: forall c:R,
  continuous (fun x:R => c*x) (X:=RTop) (Y:=RTop).
Proof.
intros.
apply continuous_iff_continuity,
      continuity_mult.
- apply continuity_const.
  red.
  now intros.
- intro.
  apply derivable_continuous_pt, derivable_pt_id.
Qed.

Corollary const_multiple_continuous: forall (X:TopologicalSpace)
  (f:point_set X -> point_set RTop) (c:R) (x:point_set X),
  continuous_at f x -> continuous_at (fun x:point_set X => c * f x) x
                       (Y:=RTop).
Proof.
intros.
apply continuous_composition_at; trivial.
apply continuous_func_continuous_everywhere,
      const_multiple_func_continuous.
Qed.

Lemma Rmult_continuous_at_origin: continuous_at_2arg Rmult 0 0
                                  (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
red.
pose proof (RTop_metrization 0).
apply continuous_at_neighborhood_basis with
  (metric_topology_neighborhood_basis R_metric 0).
- apply open_neighborhood_basis_is_neighborhood_basis.
  simpl. rewrite Rmult_0_r.
  assumption.
- intros.
  destruct H0.
  exists (EnsembleProduct (open_ball R_metric 0 r)
                     (open_ball R_metric 0 1)).
  repeat split; try (rewrite metric_zero; apply R_metric_is_metric + lra).
  + apply ProductTopology2_basis_is_basis.
    constructor;
      apply metric_space_open_ball_open;
      auto using RTop_metrization, R_metric_is_metric.
  + destruct x as [x y],
             H1 as [[] []].
    unfold R_metric in *.
    simpl.
    rewrite Rminus_0_r in *.
    rewrite Rabs_mult.
    replace r with (r*1) by auto with real.
    apply Rmult_le_0_lt_compat;
      apply Rabs_pos + trivial.
Qed.

Lemma Rmult_continuous: continuous_2arg Rmult (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
apply pointwise_continuity_2arg.
intros x0 y0.
red.
match goal with
  |- continuous_at ?f ?q =>
    replace f with
    (fun p:point_set RTop*point_set RTop =>
       (fst p - x0) * (snd p - y0) +
         y0 * fst p +
         x0 * snd p -
         x0 * y0)
end.
2: {
  extensionality p.
  destruct p.
  simpl.
  ring.
}
apply diff_continuous.
2: {
  apply continuous_func_continuous_everywhere;
    apply continuous_constant.
}
apply sum_continuous.
2: {
  apply const_multiple_continuous,
    continuous_func_continuous_everywhere;
  apply product2_snd_continuous.
}
apply sum_continuous.
2: {
  apply const_multiple_continuous,
    continuous_func_continuous_everywhere;
  apply product2_fst_continuous.
}
apply continuous_composition_at_2arg with RTop RTop.
- simpl.
  replace (x0-x0) with 0 by ring.
  replace (y0-y0) with 0 by ring.
  apply Rmult_continuous_at_origin.
- apply diff_continuous;
    apply continuous_func_continuous_everywhere;
    apply product2_fst_continuous + apply continuous_constant.
- apply diff_continuous;
    apply continuous_func_continuous_everywhere;
    apply product2_snd_continuous + apply continuous_constant.
Qed.

Corollary product_continuous: forall (X:TopologicalSpace)
  (f g:point_set X -> point_set RTop) (x:point_set X),
  continuous_at f x -> continuous_at g x ->
  continuous_at (fun x:point_set X => f x * g x) x (Y:=RTop).
Proof.
intros.
apply continuous_composition_at_2arg; trivial.
apply continuous_func_continuous_everywhere.
exact Rmult_continuous.
Qed.

Lemma Rinv_continuous (x : R) :
  x <> 0 -> @continuous_at RTop RTop Rinv x.
Proof.
intros.
apply continuous_at_iff_continuity_pt,
      continuity_pt_inv; trivial.
apply derivable_continuous_pt, derivable_pt_id.
Qed.

Lemma Rdiv_continuous: forall x y:R, y <> 0 ->
  continuous_at_2arg Rdiv x y (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
intros.
red.
match goal with |- continuous_at ?f ?q => replace f with
  (fun p:point_set RTop * point_set RTop => fst p * / snd p) end.
- apply product_continuous.
  + apply continuous_func_continuous_everywhere;
      apply product2_fst_continuous.
  + apply continuous_composition_at.
    * simpl.
      now apply Rinv_continuous.
    * apply continuous_func_continuous_everywhere;
        apply product2_snd_continuous.
- extensionality p.
  now destruct p.
Qed.

Corollary quotient_continuous: forall (X:TopologicalSpace)
  (f g:point_set X -> point_set RTop) (x0:point_set X),
  continuous_at f x0 -> continuous_at g x0 -> g x0 <> 0 ->
  continuous_at (fun x:point_set X => f x / g x) x0 (Y:=RTop).
Proof.
intros.
apply continuous_composition_at_2arg; trivial.
apply Rdiv_continuous; trivial.
Qed.

Lemma Rabs_continuous: continuous Rabs (X:=RTop) (Y:=RTop).
Proof.
apply pointwise_continuity.
intros.
apply metric_space_fun_continuity with R_metric R_metric;
  try apply RTop_metrization.
intros.
exists eps; split; trivial.
intros.
apply Rle_lt_trans with (2 := H0).
apply Rabs_triang_inv2.
Qed.

Lemma open_interval_homeomorphic_to_real_line:
  let U:=characteristic_function_to_ensemble
      (fun x:point_set RTop => -1 < x < 1) in
  homeomorphic RTop (SubspaceTopology U).
Proof.
intros.
assert (forall x:R, -1 < x / (1 + Rabs x) < 1).
{ intros.
  assert (0 < 1 + Rabs x).
  { pose proof (Rabs_pos x). lra. }
  apply and_comm, Rabs_def2.
  unfold Rdiv.
  rewrite Rabs_mult, Rabs_Rinv.
  - rewrite (Rabs_right (1 + Rabs x)); [ | now left ].
    pattern 1 at 2.
    replace 1 with ((1 + Rabs x) * / (1 + Rabs x)) by (field; lra).
    apply Rmult_lt_compat_r.
    + now apply Rinv_0_lt_compat.
    + lra.
  - lra. }
assert (forall x:point_set RTop, In U (x / (1 + Rabs x))).
{ intros.
  now constructor. }
exists (continuous_factorization _ _ H0).
exists (fun x => (subspace_inc U x) / (1 - Rabs (subspace_inc U x))).
- apply factorization_is_continuous.
  apply pointwise_continuity.
  intros.
  apply quotient_continuous.
  + apply continuous_func_continuous_everywhere, continuous_identity.
  + apply sum_continuous.
    * apply continuous_func_continuous_everywhere, continuous_constant.
    * apply continuous_func_continuous_everywhere, Rabs_continuous.
  + pose proof (Rabs_pos x).
    lra.
- apply pointwise_continuity.
  intros.
  apply quotient_continuous.
  + apply continuous_func_continuous_everywhere, subspace_inc_continuous.
  + apply diff_continuous.
    * apply continuous_func_continuous_everywhere, continuous_constant.
    * apply continuous_composition_at.
      -- apply continuous_func_continuous_everywhere, Rabs_continuous.
      -- apply continuous_func_continuous_everywhere, subspace_inc_continuous.
  + destruct x as [x [[]]]. simpl.
    cut (Rabs x < 1).
    * lra.
    * apply Rabs_def1; lra.
- simpl.
  intros.
  unfold Rabs at 1 3. destruct Rcase_abs.
  + rewrite Rabs_left.
    * field.
      lra.
    * assert (/ (1 + -x) > 0).
      { apply Rinv_0_lt_compat.
        lra. }
      replace 0 with (x*0) by auto with real.
      now apply Rmult_lt_gt_compat_neg_l.
  + rewrite Rabs_right.
    * field.
      lra.
    * assert (/ (1+x) > 0).
      { apply Rinv_0_lt_compat.
        lra. }
      apply Rle_ge.
      apply Rge_le in r.
      red in H1.
      unfold Rdiv.
      replace 0 with (0 * / (1+x)); auto with real.
- intros.
  destruct y as [x].
  simpl.
  apply subset_eq_compat.
  destruct i.
  destruct H1.
  assert (Rabs x < 1) by now apply Rabs_def1.
  unfold Rabs at 1 3. destruct Rcase_abs.
  + rewrite Rabs_left.
    * field.
      lra.
    * replace (1 - -x) with (1+x) by ring.
      assert (/ (1+x) > 0).
      { apply Rinv_0_lt_compat. lra. }
      unfold Rdiv.
      replace 0 with (x*0) by auto with real.
      now apply Rmult_lt_gt_compat_neg_l.
  + rewrite Rabs_right.
    * field.
      lra.
    * assert (/ (1-x) > 0) by
        now apply Rinv_0_lt_compat, Rgt_minus.
      unfold Rdiv.
      red in H4.
      apply Rge_le in r.
      apply Rle_ge.
      replace 0 with (0 * / (1-x)); auto with real.
Qed.

Lemma Rmin_using_Rabs x y :
  Rmin x y = (x + y - Rabs (x-y))*(1/2).
Proof.
  destruct (classic (x <= y)).
  - rewrite Rmin_left; try assumption.
    rewrite Rabs_minus_sym.
    rewrite Rabs_pos_eq.
    2: { lra. }
    lra.
  - rewrite Rmin_right; try lra.
    rewrite Rabs_pos_eq.
    2: { lra. }
    lra.
Qed.

Lemma Rmax_using_Rabs x y :
  Rmax x y = (x + y + Rabs (x-y))*(1/2).
Proof.
  destruct (classic (x <= y)).
  - rewrite Rmax_right; try assumption.
    rewrite Rabs_minus_sym.
    rewrite Rabs_pos_eq.
    2: { lra. }
    lra.
  - rewrite Rmax_left; try lra.
    rewrite Rabs_pos_eq.
    2: { lra. }
    lra.
Qed.

Lemma Rmin_continuous : continuous_2arg Rmin (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
  red.
  replace (fun p : RTop * RTop => _) with
      (fun p : RTop * RTop => ((fst p) + (snd p) - Rabs (fst p - snd p))*(1/2)).
  2: {
    apply functional_extensionality.
    intros []. simpl.
    symmetry. apply Rmin_using_Rabs.
  }
  apply @continuous_composition_2arg with (X := RTop) (Y := RTop).
  2: { apply continuous_constant. }
  2: { apply Rmult_continuous. }
  apply @continuous_composition_2arg with (X := RTop) (Y := RTop).
  3: { apply Rminus_continuous. }
  - apply @continuous_composition_2arg with (X := RTop) (Y := RTop).
    + apply product2_fst_continuous.
    + apply product2_snd_continuous.
    + apply Rplus_continuous.
  - apply @continuous_composition with (Y := RTop).
    { apply Rabs_continuous. }
    apply @continuous_composition_2arg with (X := RTop) (Y := RTop).
    + apply product2_fst_continuous.
    + apply product2_snd_continuous.
    + apply Rminus_continuous.
Qed.

Lemma Rmax_continuous : continuous_2arg Rmax (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
  red.
  replace (fun p : RTop * RTop => _) with
      (fun p : RTop * RTop => ((fst p) + (snd p) + Rabs (fst p - snd p))*(1/2)).
  2: {
    apply functional_extensionality.
    intros []. simpl.
    symmetry. apply Rmax_using_Rabs.
  }
  apply @continuous_composition_2arg with (X := RTop) (Y := RTop).
  2: { apply continuous_constant. }
  2: { apply Rmult_continuous. }
  apply @continuous_composition_2arg with (X := RTop) (Y := RTop).
  3: { apply Rplus_continuous. }
  - apply @continuous_composition_2arg with (X := RTop) (Y := RTop).
    + apply product2_fst_continuous.
    + apply product2_snd_continuous.
    + apply Rplus_continuous.
  - apply @continuous_composition with (Y := RTop).
    { apply Rabs_continuous. }
    apply @continuous_composition_2arg with (X := RTop) (Y := RTop).
    + apply product2_fst_continuous.
    + apply product2_snd_continuous.
    + apply Rminus_continuous.
Qed.

Corollary cos_continuous : @continuous RTop RTop cos.
Proof.
  apply continuous_iff_continuity.
  apply continuity_cos.
Qed.

Corollary sin_continuous : @continuous RTop RTop sin.
Proof.
  apply continuous_iff_continuity.
  apply continuity_sin.
Qed.


Set Implicit Arguments.

Require Import List  Image.

CoInductive LList (A:Type) : Type :=
  | LNil : LList A
  | LCons : A -> LList A -> LList A.

Arguments LNil {A}.

Fixpoint llist_injection {A:Type} (l:list A) :  LList A :=
  match l with
  | nil => LNil
  | a :: l' => LCons a (llist_injection l')
  end.

Theorem llist_injection_inj {A:Type}:
  injective _ _ (llist_injection (A:=A)).
Proof.
 unfold injective in |- *.
 -  simple induction x; simpl in |- *.
    simple destruct y; simpl in |- *; [ auto | discriminate 1 ].
    intros a l Hl y; case y; simpl in |- *.
   +  discriminate 1.
   +  injection 1; intros e1 e2; rewrite e2; rewrite (Hl _ e1); trivial.
Qed.