(** **********************************************************

Contents:

- Construction of a substitution system from an initial algebra
- Proof that the substitution system constructed from an initial algebra is an initial substitution system

This file differs from LiftingInitial.v in the hypotheses. Here we use omega cocontinuity instead of
Kan extensions.

Written by: Anders Mörtberg, 2016 (adapted from LiftingInitial.v)

version for simplified notion of HSS by Ralph Matthes (2022, 2023)
the file is very close to the homonymous file in the parent directory
basically, the changes in SimplifiedHSS.SubstitutionSystems are propagated

************************************************************)

Set Kernel Term Sharing.

Require Import UniMath.Foundations.PartD.

Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.Chains.All.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.yoneda.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.PointedFunctors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.HorizontalComposition.
Require Import UniMath.CategoryTheory.PointedFunctorsComposition.
Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems.
Require Import UniMath.SubstitutionSystems.GenMendlerIteration_alt.
Require Import UniMath.CategoryTheory.BicatOfCatsElementary.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.

Local Open Scope cat.

Local Coercion alg_carrier : algebra_ob >-> ob.

Section category_Algebra.

Variables (C : category) (CP : BinCoproducts C).
Variables (IC : Initial C) (CC : Colims_of_shape nat_graph C).

Local Notation "'EndC'":= ([C, C]) .
Local Notation "'Ptd'" := (category_Ptd C).

Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP.
Let EndEndC := [EndC, EndC].
Let CPEndEndC:= BinCoproducts_functor_precat _ _ CPEndC: BinCoproducts EndEndC.

Let InitialEndC : Initial EndC.
Proof.
apply Initial_functor_precat, IC.
Defined.

Let Colims_of_shape_nat_graph_EndC : Colims_of_shape nat_graph EndC.
Proof.
apply ColimsFunctorCategory_of_shape, CC.
Defined.

Section fix_an_H.

  Context (H : functor [C, C] [C, C]) (HH : is_omega_cocont H).

  Definition Const_plus_H (X : EndC) : functor EndC EndC
    := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ X) H.

  Definition Id_H :  functor [C, C] [C, C]
    := Const_plus_H (functor_identity _ : EndC).

  Let Alg : precategory := FunctorAlg Id_H.

Lemma is_omega_cocont_Id_H : is_omega_cocont Id_H.
Proof.
  apply is_omega_cocont_BinCoproduct_of_functors; try apply functor_category_has_homsets.
  - apply is_omega_cocont_constant_functor.
  - apply HH.
Defined.

Definition InitAlg : Alg :=
  InitialObject (colimAlgInitial InitialEndC is_omega_cocont_Id_H (Colims_of_shape_nat_graph_EndC _)).

Definition ptdInitAlg : Ptd := ptd_from_alg InitAlg.

Section fix_a_Z.

  Context (Z : Ptd).

Lemma isInitial_pre_comp : isInitial [C, C] (ℓ (U Z) InitialEndC).
Proof.
use make_isInitial; intros F.
use tpair.
- use tpair.
  + intros c; simpl; apply InitialArrow.
  + abstract (intros x y f; cbn; apply InitialArrowEq).
- abstract (intros G; apply subtypePath;
    [ intros x; apply isaprop_is_nat_trans, homset_property
    | apply funextsec; intro c; apply InitialArrowUnique]).
Defined.

Local Lemma HU : is_omega_cocont (pre_composition_functor C C C (U Z)).
Proof.
apply is_omega_cocont_pre_composition_functor, CC.
Defined.

Definition SpecializedGMIt (X : EndC) :
  ∏ (G : functor [C, C] [C, C]) (ρ : [C, C] ⟦ G X, X ⟧)
    (θ : functor_composite Id_H (ℓ (U Z)) ⟹ functor_composite (ℓ (U Z)) G),
  ∃! h : [C, C] ⟦ ℓ (U Z) (alg_carrier _ InitAlg), X ⟧,
    # (ℓ (U Z)) (alg_map Id_H InitAlg) · h =
    θ (alg_carrier _ InitAlg) · # G h · ρ
  := SpecialGenMendlerIteration InitialEndC Colims_of_shape_nat_graph_EndC
                                Id_H is_omega_cocont_Id_H X (ℓ (U Z)) isInitial_pre_comp HU.

Context (prestrength_in_first_arg : PrestrengthForSignatureAtPoint _ _ _ H Z).

Local Lemma aux_iso_1_is_nat_trans :
   is_nat_trans
     (functor_composite Id_H (ℓ (U Z)))
     (pr1 (BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
           (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))))
     (λ X : [C, C],
      BinCoproductOfArrows [C, C]
        (CPEndC (functor_composite (U Z) (functor_identity C))
           ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z)))
        (runitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))).
Proof.
  intros X X' α.
  apply nat_trans_eq_alt; intro c; simpl.
  etrans; [ apply BinCoproductOfArrows_comp |].
  etrans; [| eapply pathsinv0, BinCoproductOfArrows_comp ]; simpl.
  repeat rewrite id_right.
  rewrite (functor_id (H X)).
  do 2 rewrite id_left.
  apply idpath.
Qed.

Definition aux_iso_1
  : EndEndC
    ⟦ functor_composite Id_H (ℓ (U Z)),
      BinCoproductObject
           (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
              (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))⟧.
Proof.
use tpair.
- intro X.
  exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (runitor_CAT (U Z))
           (nat_trans_id (θ_source H (X⊗Z):functor C C))).
- exact aux_iso_1_is_nat_trans.
Defined.

Local Lemma aux_iso_1_inv_is_nat_trans :
   is_nat_trans
     (pr1 (BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
           (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))) )
     (functor_composite Id_H (ℓ (U Z)))
     (λ X : [C, C],
      BinCoproductOfArrows [C, C]
        (CPEndC (functor_composite (functor_identity C) (U Z))
           ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z)))
        (lunitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))).
Proof.
  intros X X' α.
  apply nat_trans_eq_alt; intro c; simpl.
  etrans; [ apply BinCoproductOfArrows_comp |].
  etrans; [| eapply pathsinv0, BinCoproductOfArrows_comp ]; simpl.
  repeat rewrite id_right.
  rewrite (functor_id (H X)).
  repeat rewrite id_left.
  apply idpath.
Qed.

Local Definition aux_iso_1_inv
  : EndEndC
    ⟦ BinCoproductObject
           (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
              (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)),
      functor_composite Id_H (ℓ (U Z)) ⟧.
Proof.
use tpair.
- intro X.
  exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (lunitor_CAT (U Z))
         (nat_trans_id (θ_source H (X⊗Z):functor C C))).
- exact aux_iso_1_inv_is_nat_trans.
Defined.

Local Lemma aux_iso_2_inv_is_nat_trans :
   is_nat_trans
     (pr1 (BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
           (functor_fix_snd_arg [C, C] Ptd [C, C](θ_target H) Z))) )
     (functor_composite (ℓ (U Z))
        (Const_plus_H (U Z)))
     (λ X : [C, C],
      nat_trans_id
        (BinCoproductObject (CPEndC (U Z) ((θ_target H) (X ⊗ Z)))
         :functor C C)).
Proof.
intros X X' α.
rewrite id_left, id_right.
apply nat_trans_eq_alt; intro c; simpl.
unfold coproduct_nat_trans_data; simpl.
unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
apply (maponpaths_12 (BinCoproductOfArrows _ _ _)); try apply idpath.
unfold functor_fix_snd_arg_mor; simpl.
revert c; apply nat_trans_eq_pointwise, maponpaths.
apply nat_trans_eq_alt; intro c; simpl.
rewrite (functor_id X).
apply id_left.
Qed.

Local Definition aux_iso_2_inv
  : EndEndC
    ⟦ BinCoproductObject
         (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
                    (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)),
      functor_composite (ℓ (U Z) )   (Const_plus_H (U Z)) ⟧.
Proof.
use tpair.
- intro X.
  exact (nat_trans_id ((@BinCoproductObject EndC (U Z) (θ_target H (X⊗Z)) (CPEndC _ _) )
           : functor C C)).
- exact aux_iso_2_inv_is_nat_trans.
Defined.

Definition θ'_Thm15
  : EndEndC
    ⟦ BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
           (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)),
      BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
            (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧
  := BinCoproductOfArrows
   EndEndC (CPEndEndC _ _) (CPEndEndC _ _)
   (identity (constant_functor EndC _ (U Z): functor_category EndC EndC))
   prestrength_in_first_arg.

Definition ρ_Thm15 (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧)
  : [C, C] ⟦ BinCoproductObject (CPEndC (U Z) (H `InitAlg)), `InitAlg ⟧
  := @BinCoproductArrow
   EndC _ _  (CPEndC (U Z)
   (H (alg_carrier _ InitAlg))) (alg_carrier _ InitAlg) f
   (BinCoproductIn2 (CPEndC _ _) · (alg_map _ InitAlg)).

Definition SpecializedGMIt_Thm15 (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧)
  : ∃! h : [C, C]
              ⟦ ℓ (U Z) (pr1 InitAlg),
              pr1 InitAlg ⟧,
       # (ℓ (U Z)) (alg_map Id_H InitAlg) · h =
       pr1 (aux_iso_1 · θ'_Thm15 · aux_iso_2_inv)
         (pr1 InitAlg) ·
       # (Const_plus_H (U Z)) h · ρ_Thm15 f :=
   (SpecializedGMIt (pr1 InitAlg) (Const_plus_H (U Z))
     (ρ_Thm15 f) (aux_iso_1 · θ'_Thm15 · aux_iso_2_inv)).

Definition bracket_Thm15 (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧)
  : [C, C]⟦ ℓ (U Z) (pr1 InitAlg), pr1 InitAlg ⟧
  := pr1 (pr1 (SpecializedGMIt_Thm15 f)).

Notation "⦃ f ⦄" := (bracket_Thm15 f) (at level 0).

(* we prove the individual components for ease of compilation *)
Lemma bracket_Thm15_ok_part1 (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) :
 f = # (pr1 (ℓ (U Z))) (η InitAlg) · ⦃f⦄.
Proof.
apply nat_trans_eq_alt; intro c.
assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 f))).
assert (h_eq' := maponpaths (λ m,
               ((aux_iso_1_inv:(_⟹_)) _)· m) h_eq); clear h_eq.
assert (h_eq1' := maponpaths (λ m,
               (BinCoproductIn1 (CPEndC _ _))· m) h_eq'); clear h_eq'.
assert (h_eq1'_inst := nat_trans_eq_pointwise h_eq1' c); clear h_eq1'.
eapply pathscomp0, pathscomp0; [|apply (!h_eq1'_inst)|]; clear h_eq1'_inst.
- apply BinCoproductIn1Commutes_right_in_ctx_dir; simpl.
  rewrite id_left, <- !assoc.
  apply BinCoproductIn1Commutes_right_in_ctx_dir; simpl.
  rewrite !id_left, !(@id_left EndC).
  now apply BinCoproductIn1Commutes_right_in_ctx_dir,
            BinCoproductIn1Commutes_right_in_ctx_dir,
            BinCoproductIn1Commutes_right_dir.
- apply BinCoproductIn1Commutes_left_in_ctx_dir; simpl.
  now rewrite id_left, assoc.
Qed.

Lemma bracket_Thm15_ok_part2 (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) :
  prestrength_in_first_arg (alg_carrier _ InitAlg) ·  # H ⦃f⦄ · τ InitAlg =
  # (pr1 (ℓ (U Z))) (τ InitAlg) · ⦃f⦄.
Proof.
apply nat_trans_eq_alt; intro c.
assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 f))).
assert (h_eq' := maponpaths (λ m,
                ((aux_iso_1_inv:(_⟹_)) _)· m) h_eq); clear h_eq.
(* until here same as in previous lemma *)
assert (h_eq2' := maponpaths (λ m,
                (BinCoproductIn2 (CPEndC _ _))· m) h_eq');  clear h_eq'.
assert (h_eq2'_inst := nat_trans_eq_pointwise h_eq2' c); clear h_eq2'.
eapply pathscomp0, pathscomp0; [|apply (!h_eq2'_inst)|]; clear h_eq2'_inst.
- apply BinCoproductIn2Commutes_right_in_ctx_dir; simpl.
  rewrite id_right, id_left, <- !assoc.
  apply BinCoproductIn2Commutes_right_in_ctx_dir; simpl.
  rewrite id_left.
  apply BinCoproductIn2Commutes_right_in_ctx_dir.
  apply BinCoproductIn2Commutes_right_in_double_ctx_dir.
  rewrite <- assoc; apply maponpaths.
  apply pathsinv0; simpl.
  rewrite <- assoc; apply maponpaths.
  now apply BinCoproductIn2Commutes.
- apply BinCoproductIn2Commutes_left_in_ctx_dir.
  now rewrite id_left; apply assoc.
Qed.

Lemma bracket_Thm15_ok (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) :
  bracket_property_parts prestrength_in_first_arg InitAlg f ⦃f⦄.
Proof.
split.
+ exact (bracket_Thm15_ok_part1 f).
+ exact (bracket_Thm15_ok_part2 f).
Qed.

Lemma bracket_Thm15_ok_cor (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) :
 bracket_property prestrength_in_first_arg InitAlg f (bracket_Thm15 f).
Proof.
now apply whole_from_parts, bracket_Thm15_ok.
Qed.

Local Lemma bracket_unique (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) :
 ∏ t : ∑ h : [C, C] ⟦ functor_composite (U Z) (pr1  InitAlg),
                            pr1 InitAlg ⟧, bracket_property prestrength_in_first_arg InitAlg f h,
   t = tpair _ ⦃f⦄ (bracket_Thm15_ok_cor f).
Proof.
intros [h' h'_eq]; apply subtypePath; [intro; apply (isaset_nat_trans (homset_property C))|].
simpl; apply parts_from_whole in h'_eq.
apply path_to_ctr, nat_trans_eq_alt; intro c.
simpl; rewrite !(@id_left EndC), id_right, <- !assoc.
etrans; [| eapply pathsinv0, postcompWithBinCoproductArrow ].
apply BinCoproductArrowUnique.
+ destruct h'_eq as [h'_eq1 _]; simpl.
  rewrite id_left, assoc.
  etrans; [ eapply pathsinv0, (nat_trans_eq_pointwise h'_eq1 c) |].
  now apply BinCoproductIn1Commutes_right_in_ctx_dir,
            BinCoproductIn1Commutes_right_in_ctx_dir,
            BinCoproductIn1Commutes_right_dir.
+ destruct h'_eq as [_ h'_eq2].
  rewrite assoc.
  etrans; [ eapply pathsinv0, (nat_trans_eq_pointwise h'_eq2 c) |].
  apply BinCoproductIn2Commutes_right_in_ctx_dir.
  apply BinCoproductIn2Commutes_right_in_double_ctx_dir.
  simpl; rewrite <- !assoc.
  now apply maponpaths, maponpaths, pathsinv0, BinCoproductIn2Commutes.
Qed.

End fix_a_Z.

End fix_an_H.

Context (H :  @Presignature C C C) (HH : is_omega_cocont H).
Let Id_H := Id_H H.
Let θ := theta H.
Let InitAlg := InitAlg H HH.
Let ptdInitAlg := ptdInitAlg H HH.

Definition bracket_for_InitAlg : bracket θ InitAlg.
Proof.
intros Z f.
use tpair.
- use tpair.
  + exact (bracket_Thm15 H HH Z (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) f).
  + exact (bracket_Thm15_ok_cor H HH Z (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) f).
    (* B: better to prove the whole outside, and apply it here *)
    (* when the first components were not opaque, the following proof
       became extremely slow *)
- cbn. apply bracket_unique.
Defined.

Definition InitHSS : hss_category CP H.
Proof.
 (*
  red. (* FORBIDDEN, otherwise universe problem when checking the definition *)
  unfold hss_precategory; simpl.
*)
exists InitAlg.
exact bracket_for_InitAlg.
Defined.

Local Definition Ghat : EndEndC := Const_plus_H H (pr1 InitAlg).

Definition constant_nat_trans (C' D : category) (d d' : D) (m : D⟦d,d'⟧)
    : [C', D] ⟦constant_functor C' D d, constant_functor C' D d'⟧.
Proof.
exists (λ _, m).
abstract (intros ? ? ?; intermediate_path m; [ apply id_left | apply pathsinv0, id_right]).
Defined.

Definition thetahat_0 (Z : Ptd) (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) :
  EndEndC
  ⟦ BinCoproductObject
      (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
         (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)),
    BinCoproductObject
      (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg))
                 (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧.
Proof.
exact (BinCoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _)
                           (constant_nat_trans _ _ _ _ f)
                           (nat_trans_fix_snd_arg _ _ _ _ _ θ Z)).
Defined.

Local Definition iso1' (Z : Ptd) : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)),
 BinCoproductObject
    (CPEndEndC (constant_functor _ _  (U Z)) (functor_fix_snd_arg _ _ _ (θ_source H) Z)) ⟧.
Proof.
exact (aux_iso_1 H Z).
Defined.

Local Lemma is_nat_trans_iso2' (Z : Ptd) :
   is_nat_trans
     (pr1 (BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg))
           (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z))))
     (functor_composite (ℓ (U Z)) Ghat)
     (λ X : [C, C],
      nat_trans_id
        (BinCoproductObject
           (CPEndC
              ((constant_functor [C, C] [C, C] (pr1 InitAlg)) X)
              ((θ_target H) (X ⊗ Z)))
         :functor C C)).
Proof.
intros X X' α.
rewrite id_left, id_right.
apply nat_trans_eq_alt; intro c; simpl.
unfold coproduct_nat_trans_data; simpl.
unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
apply (maponpaths_12 (BinCoproductOfArrows _ _ _)); try apply idpath.
unfold functor_fix_snd_arg_mor; simpl.
revert c; apply nat_trans_eq_pointwise, maponpaths.
apply nat_trans_eq_alt; intro c; simpl.
rewrite (functor_id X).
apply id_left.
Qed.

Local Definition iso2' (Z : Ptd) : EndEndC ⟦
  BinCoproductObject
  (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg))
             (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)),
  functor_composite (ℓ (U Z)) Ghat ⟧.
Proof.
use tpair.
- intro X.
  exact (nat_trans_id ((@BinCoproductObject EndC _ (θ_target H (X⊗Z)) (CPEndC _ _) )
            : functor C C)).
- exact (is_nat_trans_iso2' Z).
Defined.

Definition thetahat (Z : Ptd) (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧)
           : EndEndC ⟦ functor_composite Id_H (ℓ (U Z)),
                       functor_composite (ℓ (U Z)) (Ghat) ⟧.
Proof.
exact (iso1' Z · thetahat_0 Z f · iso2' Z).
Defined.

Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op").

Let Yon (X : EndC) : functor EndC^op HSET := yoneda_objects EndC X.

Definition Phi_fusion (Z : Ptd) (X : EndC) (b : pr1 InitAlg --> X) :
  functor_composite (functor_opp (ℓ (U Z))) (Yon (pr1 InitAlg))
   ⟹
  functor_composite (functor_opp (ℓ (U Z))) (Yon X) .
Proof.
use tpair.
- intros Y a.
  exact (a · b).
- abstract (intros ? ? ?; simpl; apply funextsec; intro;
            unfold yoneda_objects_ob; simpl; unfold compose; simpl;
            apply nat_trans_eq; [apply homset_property |]; simpl; intro;
            apply assoc').
Defined.

Let IA := colimAlgInitial InitialEndC (is_omega_cocont_Id_H H HH) (Colims_of_shape_nat_graph_EndC _).

Lemma ishssMor_InitAlg (T' : hss CP H) :
  @ishssMor C CP H InitHSS T'
           (InitialArrow IA (pr1 T') : @algebra_mor EndC Id_H InitAlg T' ).
Proof.
intros Z f.
set (β0 := InitialArrow IA (pr1 T')).
match goal with | [|- _ · ?b = _ ] => set (β := b) end.
set (rhohat := BinCoproductArrow (CPEndC _ _ )  β (tau_from_alg T')
                :  pr1 Ghat T' --> T').
set (X:= SpecializedGMIt H HH Z _ Ghat rhohat (thetahat Z f)).
intermediate_path (pr1 (pr1 X)).
- set (TT := @fusion_law EndC InitialEndC Colims_of_shape_nat_graph_EndC
                         Id_H (is_omega_cocont_Id_H H HH) _ (pr1 (InitAlg)) T').
  set (Psi := ψ_from_comps (Id_H) _ (ℓ (U Z)) (Const_plus_H H (U Z)) (ρ_Thm15 H HH Z f)
                             (aux_iso_1 H Z · θ'_Thm15 H Z (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) · aux_iso_2_inv H Z) ).
  set (T2 := TT _ (HU Z) (isInitial_pre_comp Z) Psi).
  set (T3 := T2 (ℓ (U Z)) (HU Z)).
  set (Psi' := ψ_from_comps (Id_H) _ (ℓ (U Z)) (Ghat) (rhohat)
                           (iso1' Z · thetahat_0 Z f · iso2' Z) ).
  set (T4 := T3 (isInitial_pre_comp Z) Psi').
  set (Φ := (Phi_fusion Z T' β)).
  set (T5 := T4 Φ).
  intermediate_path (Φ _ (fbracket InitHSS Z f)); try apply idpath.
  etrans; [| apply T5 ]; clear TT T2 T3 T4 T5 X.
  * now apply cancel_postcomposition.
  * (* hypothesis of fusion law *)
    apply funextsec; intro t.
    apply nat_trans_eq_alt; intro c; simpl.
    rewrite !id_right.
    (* should be decomposed into two diagrams *)
    apply BinCoproductArrow_eq_cor.
    + (* first diagram *)
      rewrite <- !assoc.
      apply BinCoproductIn1Commutes_left_in_ctx_dir, BinCoproductIn1Commutes_right_in_ctx_dir.
      simpl; rewrite id_left.
      apply BinCoproductIn1Commutes_left_in_ctx_dir, BinCoproductIn1Commutes_right_in_ctx_dir.
      simpl; rewrite id_left.
      apply BinCoproductIn1Commutes_left_in_ctx_dir.
      simpl; rewrite id_left.
      apply BinCoproductIn1Commutes_left_in_ctx_dir.
      rewrite <- assoc.
      apply maponpaths, BinCoproductIn1Commutes_right_in_ctx_dir.
      simpl; rewrite id_left.
      now apply BinCoproductIn1Commutes_right_dir.
    + (* second diagram *)
      rewrite <- !assoc.
      apply BinCoproductIn2Commutes_left_in_ctx_dir, BinCoproductIn2Commutes_right_in_ctx_dir.
      simpl; rewrite id_left.
      apply BinCoproductIn2Commutes_left_in_ctx_dir, BinCoproductIn2Commutes_right_in_ctx_dir.
      simpl; rewrite <- !assoc.
      apply maponpaths, BinCoproductIn2Commutes_left_in_ctx_dir, BinCoproductIn2Commutes_right_in_ctx_dir.
      simpl.
      rewrite <- !assoc.
      etrans;
        [| eapply pathsinv0, cancel_postcomposition,
           (nat_trans_eq_pointwise (functor_comp H t β) c) ].
      simpl; rewrite <- assoc.
      apply maponpaths, BinCoproductIn2Commutes_left_in_ctx_dir.
      assert (Hyp_c := nat_trans_eq_pointwise (τ_part_of_alg_mor _ CP _ _ _ (InitialArrow IA (pr1 T'))) c).
      simpl in Hyp_c.
      etrans; [ eapply pathsinv0, Hyp_c |].
      now apply maponpaths, pathsinv0, BinCoproductIn2Commutes.
  - apply pathsinv0, path_to_ctr.
    (* now a lot of serious verification work to be done *)
    apply nat_trans_eq_alt; intro c.
    simpl; rewrite id_right.
    (* look at type: *)
    (*  match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *)
    apply BinCoproductArrow_eq_cor.
    + rewrite <- !assoc.
      apply BinCoproductIn1Commutes_right_in_ctx_dir.
      simpl; rewrite id_left.
      apply BinCoproductIn1Commutes_right_in_ctx_dir.
      simpl; rewrite <- assoc.
      etrans;
        [| apply maponpaths, BinCoproductIn1Commutes_right_in_ctx_dir; simpl;
           rewrite id_left; apply BinCoproductIn1Commutes_right_dir, idpath ].
      rewrite !assoc.
      assert (fbracket_η_inst_c := nat_trans_eq_pointwise (fbracket_η T' (f · #U(ptd_from_alg_mor _ CP H β0))) c).
      etrans; [| apply (!fbracket_η_inst_c) ].
      apply cancel_postcomposition, (ptd_mor_commutes _ (ptd_from_alg_mor _ CP H β0) ((pr1 Z) c)).
    + (* now the difficult case *)
      repeat rewrite <- assoc.
      apply BinCoproductIn2Commutes_right_in_ctx_dir.
      simpl.
      unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data.
      rewrite id_left.
      apply BinCoproductIn2Commutes_right_in_ctx_dir.
      unfold nat_trans_fix_snd_arg_data.
      simpl.
      unfold coproduct_nat_trans_in2_data.
      repeat rewrite <- assoc.
      etrans.
      2: { apply maponpaths.
           apply BinCoproductIn2Commutes_right_in_ctx_dir.
           rewrite <- assoc.
           apply maponpaths.
           apply BinCoproductIn2Commutes_right_dir.
           apply idpath.
      }
      do 2 rewrite assoc.
      etrans.
      { apply cancel_postcomposition.
        eapply pathsinv0.
        assert (τ_part_of_alg_mor_inst := τ_part_of_alg_mor _ CP H _ _ β0).
        assert (τ_part_of_alg_mor_inst_Zc :=
                  nat_trans_eq_pointwise τ_part_of_alg_mor_inst ((pr1 Z) c));
          clear τ_part_of_alg_mor_inst.
        apply τ_part_of_alg_mor_inst_Zc.
      }
      simpl.
      unfold coproduct_nat_trans_in2_data.
      repeat rewrite <- assoc.
      etrans.
      { apply maponpaths.
        rewrite assoc.
        eapply pathsinv0.
        assert (fbracket_τ_inst := fbracket_τ T' (f · #U(ptd_from_alg_mor _ CP H β0))).
        assert (fbracket_τ_inst_c := nat_trans_eq_pointwise fbracket_τ_inst c); clear fbracket_τ_inst.
        apply fbracket_τ_inst_c.
      }
      simpl.
      unfold coproduct_nat_trans_in2_data.
      repeat rewrite assoc.
      apply cancel_postcomposition.
      apply cancel_postcomposition.
      assert (Hyp:
                 ((# (pr1 (ℓ(U Z))) (# H β))·
                 θ ((alg_carrier _  T') ⊗ Z)·
                 # H (fbracket T' _ (f · #U(ptd_from_alg_mor C CP H β0)))
                 =
                 θ (tpair (λ _ : functor C C, ptd_obj C) (alg_carrier _ (InitialObject IA)) Z) ·
                 # H (# (pr1 (ℓ(U Z))) β ·
                 fbracket T' _ (f · #U(ptd_from_alg_mor C CP H β0))))).
      2: { assert (Hyp_c := nat_trans_eq_pointwise Hyp c); clear Hyp.
           exact Hyp_c. }
      clear c. clear X. clear rhohat.
      rewrite (functor_comp H).
      rewrite assoc.
      apply cancel_postcomposition.
      apply nat_trans_eq_alt; intro c.
      assert (θ_nat_1_pointwise_inst := θ_nat_1_pointwise _ _ _ H θ _ _ β Z c).
      etrans; [ exact θ_nat_1_pointwise_inst |].
      clear θ_nat_1_pointwise_inst.
      simpl.
      apply maponpaths.
      rewrite horcomp_id_prewhisker.
      apply idpath.
Qed.

Definition hss_InitMor : ∏ T' : hss CP H, hssMor InitHSS T'.
Proof.
intro T'.
exists (InitialArrow IA (pr1 T')).
apply ishssMor_InitAlg.
Defined.

Lemma hss_InitMor_unique (T' : hss_category CP H):
  ∏ t : hss_category CP H ⟦ InitHSS, T' ⟧, t = hss_InitMor T'.
Proof.
intro t.
apply (invmap (hssMor_eq1 _ _ _ _ _ _ _)).
apply (@InitialArrowUnique _ IA (pr1 T') (pr1 t)).
Qed.

Lemma isInitial_InitHSS : isInitial (hss_category CP H) InitHSS.
Proof.
use make_isInitial; intro T.
exists (hss_InitMor T).
apply hss_InitMor_unique.
Defined.

Lemma InitialHSS : Initial (hss_category CP H).
Proof.
apply (make_Initial InitHSS), isInitial_InitHSS.
Defined.

End category_Algebra.


Add LoadPath "???\syntax".
Add LoadPath "???\type_system".
Add LoadPath "???\substitution".
Add LoadPath "???\operational_semantics".
Add LoadPath "???\logic".
Add LoadPath "???\examples".

Require Export type_lemmas logic_lemmas logic_tactics.
Open Scope string_scope.

(* ==================== Sugar ==================== *)

Definition TyBool := (TySum TyUnit TyUnit).

Definition VTrue := Left TyUnit TyUnit Unit.
Definition VFalse := Right TyUnit TyUnit Unit.

(* ==================== Theory definition ==================== *)

Example sig := (SigU (SigØ) ("choose") TyUnit TyBool).

Lemma sig_wf:
  wf_sig sig.
Proof.
unfold sig. obvious.
Qed.

Example eq_idem := (EqsU (EqsØ) CtxØ (TCtxU TCtxØ TyUnit)
  (TApp 0 Unit)
  (TOp "choose" TyUnit TyBool Unit
    (TSumMatch (Var 0) (TApp 0 Unit) (TApp 0 Unit)))
).

Example eq_idem_assoc := (EqsU eq_idem CtxØ
  (TCtxU (TCtxU (TCtxU TCtxØ TyUnit) TyUnit) TyUnit)
  (TOp "choose" TyUnit TyBool Unit
    (TSumMatch (Var 0)
      (TApp 0 Unit)
      (TOp "choose" TyUnit TyBool Unit
        (TSumMatch (Var 0) (TApp 1 Unit) (TApp 2 Unit)))))
  (TOp "choose" TyUnit TyBool Unit
    (TSumMatch (Var 0)
      (TOp "choose" TyUnit TyBool Unit
        (TSumMatch (Var 0) (TApp 0 Unit) (TApp 1 Unit)))
      (TApp 2 Unit) ))
).

Lemma eq_idem_wf:
  wf_eqs eq_idem sig.
Proof.
unfold eq_idem. unfold TyBool. apply WfEqsU; obvious.
- eapply WfTApp; obvious. obvious_vtype. simpl. auto.
- eapply WfTOp; obvious_vtype.
  + unfold sig. simpl. reflexivity.
  + eapply vsubtype_refl. obvious.
  + eapply vsubtype_refl. obvious.
  + eapply WfTSumMatch.
    * apply TypeV; obvious_vtype. apply TypeVar. simpl. auto.
    * eapply WfTApp. obvious_vtype. simpl. auto.
    * eapply WfTApp. obvious_vtype. simpl. auto.
Qed.

Lemma eq_idem_assoc_wf:
  wf_eqs eq_idem_assoc sig.
Proof.
unfold eq_idem_assoc. unfold TyBool. apply WfEqsU; obvious. apply eq_idem_wf.
- eapply WfTOp; obvious_vtype.
  unfold sig. simpl. reflexivity.
  { apply vsubtype_refl. obvious. }
  { apply vsubtype_refl; obvious. }
  eapply WfTSumMatch; obvious_vtype.
  + eapply WfTApp. obvious_vtype. simpl. auto.
  + eapply WfTOp; obvious_vtype.
    unfold sig. simpl. reflexivity.
    { apply vsubtype_refl. obvious. }
    { apply vsubtype_refl; obvious. }
    eapply WfTSumMatch; obvious_vtype.
    all: eapply WfTApp; obvious_vtype.
- eapply WfTOp; obvious_vtype.
  unfold sig. simpl. reflexivity.
  { apply vsubtype_refl. obvious. }
  { apply vsubtype_refl; obvious. }
  eapply WfTSumMatch; obvious_vtype.
  + eapply WfTOp; obvious_vtype.
    unfold sig. simpl. reflexivity.
    { apply vsubtype_refl. obvious. }
    { apply vsubtype_refl; obvious. }
    eapply WfTSumMatch; obvious_vtype.
    all: eapply WfTApp; obvious_vtype.
  + eapply WfTApp. obvious_vtype. simpl. auto.
Qed.

(* ==================== Correctness of cases ==================== *)

Example cases D :=
  (CasesU (CasesØ D)
    "choose" TyUnit TyBool (App (Var 0) VTrue)).

Lemma cases_type D :
  wf_ctype D ->
  has_htype CtxØ (cases D) sig D.
Proof.
intros wfd. apply TypeH; obvious. apply TypeCasesU.
- apply TypeH; obvious. apply TypeCasesØ.
- ctype_step. instantiate (1:=TyBool). obvious_vtype. obvious_vtype.
Qed.

Lemma cases_respect D:
  wf_ctype D ->
  respects CtxØ (cases D) sig D eq_idem_assoc.
Proof.
intros wfd. specialize (cases_type D wfd) as wfcases.
unfold sig. unfold eq_idem_assoc.
apply Respects; obvious. apply eq_idem_assoc_wf.
apply RespectEqsU. apply Respects; obvious. apply eq_idem_wf.
apply RespectEqsU. apply Respects; obvious. apply RespectEqsØ.

{(* ===== IDEMPOTENCY ===== *)
simpl_c_subs. simpl_c_subs.

(* βApp *)
apply ceq_sym. eapply ceq_trans. apply WfJudg; obvious. 2: apply βApp.
all: simpl_c_subs. apply WfCeq.

{ ctype_step. instantiate (1:=TyBool). obvious_vtype.
  obvious_ctype. obvious_vtype. }
{ obvious_ctype. }

(* βMatchLeft *)
eapply ceq_trans. apply WfJudg; obvious. 2: apply βMatchLeft.
all: simpl_c_subs. apply WfCeq.

{ obvious_ctype. }
{ obvious_ctype. }

(* reflexivity *)
apply ceq_refl. obvious_ctype. obvious.
}

{(* ===== ASSOCIATIVITY ===== *)
simpl_c_subs. simpl_c_subs.

(* Reduce right side *)
(* βApp *)
apply ceq_sym. eapply ceq_trans. apply WfJudg; obvious. 2: apply βApp.
all: simpl_c_subs. apply WfCeq.

{ ctype_step. instantiate (1:=TyBool). obvious_vtype. ctype_step. simpl.
  obvious_vtype. ctype_step. instantiate (1:=TyBool).
  obvious_vtype. obvious_ctype. obvious_vtype. obvious_ctype. obvious_vtype. }
{ ctype_step. obvious_vtype. ctype_step. instantiate (1:=TyBool).
  obvious_vtype. obvious_ctype. obvious_vtype. obvious_ctype. }

(* βMatchLeft *)
 eapply ceq_trans. apply WfJudg; obvious. 2: apply βMatchLeft.
all: simpl_c_subs. apply WfCeq.

{ ctype_step. obvious_vtype. ctype_step. instantiate (1:=TyBool).
  obvious_vtype. obvious_ctype. obvious_vtype. obvious_ctype. }
{ ctype_step. instantiate (1:=TyBool). obvious_vtype. obvious_ctype.
  obvious_vtype. }

(* βApp *)
eapply ceq_trans. apply WfJudg; obvious. 2: apply βApp.
all: simpl_c_subs. apply WfCeq.

{ ctype_step. instantiate (1:=TyBool). obvious_vtype. obvious_ctype.
  obvious_vtype. }
{ obvious_ctype. }

(* βMatchLeft *)
eapply ceq_trans. apply WfJudg; obvious. 2: apply βMatchLeft.
all: simpl_c_subs. apply WfCeq.

{ obvious_ctype. }
{ obvious_ctype. }

(* Reduce left side *)
(* βApp *)
apply ceq_sym. eapply ceq_trans. apply WfJudg; obvious. 2: apply βApp.
all: simpl_c_subs. apply WfCeq.

{ ctype_step. instantiate (1:=TyBool). obvious_vtype. ctype_step.
  obvious_vtype. ctype_step. 2: obvious_vtype. obvious_vtype.
  ctype_step. instantiate (1:=TyBool). obvious_vtype. obvious_ctype.
  obvious_vtype. obvious_vtype. }
{ ctype_step. obvious_vtype. ctype_step. 2: obvious_vtype. obvious_vtype.
  ctype_step. instantiate (1:=TyBool). obvious_vtype. obvious_ctype.
  obvious_vtype. }

(* βMatchLeft *)
eapply ceq_trans. apply WfJudg; obvious. 2: apply βMatchLeft.
all: simpl_c_subs. apply WfCeq.

{ ctype_step. obvious_vtype. ctype_step. 2: obvious_vtype. obvious_vtype.
  ctype_step. instantiate (1:=TyBool). obvious_vtype. obvious_ctype.
  obvious_vtype. }
{ obvious_ctype. }

(* reflexivity *)
apply ceq_refl; obvious_ctype.
}
Qed.


Set Primitive Projections.

Record foo : Type := bar { x : unit }.

Goal forall t u, bar t = bar u -> t = u.
Proof.
  intros.
  injection H.
  trivial.
Qed.
(* Was: Error: Pattern-matching expression on an object of inductive type foo has invalid information. *)

(** Dependent pattern-matching is ok on this one as it has eta *)
Definition baz (x : foo) :=
  match x as x' return x' = x' with
  | bar u => eq_refl
  end.

Inductive foo' : Type := bar' {x' : unit; y: foo'}.
(** Dependent pattern-matching is not ok on this one *)
Fail Definition baz' (x : foo') :=
  match x as x' return x' = x' with
  | bar' u y => eq_refl
  end.


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

From QArithSternBrocot Require Export general_Q.
From QArithSternBrocot Require Export positive_fraction_encoding.
From QArithSternBrocot Require Import Merge_Order.
From Coq Require Import Wf_nat.

Definition top_more (a b c d : Z) :=
  (c <= a)%Z /\ (d < b)%Z \/ (c < a)%Z /\ (d <= b)%Z.

Lemma top_more_informative :
 forall a b c d : Z, {top_more a b c d} + {~ top_more a b c d}.
Proof.
 intros.
 case (quadro_leq_inf a b c d).
 intro.
 elim a0.
 intros.
 case (Z_le_lt_eq_dec c a H).
 intro.
 left.
 right.
 split.
 assumption.
 assumption.
 intro.
 case (Z_le_lt_eq_dec d b H0).
 intro.
 left.
 left.
 split.
 assumption.
 assumption.
 intro.
 right.
 intro.
 case H1.
 intro.
 elim H2.
 intros.
 rewrite e0 in H4.
 apply (Zgt_irrefl b).
 Flip.
 intro.
 elim H2.
 intros.
 rewrite e in H3.
 apply (Zgt_irrefl a).
 Flip.

 unfold top_more in |- *.
 intro.
 right.
 intro.
 case H.
 intro.
 apply n.
 elim H0.
 intros.
 split.
 assumption.
 apply Zlt_le_weak.
 assumption.
 intro.
 apply n.
 elim H0.
 intros.
 split.
 apply Zlt_le_weak.
 assumption.
 assumption.
Defined.

Lemma top_more_1 :
 forall a b c d : Z, top_more a b c d -> (0 < a - c + (b - d))%Z.
Proof.
 intros.
 case H.
 intros.
 elim H0.
 intros.
 replace 0%Z with (0 + 0)%Z.
 apply Zplus_le_lt_compat.
 unfold Zminus in |- *.
 apply Zle_left.
 assumption.
 apply Zlt_minus.
 assumption.
 constructor.
 intro.
 elim H0.
 intros.
 replace 0%Z with (0 + 0)%Z.
 apply Zplus_lt_le_compat.
 apply Zlt_minus.
 assumption.
 unfold Zminus in |- *.
 apply Zle_left.
 assumption.
 constructor.
Defined.

Lemma top_more_2 : forall a b c d : Z, top_more a b c d -> (c + d < a + b)%Z.
Proof.
 intros.
 case H.
 intros.
 elim H0.
 intros.
 apply Zplus_le_lt_compat.
 assumption.
 assumption.
 intros.
 elim H0.
 intros.
 apply Zplus_lt_le_compat.
 assumption.
 assumption.
Defined.

Lemma top_more_3 :
 forall a b c d : Z, (0 < c + d)%Z -> (a - c + (b - d) < a + b)%Z.
Proof.
 intros.
 apply Zplus_lt_reg_l with (c + d)%Z.
 apply Zplus_lt_reg_l with (- a - b)%Z.
 replace (- a - b + (c + d + (a - c + (b - d))))%Z with 0%Z.
 replace (- a - b + (c + d + (a + b)))%Z with (c + d)%Z.
 assumption.
 ring.
 ring.
Defined.

Lemma top_more_4 : forall a b c d : Z, top_more a b c d -> (c <= a)%Z.
Proof.
 intros.
 case H.
 intros.
 elim H0.
 intros.
 assumption.
 intros.
 elim H0.
 intros.
 apply Zlt_le_weak.
 assumption.
Defined.

Lemma top_more_4' : forall a b c d : Z, top_more a b c d -> (d <= b)%Z.
Proof.
 intros.
 case H.
 intros.
 elim H0.
 intros.
 apply Zlt_le_weak.
 assumption.
 intros.
 elim H0.
 intros.
 assumption.
Defined.

Lemma top_more_5 :
 forall a b c d : Z,
 (0 < c + d)%Z -> (a - c + (b - d) + c + d < a + b + c + d)%Z.
Proof.
 intros.
 assert ((a - c + (b - d) + c + d)%Z = (a + b + 0)%Z).
 ring.
 rewrite H0.
 rewrite Zplus_assoc_reverse with (n := (a + b)%Z).
 apply Zplus_le_lt_compat.
 apply Z.le_refl.
 assumption.
Defined.

Lemma top_more_5' :
 forall a b c d : Z,
 (0 < a + b)%Z -> (a + b + (c - a) + (d - b) < a + b + c + d)%Z.
Proof.
 intros.
 assert ((a + b + (c - a) + (d - b))%Z = (0 + (c + d))%Z).
 ring.
 rewrite H0.
 rewrite Zplus_assoc_reverse with (n := (a + b)%Z).
 apply Zplus_lt_le_compat.
 assumption.
 apply Z.le_refl.
Defined.

Inductive homographicAcc : Z -> Z -> Z -> Z -> Qpositive -> Prop :=
  | homographicacc0 :
      forall (a b c d : Z) (p : Qpositive),
      p = One -> (0 < a + b)%Z -> (0 < c + d)%Z -> homographicAcc a b c d p
  | homographicacc1 :
      forall (a b c d : Z) (p : Qpositive),
      p <> One ->
      top_more a b c d ->
      homographicAcc (a - c)%Z (b - d)%Z c d p -> homographicAcc a b c d p
  | homographicacc2 :
      forall (a b c d : Z) (p : Qpositive),
      p <> One ->
      ~ top_more a b c d ->
      top_more c d a b ->
      homographicAcc a b (c - a)%Z (d - b)%Z p -> homographicAcc a b c d p
  | homographicacc3 :
      forall (a b c d : Z) (xs : Qpositive),
      ~ top_more a b c d ->
      ~ top_more c d a b ->
      homographicAcc a (a + b)%Z c (c + d)%Z xs ->
      homographicAcc a b c d (nR xs)
  | homographicacc3' :
      forall (a b c d : Z) (xs : Qpositive),
      ~ top_more a b c d ->
      ~ top_more c d a b ->
      homographicAcc (a + b)%Z b (c + d)%Z d xs ->
      homographicAcc a b c d (dL xs).

Lemma homographicacc_0_num :
 forall a b c d : Z, homographicAcc a b c d One -> (0 < a + b)%Z.
Proof.
 intros.
 abstract (inversion H; trivial; Irreflex; discriminate H0).
Defined.

Lemma homographicacc_0_denom :
 forall a b c d : Z, homographicAcc a b c d One -> (0 < c + d)%Z.
Proof.
 intros.
 abstract (inversion H; trivial; Irreflex; discriminate H0).
Defined.

Lemma homographicacc_1 :
 forall (a b c d : Z) (p : Qpositive),
 homographicAcc a b c d p ->
 p <> One -> top_more a b c d -> homographicAcc (a - c) (b - d) c d p.
Proof.
 simple destruct 1; intros; trivial; Falsum.
Defined.

Lemma homographicacc_2 :
 forall (a b c d : Z) (p : Qpositive),
 homographicAcc a b c d p ->
 p <> One ->
 ~ top_more a b c d ->
 top_more c d a b -> homographicAcc a b (c - a) (d - b) p.
Proof.
 simple destruct 1; intros; trivial; Falsum.
Defined.

Lemma homographicacc_3 :
 forall (a b c d : Z) (p : Qpositive),
 homographicAcc a b c d p ->
 forall xs : Qpositive,
 p = nR xs ->
 ~ top_more a b c d ->
 ~ top_more c d a b -> homographicAcc a (a + b) c (c + d) xs.
Proof.
 intros a b c d p HAcc; case HAcc; intros; try solve [ Falsum ];
  [ rewrite H2 in H; clear H2; discriminate H
  | let T_local := eval compute in (f_equal Qpositive_tail H2) in
    (rewrite <- T_local; assumption)
  | discriminate H2 ].
Defined.

Lemma homographicacc_3' :
 forall (a b c d : Z) (p : Qpositive),
 homographicAcc a b c d p ->
 forall xs : Qpositive,
 p = dL xs ->
 ~ top_more a b c d ->
 ~ top_more c d a b -> homographicAcc (a + b) b (c + d) d xs.
Proof.
 intros a b c d p HAcc xs.
 case HAcc; intros; try solve [ Falsum ];
  [ rewrite H2 in H; clear H2; discriminate H
  | discriminate H2
  | let T_local := eval compute in (f_equal Qpositive_tail H2) in
    (rewrite <- T_local; assumption) ].
Defined.

Fixpoint Qhomographic_Qpositive_to_Qpositive (a b c d : Z)
 (p : Qpositive) (hyp : homographicAcc a b c d p) {struct hyp} : Qpositive :=
  match Qpositive_dec_One p with
  | left H_p_is_One =>
      let H :=
        eq_ind p (fun p : Qpositive => homographicAcc a b c d p) hyp One
          H_p_is_One in
      (fun hyp0 : homographicAcc a b c d One =>
       (fun (Hab : (0 < a + b)%Z) (Hcd : (0 < c + d)%Z) =>
        positive_fraction_encoding (a + b) (c + d) Hab Hcd)
         (homographicacc_0_num a b c d hyp0)
         (homographicacc_0_denom a b c d hyp0)) H
  | right H_p_not_One =>
      match top_more_informative a b c d with
      | left H_abcd =>
          nR
            (Qhomographic_Qpositive_to_Qpositive (a - c)%Z
               (b - d)%Z c d p
               (homographicacc_1 a b c d p hyp H_p_not_One H_abcd))
      | right H_abcd =>
          match top_more_informative c d a b with
          | left H_cdab =>
              dL
                (Qhomographic_Qpositive_to_Qpositive a b
                   (c - a)%Z (d - b)%Z p
                   (homographicacc_2 a b c d p hyp H_p_not_One H_abcd H_cdab))
          | right H_cdab =>
              match p as q return (p = q -> Qpositive) with
              | nR q =>
                  fun H : p = nR q =>
                  Qhomographic_Qpositive_to_Qpositive a
                    (a + b)%Z c (c + d)%Z q
                    (homographicacc_3 a b c d p hyp q H H_abcd H_cdab)
              | dL q =>
                  fun H : p = dL q =>
                  Qhomographic_Qpositive_to_Qpositive
                    (a + b)%Z b (c + d)%Z d q
                    (homographicacc_3' a b c d p hyp q H H_abcd H_cdab)
              | One =>
                  fun q : p = One =>
                  False_rec Qpositive (False_ind False (H_p_not_One q))
              end (refl_equal p)
          end
      end
  end.

(** some sort of lexicographical order on binary lists *)

Fixpoint Qpositive_length (qp : Qpositive) : nat :=
  match qp with
  | One => 0
  | dL qp1 => S (Qpositive_length qp1)
  | nR qp1 => S (Qpositive_length qp1)
  end.

Definition bin_lt (qp1 qp2 : Qpositive) : Prop :=
  Qpositive_length qp1 < Qpositive_length qp2.

Definition bin_eq (x y : Qpositive) := x = y.

(* We mention the following form only for the proof of the well-foundedness  *)
Lemma bin_lt_compat_via_length :
 forall x y : Qpositive,
 bin_lt x y -> Qpositive_length x < Qpositive_length y.
Proof.
 trivial.
Defined.

Lemma compare_dL : forall x : Qpositive, bin_lt x (dL x).
Proof.
 unfold bin_lt in |- *.
 simpl in |- *.
 auto with arith.
Defined.

Lemma compare_nR : forall x : Qpositive, bin_lt x (nR x).
Proof.
 unfold bin_lt in |- *.
 simpl in |- *.
 auto with arith.
Defined.

(** Definition of order for quadroples and a binary sequnce *)

Record Z_pos : Set :=  {zposcrr :> Z; z4prf_Z_pos : (0 <= zposcrr)%Z}.

Definition qlt (a b c d : Z) (p : Qpositive) (a' b' c' d' : Z)
  (p' : Qpositive) : Prop :=
  bin_lt p p' \/ p = p' /\ (a + b + c + d < a' + b' + c' + d')%Z.

Definition qle (a b c d : Z) (p : Qpositive) (a' b' c' d' : Z)
  (p' : Qpositive) : Prop :=
  qlt a b c d p a' b' c' d' p' \/
  a = a' /\ b = b' /\ c = c' /\ d = d' /\ p = p'.

Definition quadrointegral_lt (a b c d a' b' c' d' : Z) :=
  (a + b + c + d < a' + b' + c' + d')%Z.

Definition quadrointegral_eq (a b c d a' b' c' d' : Z) :=
  a = a' /\ b = b' /\ c = c' /\ d = d'.

Record Z4 : Set :=
  {z4crr :> Z * Z * (Z * Z);
   z4prf :
    (0 <= fst (fst z4crr))%Z /\
    (0 <= snd (fst z4crr))%Z /\
    (0 <= fst (snd z4crr))%Z /\ (0 <= snd (snd z4crr))%Z}.

Definition Z4_lt (x y : Z4) :=
  let (V1, V2) := z4crr x in
  let (V3, V4) := z4crr y in
  let (a, b) := V1 in
  let (c, d) := V2 in
  let (a', b') := V3 in
  let (c', d') := V4 in quadrointegral_lt a b c d a' b' c' d'.

Definition Z4_eq (x y : Z4) :=
  let (V1, V2) := z4crr x in
  let (V3, V4) := z4crr y in
  let (a, b) := V1 in
  let (c, d) := V2 in
  let (a', b') := V3 in
  let (c', d') := V4 in quadrointegral_eq a b c d a' b' c' d'.

Lemma Z4_lt_is_irreflexive : forall x : Z4, ~ Z4_lt x x.
Proof.
 intros (((a, b), (c, d)), z4prf0).
 unfold Z4_lt in |- *.
 unfold quadrointegral_lt in |- *.
 simpl in |- *.
 apply Z.lt_irrefl.
Defined.

Lemma Z4_lt_is_transitive :
 forall x y z : Z4, Z4_lt x y -> Z4_lt y z -> Z4_lt x z.
Proof.
 intros (((a, b), (c, d)), z4prf0) (((a', b'), (c', d')), z4prf1)
  (((a2, b2), (c2, d2)), z4prf2).
 unfold Z4_lt in |- *.
 unfold quadrointegral_lt in |- *.
 simpl in |- *.
 intros.
 apply Z.lt_trans with (a' + b' + c' + d')%Z; assumption.
Defined.

Lemma Z4_lt_is_order : is_order Z4 Z4_lt.
Proof.
 split.
 apply Z4_lt_is_irreflexive.
 apply Z4_lt_is_transitive.
Defined.

Lemma Z4_eq_is_reflexive : forall x : Z4, Z4_eq x x.
Proof.
 intros (((a, b), (c, d)), z4prf0).
 unfold Z4_eq in |- *.
 unfold quadrointegral_eq in |- *; repeat split.
Defined.

Lemma Z4_eq_is_symmetric : forall x y : Z4, Z4_eq x y -> Z4_eq y x.
Proof.
 intros (((a, b), (c, d)), z4prf0) (((a', b'), (c', d')), z4prf1).
 unfold Z4_eq in |- *.
 unfold quadrointegral_eq in |- *.
 intros (HH1, (HH2, (HH3, HH4))); repeat split; symmetry  in |- *; assumption.
Defined.

Lemma Z4_eq_is_transitive :
 forall x y z : Z4, Z4_eq x y -> Z4_eq y z -> Z4_eq x z.
Proof.
 intros (((a, b), (c, d)), z4prf0) (((a', b'), (c', d')), z4prf1)
  (((a2, b2), (c2, d2)), z4prf2).
 unfold Z4_eq in |- *.
 unfold quadrointegral_eq in |- *.
 simpl in |- *.
 intros (HH2, (HH4, (HH6, HH7))) (HH9, (HH11, (HH13, HH14))); repeat split;
  match goal with
  | id12:(?X1 = ?X2),id23:(?X2 = ?X3) |- (?X1 = ?X3) =>
      try apply (trans_eq id12 id23)
  end.
Defined.

Lemma Z4_eq_is_equality : is_equality Z4 Z4_eq.
Proof.
 split.
 apply Z4_eq_is_reflexive.
 split.
 apply Z4_eq_is_symmetric.
 apply Z4_eq_is_transitive.
Defined.

Lemma Z_pos_lt_is_wf :
 forall P : Z_pos -> Prop,
 (forall q : Z_pos, (forall r : Z_pos, (r < q)%Z -> P r) -> P q) ->
 forall q : Z_pos, P q.
Proof.
 intros.
 destruct q.
 rename zposcrr0 into q.
 set (P2 := fun p : Z => forall Hp : (0 <= p)%Z, P (Build_Z_pos p Hp)) in *.
 assert (P2 q).
 apply Zind_wf with (p := 0%Z).
 intros.
 unfold P2 in |- *.
 intro.
 apply H.
 intros.
 destruct r.
 rename zposcrr0 into r.
 assert (P2 r).
 apply H0.
 split.
 assumption.
 assumption.
 apply (H2 z4prf_Z_pos1).
 assumption.
 apply (H0 z4prf_Z_pos0).
Defined.

Lemma Z4_lt_is_wf : wf_ind Z4 Z4_lt.
Proof.
 red in |- *.
 intros P H (((a, b), (c, d)), p); revert p;
 simpl in |- *.
 intros (Ha, (Hb, (Hc, Hd))).
 assert (H_a_b_c_d : (0 <= a + b + c + d)%Z); repeat apply Zplus_le_0_compat;
  try assumption.
 (* Here Omega tactic would have worked as opposed to the similar situation below *)
 set
  (P4 :=
   fun k : Z_pos =>
   forall (a b c d : Z)
     (Habcd : (0 <= a)%Z /\ (0 <= b)%Z /\ (0 <= c)%Z /\ (0 <= d)%Z)
     (Hk : zposcrr k = (a + b + c + d)%Z), P (Build_Z4 (a, b, (c, d)) Habcd))
  in *.
 assert (P4 (Build_Z_pos (a + b + c + d) H_a_b_c_d)).

 apply Z_pos_lt_is_wf.
 intros q_pos.
 red in |- *.
 intros.
 apply H.
 intros (((r_a, r_b), (r_c, r_d)), p); revert p.
 simpl in |- *.
 intros (H_r_a, (H_r_b, (H_r_c, H_r_d))).
 intro Hq.

 assert (H_r_a_b_c_d : (0 <= r_a + r_b + r_c + r_d)%Z);
  repeat apply Zplus_le_0_compat; try assumption.
 (* Here Omega tactic does not work, as if we say "Clear z4prf1" and gives an error! *)
 assert (P4 (Build_Z_pos (r_a + r_b + r_c + r_d) H_r_a_b_c_d)).

 apply H0.
 rewrite Hk.
 simpl in |- *.
 assumption.

 apply H1.
 reflexivity.
 apply H0.
 reflexivity.
Defined.

Lemma Z4_lt_is_well_def_rht : is_well_def_rht Z4 Z4_lt Z4_eq.
Proof.
 red in |- *.
 intros (((a, b), (c, d)), z4prf0) (((a', b'), (c', d')), z4prf1).
 intro H.
 intros (((a2, b2), (c2, d2)), z4prf2).
 generalize H.
 unfold Z4_lt in |- *.
 unfold Z4_eq in |- *.
 unfold quadrointegral_lt in |- *.
 unfold quadrointegral_eq in |- *.
 simpl in |- *.
 clear H z4prf0 z4prf1 z4prf2.
 intros H0 (H1, (H2, (H3, H4))).
 repeat
  match goal with
  | id:(?X1 = ?X2) |- _ => try rewrite id in H0; clear id
  end.
 assumption.
Defined.

Definition Z4_as_well_ordering :=
  Build_well_ordering Z4 Z4_lt Z4_eq Z4_lt_is_order Z4_eq_is_equality
    Z4_lt_is_wf Z4_lt_is_well_def_rht.

Lemma bin_lt_is_irreflexive : forall x : Qpositive, ~ bin_lt x x.
Proof.
 intros x.
 unfold bin_lt in |- *.
 apply Nat.lt_irrefl.
Defined.

Lemma bin_lt_is_transitive :
 forall x y z : Qpositive, bin_lt x y -> bin_lt y z -> bin_lt x z.
Proof.
 intros x y z; unfold bin_lt in |- *.
 apply Nat.lt_trans.
Defined.

Lemma bin_lt_is_order : is_order Qpositive bin_lt.
Proof.
 split.
 apply bin_lt_is_irreflexive.
 apply bin_lt_is_transitive.
Defined.

Lemma bin_eq_is_reflexive : forall x : Qpositive, bin_eq x x.
Proof.
 intros.
 unfold bin_eq in |- *.
 reflexivity.
Defined.

Lemma bin_eq_is_symmetric : forall x y : Qpositive, bin_eq x y -> bin_eq y x.
Proof.
 intros x y.
 unfold bin_eq in |- *.
 apply sym_eq.
Defined.

Lemma bin_eq_is_transitive :
 forall x y z : Qpositive, bin_eq x y -> bin_eq y z -> bin_eq x z.
Proof.
 intros x y z.
 unfold bin_eq in |- *.
 apply trans_eq.
Defined.

Lemma bin_eq_is_equality : is_equality Qpositive bin_eq.
Proof.
 split.
 apply bin_eq_is_reflexive.
 split.
 apply bin_eq_is_symmetric.
 apply bin_eq_is_transitive.
Defined.

Lemma bin_lt_is_wf : wf_ind Qpositive bin_lt.
Proof.
 generalize
  (well_founded_lt_compat Qpositive Qpositive_length bin_lt
     bin_lt_compat_via_length).
 intro H.
 exact (well_founded_ind H).
Defined.

Lemma bin_lt_is_well_def_rht : is_well_def_rht Qpositive bin_lt bin_eq.
Proof.
 red in |- *.
 intros.
 red in H0.
 rewrite <- H0.
 assumption.
Defined.

Definition Qpositive_as_well_ordering :=
  Build_well_ordering Qpositive bin_lt bin_eq bin_lt_is_order
    bin_eq_is_equality bin_lt_is_wf bin_lt_is_well_def_rht.

Lemma qlt_wf_rec_without_zeros_and_One :
 forall P : Z -> Z -> Z -> Z -> Qpositive -> Prop,
 (forall (a b c d : Z_pos) (p : Qpositive),
  (forall (r s t u : Z_pos) (p1 : Qpositive),
   qlt r s t u p1 a b c d p -> P r s t u p1) -> P a b c d p) ->
 forall (a b c d : Z_pos) (p : Qpositive), P a b c d p.
Proof.
 intros P H (a, Ha) (b, Hb) (c, Hc) (d, Hd) p.
 set
  (P2 :=
   fun (p_i : Qpositive) (x : Z4) =>
   P (fst (fst x)) (snd (fst x)) (fst (snd x)) (snd (snd x)) p_i)
  in *.
 simpl in |- *.

 assert (z4prf_Z4 : (0 <= a)%Z /\ (0 <= b)%Z /\ (0 <= c)%Z /\ (0 <= d)%Z);
  repeat split; try assumption.

 assert (P2 p (Build_Z4 (a, b, (c, d)) z4prf_Z4)).

 apply (merge_lt_wf Qpositive_as_well_ordering Z4_as_well_ordering).
 intro p_i.
 intros (((a_i, b_i), (c_i, d_i)), q); revert q.
 unfold P2 in |- *.
 simpl in |- *.
 intros (Ha_i, (Hb_i, (Hc_i, Hd_i))).
 intros.
 change
   (P (Build_Z_pos a_i Ha_i) (Build_Z_pos b_i Hb_i)
      (Build_Z_pos c_i Hc_i) (Build_Z_pos d_i Hd_i) p_i)
  in |- *.
 apply H.
 intros (r_, r_p) (s_, s_p) (t_, t_p) (u_, u_p) p1.
 simpl in |- *.
 intro H1.
 assert
  (z4prf2_Z4 : (0 <= r_)%Z /\ (0 <= s_)%Z /\ (0 <= t_)%Z /\ (0 <= u_)%Z);
  repeat split; try assumption.
 apply (H0 p1 (Build_Z4 (r_, s_, (t_, u_)) z4prf2_Z4)).
 case H1.
 intro.
 left.
 assumption.
 intros (H2, H3).
 right.
 split; assumption.
 assumption.
Defined.

Lemma homographicAcc_wf :
 forall (a b c d : Z) (p : Qpositive),
 (0 < a + b)%Z ->
 (0 < c + d)%Z ->
 (0 <= a)%Z ->
 (0 <= b)%Z -> (0 <= c)%Z -> (0 <= d)%Z -> homographicAcc a b c d p.
Proof.
 intros a b c d p Hab Hcd Ha Hb Hc Hd.
 set (ha := Build_Z_pos a Ha) in *.
 set (hb := Build_Z_pos b Hb) in *.
 set (hc := Build_Z_pos c Hc) in *.
 set (hd := Build_Z_pos d Hd) in *.
 generalize Hab Hcd Ha Hb Hc Hd.
 change
   ((0 < ha + hb)%Z ->
    (0 < hc + hd)%Z ->
    (0 <= ha)%Z ->
    (0 <= hb)%Z -> (0 <= hc)%Z -> (0 <= hd)%Z -> homographicAcc ha hb hc hd p)
  in |- *.

 apply
  qlt_wf_rec_without_zeros_and_One
   with
     (P := fun (r s t u : Z) (p1 : Qpositive) =>
           (0 < r + s)%Z ->
           (0 < t + u)%Z ->
           (0 <= r)%Z ->
           (0 <= s)%Z ->
           (0 <= t)%Z -> (0 <= u)%Z -> homographicAcc r s t u p1).

 intros a0 b0 c0 d0 p0 hyp1_aux.

(* modifying hyp1_aux *)
 assert
  (hyp1 :
   forall (r s t u : Z) (p1 : Qpositive),
   qlt r s t u p1 a0 b0 c0 d0 p0 ->
   (0 < r + s)%Z ->
   (0 < t + u)%Z ->
   (0 <= r)%Z ->
   (0 <= s)%Z -> (0 <= t)%Z -> (0 <= u)%Z -> homographicAcc r s t u p1).
 intros.
 change
   (homographicAcc (Build_Z_pos r H2) (Build_Z_pos s H3)
      (Build_Z_pos t H4) (Build_Z_pos u H5) p1) in |- *.
 apply hyp1_aux; repeat assumption.
(* end modifying hyp1 *)

 destruct p0 as [q| q| ].

 (** p0 = (nR p0) *)
  case (top_more_informative a0 b0 c0 d0).
  (** (top_more a0 b0 c0 d0) *)
   intros.
   apply homographicacc1.
   discriminate.
   assumption.
   apply hyp1.
   right.
   split.
   reflexivity.
   apply top_more_5.
   assumption.
   apply top_more_1.
   assumption.
   assumption.
   apply Zle_minus.
   apply (top_more_4 _ _ _ _ t).
   apply Zle_minus.
   apply (top_more_4' _ _ _ _ t).
   assumption.
   assumption.
  (** ~(top_more a0 b0 c0 d0) *)
   intro.
   case (top_more_informative c0 d0 a0 b0).
   (** (top_more c0 d0 a0 b0) *)
    intros.
    apply homographicacc2.
    discriminate.
    assumption.
    assumption.
    apply hyp1.
    right.
    split.
    reflexivity.
    apply top_more_5'.
    assumption.
    assumption.
    apply top_more_1.
    assumption.
    assumption.
    assumption.
    apply Zle_minus.
    apply (top_more_4 _ _ _ _ t).
    apply Zle_minus.
    apply (top_more_4' _ _ _ _ t).
   (** ~(top_more c0 d0 a0 b0) *)
    intros.
    apply homographicacc3.
    (* Discriminate. *)(**)
    assumption.
    assumption.
    apply hyp1.

    left.
    unfold bin_lt in |- *.
    apply compare_nR.

    replace 0%Z with (0 + 0)%Z.
    apply Zplus_le_lt_compat.
    assumption.
    assumption.
    constructor.
    replace 0%Z with (0 + 0)%Z.
    apply Zplus_le_lt_compat.
    assumption.
    assumption.
    constructor.
    assumption.
    apply Zlt_le_weak.
    assumption.
    assumption.
    apply Zlt_le_weak.
    assumption.
 (** p0 = (dL p0) *)
  case (top_more_informative a0 b0 c0 d0).
  (** (top_more a0 b0 c0 d0) *)
   intros.
   apply homographicacc1.
   discriminate.
   assumption.
   apply hyp1.
   right.

   split.
   reflexivity.

   apply top_more_5.
   assumption.

   apply top_more_1.
   assumption.
   assumption.
   apply Zle_minus.
   apply (top_more_4 _ _ _ _ t).
   apply Zle_minus.
   apply (top_more_4' _ _ _ _ t).
   assumption.
   assumption.
  (** ~(top_more a0 b0 c0 d0) *)
   intro.
   case (top_more_informative c0 d0 a0 b0).
   (** (top_more c0 d0 a0 b0) *)
    intros.
    apply homographicacc2.
    discriminate.
    assumption.
    assumption.
    apply hyp1.
    right.

    split.
    reflexivity.

    apply top_more_5'.
    assumption.

    assumption.
    apply top_more_1.
    assumption.
    assumption.
    assumption.
    apply Zle_minus.
    apply (top_more_4 _ _ _ _ t).
    apply Zle_minus.
    apply (top_more_4' _ _ _ _ t).
   (** ~(top_more c0 d0 a0 b0) *)
    intros.
    apply homographicacc3'.

    assumption.
    assumption.
    apply hyp1.
    left.

    unfold bin_lt in |- *.
    apply compare_dL.
    replace 0%Z with (0 + 0)%Z.
    apply Zplus_lt_le_compat.
    assumption.
    assumption.
    constructor.
    replace 0%Z with (0 + 0)%Z.
    apply Zplus_lt_le_compat.
    assumption.
    assumption.
    constructor.
    apply Zlt_le_weak.
    assumption.
    assumption.
    apply Zlt_le_weak.
    assumption.
    assumption.
 (** p = One *)
  intros.
  apply homographicacc0.
  reflexivity.
  assumption.
  assumption.
Defined.

(* TEST part *)
(* This part is an attempt to test the computational power of "Qhomographic_Qpositive_to_Qpositive" function. We try to calculate h(x)=2x+3/(x+4) for x:=1 *)
(* TEST 1 : 01_08_02 RAM:386MB Coq:7.3 OS:Redhat7.3   RESULT:insufficient memory *)

Remark one_non_negative : (0 <= 1)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark two_non_negative : (0 <= 2)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark three_non_negative : (0 <= 3)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark four_non_negative : (0 <= 4)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark five_non_negative : (0 <= 5)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark six_non_negative : (0 <= 6)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark seven_non_negative : (0 <= 7)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark two_plus_three_positive : (0 < 2 + 3)%Z.
Proof.
 simpl in |- *.
 apply ZERO_lt_POS.
Defined.

Remark one_plus_four_positive : (0 < 1 + 4)%Z.
Proof.
 simpl in |- *.
 apply ZERO_lt_POS.
Defined.

Definition homographicacc_wf_for_five_over_five :=
  homographicAcc_wf 2 3 1 4 One two_plus_three_positive
    one_plus_four_positive two_non_negative three_non_negative
    one_non_negative four_non_negative.

(* TEST: Eval Compute in (Qhomographic_Qpositive_to_Qpositive `2` `3` `1` `4` (One) homographicacc_wf_for_five_over_five). *)

(* End of the TEST part *)

(** Proof independence of Qhomographic_Qpositive_to_Qpositive: *)

Scheme homographicAcc_ind_dep := Induction for homographicAcc Sort Prop.

Lemma Qhomographic_Qpositive_to_Qpositive_equal :
 forall (a b c d : Z) (p : Qpositive) (hyp1 hyp2 : homographicAcc a b c d p),
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp1 =
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp2.
Proof.
 intros a b c d p hyp1 hyp2.
 generalize hyp2.
 clear hyp2.
 pattern a, b, c, d, p, hyp1 in |- *.
 elim hyp1 using homographicAcc_ind_dep; clear a b c d p hyp1.

 (* 1st big subgoal *)
   intros a b c d p Hp Hab Hcd hyp2; generalize Hp Hab Hcd; clear Hp Hab Hcd.
   pattern a, b, c, d, p, hyp2 in |- *.
   elim hyp2 using homographicAcc_ind_dep; clear a b c d p hyp2; intros.

    (* 1.1 *)
    simpl in |- *.
    case (Qpositive_dec_One p); intro Hp_; [ idtac | Falsum ].
    apply positive_fraction_encoding_equal.
    (* 1.2 *)
    Falsum.
    (* 1.3 *)
    Falsum.
    (* 1.4 *)
    discriminate Hp.
    (* 1.5 *)
    discriminate Hp.

 (* 2nd big subgoal *)
   intros a b c d p Hp Habcd hyp1 H_ind hyp2; generalize Hp Habcd hyp1 H_ind;
    clear Hp Habcd H_ind hyp1.
   pattern a, b, c, d, p, hyp2 in |- *.
   elim hyp2 using homographicAcc_ind_dep; clear a b c d p hyp2; intros.

    (* 2.1 *)
    Falsum.
    (* 2.2 *)
    simpl in |- *; case (Qpositive_dec_One p); intro Hp_; [ Falsum | idtac ];
     case (top_more_informative a b c d); intro Habcd_;
     [ idtac | Falsum ]; apply f_equal with Qpositive;
     apply H_ind.
    (* 2.3 *)
    Falsum.
    (* 2.4 *)
    Falsum.
    (* 2.5 *)
    Falsum.

 (* 3rd big subgoal *)
   intros a b c d p Hp Habcd Hcdab hyp1 H_ind hyp2;
    generalize Hp Habcd Hcdab hyp1 H_ind; clear Hp Habcd Hcdab H_ind hyp1.
   pattern a, b, c, d, p, hyp2 in |- *.
   elim hyp2 using homographicAcc_ind_dep; clear a b c d p hyp2; intros.

    (* 3.1 *)
    Falsum.
    (* 3.2 *)
    Falsum.
    (* 3.3 *)
    simpl in |- *; case (Qpositive_dec_One p); intro Hp_; [ Falsum | idtac ];
     case (top_more_informative a b c d); intro Habcd_;
     [ Falsum | idtac ]; case (top_more_informative c d a b);
     intro Hcdab_; [ idtac | Falsum ]; apply f_equal with Qpositive;
     apply H_ind.
    (* 3.4 *)
    Falsum.
    (* 3.5 *)
    Falsum.

 (* 4th big subgoal *)
   intros a b c d xs Habcd Hcdab hyp1 H_ind hyp2.
   set (P := nR xs) in *; assert (HP : P = nR xs); trivial; generalize HP.
   generalize Habcd Hcdab hyp1 H_ind.
   clear Habcd Hcdab H_ind hyp1.
   (* here we copy-paste the current goal but change the 2nd occurnece of P to (dL xs) *)
   elim hyp2 using
    homographicAcc_ind_dep
     with
       (P := fun (a b c d : Z) (P : Qpositive)
               (hyp2 : homographicAcc a b c d P) =>
             forall (Habcd : ~ top_more a b c d) (Hcdab : ~ top_more c d a b)
               (hyp1 : homographicAcc a (a + b) c (c + d) xs),
             (forall hyp2 : homographicAcc a (a + b) c (c + d) xs,
              Qhomographic_Qpositive_to_Qpositive a (a + b) c (c + d) xs hyp1 =
              Qhomographic_Qpositive_to_Qpositive a (a + b) c (c + d) xs hyp2) ->
             P = nR xs ->
             Qhomographic_Qpositive_to_Qpositive a b c d
               (nR xs) (homographicacc3 a b c d xs Habcd Hcdab hyp1) =
             Qhomographic_Qpositive_to_Qpositive a b c d P hyp2);
    clear a b c d hyp2; intros.

    (* 4.1 *)
    Falsum; rewrite H0 in e; discriminate e.
    (* 4.2 *)
    Falsum.
    (* 4.3 *)
    Falsum.
    (* 4.4 *)
    simpl in |- *.
    case (top_more_informative a b c d); intro Habcd_; [ Falsum | idtac ];
     case (top_more_informative c d a b); intro Hcdab_;
     [ Falsum | idtac ].
    generalize h;
     let T_local := eval compute in (f_equal Qpositive_tail H1) in
     rewrite T_local.
    intro; apply H0.
    (* 4.5 *)
    discriminate H1.

 (* 5th big subgoal *)
   intros a b c d xs Habcd Hcdab hyp1 H_ind hyp2.
   set (P := dL xs) in *; assert (HP : P = dL xs); trivial; generalize HP.
   generalize Habcd Hcdab hyp1 H_ind.
   clear Habcd Hcdab H_ind hyp1.
   elim hyp2 using
    homographicAcc_ind_dep
     with
       (P := fun (a b c d : Z) (P : Qpositive)
               (hyp2 : homographicAcc a b c d P) =>
             forall (Habcd : ~ top_more a b c d) (Hcdab : ~ top_more c d a b)
               (hyp1 : homographicAcc (a + b) b (c + d) d xs),
             (forall hyp2 : homographicAcc (a + b) b (c + d) d xs,
              Qhomographic_Qpositive_to_Qpositive (a + b) b (c + d) d xs hyp1 =
              Qhomographic_Qpositive_to_Qpositive (a + b) b (c + d) d xs hyp2) ->
             P = dL xs ->
             Qhomographic_Qpositive_to_Qpositive a b c d
               (dL xs) (homographicacc3' a b c d xs Habcd Hcdab hyp1) =
             Qhomographic_Qpositive_to_Qpositive a b c d P hyp2);
    clear a b c d hyp2; intros.

    (* 5.1 *)
    Falsum; rewrite H0 in e; discriminate e.
    (* 5.2 *)
    Falsum.
    (* 5.3 *)
    Falsum.
    (* 5.4 *)
    discriminate H1.
    (* 5.5 *)
    simpl in |- *.
    case (top_more_informative a b c d); intro Habcd_; [ Falsum | idtac ];
     case (top_more_informative c d a b); intro Hcdab_;
     [ Falsum | idtac ].
    generalize h;
     let T_local := eval compute in (f_equal Qpositive_tail H1) in
     rewrite T_local.
    intro; apply H0.
Defined.

Lemma Qhomographic_Qpositive_to_Qpositive_equal_strong :
 forall (a1 a2 b1 b2 c1 c2 d1 d2 : Z) (p1 p2 : Qpositive)
   (hyp1 : homographicAcc a1 b1 c1 d1 p1)
   (hyp2 : homographicAcc a2 b2 c2 d2 p2),
 a1 = a2 ->
 b1 = b2 ->
 c1 = c2 ->
 d1 = d2 ->
 p1 = p2 ->
 Qhomographic_Qpositive_to_Qpositive a1 b1 c1 d1 p1 hyp1 =
 Qhomographic_Qpositive_to_Qpositive a2 b2 c2 d2 p2 hyp2.
Proof.
 intros.
 subst.
 apply Qhomographic_Qpositive_to_Qpositive_equal.
Defined.

(** Here we expand the fixpoint equations of "Qhomographic_Qpositive_to_Qpositive" function *)

Lemma Qhomographic_Qpositive_to_Qpositive_0 :
 forall (a b c d : Z) (p : Qpositive) (hyp : homographicAcc a b c d p),
 p = One ->
 forall (H1 : (0 < a + b)%Z) (H2 : (0 < c + d)%Z),
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp =
 positive_fraction_encoding (a + b) (c + d) H1 H2.
Proof.
 intros.
 apply
  trans_eq
   with
     (Qhomographic_Qpositive_to_Qpositive a b c d One
        (homographicacc0 a b c d One (refl_equal One) H1 H2)).
 apply Qhomographic_Qpositive_to_Qpositive_equal_strong; repeat reflexivity.
 assumption.
  simpl in |- *.
  apply positive_fraction_encoding_equal.
Defined.

Lemma Qhomographic_Qpositive_to_Qpositive_1 :
 forall (a b c d : Z) (p : Qpositive) (hyp : homographicAcc a b c d p),
 p <> One ->
 top_more a b c d ->
 forall h : homographicAcc (a - c) (b - d) c d p,
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp =
 nR (Qhomographic_Qpositive_to_Qpositive (a - c) (b - d) c d p h).
Proof.
 intros.
 apply
  trans_eq
   with
     (Qhomographic_Qpositive_to_Qpositive a b c d p
        (homographicacc1 a b c d p H H0 h)).
 apply Qhomographic_Qpositive_to_Qpositive_equal.
  simpl in |- *.
  case (Qpositive_dec_One p); intros Hp; [ Falsum | idtac ].
  case (top_more_informative a b c d); intros Habcd; [ idtac | Falsum ].
  apply f_equal with Qpositive; reflexivity.
Defined.

Lemma Qhomographic_Qpositive_to_Qpositive_2 :
 forall (a b c d : Z) (p : Qpositive) (hyp : homographicAcc a b c d p),
 p <> One ->
 ~ top_more a b c d ->
 top_more c d a b ->
 forall h : homographicAcc a b (c - a) (d - b) p,
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp =
 dL (Qhomographic_Qpositive_to_Qpositive a b (c - a) (d - b) p h).
Proof.
 intros.
 apply
  trans_eq
   with
     (Qhomographic_Qpositive_to_Qpositive a b c d p
        (homographicacc2 a b c d p H H0 H1 h)).
 apply Qhomographic_Qpositive_to_Qpositive_equal.
  simpl in |- *.
  case (Qpositive_dec_One p); intros Hp; [ Falsum | idtac ].
  case (top_more_informative a b c d); intros Habcd; [ Falsum | idtac ].
  case (top_more_informative c d a b); intros Hcdab; [ idtac | Falsum ].
  apply f_equal with Qpositive; reflexivity.
Defined.

Lemma Qhomographic_Qpositive_to_Qpositive_3 :
 forall (a b c d : Z) (p : Qpositive) (hyp : homographicAcc a b c d p),
 ~ top_more a b c d ->
 ~ top_more c d a b ->
 forall xs : Qpositive,
 p = nR xs ->
 forall h : homographicAcc a (a + b) c (c + d) xs,
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp =
 Qhomographic_Qpositive_to_Qpositive a (a + b) c (c + d) xs h.
Proof.
 intros.
 apply
  trans_eq
   with
     (Qhomographic_Qpositive_to_Qpositive a b c d (nR xs)
        (homographicacc3 a b c d xs H H0 h)).
 apply Qhomographic_Qpositive_to_Qpositive_equal_strong; trivial.
  simpl in |- *.
  case (top_more_informative a b c d); intros Habcd; [ Falsum | idtac ].
  case (top_more_informative c d a b); intros Hcdab; [ Falsum | idtac ].
  reflexivity.
Defined.

Lemma Qhomographic_Qpositive_to_Qpositive_3' :
 forall (a b c d : Z) (p : Qpositive) (hyp : homographicAcc a b c d p),
 ~ top_more a b c d ->
 ~ top_more c d a b ->
 forall xs : Qpositive,
 p = dL xs ->
 forall h : homographicAcc (a + b) b (c + d) d xs,
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp =
 Qhomographic_Qpositive_to_Qpositive (a + b) b (c + d) d xs h.
Proof.
 intros.
 apply
  trans_eq
   with
     (Qhomographic_Qpositive_to_Qpositive a b c d (dL xs)
        (homographicacc3' a b c d xs H H0 h)).
 apply Qhomographic_Qpositive_to_Qpositive_equal_strong; trivial.
  simpl in |- *.
  case (top_more_informative a b c d); intros Habcd; [ Falsum | idtac ].
  case (top_more_informative c d a b); intros Hcdab; [ Falsum | idtac ].
  reflexivity.
Defined.


(*===========================================================================
  Properties of partial finite maps
  ===========================================================================*)
Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.eqtype Ssreflect.ssrnat Ssreflect.seq Ssreflect.choice Ssreflect.fintype Ssreflect.tuple Ssreflect.finfun.
Require Import x86proved.tuplehelp x86proved.bitsrep x86proved.bitsprops x86proved.pmap.
Require Export x86proved.update.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import Coq.Program.Equality.
Lemma existsVal {n} :
  forall {V} (m:NEPMAP V n), exists v, exists p: BITS n, lookupNE m p = Some v.
Proof. induction n.
+ dependent destruction m. by exists v, (nil_tuple _).
+ dependent destruction m.
  destruct (IHn _ m1) as [v [p H]]. exists v, (cons_tuple false p). by rewrite /=beheadCons.
  destruct (IHn _ m) as [v [p H]]. exists v, (cons_tuple false p). by rewrite /=beheadCons.
  destruct (IHn _ m) as [v [p H]]. exists v, (cons_tuple true p). by rewrite /=beheadCons.
Qed.

Lemma extensional_NEPMAP n: forall V (m1 m2: NEPMAP V n),
  (forall x, lookupNE m1 x = lookupNE m2 x) -> m1 = m2.
Proof. induction n => V m1 m2 H.
  + dependent destruction m1.  dependent destruction m2.
    specialize (H (nil_tuple _)). simpl in H. congruence.
  + dependent destruction m1.
    - dependent destruction m2.
      * simpl in H. rewrite (IHn _ m1_1 m2_1). rewrite (IHn _ m1_2 m2_2). done.
        move => x. specialize (H (cons_tuple true x)). by rewrite beheadCons in H.
        move => x. specialize (H (cons_tuple false x)). by rewrite beheadCons in H.
      * destruct (existsVal m1_2) as [v [p H1]].
        specialize (H (cons_tuple true p)). simpl in H. rewrite beheadCons in H. rewrite H in H1. inversion H1.
      * destruct (existsVal m1_1) as [v [p H1]].
        specialize (H (cons_tuple false p)). simpl in H. rewrite beheadCons in H. rewrite H in H1. inversion H1.

    - dependent destruction m2.
      * destruct (existsVal m2_2) as [v [p H1]].
        specialize (H (cons_tuple true p)). simpl in H. rewrite beheadCons in H. rewrite H1 in H. inversion H.
      * simpl in H. rewrite (IHn _ m1 m2). done.
        move => p. specialize (H (cons_tuple false p)). simpl in H. by rewrite beheadCons in H.
      * simpl in H.
        destruct (existsVal m1) as [v [p H1]].
        specialize (H (cons_tuple false p)). simpl in H. rewrite beheadCons in H. rewrite H in H1. inversion H1.

    - dependent destruction m2.
      * destruct (existsVal m2_1) as [v [p H1]].
        specialize (H (cons_tuple false p)). simpl in H. rewrite beheadCons in H. rewrite H1 in H. inversion H.
      * simpl in H.
        destruct (existsVal m2) as [v [p H1]].
        specialize (H (cons_tuple false p)). simpl in H. rewrite beheadCons in H. rewrite H1 in H. inversion H.
      * simpl in H. rewrite (IHn _ m1 m2). done.
        move => p. specialize (H (cons_tuple true p)). simpl in H. by rewrite beheadCons in H.
Qed.

(*=extensional_PMAP *)
Lemma extensional_PMAP n V:
  forall (m1 m2: PMAP V n), (forall x, m1 x = m2 x) -> m1 = m2.
(*=End *)
Proof. case => [a1 |].
  case => [a2 |].
    move => H. by rewrite (extensional_NEPMAP H).
    move => H. simpl in H. destruct (existsVal a1) as [v [p H1]]. by rewrite (H p) in H1.
    case => [a2 |].
    move => H. simpl in H. destruct (existsVal a2) as [v [p H1]]. by rewrite -(H p) in H1.
    move => H. done.
Qed.

Lemma singleNEThenLookup {n V} :
  forall (p: BITS n) (v:V), lookupNE (singleNE p v) p = Some v.
Proof. induction n => p v.
+ done.
+ case/tupleP: p => b p'. case b; by simpl.
Qed.

Lemma updateNEThenLookup {n V} :
  forall (m: NEPMAP V n) (p: BITS n) (v: V),
  lookupNE (updateNE m p v) p = Some v.
Proof. induction m => p v0.
  + done.
  + simpl. case e: (thead p); simpl; rewrite e. by rewrite IHm2. by rewrite IHm1.
  + simpl. case e: (thead p); simpl; rewrite e. by rewrite singleNEThenLookup. by rewrite IHm.
  + simpl. case e: (thead p); simpl; rewrite e. done.
  + by rewrite singleNEThenLookup.
Qed.

Open Scope update_scope.
Lemma updateThenLookup {n V} :
  forall (m: PMAP V n) (p: BITS n) (v: V),
  (m !p:=v) p = Some v.
Proof. case => *; simpl. by rewrite updateNEThenLookup. by rewrite singleNEThenLookup. Qed.

Lemma tlneq {n} {h} (t t': BITS n) : cons_tuple h t <> cons_tuple h t' -> t <> t'.
Proof. move => neq. move => H. by rewrite H in neq. Qed.

Lemma singleNEThenLookupOther {n V} :
  forall (p q: BITS n) (v:V),
   p<>q -> lookupNE (singleNE p v) q = None.
Proof.
  induction n.
    + move => p q v pq. case: pq. by rewrite (tuple0 p) (tuple0 q).
    + case/tupleP => b p'. case/tupleP => b' q'.
      move => v pq. simpl. rewrite beheadCons.
      destruct b.
      - destruct b'. simpl. rewrite beheadCons. apply IHn. apply: tlneq pq. done.
      - destruct b'. done. simpl. rewrite beheadCons. apply IHn. apply: tlneq pq.
Qed.

(* test
Definition m :PMAP DWORD 32 := EmptyPMap !#5:=#23 !#6:=#123 !#7:=#213 !#8:= #100 !#1234:=#121.
*)

Fixpoint nodesNEaux {n V} (c:nat) (m: NEPMAP n V) :=
  match m with
  | VAL _ => c.+1
  | LSPLIT _ m => nodesNEaux (c.+1) m
  | RSPLIT _ m => nodesNEaux (c.+1) m
  | SPLIT _ m1 m2 => nodesNEaux (nodesNEaux (c.+1) m1) m2
  end.
Definition nodes {n V} (m: PMAP n V) :=
  match m with
  | EmptyPMap => 0
  | PMap m => nodesNEaux 0 m
  end.

Lemma updateNEThenLookupDistinct {n V} :
  forall (m: NEPMAP V n) (p q: BITS n) (v: V),
  p <> q -> lookupNE (updateNE m p v) q = lookupNE m q.
Proof.
induction m.
+ simpl. move => p q. rewrite (tuple0 p) (tuple0 q). by intuition.
+ simpl. case/tupleP => b p. case: b.
  case/tupleP => b' q.
  case: b'.
    move => v pq. simpl. rewrite !beheadCons. rewrite IHm2. done. apply: tlneq pq.
    done.
  case/tupleP => b' q.
  case: b'.
    done.
    move => v pq. simpl. rewrite !beheadCons. rewrite IHm1. done. apply: tlneq pq.
+ simpl. case/tupleP => b p. case: b.
  case/tupleP => b' q.
    move => v pq. simpl. rewrite !beheadCons !theadCons.
    destruct b'. apply singleNEThenLookupOther.
    apply: tlneq pq.
    done.
  case/tupleP => b' q.
    move => v pq. simpl. rewrite !beheadCons !theadCons.
    destruct b'. done.
    rewrite IHm. done. apply: tlneq pq.
+ simpl. case/tupleP => b p. case/tupleP => b' q.
  move => v pq. rewrite !theadCons. rewrite !beheadCons.
  destruct b'. destruct b. simpl. rewrite beheadCons. rewrite IHm. done. apply: tlneq pq.
  simpl. by rewrite beheadCons.
  destruct b.  done. simpl. rewrite beheadCons.
  rewrite singleNEThenLookupOther. done. apply: tlneq pq.
Qed.

Lemma updateThenLookupDistinct {n V} :
  forall (m: PMAP V n) (p q: BITS n) (v: V),
  p <> q -> (m !p:=v) q = m q.
Proof.
case.
move => m p q v pq.
simpl. by rewrite updateNEThenLookupDistinct.
simpl. move => p q v pq. by rewrite singleNEThenLookupOther.
Qed.

Instance PMapUpdate {n} V : Update (PMAP V n) (BITS n) V.
  apply Build_Update.
  (* update same key *)
  move => m k v w. apply extensional_PMAP => p.
  case e: (p==k).
  + rewrite (eqP e). by rewrite !updateThenLookup.
  + assert (k<>p). intro E. rewrite E in e. rewrite eq_refl in e. inversion e. rewrite !updateThenLookupDistinct; done.
  (* update different keys *)
  move => m k l v w kl.
  apply extensional_PMAP => p.
  case e: (p==k).
  + rewrite (eqP e). rewrite updateThenLookup. rewrite updateThenLookupDistinct. by rewrite updateThenLookup. intuition.
  + assert (k<>p). intro E. rewrite E in e. rewrite eq_refl in e. inversion e.
    case e': (p==l).
    - rewrite (eqP e'). rewrite updateThenLookup. rewrite updateThenLookupDistinct. by rewrite updateThenLookup. intuition.
    - assert (l<>p). intro E. rewrite E in e'. rewrite eq_refl in e'. inversion e'.
      rewrite !updateThenLookupDistinct. done. intuition. done.  done. done.
  Qed.

Lemma fillNE_lookup V n (f: BITS n -> V) k:
  lookupNE (fillNE f) k = Some (f k).
Proof.
  move: f k. elim: n => [|n IHn] f k.
  - rewrite /fillNE /lookupNE. f_equal. f_equal. apply trivialBits.
  - rewrite /fillNE -/fillNE /lookupNE; fold (@lookupNE V n).
    case Hsplit: (splitlsb k) => [p []].
    - rewrite IHn. rewrite /consBfun.
      replace (consB true p) with (joinlsb (p,true)) by done. rewrite -Hsplit.
      by rewrite splitlsbK.
    - rewrite IHn. rewrite /consBfun.
      replace (consB false p) with (joinlsb (p,false)) by done. rewrite -Hsplit.
      by rewrite splitlsbK.
Qed.

Lemma fill_lookup n V (f: BITS n -> V) k:
  (fill f) k = Some (f k).
Proof. apply fillNE_lookup. Qed.

Lemma splitlsb_consBfun {A} {n} p' p b (f: BITS n.+1 -> A):
  splitlsb p' = (p, b) ->
  consBfun b f p = f p'.
Proof.
  move=> Hsplit. rewrite /consBfun.
  replace (consB b p) with (joinlsb (p,b)) by done. by rewrite -Hsplit splitlsbK.
Qed.

Lemma pmap_of_lookup n V (f: BITS n -> option V) k:
  (pmap_of f) k = f k.
Proof.
  move: f k. elim: n => [|n IHn] f k.
  - rewrite /pmap_of /lookupNE. case Hf: (f (zero 0)) => [v|].
    - rewrite /lookup /lookupNE. rewrite <-Hf.
      f_equal. apply trivialBits.
    - rewrite /lookup -Hf. f_equal. apply trivialBits.
  - rewrite /pmap_of; fold (@pmap_of V n). rewrite /lookup.
    (* This is a copy-paste mess. Maybe it can be improved, but the number of
       cases does actually correspond to the number of cases in the functions
       involved. *)
    case Hleft: (pmap_of (consBfun false f)) => [ml|];
      case Hright: (pmap_of (consBfun true f)) => [mr|].
    - rewrite /lookupNE; fold (@lookupNE V n).
      case Hsplit: (splitlsb k) => [p []].
      - specialize (IHn (consBfun true f) p).
        rewrite /lookup Hright in IHn. rewrite IHn. exact: splitlsb_consBfun.
      - specialize (IHn (consBfun false f) p).
        rewrite /lookup Hleft in IHn. rewrite IHn. exact: splitlsb_consBfun.
    - rewrite /lookupNE; fold (@lookupNE V n).
      case Hsplit: (splitlsb k) => [p []].
      - specialize (IHn (consBfun true f) p).
        rewrite /lookup Hright in IHn. rewrite IHn. exact: splitlsb_consBfun.
      - specialize (IHn (consBfun false f) p).
        rewrite /lookup Hleft in IHn. rewrite IHn. exact: splitlsb_consBfun.
    - rewrite /lookupNE; fold (@lookupNE V n).
      case Hsplit: (splitlsb k) => [p []].
      - specialize (IHn (consBfun true f) p).
        rewrite /lookup Hright in IHn. rewrite IHn. exact: splitlsb_consBfun.
      - specialize (IHn (consBfun false f) p).
        rewrite /lookup Hleft in IHn. rewrite IHn. exact: splitlsb_consBfun.
    - case Hsplit: (splitlsb k) => [p []].
      - specialize (IHn (consBfun true f) p).
        rewrite /lookup Hright in IHn. rewrite IHn. exact: splitlsb_consBfun.
      - specialize (IHn (consBfun false f) p).
        rewrite /lookup Hleft in IHn. rewrite IHn. exact: splitlsb_consBfun.
Qed.


(** ** Substitutivity proofs of reduction. *)

(** *** Substitutivity for the Lambda Calculus with Pairs *)
Require core fintype.
From Chapter6 Require sysf_cbv.
From Chapter6 Require utlc_pairs.

Module polyadic.
Section polyadic.
  Import core fintype.
  Import ScopedNotations.
  Export Chapter6.utlc_pairs.

  Inductive step {m} : tm m -> tm m -> Prop :=
  | beta s t t' : t' = (s[t..]) -> step (app (lam s) t) t'
  | beta_match s1 s2 t t' : t' = (t[s1 .: s2..]) -> step (matchpair (pair s1 s2) t) t'.

  Lemma step_substitutive m m' (s: tm m) t (sigma: fin m -> tm m')  :
    step s t -> step (s[sigma]) (t[sigma]).
  Proof.
    induction 1; subst.
    - cbn. constructor. now asimpl.
    - cbn. constructor. now asimpl.
Qed.

End polyadic.
End polyadic.

(** *** Substitutivity for Call-by-Value System F *)

Module sysf_cbv.
Section sysf_cbv.
  Import core fintype.
  Import ScopedNotations.
  Export Chapter6.sysf_cbv.

  Inductive step {m n} : tm m n -> tm m n -> Prop :=
  | beta A s v t : t = (s[ids;v..]) -> step (app (vt (lam A s)) (vt v)) t
  | Beta s A t: t = (s[A..;ids]) ->  step (tapp (vt (tlam s)) A) t.

  Lemma step_substitutive m n m' n' (s: tm m n) t sigma (tau: fin n -> vl m' n'):
    step s t -> step (s[sigma;tau]) (t[sigma;tau]).
  Proof.
    induction 1; subst.
    - cbn. constructor. now asimpl.
    - cbn. constructor. now asimpl.
  Qed.

End sysf_cbv.
End sysf_cbv.


Require Import FP.CoreData.
Require Import FP.CoreClasses.
Require Import FP.Classes.
Require Import FP.DerivingEverything.
Require Import FP.DerivingMonad.
Require Import FP.Data.Type.
Require Import FP.Data.Sum.
Require Import FP.Data.Unit.
Require Import FP.Data.Error.
Require Import FP.Data.ErrorMonad.

Import CoreClassesNotation.
Import ClassesNotation.

Arguments Some {A} _.
Arguments None {A}.

Section sum_Bijection.
  Context {A:Type}.

  Definition option_to_sum (aM:option A) : unit + A :=
    match aM with
    | None => inl tt
    | Some a => inr a
    end.
  Global Instance IR_option_to_sum_eq
    : InjectionRespect (option A) (unit+A) option_to_sum eq eq.
  Proof.
    constructor ; unfold Proper ; simpl in * ; intros ; try congruence.
    destruct x,y ; simpl in * ; congruence.
  Qed.

  Definition sum_to_option (aM:unit+A) : option A :=
    match aM with
    | inl tt => None
    | inr a => Some a
    end.
  Global Instance II_sum_to_option_eq
    : InjectionInverse (unit+A) (option A) sum_to_option option_to_sum eq.
  Proof.
    constructor ; intros.
    destruct x ; [ destruct u | idtac ] ; simpl in * ; auto.
  Qed.
End sum_Bijection.

Module option_DE_Arg <: DE_Functor_Arg.
  Definition T := option.
  Definition U A := (unit:Type)+A.
  Definition to : forall {A}, T A -> U A := @option_to_sum.
  Definition from : forall {A}, U A -> T A := @sum_to_option.
  Definition IR_to {A} : InjectionRespect (T A) (U A) to eq eq := _.
  Definition II_from {A} : InjectionInverse (U A) (T A) from to eq := _.
  Definition _DE_FunctorI : DE_FunctorI' U.
  Proof. econstructor ; econstructor ; eauto with typeclass_instances. Defined.
End option_DE_Arg.
Module option_DE := DE_Functor option_DE_Arg.
Import option_DE.

Definition option_elim {A C} (aM:option A) (z:C) (f:A -> C) : C :=
  match aM with
  | None => z
  | Some a => f a
  end.
Definition from_option {A} (a:A) (aM:option A) : A := option_elim aM a id.
Section Proper_option_elim.
  Context {A C} `{! Eqv A ,! PER_WF A ,! Eqv C ,! PER_WF C }.

  Global Instance Proper_option_elim : Proper eqv (@option_elim A C).
  Proof.
    unfold Proper ; logical_eqv_intro.
    destruct x,y ; simpl ; inversion H ; subst ; clear H ; logical_eqv.
  Qed.
End Proper_option_elim.

Ltac destruct_option_eqv x y :=
  match goal with
  | [ e : eqv x y |- _ ] =>
      destruct x,y
      ; [ apply InjectionRespect_beta in e
        | inversion e
        | inversion e
        | idtac
        ]
  end.

Ltac fold_option :=
  match goal with
  | [ |- context
         [ match ?aM with
           | None => ?z
           | Some a => (@?f a)
           end
         ]
    ] => fold (option_elim aM z f)
  end.

Section Properties.
  Context {A} `{! Eqv A }.

  Global Instance IR_Some_eqv : InjectionRespect A (option A) Some eqv eqv.
  Proof.
    constructor ; unfold Proper,"==>","<==" ; intros.
    - constructor ; auto.
    - inversion H ; auto.
  Qed.

  Global Instance None_Proper : Proper eqv None.
  Proof.
    unfold Proper,eqv ; simpl.
    eapply InjectionRespect_eta ; reflexivity.
  Qed.

  Global Instance Some_Proper : Proper eqv Some.
  Proof.
    unfold Proper ; logical_eqv_intro.
    apply InjectionRespect_eta ; auto.
  Qed.

  Context {C} `{! Eqv C }.
  Instance option_elim_respect : Proper eqv (option_elim (A:=A) (C:=C)).
  Proof.
    unfold option_elim.
    logical_eqv.
    destruct_option_eqv x y ; logical_eqv.
  Qed.
End Properties.

Section error_Bijection.
  Definition option_to_error {A} (aM:option A) : error unit A :=
    match aM with
    | None => Failure tt
    | Some a => Success a
    end.

  Definition error_to_option {A} (aM:error unit A) : option A :=
    match aM with
    | Failure tt => None
    | Success a => Some a
    end.

  Global Instance IR_error_to_option_eqv {A} `{! Eqv A ,! PER_WF A }
    : InjectionRespect (error unit A) (option A) error_to_option eqv eqv.
  Proof.
    constructor ; unfold Proper,"==>","<==" ; intros.
    - destruct x,y ; simpl
      ; repeat
          match goal with
          | [ H : unit |- _ ] => destruct H
          end
      ; auto.
    - destruct x,y ; simpl in *
      ; repeat
          match goal with
          | [ H : unit |- _ ] => destruct H
          end
      ; auto.
    Qed.

  Global Instance II_option_to_error_eqv {A} `{! Eqv A ,! PER_WF A }
    : InjectionInverse (option A) (error unit A) option_to_error error_to_option eqv.
  Proof.
    constructor ; intros.
    destruct x ; simpl ; auto.
  Qed.

  Global Instance II_error_to_option_eqv {A} `{! Eqv A ,! PER_WF A }
    : InjectionInverse (error unit A) (option A) error_to_option option_to_error eqv.
  Proof.
    constructor ; intros.
    destruct x
    ; try
        match goal with
        | [ H : unit |- _ ] => destruct H
        end
    ; auto.
  Qed.

  Global Instance Proper_option_to_error {A} `{! Eqv A ,! PER_WF A } : Proper eqv option_to_error.
  Proof.
    unfold Proper ; logical_eqv_intro ; unfold option_to_error
    ; simpl ; repeat fold_option ; logical_eqv.
  Qed.

  Global Instance Proper_error_to_option {A} `{! Eqv A ,! PER_WF A } : Proper eqv error_to_option.
  Proof.
    unfold Proper ; logical_eqv_intro ; unfold error_to_option
    ; simpl ; repeat fold_error ; logical_eqv
    ; repeat
        match goal with
        | [ H : unit |- _ ] => destruct H
        end
    ; auto.
    constructor ; auto.
  Qed.
End error_Bijection.

Module option_DMError_Arg <: DMError_Functor_Arg.
  Definition T := option.
  Definition U := error unit.
  Definition to : forall {A}, T A -> U A := @option_to_error.
  Definition from : forall {A}, U A -> T A := @error_to_option.
  Definition _DM_FunctorI : DM_FunctorI' T U.
  Proof. econstructor ; econstructor ; eauto with typeclass_instances. Defined.
  Definition IR_from_eqv :
    forall {A} `{! Eqv A ,! PER_WF A },
    InjectionRespect (U A) (T A) from eqv eqv := _.
  Definition II_to_from_eqv :
    forall {A} `{! Eqv A ,! PER_WF A },
    InjectionInverse (T A) (U A) to from eqv := _.
  Definition II_from_from_eqv :
    forall {A} `{! Eqv A ,! PER_WF A },
    InjectionInverse (U A) (T A) from to eqv := _.
  Definition Proper_to_eqv :
    forall {A} `{! Eqv A ,! PER_WF A },
    Proper eqv (@to A) := _.
  Definition Proper_from_eqv :
    forall {A} `{! Eqv A ,! PER_WF A },
    Proper eqv (@from A) := _.

  Definition E := unit.
  Definition _DMError_FunctorI : DMError_FunctorI unit T U.
  Proof. econstructor ; eauto with typeclass_instances. Defined.
End option_DMError_Arg.

Module option_DMError := DMError_Functor option_DMError_Arg.
Import option_DMError.


Fixpoint exn (n:nat) :=
  match n with O => False | S n => exists tt:unit, exn n end.

Goal exn 125 -> False. intro H. cbv in H.
  Time (repeat match goal with H:exists _, _ |-_=> destruct H end; assumption).
Time Qed.
(* Finished transaction in 0.186 secs (0.105u,0.079s) (successful) *)
(* Finished transaction in 0.115 secs (0.114u,0.s) (successful) *)

Goal exn 250 -> False. intro H. cbv in H.
  idtac "".
  Time (repeat match goal with H:exists _, _ |-_=> destruct H end; assumption).
Time Qed.
(* Finished transaction in 0.454 secs (0.451u,0.s) (successful) *)
(* Finished transaction in 0.448 secs (0.444u,0.s) (successful) *)

Goal exn 500 -> False. intro H. cbv in H.
  idtac "".
  Time (repeat match goal with H:exists _, _ |-_=> destruct H end; assumption).
Time Qed.
(* Finished transaction in 1.935 secs (1.898u,0.022s) (successful) *)
(* Finished transaction in 1.844 secs (1.824u,0.006s) (successful) *)

Goal exn 1000 -> False. intro H. cbv in H.
  idtac "".
  Time (repeat match goal with H:exists _, _ |-_=> destruct H end; assumption).
Time Qed.
(* Finished transaction in 7.444 secs (7.314u,0.079s) (successful) *)
(* Finished transaction in 7.449 secs (7.404u,0.s) (successful) *)

Goal exn 2000 -> False. intro H. cbv in H.
  idtac "".
  Time (repeat match goal with H:exists _, _ |-_=> destruct H end; assumption).
Time Qed.
(* Finished transaction in 30.733 secs (30.302u,0.238s) (successful) *)
(* Finished transaction in 30.184 secs (29.991u,0.026s) (successful) *)

(* coqc destruct_ex.v  125.62s user 0.66s system 99% cpu 2:06.88 total *)