From mathcomp Require Import ssreflect.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Relations.Relation_Definitions.
From Category.Base Require Import Logic Category Functor NatTran.
From Category.Instances Require Import Univ.FunctorComp Univ.NatTranComp.

Set Universe Polymorphism.

Program Definition FunctorCategory (C D : Category) : Category :=
  {|
    Obj := Functor C D;
    Hom := fun (F1 F2 : Functor C D) => NatTran F1 F2;
    Hom_Id := fun (F1 : Functor C D) => NatTran_Id F1;
    Hom_comp := fun (F1 F2 F3 : Functor C D) => fun (N1 : NatTran F2 F3) (N2 : NatTran F1 F2) => NatTran_Vertical_Comp N1 N2
  |}.
Next Obligation.
Proof.
  exact: NatTran_Vertical_Comp_assoc.
Qed.
Next Obligation.
  exact: NatTran_Vertical_Comp_IdL.
Qed.
Next Obligation.
  exact: NatTran_Vertical_Comp_IdR.
Qed.

Section NaturalEquivalence.

  Context {C D : Category}.
  Context {F1 F2 : Functor C D}.

  Definition NaturalEquivalence (N1 : NatTran F1 F2) := @isomorphism (FunctorCategory C D) _ _ N1.

  Lemma ToNaturalEquivalence : forall N1,
      (forall X, isomorphism (NApp N1 X)) -> NaturalEquivalence N1.
  Proof.
    move => N1 cond.
    have: (forall (X : Obj C), exists! (h : Hom (FApp F2 X) (FApp F1 X)), isomorphism_pair (NApp N1 X) h).
    {
      move => X.
      move: (cond X).
      case.
      move => h pair_Nx.
      exists h.
      split.
      {
        destruct pair_Nx.
        by split.
      } {
        move => h' pair_Nh'.
        apply: (isomorphism_pair_unqR (NApp N1 X)).
        by split.
      }
    }
    move => Cond.
    apply (dependent_unique_choice (Obj C) (fun X => Hom (FApp F2 X) (FApp F1 X))) in Cond.
    move: Cond.
    case.
    move => NApp2 ispair.
    have: (forall (X Y : Obj C) (f : Hom X Y), FAppH F1 f \o (NApp2 X) = (NApp2 Y) \o FAppH F2 f).
    {
      move => X Y f.
      move: (NatTran_rectangle _ _ N1 _ _ f).
      move => HH.
      apply (f_equal (fun N => N \o (NApp2 X))) in HH.
      rewrite (Hom_assoc (FAppH F2 f) (NApp N1 X) (NApp2 X)) in HH.
      rewrite (proj2 (ispair X)) in HH.
      rewrite (Hom_IdR) in HH.
      move: HH =>->.
      rewrite <- (Hom_assoc (NApp2 Y) _ (NApp2 X)).
      rewrite <- (Hom_assoc (NApp2 Y) (NApp N1 Y)).
      rewrite (proj1 (ispair Y)).
      rewrite Hom_IdL.
      reflexivity.
    }
    move => NApp2_cond.
    set (Build_NatTran _ _ _ _ NApp2 NApp2_cond) as N2.
    exists N2.
    split; rewrite /=; apply ToNatTranEq; unfold NatTran_Vertical_Comp; rewrite /=; apply: functional_extensionality_dep; move => X; move: (ispair X); case; by [].
  Qed.

  Lemma OfNaturalEquivalence : forall N1,
      NaturalEquivalence N1 -> (forall X, isomorphism (NApp N1 X)).
  Proof.
    unfold NaturalEquivalence.
    move => N1.
    move => [N2 [eqN21 eqN12]].
    move => X.
    exists (NApp N2 X).
    split.
    {
      move: eqN21.
      rewrite /=.
      by apply/ (f_equal (fun N => NApp N X)).
    } {
      move: eqN12.
      rewrite /=.
      by apply/ (f_equal (fun N => NApp N X)).
    }
  Qed.

End NaturalEquivalence.

Lemma NApp_HomId'_eq {C D : Category} {F1 F2: Functor C D} (eqF : F1 = F2) X (eqFX : FApp F1 X = FApp F2 X) :
  NApp (@HomId' (FunctorCategory C D) _ _ eqF) X = HomId' eqFX.
Proof.
  subst.
  repeat rewrite HomId'_id.
  rewrite /=.
  reflexivity.
Qed.

Program Definition ToConstFunctor (C D : Category) : Functor D (FunctorCategory C D) :=
  {|
    FApp := fun (X : Obj D) => ConstFunctor C X;
    FAppH := fun X1 X2 => fun f =>
                            {|
                              NApp := fun Y => f
                            |}
  |}.
Next Obligation.
  rewrite Hom_IdL.
  rewrite Hom_IdR.
  reflexivity.
Qed.
Next Obligation.
  apply: ToNatTranEq.
  rewrite /=.
  reflexivity.
Qed.
Next Obligation.
  apply: ToNatTranEq.
  rewrite /=.
  reflexivity.
Qed.


(* This file contains some definitions and lemmas on using lists as sets. Mainly
   we want to know whether two lists have the same set of elements (see the
   definition of `list_set_eq`).
 *)

(* TODO: Help Wanted: isn't there some library that more or less does this?
   The ones I found don't seem to have a notation of equality of sets. *)

Set Implicit Arguments.
Set Asymmetric Patterns.

Require Import Coq.Lists.List.
Import Coq.Lists.List.ListNotations.

Section list_set_eq.
  Context {A: Type}.

  Definition list_set_eq (xs ys : list A): Prop :=
    forall (a : A), (In a xs) <-> (In a ys).

  Hint Unfold list_set_eq: list_set_db.

  (* Hint Extern extends an auto database with a tactic.
   You can specify a cost (the natural number 0 in this case) and a
   pattern to apply the tactic to.
   See https://coq.inria.fr/refman/proof-engine/tactics.html#coq:cmdv.hint-extern *)
  Hint Extern 0 (_ <-> _) => split : list_set_db.

  Lemma list_set_eq_refl (xs: list A):
    list_set_eq xs xs.
  Proof.
    auto with list_set_db.
  Qed.

  Hint Resolve list_set_eq_refl: list_set_db.

  Lemma list_set_eq_symm (xs ys: list A):
    list_set_eq xs ys <-> list_set_eq ys xs.
  Proof.
    easy.
    (* Interesting note: auto doesn't solve this (even auto 10), but easy does. *)
  Qed.

  Lemma list_set_eq_step (a : A) (xs: list A):
    list_set_eq (a::xs) (a::(a::xs)).
  Proof.
(* From the manual: "This tactic unfolds constants that were declared through a
   Hint Unfold in the given databases."
   https://coq.inria.fr/distrib/current/refman/proof-engine/tactics.html#coq:tacn.autounfold

   In this case, I wanted to unfold list_set_eq. (We did `Hint Unfold list_set_eq:
   list_set_db.` before.)
 *)
    autounfold with list_set_db.
    intros.
    split.
    - intro H.
      unfold In.
      auto.
    - intro H.
      unfold In in *.
      destruct H; auto.
      (* TODO: Help Wanted
         Is there a way to do this entire proof in an automatised way?
         We're only introducing, unfolding and destructing the logical disjunction H.
       *)
  Qed.

  Lemma list_set_eq_trans (xs ys zs : list A):
    list_set_eq xs ys
    -> list_set_eq ys zs
    -> list_set_eq xs zs.
  Proof.
    intros.
    unfold list_set_eq in *.
    intro.
    split.
    - intro.
      auto using H, H0 with list_set_db.
      (* TODO: Help Wanted
         How can the above auto statement fail to just apply the hints
         I told it to apply?
         The Coq manual does say (https://coq.inria.fr/distrib/current/refman/proof-engine/tactics.html#automation):

         "auto uses a weaker version of apply that is closer to simple apply so it
         is expected that sometimes auto will fail even if applying manually one
         of the hints would succeed."

         And indeed, `simple apply H0` does not work. So maybe that is the reason?

         But then that raises the question: how do we get it to work? Should be
         possible.
       *)
      apply H0.
      apply H.
      assumption.
    - intro.
      apply H.
      apply H0.
      assumption.
  Qed.

  Lemma list_set_eq_ind_step (xs ys: list A) (x : A):
    list_set_eq xs ys ->
    list_set_eq (x::xs) (x::ys).
  Proof.
    intros.
    unfold list_set_eq.
    intros.
    split.
    - intros H0.
      destruct H0.
      + subst. cbn. auto.
      + subst. cbn. right.
        apply H. assumption.
    - intros H0.
      destruct H0.
      + subst. cbn. auto.
      + subst. cbn. right.
        apply H. assumption.
  Qed.
End list_set_eq.


From Coq Require Import List Relations Permutation.
From StructTact Require Import StructTactics.
From Verdi Require Import Net.
Import ListNotations.

Section dup_drop_reorder.
  Variable A : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Inductive dup_drop_step : list A -> list A -> Prop :=
  | DDS_dup : forall l p,
      In p l ->
      dup_drop_step l (p :: l)
  | DDS_drop : forall xs p ys,
      dup_drop_step (xs ++ p :: ys) (xs ++ ys).

  Definition dup_drop_step_star := clos_refl_trans_n1 _ dup_drop_step.

  Lemma dup_drop_step_star_trans :
    forall l l' l'',
      dup_drop_step_star l l' ->
      dup_drop_step_star l' l'' ->
      dup_drop_step_star l l''.
  Proof using.
    intros.
    apply clos_rt_rtn1_iff.
    eapply rt_trans; apply clos_rt_rtn1_iff; eauto.
  Qed.

  Lemma dup_drop_step_star_step_n1 :
    forall l l' l'',
      dup_drop_step_star l l' ->
      dup_drop_step l' l'' ->
      dup_drop_step_star l l''.
  Proof using.
    intros.
    econstructor; eauto.
  Qed.

  Lemma dup_drop_step_star_step_1n :
    forall l l' l'',
      dup_drop_step l l' ->
      dup_drop_step_star l' l'' ->
      dup_drop_step_star l l''.
  Proof using.
    intros.
    apply clos_rt_rtn1_iff.
    apply clos_rt_rt1n_iff.
    econstructor; [eauto|].
    apply clos_rt_rt1n_iff.
    apply clos_rt_rtn1_iff.
    auto.
  Qed.

  Lemma dup_drop_step_star_step_1 :
    forall l l',
      dup_drop_step l l' ->
      dup_drop_step_star l l'.
  Proof using.
    intros.
    eapply dup_drop_step_star_step_1n; eauto.
    constructor.
  Qed.

  Lemma dup_drop_swap :
    forall l x y,
      dup_drop_step_star (x :: y :: l) (y :: x :: l).
  Proof using.
    intros.
    eapply dup_drop_step_star_step_1n; [eapply DDS_dup with (p := y); simpl; auto|].
    eapply dup_drop_step_star_step_1n.
    eapply DDS_drop with (xs := [y; x]) (p := y) (ys := l).
    constructor.
  Qed.

  Lemma dup_drop_cons :
    forall l l' x,
      dup_drop_step_star l l' ->
      dup_drop_step_star (x :: l) (x :: l').
  Proof using.
    induction 1.
    - constructor.
    - invc H.
      + eapply dup_drop_step_star_trans; [eauto|].
        eapply dup_drop_step_star_step_1n; [eapply DDS_dup with (p := p); simpl; auto|].
        auto using dup_drop_swap.
      + eapply dup_drop_step_star_trans; [eauto|].
        eapply dup_drop_step_star_step_1n.
        eapply DDS_drop with (xs := x :: xs) (p := p) (ys := ys).
        constructor.
  Qed.

  Lemma dup_drop_Permutation :
    forall l l',
      Permutation l l' ->
      dup_drop_step_star l l'.
  Proof using.
    induction 1.
    - constructor.
    - auto using dup_drop_cons.
    - auto using dup_drop_swap.
    - eauto using dup_drop_step_star_trans.
  Qed.

  Lemma remove_not_in_nop :
    forall a l,
      ~ In a l ->
      remove A_eq_dec a l = l.
  Proof using.
    induction l; simpl; intuition.
    break_if; congruence.
  Qed.

  Lemma dup_drop_in :
    forall l l' a,
      dup_drop_step_star l l' ->
      In a l' ->
      In a l.
  Proof using.
    induction 1; intros.
    - auto.
    - invc H.
      + simpl in *. intuition.
        subst. auto.
      + apply IHclos_refl_trans_n1.
        find_apply_lem_hyp in_app_or.
        intuition auto with datatypes.
  Qed.

  Lemma dup_drop_dup_early :
    forall l l' a,
      dup_drop_step_star l l' ->
      In a l ->
      dup_drop_step_star l (a :: l').
  Proof using.
    induction 1; intros.
    - apply dup_drop_step_star_step_1. constructor. auto.
    - concludes.
      eapply dup_drop_step_star_trans; eauto.
      apply dup_drop_cons.
      apply dup_drop_step_star_step_1.
      auto.
  Qed.

  Lemma dup_drop_step_star_remove_In :
    forall l' l a,
      In a l' ->
      dup_drop_step_star l (remove A_eq_dec a l') ->
      dup_drop_step_star (a :: l) l'.
  Proof using.
    induction l'; simpl; intuition.
    - subst. break_if; try congruence.
      destruct (in_dec A_eq_dec a0 l').
      + find_apply_hyp_hyp.
        eapply dup_drop_step_star_trans; eauto.
        eapply dup_drop_step_star_step_1.
        apply DDS_dup; auto.
      + rewrite remove_not_in_nop in * by auto.
        apply dup_drop_cons. auto.
    - break_if.
      + subst.
        find_apply_hyp_hyp.
        eapply dup_drop_step_star_trans; eauto.
        eapply dup_drop_step_star_step_1.
        apply DDS_dup; auto.
      + pose proof dup_drop_in l _ a ltac:(eauto).
        try concludes. (* Only needed in Coq 8.5 *)
        eapply dup_drop_step_star_step_n1 in H0; [| eapply DDS_drop with (xs := [])].
        simpl in *.
        apply IHl' in H0; auto.
        apply dup_drop_dup_early; auto.
        simpl. intuition.
  Qed.

  Lemma remove_In_elim :
    forall x a l,
      In x (remove A_eq_dec a l) ->
      x <> a /\ In x l.
  Proof using.
    induction l; simpl; intuition; break_if; subst; simpl in *; intuition.
  Qed.

  Lemma dup_drop_reorder :
    forall l l' : list A,
      (forall x, In x l' -> In x l) ->
      dup_drop_step_star l l'.
  Proof using A_eq_dec.
    induction l; intros.
    - destruct l'.
      + constructor.
      + simpl in *. exfalso. eauto.
    - destruct (in_dec A_eq_dec a l').
      + eapply dup_drop_step_star_remove_In. auto.
        apply IHl.
        intros.
        find_apply_lem_hyp remove_In_elim.
        intuition.
        find_apply_hyp_hyp.
        simpl in *. intuition.
        exfalso. eauto.
      + eapply dup_drop_step_star_step_1n.
        eapply DDS_drop with (xs := []).
        apply IHl.
        simpl in *. intros.
        find_copy_apply_hyp_hyp.
        intuition.
        subst. exfalso. eauto.
  Qed.
End dup_drop_reorder.

Section step_failure_dup_drop_step.
  Context `{params : FailureParams}.

  Theorem step_failure_dup_drop_step :
    forall ps ps' Sigma f,
      dup_drop_step_star _ ps ps' ->
      step_failure_star (f, mkNetwork ps Sigma) (f, mkNetwork ps' Sigma) [].
  Proof using.
    induction 1.
    - constructor.
    - match goal with
      | [ H : dup_drop_step _ _ _ |- _ ] => invc H
      end.
      + find_apply_lem_hyp in_split. break_exists. break_and. subst.
        apply refl_trans_n1_1n_trace.
        eapply RTn1TStep with (cs := []).
        * apply refl_trans_1n_n1_trace.
          apply IHclos_refl_trans_n1.
        * eapply StepFailure_dup; [simpl; eauto|]. auto.
      + apply refl_trans_n1_1n_trace.
        eapply RTn1TStep with (cs := []).
        * apply refl_trans_1n_n1_trace.
          apply IHclos_refl_trans_n1.
        * eapply StepFailure_drop; [simpl; eauto|]. auto.
  Qed.
End step_failure_dup_drop_step.


(** Pierre Casteran, LaBRI, University of Bordeaux *)

(** * Data types

 An hydra is a finitely branched tree. We use the auxiliary type [Hydrae]  for
 representing finite sequences  of hydras.
 *)

From Coq Require Export Relations.
From hydras Require Import T1 Epsilon0.

(* begin snippet HydraDef *)

Inductive Hydra : Set :=
| node :  Hydrae -> Hydra
with Hydrae : Set :=
| hnil : Hydrae
| hcons : Hydra -> Hydrae -> Hydrae.

(* end snippet HydraDef *)

(** Alternative representation (discarded) *)

(* begin snippet HydraAlt *)

Module Alt.
  Inductive Hydra : Set :=
  | hnode (daughters : list Hydra).
End Alt.

(* end snippet HydraAlt *)

(**   Mutual induction scheme for types Hydra and Hydrae
 *)

(* begin snippet HydraRect2 *)
Scheme Hydra_rect2 := Induction for Hydra Sort Type
with   Hydrae_rect2 := Induction for Hydrae Sort Type.
(* end snippet HydraRect2 *)

Arguments Hydra_rect2 P P0 : rename.
Arguments Hydrae_rect2 P P0 : rename.

(* begin snippet hForall *)
(** All elements of s satisfy P *)
Fixpoint h_forall (P: Hydra -> Prop) (s: Hydrae) :=
  match s with
  | hnil => True
  | hcons h s' => P h /\ h_forall P s'
  end.
(* end snippet hForall *)

Lemma h_eq_dec : forall h h':Hydra, {h = h'}+{h <> h'}
with hs_eq_dec : forall l l':Hydrae, {l = l'}+{l <> l'}.
Proof.
 all: decide equality.
Defined.

(**   Number of nodes (a.k.a. size)
 *)

(* begin snippet hsize *)
Fixpoint hsize (h:Hydra) : nat :=
  match h with
  | node l => S (lhsize l)
  end
with lhsize l : nat :=
       match l with
       | hnil => 0
       | hcons h hs => hsize h + lhsize hs
       end.
(* end snippet hsize *)

(** ***  height (length of longest branch)
 *)

(* begin snippet height *)
Fixpoint height  (h:Hydra) : nat :=
  match h with
  | node l => lheight l
  end
with lheight l : nat :=
       match l with
       | hnil => 0
       | hcons h hs => Nat.max (S (height h)) (lheight hs)
       end.
(* end snippet height *)

(** ** Abbreviations
 *)

(** *** Heads : A head is just a node without daughters
*)

(* begin snippet headsEtc *)
(** *** Hydra with 0, 1, 2 or 3 daughters *)

Notation head := (node hnil).
Notation hyd1 h := (node (hcons h hnil)).
Notation hyd2 h h' := (node (hcons h (hcons h' hnil))).
Notation hyd3 h h' h'' := (node (hcons h (hcons h' (hcons h'' hnil)))).
(* end snippet headsEtc *)

(** *** Adds n copies of the same hydra h at the right of  s
*)

(* begin snippet hconsMult *)
Fixpoint hcons_mult (h:Hydra)(n:nat)(s:Hydrae):Hydrae :=
  match n with
  | O => s
  | S p => hcons h (hcons_mult h p s)
  end.

(** *** Hydra with n equal daughters *)

Definition hyd_mult h n :=
  node (hcons_mult h n hnil).
(* end snippet hconsMult *)

(** ** Managing sequences of hydras
 *)

(** *** Appending
 *)

Fixpoint hy_app (s1 s2: Hydrae) : Hydrae :=
  match s1 with
    hnil => s2
  | hcons h1 s1' => hcons h1 (hy_app s1' s2)
  end.

(** ***  Adds a  head to  the right of [s]
 *)

Fixpoint add_head_r (s: Hydrae) :=
  match s with
    hnil => hcons  head hnil
  | hcons h s' => hcons h (add_head_r s')
  end.

(** ***  Adds i   heads to the right of [s]
 *)

Fixpoint add_head_r_plus (s:Hydrae) (i:nat)  :=
  match i with
    0 => s
  | S j => add_head_r (add_head_r_plus s j)
  end.

(** *** adds [i] heads to  the root of [h] (to the right of its daughters)
 *)

Definition add_r h i :=
  match h with node s => node (add_head_r_plus s i) end.

(** *  Hydra Battles

    ** Relation associated with a single round.

  We represent the rules of Hydra Battles through a binary relation:
  [round_n n] on the [Hydra] type.
The proposition  [round_n n  h h'] holds if [h'] is obtained from [h] by a single round of a battle, and [n] is the _expected_ replication  factor (irrelevant if the chopped head is at distance 1 from the foot).

The proposition [round_n n h h'] holds

- if [h'] is obtained from [h] by chopping off one head of height 1. This situation is described by the proposition [R1 h h'].

- Or [h'] is obtained from [h] through a beheading at distance $\geq 2$ from the foot, with creation of [n] copies of some dub-hydra.

Before giving the definition in Coq of [round_n], we need to define several  auxiliary relations.

 ***  S0

 The proposition [S0 s s'] holds if the sequence [s'] is obtained by removing one head from [s]
*)

(* begin snippet S0Def *)
Inductive S0 :  relation Hydrae :=
| S0_first : forall s, S0 (hcons head s) s
| S0_rest : forall  h s s', S0  s s' -> S0 (hcons h s) (hcons h s').
(* end snippet S0Def *)

(** *** R1

    The proposition [R1 h h'] holds if [h'] is obtained by removing one head from [h] at distance 1 from  the foot

*)

(* begin snippet R1Def *)
Inductive R1  :  relation Hydra :=
| R1_intro : forall s s', S0 s s' -> R1 (node s) (node s').
(* end snippet R1Def *)

 (** *** S1

  [S1 n s s'] holds if [s'] is obtained from [s] by replacing some  member [h] of [s] by $n+1$ copies of [h],  where [R1 h h'] holds.
  Thus, [n] is the number of new replicas of [h'].

 *)

(* begin snippet S1Def *)

Inductive S1 (n:nat)  : relation  Hydrae  :=
| S1_first : forall s h h' ,
              R1 h h' ->
              S1 n (hcons h s) (hcons_mult h' (S n) s)
| S1_next : forall h s s',
                 S1 n s s' ->
                 S1 n (hcons h s) (hcons h s').

(* end snippet S1Def *)

(**  *** R2

The proposition [R2 n h h'] holds if some sub-hydra [h0] of [h] has been replaced by [h'0],
  where [R1 n h0 h'0]. The [S2] relation is just a helper for [R2].

*)

(* begin snippet R2Def *)
Inductive R2 (n:nat)  :  relation Hydra  :=
| R2_intro : forall s s', S1 n s s' -> R2 n (node s) (node s')
| R2_intro_2 : forall s s', S2 n s s' -> R2 n (node s) (node s')

with S2 (n:nat) :  relation Hydrae :=
     |  S2_first : forall h h' s ,
         R2 n   h h'->  S2  n (hcons h s) (hcons h'  s)
     |  S2_next  : forall h   r r',
         S2 n r r' ->  S2 n (hcons h r) (hcons h r').
(* end snippet R2Def *)

(**  *** [round_n]

   Let [n] be an _expected_ replication number. The relation [round_n n h h']
   holds:
   - if  [h'] is obtained from [h] by removing one head of height 1 (and the factor [n] is irrelevant)
   - or  [h'] is obtained from [h] by removing one head of height greater or equal than 2, and this beheading was made with a relocation factor [n].
*)

(* begin snippet roundNDef *)
Definition round_n n h h' := R1 h h' \/ R2 n h h'.
(* end snippet roundNDef *)

(** Transition system associated with battles *)

(** *** Binary relation associated with a battle round *)

(* begin snippet roundDef *)
Definition round h h' := exists n,  round_n n h h'.
Infix "-1->" := round (at level 60).
(* end snippet roundDef *)

(** *** transitive closures of round
*)

(* begin snippet roundPlus *)
Definition round_plus := clos_trans_1n Hydra round.
Definition round_star h h' := h = h' \/ round_plus h h'.

Infix "-+->" := round_plus (at level 60).
Infix "-*->" := round_star (at level 60).
(* end snippet roundPlus *)

(** **  Experimental tactics for interactive battles  *)

(**  *** removes the i-th daughter (should be a head) *)

Ltac chop_off i :=
  match goal with |- S0 ?h ?h' =>
                  match i with
                    | O => eapply S0_first
                    | S ?j => eapply S0_rest; chop_off j
                  end
                  |  |- round ?h ?h' =>
                     exists 0; left; split; chop_off i
                  |  |- round_n ?n ?h ?h' =>
                     left ; split; chop_off i
  end.

(**  Calls the [R2] relation *)

Ltac h_search_n n  :=  match goal with
                       |- round ?h ?h' =>  exists n; eright
                    end.

Ltac h_search   :=  match goal with
                    | |- round_n ?p ?h ?h' => eright
                    end.

Ltac s2_nth n :=
  match n with
    | 0 => eleft
    | S ?p => eright ; s2_nth p
    end.

(** Moves to the [i]-th daugther *)

Ltac r2_up i := match goal with
                    |- R2 ?n ?h ?h' => eright; s2_nth i
end.

Ltac S1_nth i :=
  match goal with
      |- S1 ?n ?h ?h' =>
      match i with
        | 0 => eleft
        | S ?j => eright ; S1_nth j
      end
  end.

(** Notifies we are at distance 2 from the expected head
    goto to [i]-th dauchter, then chop off the [j]-th head *)

Ltac r2_d2 i j :=
 match goal with
      |- R2 ?n ?h ?h' =>  eleft; S1_nth i; split; chop_off j
 end.

(** End of the battle *)

Ltac stop :=
  match goal with
      |- round_star ?h ?h' => left; reflexivity
  end.

(** Still fighting *)

Lemma round_star_intro h h'' : forall h',
    h -1-> h' -> h' -*-> h'' -> h -*-> h''.
Proof.
  destruct 2.
  - subst; right; now left .
  - right; now right with h'.
Qed.

Ltac forward :=
  match goal with
      |- round_star ?h ?h' => eapply round_star_intro
  end.

(**  ** Traces *)

Inductive trace_to  dest : list  nat -> Hydra -> Prop :=
  trace_to1 : forall n h, round_n  n h dest -> trace_to dest (n:: nil) h
| trace_toS : forall n t h h',  round_n n  h h' -> trace_to dest t h' ->
                                 trace_to dest (n:: t) h.

Definition trace t h h' := trace_to h' t h.

(**
  Let $h$ be an hydra and $n$ and expected replication factor. The next step of
  the current battle may be specified by the following type *)

Definition round_spec h n :=
  {h' : Hydra |  round_n n h h'} + {h = head}.

(** ** Classes of battles

In an hydra battle, the interaction between the two players  may depend on the time (number of rounds) elapsed since the beginning of the fight.

Let us formalize this dependence through a relation linking the number of the current round, and the hydra before and after the considered round.

*)

(* begin snippet BattleDef *)
Definition round_t := nat -> Hydra -> Hydra -> Prop.

Class Battle :=
  { battle_rel : round_t;
    battle_ok : forall i h h', battle_rel i h h' -> round h h'}.

Arguments battle_rel : clear implicits.
(* end snippet BattleDef *)

(** In the current state of this development, we will consider two instances of class [Battle]:

 - In [free], we hydra may chose any replication factor at any time.

 - In [standard] the replication factor at round number [i] is just [i]
 *)

(* begin snippet freeDef *)
#[ global ] Program Instance free : Battle
  := Build_Battle (fun _  h h' => round h h') _.
(* end snippet freeDef *)

(* begin snippet standardDef *)
#[ global ] Program Instance standard : Battle :=
  Build_Battle round_n  _.
Next Obligation.
  now exists i.
Defined.

(* end snippet standardDef *)

(**  The following relation allows us to consider sequences of rounds in a given  class  of battles

 The proposition [rounds b i h j h'] holds if there is a battle of class [B] that
  starts with hydra [h] at round [i] and ends with hydra [h'] at round [j]
 *)

(* begin snippet battleRelDef *)
Inductive rounds (B:Battle)
  : nat -> Hydra -> nat -> Hydra -> Prop :=
  rounds_1 : forall i h  h',
    battle_rel   B i  h h' -> rounds B i h (S i) h'
| rounds_n : forall i h  j h' h'',
    battle_rel  B i h h''  ->
    rounds B (S i) h'' j h'  ->
    rounds B i h j h'.

(** number of steps leading to the hydra's death *)

Definition battle_length B k h l :=
    rounds B k h (Nat.pred (k + l)%nat) head.
(* end snippet battleRelDef *)

#[deprecated(note="use rounds")]
  Notation battle := rounds (only parsing).

(** *** Uniform termination *)

(* begin snippet TerminationDef *)

Definition Termination :=  well_founded (transp _ round).

(* end snippet TerminationDef *)

Definition B_termination (B: Battle) :=
  well_founded (fun h' h =>  exists i:nat, battle_rel B i h h' ).

(** *** Variants for proving termination
 *)

(* begin snippet HvariantDef *)

Class Hvariant {A:Type}{Lt:relation A}
      (Wf: well_founded Lt)(B : Battle)
      (m: Hydra -> A): Prop :=
  {variant_decr: forall i h h',
      h <> head -> battle_rel B i  h h' -> Lt (m h') (m h)}.

(* end snippet HvariantDef *)

(** Variant bounded by some ordinal alpha < epsilon0 *)
(** **  Strictly Bounded variants *)

(* begin snippet BoundedVariant *)

Class BoundedVariant {A:Type}{Lt:relation A}
      {Wf: well_founded Lt}{B : Battle}
      {m: Hydra -> A} (Var: Hvariant  Wf  B m)(mu:A):=
  { m_bounded: forall h, Lt (m h ) mu }.

(* end snippet BoundedVariant *)

(** *** Liveness

 For every reachable configuration [(i,h)], either [h] is a head, or
 there exists a beheading leading to some configuration [(S i, h')].
 *)

(* begin snippet AliveDef *)
Definition Alive (B : Battle) :=
  forall i h, h <> head -> {h' : Hydra |  battle_rel  B i h h'}.
(* end snippet AliveDef *)


Require Export Axioms.
Require Export Classical.

Definition Single X :=
  Pair X X.

Theorem in_single X Y (Y_ : M Y) :
  Y ∈ Single X <-> Y = X.
Proof.
  split; rewrite in_pair => // H.
  + by case H.
  + by left.
Qed.

Theorem single_set X :
    M X -> M (Single X).
Proof.
  move => X_.
  apply pair_set => //.
Qed.

Definition Orderd X Y:= Pair (Single X) (Pair X Y).
Notation "<| a , b , .. , d |>" := (Orderd .. (Orderd a b) .. d)(at level 0).

Theorem orderd_set X Y (X_ : M X) (Y_ : M Y) :
  M (<|X,Y|>).
Proof.
  apply pair_set.
  by apply pair_set.
  by apply pair_set.
Qed.

Definition InRel :=
  {|fun u => exists x y, M x /\ M y /\ u = <|x,y|> /\ x ∈ y|}.

Ltac is_set := unfold M; eauto.

Theorem inrel u :
  u ∈ InRel <-> exists x y, M x /\ M y /\ u = <|x,y|> /\ x ∈ y.
Proof.
  split => [H|[x [y [x_ [y_ [u_xy xy]]]]]].
  + have u_ : M u by is_set.
    by move /(in_cls _ _ u_) : H.
  + subst u.
    apply in_cls.
    apply orderd_set => //.
    by exists x; exists y.
Qed.

Definition Intersection X Y :=
  {|fun u => u ∈ X /\ u ∈ Y|}.
Notation "X ∩ Y" := (Intersection X Y)  (at level 60).

Theorem in_cap X Y u :
    u ∈ (X ∩ Y) <->  u ∈ X /\ u ∈ Y.
Proof.
  split => [H | H].
  + assert (u_ : M u) by is_set.
    move /in_cls : H.
    by apply.
  + move : H => [uX uY].
    rewrite in_cls => //.
    is_set.
Qed.

Definition Comple X :=
  {| fun x => ~ x ∈ X|}.
Notation "¬ X" := (Comple X)(at level 5).

Theorem in_comp X x (x_ : M x):
    x ∈ ¬X <-> ~ x ∈ X.
Proof.
  by rewrite in_cls.
Qed.

Definition Cup X Y :=
  ¬(¬X ∩ ¬Y).
Notation "X ∪ Y" := (Cup X Y) (at level 10).

Theorem in_cup X Y u :
  u ∈ (X ∪ Y) <-> u ∈ X \/ u ∈ Y.
Proof.
  split => [H | H].
  + have u_ : M u by is_set.
    move /(in_comp _ _ u_) : H.
    move /in_cap.
    move /not_and_or.
    by case; move /(in_comp _ _ u_) => H; [left|right]; apply NNPP.
  + case H => [uX|uY]; have u_ : M u by is_set.
    - rewrite in_comp => //.
      rewrite in_cap.
      apply or_not_and.
      left.
      by rewrite in_comp.
    - rewrite in_comp => //.
      rewrite in_cap.
      apply or_not_and.
      right.
      by rewrite in_comp.
Qed.

Definition V :=
  ¬∅.

Theorem in_universe x :
  x ∈ V <-> M x.
Proof.
  split => [H | H].
  + by exists V.
  + rewrite in_comp => //.
    by apply notin_empty.
Qed.

Definition Dom f :=
  {| fun x => exists y, M y /\ <|x,y|> ∈ f|}.

Theorem in_dom f x (x_ : M x):
  x ∈ Dom f <-> exists y, M y /\ <|x,y|> ∈ f.
Proof.
  by rewrite in_cls.
Qed.

Definition Ran f :=
  {|fun y => exists x, M x /\ <|x,y|> ∈ f|}.

Theorem in_ran f y (y_ : M y) :
  y ∈ Ran f <-> exists x, M x /\ <|x,y|> ∈ f.
Proof.
  by rewrite in_cls.
Qed.

Definition Diff X Y :=
  {| fun u => u ∈ X /\ ~ u ∈ Y|}.
Notation "X ~ Y"  := (Diff X Y) (at level 10).

Theorem diff X Y u :
  u ∈ X ~ Y <-> u ∈ X /\ ~ u ∈ Y.
Proof.
  split => [H | [uX _uY]]; have u_ : M u by is_set.
  + by move /(in_cls _ _ u_) : H.
  + by rewrite in_cls.
Qed.

Definition Product X Y :=
  {| fun u => exists x y, M x /\ M y /\ u = <|x,y|> /\ x ∈ X /\ y ∈ Y|}.
Notation "X × Y" := (Product X Y) (at level 10).

Theorem in_prod X Y u :
  u ∈ X × Y <-> exists x y, M x /\ M y /\ u = <|x,y|> /\ x ∈ X /\ y ∈ Y.
Proof.
  split => [uXY | [x [y [x_ [y_ [u_xy [xX yY]]]]]]].
  + have u_ : M u by is_set.
    move /in_cls : uXY; auto.
  + rewrite in_cls.
    by exists x; exists y.
    by subst u; apply orderd_set.
Qed.

Definition Sq X := X × X.
Notation "X ²" := (Sq X)(at level 1).

Definition Rel X := X ⊂ V².

Definition Power X :=
  {| fun x => x ⊂ X|}.

Theorem in_pow X x (x_ : M x):
    x ∈ (Power X) <-> x ⊂ X.
Proof.
  by rewrite in_cls.
Qed.

Axiom pow_set :
  forall x, M x -> M (Power x).

Definition Cups X :=
  {| fun x => exists Y, x ∈ Y /\ Y ∈ X|}.
Notation "⊔ X" := (Cups X) (at level 10).

Theorem in_cups X x :
  x ∈ ⊔ X <-> exists Y, x ∈ Y /\ Y ∈ X.
Proof.
  split => [H | [Y [xY YX]]].
  + have x_ : M x  by is_set.
    move /in_cls : H; auto.
  + rewrite in_cls.
    by exists Y.
    is_set.
Qed.

Axiom cups_set :
  forall x, M x -> M (⊔ x).

Definition Caps X :=
  {|fun x => forall Y, Y ∈ X -> x ∈ Y|}.
Notation "⊓ X" := (Caps X) (at level 10).

Theorem in_caps X x (x_ : M x) :
    x ∈ ⊓ X <-> (forall Y, Y ∈ X -> x ∈ Y).
Proof.
  by rewrite in_cls.
Qed.

Theorem caps_empty__universe :
  ⊓ ∅ = V.
Proof.
  rewrite -Equal => i.
  split => [H | H]; have i_ : M i by is_set.
  + by apply in_universe.
  + rewrite in_caps => // Y HY.
    have Y_ : M Y by is_set.
    case (notin_empty Y Y_ HY).
Qed.


Require Export GeoCoq.Highschool.circumcenter.

Section Concyclic.

Context `{TE:Tarski_euclidean}.

Definition Concyclic A B C D := Coplanar A B C D /\ exists O, Cong O A O B /\ Cong O A O C /\ Cong O A O D.

Lemma concyclic_aux : forall A B C D, Concyclic A B C D ->
  exists O, Cong O A O B /\ Cong O A O C /\ Cong O A O D /\ Coplanar A B C O.
Proof.
  intros A B C D [HCop [O1]]; spliter.
  destruct (col_dec A B C).
    exists O1; repeat split; Cop.
  destruct (l11_62_existence A B C O1) as [O []].
  exists O.
  repeat split; try apply cong2_per2__cong with O1 O1; finish.
Qed.

Lemma concyclic_trans : forall A B C D E,
 ~ Col A B C ->
 Concyclic A B C D  -> Concyclic A B C E -> Concyclic A B D E.
Proof.
intros.
split.
unfold Concyclic in *; spliter; CopR.
apply concyclic_aux in H0.
apply concyclic_aux in H1.
decompose [ex and] H0;clear H0.
decompose [ex and] H1;clear H1.
exists x.
repeat split;Cong.
assert (x=x0).
assert_diffs.
apply is_circumcenter_uniqueness with A B C;try assumption.
repeat split; [CongR..|Cop].
repeat split; [CongR..|Cop].
subst.
Cong.
Qed.

Lemma concyclic_perm_1: forall A B C D,
  Concyclic A B C D -> Concyclic A B D C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_2 : forall A B C D,
  Concyclic A B C D -> Concyclic A C B D.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_3 : forall A B C D,
  Concyclic A B C D -> Concyclic A C D B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_4 : forall A B C D,
  Concyclic A B C D -> Concyclic A D B C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_5 : forall A B C D,
  Concyclic A B C D -> Concyclic A D C B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_6 : forall A B C D,
  Concyclic A B C D -> Concyclic B A C D.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_7 : forall A B C D,
  Concyclic A B C D -> Concyclic B A D C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_8 : forall A B C D,
  Concyclic A B C D -> Concyclic B C A D.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_9 : forall A B C D,
  Concyclic A B C D -> Concyclic B C D A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_10 : forall A B C D,
  Concyclic A B C D -> Concyclic B D A C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_11 : forall A B C D,
  Concyclic A B C D -> Concyclic B D C A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_12 : forall A B C D,
  Concyclic A B C D -> Concyclic C A B D.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_13 : forall A B C D,
  Concyclic A B C D -> Concyclic C A D B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_14 : forall A B C D,
  Concyclic A B C D -> Concyclic C B A D.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_15 : forall A B C D,
  Concyclic A B C D -> Concyclic C B D A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_16 : forall A B C D,
  Concyclic A B C D -> Concyclic C D A B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_17 : forall A B C D,
  Concyclic A B C D -> Concyclic C D B A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_18 : forall A B C D,
  Concyclic A B C D -> Concyclic D A B C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_19 : forall A B C D,
  Concyclic A B C D -> Concyclic D A C B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_20 : forall A B C D,
  Concyclic A B C D -> Concyclic D B A C.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_21 : forall A B C D,
  Concyclic A B C D -> Concyclic D B C A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_22 : forall A B C D,
  Concyclic A B C D -> Concyclic D C A B.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_perm_23 : forall A B C D,
  Concyclic A B C D -> Concyclic D C B A.
Proof.
intros A B C D H.
destruct H as [H1 [X H2]].
split; [Cop|spliter; exists X; repeat split; CongR..].
Qed.

Lemma concyclic_1123 : forall A B C,
 ~ Col A B C ->
 Concyclic A A B C.
Proof.
intros A B C HABC.
unfold Concyclic.
split.
apply coplanar_trivial.
destruct (exists_circumcenter A B C HABC) as [G HG].
exists G.
apply circumcenter_cong in HG;spliter;repeat split;Cong.
Qed.

End Concyclic.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
(*Require Import depoolContract.Lib.CommonCommon.*)
(* Require Import depoolContract.Lib.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

Require Export Coq.micromega.Lia.

Lemma div_neg_neg_or : forall a b, a / b < 0 -> (a < 0 \/ b < 0).
Proof.
intros. case_eq (a <? 0). intros. apply Zlt_is_lt_bool in H0. left. assumption.
intros. assert (a < 0 \/ 0 <= a) by apply Z.neg_nonneg_cases. inversion H1.
apply Zlt_is_lt_bool in H2. congruence.
case_eq (b <? 0). intros. apply Zlt_is_lt_bool in H3. right. assumption.
intros. assert (b < 0 \/ 0 <= b) by apply Z.neg_nonneg_cases. inversion H4.
apply Zlt_is_lt_bool in H5. congruence. apply Z.lt_eq_cases in H5. inversion H5.
assert (0 <= a / b). apply Z.div_pos ; assumption. omega. rewrite <- H6 in H.
rewrite Zdiv_0_r in H. omega.
Qed.

Lemma neg_lt0b_ge0 : forall a, (a <? 0) = false -> a = 0 \/ 0 < a.
Proof.
intros. assert (a < 0 \/ 0 <= a) by apply Z.neg_nonneg_cases. inversion H0.
apply Zlt_is_lt_bool in H1. congruence. omega.
Qed.

Definition non_neg_zlist (l : list Z) := Forall (Z.le 0) l.
Definition pos_zlist (l : list Z) := Forall (Z.lt 0) l.

Lemma sum_z_eq_z_add_z_0 : forall (l : list Z)(z : Z),
    fold_left Z.add l z = z + fold_left Z.add l 0.
Proof.
intro l. induction l. simpl. lia. intros. simpl. rewrite IHl.
rewrite IHl with (z := a). lia.
Qed.

Lemma sum_not_neg_not_neg : forall (l : list Z),
    non_neg_zlist l ->
    0 <= fold_left Z.add l 0.
Proof.
intros. induction l. simpl. lia. simpl. rewrite sum_z_eq_z_add_z_0.
unfold non_neg_zlist in H. inversion H. unfold non_neg_zlist in IHl.
apply IHl in H3. apply Z.add_nonneg_nonneg ; assumption.
Qed.

Lemma element_less_sum : forall (l : list Z)(z : Z),
    non_neg_zlist l ->
    In z l ->
    z <= fold_left Z.add l 0.
Proof.
intro l. induction l. intros. simpl. inversion H0. intros. inversion H0.
rewrite H1. simpl. rewrite sum_z_eq_z_add_z_0. replace z with (z + 0) at 1.
apply Z.add_le_mono_l. apply sum_not_neg_not_neg. unfold non_neg_zlist in H.
inversion H. unfold non_neg_zlist. assumption. lia. simpl. rewrite sum_z_eq_z_add_z_0.
assert(forall m n p, 0 <= n -> m <= p -> m <= n + p) by lia.
apply H2. unfold non_neg_zlist in H. inversion H. assumption. apply IHl.
unfold non_neg_zlist in *. inversion H. assumption. assumption.
Qed.

Lemma ForAll_map : forall (X Y : Type) (f : Y -> Prop) (g : X -> Y) ( l : list X),
Forall f (map g l) <-> Forall (compose f g) l.
Proof.
intros. split. intros. induction l. simpl in H. auto.
apply CommonProofs.Forall_cons. apply CommonProofs.Forall_cons in H.
inversion H. split. auto. apply IHl. unfold map. assumption.
intros. induction l. simpl. auto. apply CommonProofs.Forall_cons. split.
apply CommonProofs.Forall_cons in H. inversion H. auto.
unfold map in IHl. apply IHl. apply CommonProofs.Forall_cons in H.
inversion H. assumption.
Qed.

Lemma in_map_exists : forall (A B : Type) (l : list A) (s : B)  (f : A -> B) ,
    In s (map f l) ->
    (exists k, In k l /\ s = f k).
Proof.
intro A. intro B. intro l. induction l. intros. inversion H. intros.
simpl in H. inversion H. exists a. split. simpl. left. reflexivity.
symmetry. assumption. apply IHl in H0. inversion H0. exists x. inversion H1.
split. simpl. right. assumption. assumption.
Qed.

Lemma sub_sub_min_non_neg_l : forall m n,
    0 <= n ->
    0 <= n - intMin n m.
Proof.
intros. unfold intMin. simpl. case_eq (n <=? m) ; intros . lia.
apply Zle_minus_le_0. apply Z.leb_gt in H0. apply Z.lt_le_incl. assumption.
Qed.

Lemma intMin_sym : forall m n, intMin n m = intMin m n.
Proof.
intros. unfold intMin. simpl. case_eq (n <=? m) ; intros ; case_eq (m <=? n) ;
intros ; try reflexivity . apply Zle_bool_imp_le in H. apply Zle_bool_imp_le in H0.
apply Z.le_antisymm ; assumption. apply Z.leb_gt in H. apply Z.leb_gt in H0. lia.
Qed.

Lemma sub_sub_min_non_neg_r : forall m n,
    0 <= n ->
    0 <= n - intMin m n.
Proof.
intros. rewrite intMin_sym. apply sub_sub_min_non_neg_l. assumption.
Qed.

Lemma min_lte_l : forall n m,
    intMin n m <= n.
Proof.
intros.  unfold intMin. simpl. case_eq(n <=? m). lia. intros. apply Z.leb_gt in H. lia.
Qed.

Lemma min_lte_r : forall n m,
    intMin n m <= m.
Proof.
intros. rewrite intMin_sym. apply min_lte_l.
Qed.

Lemma min_n_m : forall n m,
    intMin n m = n \/ intMin n m = m.
Proof.
intros. unfold intMin. simpl. case_eq(n <=? m) ; intros. left. reflexivity.
right. reflexivity.
Qed.

Lemma min_gte_0 : forall n m,
    0 <= n ->
    0 <= m ->
    0 <= intMin n m.
Proof.
intros. assert (intMin n m = n \/ intMin n m = m) by apply min_n_m.
inversion H1 ; rewrite H2; assumption.
Qed.

Lemma add_le_2 : forall n1 n2 m1 m2 p,
    n1 <= m1 ->
    n2 <= m2 ->
    m1 + m2 <= p ->
    n1 + n2 <= p.
Proof.
intros. apply Z.le_trans with (m := m1 + m2). apply Z.add_le_mono ; assumption. assumption.
Qed.

Lemma add_le_3 : forall n1 n2 n3 m1 m2 m3 p,
    n1 <= m1 ->
    n2 <= m2 ->
    n3 <= m3 ->
    m1 + m2 + m3 <= p ->
    n1 + n2 + n3 <= p.
Proof.
intros. apply add_le_2 with (m1 := m1 + m2)(m2 := m3).
apply add_le_2 with (m1 := m1)(m2 := m2). assumption. assumption. lia.
assumption. assumption.
Qed.

Lemma intMulDiv_le_full : forall a b c,
    0 <= a ->
    0 <= b ->
    a <= c ->
    0 < c ->
    intMulDiv a b c <= b.
Proof.
intros. unfold intMulDiv. simpl. rewrite <- Z_div_mult with (b := c).
setoid_rewrite Z.mul_comm at 2. apply Z_div_le. lia. apply Z.mul_le_mono_nonneg_r.
assumption. assumption. lia.
Qed.

Lemma intMulDiv_le_a : forall a b c,
    0 <= a ->
    b <= c ->
    0 < c ->
    intMulDiv a b c <= a.
Proof.
intros. unfold intMulDiv. simpl. rewrite <- Z_div_mult with (a:=a)(b:=c) at 2.
apply Z.div_le_mono. assumption. apply Zmult_le_compat_l ; assumption. lia.
Qed.

Lemma intMulDiv_ge_0 : forall a b c,
    0 <= a ->
    0 <= b ->
    0 < c ->
    0 <= intMulDiv a b c.
Proof.
intros. unfold intMulDiv. simpl. apply Z_div_pos. lia. lia.
Qed.

Lemma pos_zlist_is_non_neg_zlist : forall (l : list Z),
    pos_zlist l -> non_neg_zlist l.
Proof.
intros. induction l. unfold non_neg_zlist. apply Forall_nil. apply Forall_cons.
inversion H. lia. unfold non_neg_zlist in IHl. apply IHl. apply Forall_inv_tail in H.
unfold pos_zlist. assumption.
Qed.

Lemma forall_f_to_g : forall (X : Type) (f g : X -> Prop) (l : list X),
    (forall x, f x -> g x) -> Forall f l -> Forall g l.
Proof.
intros. induction l. apply Forall_nil. apply ForallCons in H0. inversion H0.
apply Forall_cons. apply H. assumption. apply IHl. assumption.
Qed.

Lemma element_strictly_less_sum : forall (l : list Z),
    pos_zlist l ->
    (1 < length l)%nat ->
    Forall (Z.gt (fold_left Z.add l 0)) l.
Proof.
intros. induction l. inversion H0.
simpl. rewrite sum_z_eq_z_add_z_0. apply Forall_cons. rewrite <- Z.add_0_r.
apply Z.lt_gt. apply Zplus_lt_compat_l. destruct l. inversion H0. inversion H2.
simpl. rewrite sum_z_eq_z_add_z_0. apply Z.add_pos_nonneg. inversion H.
inversion H4. assumption. apply sum_not_neg_not_neg. apply pos_zlist_is_non_neg_zlist.
inversion H. inversion H4. unfold pos_zlist. assumption. induction l.
simpl in *. lia. clear IHl0. induction l. simpl in *. apply Forall_cons.
apply Z.lt_gt. replace a0 with (0 + a0) at 1. inversion H. apply Z.add_lt_le_mono.
assumption. lia. lia. apply Forall_nil.
apply forall_f_to_g with (f := Z.gt (fold_left Z.add (a0 :: a1 :: l) 0)). intros.
apply Z.gt_lt in H1. apply Z.lt_gt. replace x with (0 + x). apply Z.add_lt_mono.
inversion H. assumption. assumption. lia. apply IHl. inversion H. unfold pos_zlist.
assumption. simpl. lia.
Qed.

Lemma pos_zlist_assoc : forall (l : list Z) a b ,
    pos_zlist (a :: b :: l) ->
    pos_zlist (b :: a :: l).
Proof.
intros. inversion_clear H. inversion_clear H1.
unfold pos_zlist. apply Forall_cons. assumption. apply Forall_cons. assumption. assumption.
Qed.

Lemma pos_zlist_sum_is_pos_not_empty : forall (l : list Z),
    pos_zlist l ->
    (0 < length l)%nat ->
    0 < (fold_left Z.add l 0).
Proof.
intros. destruct l. inversion H0. clear H0. induction l. simpl. unfold pos_zlist in H.
apply (Forall_one(a := z)) in H. assumption. simpl.
rewrite sum_z_eq_z_add_z_0. apply pos_zlist_assoc in H. inversion_clear H. apply IHl in H1.
simpl in H1. rewrite sum_z_eq_z_add_z_0 in H1. lia.
Qed.

Lemma matchOpt_exists : forall (X : Type) (o : option X),
    match o with | Some _ => true | _ => false end = true <->
    exists z, o = Some z.
Proof.
intros. split. intros. destruct o. exists x. reflexivity. discriminate.
intros. inversion H. destruct o. reflexivity. discriminate.
Qed.

Lemma len_one_as_list_one : forall (X : Type) (l : list X),
    (1 = length l)%nat <->
    exists x, l = [x].
Proof.
intros. split. intros. destruct l. inversion H. destruct l. exists x. reflexivity.
inversion H. intros. inversion H. rewrite H0. auto.
Qed.

Lemma isSome_false_default : forall (X : Type) (x : XMaybe X)`{XDefault X},
xMaybeIsSome x = xBoolFalse -> maybeGet x = default.
Proof.
intros. unfold xMaybeIsSome in H0. destruct x. discriminate. compute. reflexivity.
Qed.


Set Implicit Arguments.
Require Import List.
Opaque plus. (* avoid pesky reductions *)
From Dblib Require Import DblibTactics DeBruijn.

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

(* Environments map variables to data. *)

(* Environments are homogeneous -- there is only one kind of variables --
   and non-dependent -- variables do not occur within data. *)

(* What should be the type of an environment? Multiple answers come to mind,
   such as [list A], [nat -> option A], [list (option A)], etc. The choice of
   a definition is guided by the desire that [lookup] and [insert] be total
   functions that satisfy a number of natural laws. In particular, if [insert]
   is a total function, then we cannot expect the domain of an environment to
   be contiguous. This rules out [list A]. Representing an environment by its
   lookup function, of type [nat -> option A], works, but does not allow
   defining [fold] over environments. In the end, representing an environment
   by a finite list of possibly-null entries seems to be a reasonable
   choice. *)

Definition env A :=
  list (option A).

(* What notion of equality over environments do we need? Extensional equality
   of the [lookup] functions seems to be the most natural notion. The
   predicate [agree], defined below, is a bounded version of this
   notion. Perhaps by chance, the basic laws that relate [lookup], [insert],
   and [map] are valid with respect to Leibniz equality, so we do not define
   extensional equality. *)

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

(* Operations on environments. *)

(* The empty environment is undefined everywhere. *)

Definition empty A : env A :=
  nil.

(* Environment lookup. *)

Fixpoint lookup A (x : nat) (e : env A) : option A :=
  match e, x with
  | nil, _ =>
      None
  | entry :: _, 0 =>
      entry
  | _ :: e, S x =>
      lookup x e
  end.

(* [insert x a e] inserts a new variable [x], associated with data [a], in the
   environment [e]. The pre-existing environment entries at index [x] and
   above are shifted up. Thus, [insert x] is closely analogous to [shift x]
   for terms. *)

(* [insert] inserts a non-null entry in the environment. We define it in terms
   of [raw_insert], which can also be used to insert a null entry. [raw_insert]
   is useful because it allows generating every environment (thus, it can be
   used in the formulation of an induction principle). *)

Fixpoint raw_insert A (x : nat) (o : option A) (e : env A) : env A :=
  match x, e with
  | 0, _ =>
      o :: e
  | S x, entry :: e =>
      entry :: raw_insert x o e
  | S x, nil =>
      None :: raw_insert x o e
  end.

Notation insert x a e :=
  (raw_insert x (Some a) e).

(* [map f e] is the environment obtained by applying [f] to every datum
   in the environment [e]. *)

Fixpoint map A B (f : A -> B) (e : env A) :=
  match e with
  | nil =>
      nil
  | None :: e =>
      None :: map f e
  | Some a :: e =>
      Some (f a) :: map f e
  end.

(* [fold f e accu] performs an iteration over all entries in the environment.
   Older entries are visited first: in other words, the initial accumulator
   should make sense at the toplevel, outside of the environment, and is
   pushed successively into every binding, so as to yield a final accumulator
   that makes sense inside this environment. *)

Fixpoint fold A B (f : option A -> B -> B) (e : env A) (accu : B) : B :=
  match e with
  | nil =>
      accu
  | o :: e =>
      f o (fold f e accu)
  end.

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

(* Basic arithmetic simplifications. *)

Lemma one_plus_x_minus_one_left:
  forall x,
  (1 + x) - 1 = x.
Proof.
  intros. omega.
Qed.

Lemma one_plus_x_minus_one_right:
  forall x,
  x > 0 ->
  1 + (x - 1) = x.
Proof.
  intros. omega.
Qed.

Ltac one_plus_x_minus_one :=
  repeat rewrite one_plus_x_minus_one_left in *;
  repeat rewrite one_plus_x_minus_one_right in * by omega.
  (* I tried [autorewrite with ... using omega]; it does not work. *)

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

(* Trivial facts. *)

Lemma raw_insert_zero:
  forall A o (e : env A),
  raw_insert 0 o e = o :: e.
Proof.
  reflexivity.
Qed.

Lemma raw_insert_successor:
  forall A x o (e : env A),
  raw_insert (S x) o e =
  lookup 0 e :: raw_insert x o (tail e).
Proof.
  intros. destruct e; reflexivity. (* ! *)
Qed. (* Maybe this should be the definition of [raw_insert]. *)

Lemma empty_eq_insert:
  forall A x o (e : env A),
  empty _ = insert x o e ->
  False.
Proof.
  unfold empty; intros; destruct x.
  rewrite raw_insert_zero in *. congruence.
  rewrite raw_insert_successor in *. congruence.
Qed.

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

(* Interaction between [lookup] and [empty]. *)

Lemma lookup_empty_None:
  forall A x,
  lookup x (@empty A) = None.
Proof.
  destruct x; simpl; reflexivity.
Qed.

Lemma lookup_empty_Some:
  forall A x (a : A),
  lookup x (@empty _) = Some a ->
  False.
Proof.
  destruct x; simpl; congruence.
Qed.

Lemma lookup_successor:
  forall A x (e : env A),
  lookup (S x) e = lookup x (tail e).
Proof.
  destruct e.
  do 2 rewrite lookup_empty_None. reflexivity.
  reflexivity.
Qed.

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

(* Interaction between [lookup] and [insert]. *)

Lemma lookup_insert_bingo:
  forall A x y (o : option A) e,
  x = y ->
  lookup x (raw_insert y o e) = o.
(* Hence, [lookup x (insert y a e) = Some a]. *)
Proof.
  induction x; intros; destruct y; destruct e; simpl; try solve [
    elimtype False; omega
  | eauto with omega
  ].
Qed.

Lemma lookup_insert_recent:
  forall A x y (o : option A) e,
  x < y ->
  lookup x (raw_insert y o e) = lookup x e.
(* Hence, [lookup x (insert y a e) = lookup x e]. *)
Proof.
  induction x; intros; destruct y; destruct e; simpl; try solve [
    elimtype False; omega
  | eauto with omega
  ].
  (* One troublesome case. *)
  erewrite <- lookup_empty_None. eauto with omega.
Qed.

Lemma lookup_insert_old:
  forall A x y (o : option A) e,
  x > y ->
  lookup x (raw_insert y o e) = lookup (x - 1) e.
(* Hence, [lookup x (insert y a e) = lookup (x - 1) e]. *)
Proof.
  (* Induction over [x], which is non-zero. *)
  induction x; intros; [ elimtype False; omega | replace (S x - 1) with x by omega ].
  (* Case analysis. *)
  destruct y; destruct e; simpl; try solve [ eauto ].
  (* One troublesome case. *)
  rewrite lookup_empty_None. erewrite <- lookup_empty_None. eauto with omega.
  (* Another troublesome case. *)
  destruct x; intros; [ elimtype False; omega | replace (S x - 1) with x in * by omega ].
  simpl lookup at 2.
  eauto with omega.
Qed.

Lemma lookup_shift_insert:
  forall A x y (o : option A) e,
  lookup (shift y x) (raw_insert y o e) = lookup x e.
(* Hence, [lookup (shift y x) (insert y a e) = lookup x e]. *)
Proof.
  intros. destruct_lift_idx.
  rewrite lookup_insert_old by omega. f_equal. omega.
  rewrite lookup_insert_recent by omega. reflexivity.
Qed.

Ltac lookup_insert :=
  first [
    rewrite lookup_insert_bingo by omega
  | rewrite lookup_insert_old by omega; one_plus_x_minus_one
  | rewrite lookup_insert_recent by omega
  | rewrite lookup_shift_insert
  ].

Ltac lookup_insert_all :=
  first [
    rewrite lookup_insert_bingo in * by omega;
    try match goal with h: Some _ = Some _ |- _ => injection h; intro; subst; clear h end
  | rewrite lookup_insert_old in * by omega; one_plus_x_minus_one
  | rewrite lookup_insert_recent in * by omega
  | rewrite lookup_shift_insert in *
  ].

Hint Extern 1 (lookup _ (raw_insert _ _ _) = _) =>
  lookup_insert
: lookup_insert.

Hint Extern 1 (lookup _ _ = _) =>
  lookup_insert_all
: lookup_insert.

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

(* Interaction between [map] and [empty]. *)

Lemma map_empty:
  forall A B (f : A -> B),
  map f (@empty _) = @empty _.
Proof.
  reflexivity.
Qed.

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

(* Interaction between [lookup] and [map]. *)

Lemma lookup_map_none:
  forall A B x e (f : A -> B),
  lookup x e = None ->
  lookup x (map f e) = None.
Proof.
  induction x; intros; destruct e as [ | [ | ] ? ]; simpl in *; subst;
  solve [ eauto | congruence ].
Qed.

Lemma lookup_map_some:
  forall A B x a e (f : A -> B),
  lookup x e = Some a ->
  lookup x (map f e) = Some (f a).
Proof.
  induction x; intros; destruct e as [ | [ | ] ? ]; simpl in *; subst; try solve [
    congruence
  | eauto
  ].
Qed.

Lemma lookup_map_some_reverse:
  forall A B x b e (f : A -> B),
  lookup x (map f e) = Some b ->
  exists a,
  lookup x e = Some a /\ b = f a.
Proof.
  induction x; intros; destruct e as [ | [ | ] ? ]; simpl in *; subst; try solve [
    congruence
  | eauto
  ].
  eexists. split. reflexivity. congruence.
Qed.

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

(* [insert] commutes with itself, just like [lift] commutes with itself. *)

Lemma insert_insert:
  forall A k s (a b : option A) e,
  k <= s ->
  raw_insert k a (raw_insert s b e) = raw_insert (1 + s) b (raw_insert k a e).
Proof.
  intros ? k s. generalize s k; clear s k. induction s; intros.
  (* Case [s = 0]. *)
  destruct k; [ | elimtype False; omega ]. reflexivity.
  (* Case [s > 0]. *)
  destruct k.
  (* Sub-case [k = 0]. *)
  reflexivity.
  (* Sub-case [k > 0]. *)
  destruct e; replace (1 + S s) with (S (1 + s)) by omega; simpl; f_equal; eauto with omega.
Qed.

(* Even when it is not known which of [k] and [s] is greater, [insert] commutes
   with itself. The formula is slightly horrid, but can be very useful. *)

Lemma insert_insert_always:
  forall A k s (a b : option A) e,
  raw_insert k a (raw_insert s b e) =
  raw_insert (shift k s) b (raw_insert (if le_gt_dec k s then k else k - 1) a e).
Proof.
  intros.
  destruct (le_gt_dec k s).
  rewrite lift_idx_old by assumption. eauto using insert_insert.
  rewrite lift_idx_recent by assumption.
  replace k with (1 + (k - 1)) in * by omega. rewrite <- insert_insert by omega.
  do 2 f_equal. omega.
Qed.

(* Attempting to rewrite in both directions may seem redundant, because of the
   symmetry of the law [insert_insert]. It is not: because [omega] fails in
   the presence of meta-variables, rewriting in one direction may be possible
   while the other direction fails. *)

Ltac insert_insert :=
  first [
    rewrite    insert_insert; [ reflexivity | omega ]
  | rewrite <- insert_insert; [ reflexivity | omega ]
  ].

Hint Extern 1 (raw_insert _ _ _ = _) =>
  insert_insert
: insert_insert.

Hint Extern 1 (_ = raw_insert _ _ _) =>
  insert_insert
: insert_insert.

(* The result of an insertion cannot be nil. *)

Lemma insert_nil:
  forall A x a (e : env A),
  insert x a e = nil ->
  False.
Proof.
  destruct x; destruct e; simpl; congruence.
Qed.

(* Two lemmas about equations of the form [insert x a1 e1 = insert x a2 e2].
   Note that we have [a1 = a2], but not [e1 = e2], due to padding. *)

Lemma insert_eq_insert_1:
  forall A x a1 a2 (e1 e2 : env A),
  insert x a1 e1 = insert x a2 e2 ->
  a1 = a2.
Proof.
  intros.
  assert (lookup x (insert x a1 e1) = Some a1). eauto using lookup_insert_bingo.
  assert (lookup x (insert x a2 e2) = Some a2). eauto using lookup_insert_bingo.
  congruence.
Qed.

Lemma insert_eq_insert_2:
  forall A x a1 a2 (e1 e2 : env A),
  insert x a1 e1 = insert x a2 e2 ->
  forall b,
  insert x b e1 = insert x b e2.
Proof.
  induction x; simpl; intros.
  congruence.
  destruct e1; destruct e2;
  match goal with h: _ = _ |- _ => injection h; clear h; intros end;
  f_equal; try congruence; eauto.
Qed.

(* This is a really crazy diamond lemma that says, roughly, if the equation
    [insert x1 a1 e1 = insert x2 a2 e2] holds, then [e1] and [e2] can be
    constructed out of a common environment [e]. We would like to conclude
    [e1 = insert x2 a2 e /\ e2 = insert x1 a1 e], but this is false, because
    one of the indices is off-by-one in one way or the other. We need to
    adjust, and the arithmetic is a bit painful. *)

Lemma insert_eq_insert_3:
  forall A x1 x2 a1 a2 (e1 e2 : env A),
  insert x1 a1 e1 = insert x2 a2 e2 ->
  x1 <> x2 ->
  exists e y1 y2,
  e1 = insert y1 a2 e /\
  e2 = insert y2 a1 e /\
  shift x1 y1 = x2 /\
  y2 = (if le_gt_dec x1 y1 then x1 else x1 - 1).
Proof.
  induction x1; intros.
  (* Case [x1 = 0]. *)
  destruct x2; [ omega | ].
  rewrite raw_insert_zero in *. rewrite raw_insert_successor in *.
  match goal with h: _ = _ |- _ =>
    injection h; clear h; intros
  end.
  destruct e2; [ congruence | ]. subst. simpl.
  exists e2. exists x2. exists 0. eauto.
  (* Case [x1 > 0]. *)
  destruct x2.
  (* Sub-case [x2 = 0]. *)
  rewrite raw_insert_zero in *. rewrite raw_insert_successor in *.
  match goal with h: _ = _ |- _ =>
    injection h; clear h; intros
  end.
  destruct e1; [ congruence | ]. subst.
  exists e1. exists 0. exists x1.
  split. eauto.
  split. eauto.
  split. eauto.
  dblib_by_cases. omega.
  (* Sub-case [x2 > 0]. *)
  do 2 rewrite raw_insert_successor in *.
  assert (xx: x1 <> x2). omega.
  match goal with h: _ = _ |- _ =>
    injection h; clear h; intros h ?;
    generalize (IHx1 _ _ _ _ _ h xx); intros [ e [ y1 [ y2 [ ? [ ? [ ? ? ]]]]]]
  end.
  (* [e1] and [e2] must be non-nil. *)
  destruct e1; simpl tl in *; [ elimtype False; eauto using insert_nil | ].
  destruct e2; simpl tl in *; [ elimtype False; eauto using insert_nil | ].
  exists (o :: e). exists (S y1). exists (S y2).
  split. simpl. congruence.
  split. simpl. congruence.
  split. eapply translate_lift with (k := 1). eauto.
  dblib_by_cases; omega.
Qed.

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

(* Interaction between [map] and [insert]. *)

Lemma map_insert:
  forall A B (f : A -> B) x a e,
  map f (insert x a e) = insert x (f a) (map f e).
Proof.
  induction x; intros; destruct e; simpl; eauto.
  rewrite IHx. reflexivity.
  match goal with o: option _ |- _ => destruct o end; f_equal; eauto.
Qed.

(* The following variant is easier to use for [eauto]. *)

Lemma map_insert_eq:
  forall A B (f : A -> B) x a b e,
  f a = b ->
  map f (insert x a e) = insert x b (map f e).
Proof.
  intros; subst. eapply map_insert.
Qed.

Ltac map_insert :=
  first [
    rewrite map_insert; reflexivity
  | rewrite <- map_insert; reflexivity
  ].

Hint Extern 1 (map _ (insert _ _ _) = insert _ _ (map _ _)) =>
  map_insert
: map_insert.

Hint Extern 1 (insert _ _ (map _ _) = map _ (insert _ _ _)) =>
  map_insert
: map_insert.

Lemma map_raw_insert:
  forall A B (f : A -> B) x e,
  map f (raw_insert x None e) = raw_insert x None (map f e).
Proof.
  induction x; intros; destruct e; simpl; eauto.
  rewrite IHx. reflexivity.
  match goal with o: option _ |- _ => destruct o end; f_equal; eauto.
Qed.

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

(* [map] composes with itself. *)

Lemma map_map_fuse:
  forall A B C (f : B -> C) (g : A -> B) h e,
  (forall (d : A), f (g d) = h d) ->
  map f (map g e) = map h e.
Proof.
  induction e; intros;
  try match goal with o: option _ |- _ => destruct o end;
  simpl; eauto with f_equal.
Qed.

Lemma map_map_exchange:
  forall A F G B (f1 : F -> B) (f2 : A -> F) (g1 : G -> B) (g2 : A -> G) e,
  (forall (d : A), f1 (f2 d) = g1 (g2 d)) ->
  map f1 (map f2 e) = map g1 (map g2 e).
Proof.
  induction e; intros;
  try match goal with o: option _ |- _ => destruct o end;
  simpl; eauto with f_equal.
Qed.

Lemma map_lift_map_lift:
  forall T k s wk ws (e : env T),
  forall `{Lift T},
  @LiftLift T _ ->
  k <= s ->
  map (lift wk k) (map (lift ws s) e) = map (lift ws (wk + s)) (map (lift wk k) e).
Proof.
  eauto using map_map_exchange, @lift_lift.
Qed.

Lemma map_insert_map:
  forall A (f g h : A -> A) x (a : A) e,
  (forall a, f (g a) = g (h a)) ->
  map f (insert x a (map g e)) =
  insert x (f a) (map g (map h e)).
Proof.
  intros.
  rewrite map_insert. f_equal.
  eapply map_map_exchange.
  eauto.
Qed.

Lemma map_map_vanish:
  forall A B (f : B -> A) (g : A -> B) (e : env A),
  (forall x, f (g x) = x) ->
  map f (map g e) = e.
Proof.
  induction e; intros;
  try match goal with o: option _ |- _ => destruct o end;
  simpl; eauto with f_equal.
Qed.

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

(* Properties of [fold]. *)

(* Interaction between [fold] and [empty]. *)

Lemma fold_empty:
  forall A B (f : option A -> B -> B) accu,
  fold f (@empty _) accu = accu.
Proof.
  reflexivity.
Qed.

(* Interaction between [fold] and [insert]. *)

Lemma fold_insert:
  forall A B (f : option A -> B -> B) o e accu,
  fold f (raw_insert 0 o e) accu = f o (fold f e accu).
Proof.
  reflexivity.
Qed.

(* An induction principle. In order to prove that a property [P] holds of
   [fold f e accu], it suffices to hold that it holds of the initial
   accumulator and that it is preserved by one iteration. The statement is
   expressed in terms of [empty] and [raw_insert], so the fact that
   environments are implemented as lists is not exposed. *)

Lemma fold_invariant:
  forall A B (P : env A -> B -> Prop) f accu,
  P (@empty _) accu ->
  (forall o e accu, P e accu -> P (raw_insert 0 o e) (f o accu)) ->
  forall e,
  P e (fold f e accu).
Proof.
  intros ? ? ? ? ? init step.
  induction e; simpl.
  eapply init.
  eapply step. eauto.
Qed.

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

(* [length e] should be viewed as an upper bound on the true length of the
   environment [e], since there may be useless [None] entries at the end.
   We are careful to always work with hypotheses and goals of the form
   [length e <= k]. *)

Lemma length_monotonic:
  forall A (e : env A) k1 k2,
  length e <= k1 ->
  k1 <= k2 ->
  length e <= k2.
Proof.
  intros. omega.
Qed.

Lemma lookup_beyond_length:
  forall A (e : env A) x,
  length e <= x ->
  lookup x e = None.
Proof.
  induction e; simpl; intros.
  eapply lookup_empty_None.
  destruct x; [ omega | ]. simpl. eapply IHe. omega.
Qed.

(* Every variable that is defined in the environment is less than the
   length of the environment. *)

Lemma defined_implies_below_length:
  forall A (e : env A) x k a,
  length e <= k ->
  lookup x e = Some a ->
  x < k.
Proof.
  intros.
  (* If [x < k] holds, the result is immediate. Consider the other case,
     [k <= x]. *)
  case (le_gt_dec k x); intro; try tauto.
  (* By definition of [length], [lookup x e] is [None]. *)
  assert (lookup x e = None). eapply lookup_beyond_length. omega.
  (* We obtain a contradiction. *)
  congruence.
Qed.

Hint Resolve defined_implies_below_length : lift_idx_hints.

(* The empty environment has zero length. *)

Lemma length_empty:
  forall A k,
  length (@empty A) <= k.
Proof.
  simpl. intros. omega.
Qed.

(* This definition of [max] is much more pleasant to work with than the
   one found in Coq's standard library. It can be easily unfolded, and
   then [omega] takes control. *)

Definition mymax m n :=
  if le_gt_dec m n then n else m.

Ltac mymax :=
  unfold mymax in *; dblib_by_cases; try omega.

Lemma mymax_l:
  forall i j, mymax i j >= i.
Proof.
  intros. mymax.
Qed.

Lemma mymax_r:
  forall i j, mymax i j >= j.
Proof.
  intros. mymax.
Qed.

Hint Resolve mymax_l mymax_r : mymax.

(* Extending an environment increments its length by one, in the usual case.
   It can be extended by more than one if [x] is far away. *)

Lemma length_insert_general:
  forall A x k o (e : env A),
  length e = k ->
  length (raw_insert x o e) = mymax (1 + k) (1 + x).
Proof.
  induction x; simpl; intros; subst.
  mymax.
  destruct e; simpl.
  mymax. erewrite IHx by reflexivity. simpl. mymax.
  erewrite IHx by reflexivity. mymax.
Qed.

(* This should be the usual case. *)

Lemma length_insert:
  forall A x k km1 o (e : env A),
  length e <= km1 ->
  km1 <= k - 1 ->
  x < k ->
  length (raw_insert x o e) <= k.
Proof.
  intros. erewrite length_insert_general by reflexivity. mymax.
Qed.

(* Pain, pain. *)

Lemma length_insert_reverse_1:
  forall A (e : env A) k x a,
  length (insert x a e) <= k ->
  x < k.
Proof.
  intros. erewrite length_insert_general in * by reflexivity. mymax.
Qed.

Lemma length_insert_reverse_2:
  forall A (e : env A) k x a,
  length (insert x a e) <= k + 1 ->
  length e <= k.
Proof.
  intros. erewrite length_insert_general in * by reflexivity. mymax.
Qed.

Lemma length_insert_independent:
  forall A (e : env A) k x a,
  length (insert x a e) <= k ->
  forall y o,
  y < k ->
  length (raw_insert y o e) <= k.
Proof.
  intros. erewrite length_insert_general in * by reflexivity. mymax.
Qed.

(* Applying a transformation to an environment does not affect its length. *)

Lemma length_map_general:
  forall A B (f : A -> B) (e : env A),
  length (map f e) = length e.
Proof.
  induction e as [| [|] ]; simpl; intros; congruence.
Qed.

Lemma length_map:
  forall A B (f : A -> B) (e : env A) k,
  length e <= k ->
  length (map f e) <= k.
Proof.
  intros. rewrite length_map_general. assumption.
Qed.

Hint Resolve length_empty length_insert length_map : length.

Hint Resolve length_insert length_map : construction_closed.

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

(* The definitions and properties that follow should be independent of the
   details of the definitions of [empty], [lookup], [insert], and [map]. *)

Opaque empty lookup raw_insert map.

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

(* A definition of when two environments agree up to length [k]. *)

Definition agree A (e1 e2 : env A) (k : nat) :=
  forall x,
  x < k ->
  lookup x e1 = lookup x e2.

(* A simple consequence of the definition. *)

Lemma agree_below:
  forall A (e1 e2 : env A) x a k,
  lookup x e1 = Some a ->
  x < k ->
  agree e1 e2 k ->
  lookup x e2 = Some a.
Proof.
  do 6 intro. intros hlookup ? ?.
  rewrite <- hlookup. symmetry.
  eauto.
Qed.

(* The empty environment agrees with every environment up to length [0]. *)

Lemma agree_empty_left:
  forall A (e : env A),
  agree (@empty _) e 0.
Proof.
  unfold agree. intros. elimtype False. omega.
Qed.

Lemma agree_empty_right:
  forall A (e : env A),
  agree e (@empty _) 0.
Proof.
  unfold agree. intros. elimtype False. omega.
Qed.

(* If two environments that agree up to [k] are extended with a new variable,
   then they agree up to [k+1]. *)

Lemma agree_insert:
  forall A (e1 e2 : env A) k,
  agree e1 e2 k ->
  forall x o,
  x <= k ->
  agree (raw_insert x o e1) (raw_insert x o e2) (1 + k).
Proof.
  unfold agree. do 8 intro. intros n ?.
  (* Reason by cases: [x = n], [x < n], [x > n]. *)
  case (le_gt_dec x n); [ case (eq_nat_dec x n) | ]; intros;
  (* In each case, [lookup_insert] simplifies the goal. *)
  do 2 lookup_insert; eauto with omega.
Qed.

Hint Resolve defined_implies_below_length agree_below agree_empty_left
agree_empty_right agree_insert : agree.

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

(* A definition of when an environment subsumes another, up to a notion of
   subsumption on environment entries. *)

Section Subsume.

  Variable A : Type.

  Variable sub : A -> A -> Prop.

  Variable sub_reflexive:
    forall a,
    sub a a.

  Variable sub_transitive:
    forall a1 a2 a3,
    sub a1 a2 ->
    sub a2 a3 ->
    sub a1 a3.

  (* Subsumption is first extended to options. *)

  Definition osub (o1 o2 : option A) :=
    forall a2,
    o2 = Some a2 ->
    exists a1,
    o1 = Some a1 /\ sub a1 a2.

  Lemma osub_None:
    forall o,
    osub o None.
  Proof.
    unfold osub. congruence.
  Qed.

  Lemma osub_Some_Some:
    forall a1 a2,
    sub a1 a2 ->
    osub (Some a1) (Some a2).
  Proof.
    unfold osub. intros ? ? ? ? h. injection h; clear h; intro; subst; eauto.
  Qed.

  Lemma osub_None_Some:
    forall a2,
    osub None (Some a2) ->
    False.
  Proof.
    unfold osub. intros ? h.
    generalize (h _ eq_refl). clear h. intros [ a1 [ ? ? ]].
    congruence.
  Qed.

  Lemma osub_Some_inversion:
    forall o1 a2,
    osub o1 (Some a2) ->
    exists a1,
    o1 = Some a1 /\ sub a1 a2.
  Proof.
    intros. destruct o1. eauto. elimtype False. eauto using osub_None_Some.
  Qed.

  (* Then, it is extended pointwise to environments. *)

  Definition subsume (e1 e2 : env A) :=
    forall x,
    osub (lookup x e1) (lookup x e2).

  (* Subsumption of environments is reflexive and transitive. *)

  Lemma osub_reflexive:
    forall o,
    osub o o.
  Proof.
    unfold osub. eauto.
  Qed.

  Lemma subsume_reflexive:
    forall e,
    subsume e e.
  Proof.
    unfold subsume. eauto using osub_reflexive.
  Qed.

  Lemma osub_transitive:
    forall o1 o2 o3,
    osub o1 o2 ->
    osub o2 o3 ->
    osub o1 o3.
  Proof.
    unfold osub. intros ? ? ? hs1 hs2 a3 h3.
    generalize (hs2 _ h3); intros [ a2 [ h2 ? ]].
    generalize (hs1 _ h2); intros [ a1 [ h1 ? ]].
    eauto.
  Qed.

  Lemma subsume_transitive:
    forall e1 e2 e3,
    subsume e1 e2 ->
    subsume e2 e3 ->
    subsume e1 e3.
  Proof.
    unfold subsume. eauto using osub_transitive.
  Qed.

  (* Every environment subsumes the empty environment. *)

  Lemma subsume_empty:
    forall e,
    subsume e (@empty _).
  Proof.
    unfold subsume. intros. rewrite lookup_empty_None. apply osub_None.
  Qed.

  (* Extending two environments with a new variable preserves subsumption. *)

  Lemma subsume_insert:
    forall e1 e2,
    subsume e1 e2 ->
    forall x o1 o2,
    osub o1 o2 ->
    subsume (raw_insert x o1 e1) (raw_insert x o2 e2).
  Proof.
    unfold subsume. do 7 intro. intros n.
    (* Reason by cases: [x = n], [x < n], [x > n]. *)
    case (le_gt_dec x n); [ case (eq_nat_dec x n) | ]; intros;
    (* In each case, [lookup_insert] simplifies the goal. *)
    repeat lookup_insert; eauto.
  Qed.

  Lemma subsume_cons:
    forall o e1 e2,
    osub o (lookup 0 e2) ->
    subsume e1 (tl e2) ->
    subsume (o :: e1) e2.
  Proof.
    do 3 intro. intros h1 h2. intro n. destruct n.
    eauto.
    do 2 rewrite lookup_successor. eauto.
  Qed.

  Lemma subsume_cons_cons_inversion:
    forall o1 o2 e1 e2,
    subsume (o1 :: e1) (o2 :: e2) ->
    osub o1 o2 /\
    subsume e1 e2.
  Proof.
    do 4 intro. intro h.
    split.
    eapply (h 0).
    intro n. eapply (h (1 + n)).
  Qed.

  Lemma subsume_insert_inversion:
    forall e1 x a2 e2,
    subsume e1 (insert x a2 e2) ->
    exists f1 a1,
    e1 = insert x a1 f1 /\
    subsume f1 e2 /\
    sub a1 a2.
  Proof.
    (* Really painful. *)
    induction e1; simpl; intros.
    (* Base. *)
    elimtype False.
    match goal with h: subsume nil _ |- _ =>
      generalize (h x); clear h; intro h;
      rewrite lookup_insert_bingo in h by reflexivity;
      rewrite lookup_empty_None in h
    end.
    solve [ eauto using osub_None_Some ].
    (* Step. *)
    destruct x.
    (* Case [x = 0]. *)
    match goal with h: subsume _ _ |- _ =>
      rewrite raw_insert_zero in h;
      generalize (subsume_cons_cons_inversion h); clear h; intros [ h ? ];
      generalize (osub_Some_inversion h); intros [ ? [ ? ? ]]; subst
    end.
    do 2 eexists.
    rewrite raw_insert_zero.
    solve [ eauto ].
    (* Case [x > 0]. *)
    match goal with h: subsume _ _ |- _ =>
      rewrite raw_insert_successor in h;
      generalize (subsume_cons_cons_inversion h); clear h; intros [ ? h ];
      generalize (IHe1 _ _ _ h); clear IHe1; intros [ f1 [ a1 [ ? [ ? ? ]]]]; subst
    end.
    exists (a :: f1). exists a1.
    rewrite raw_insert_successor. simpl.
    split; [ | split ].
    reflexivity.
    eauto using subsume_cons.
    eauto.
  Qed.

  (* Applying a transformation [f] pointwise to two environments preserves
     environment subsumption, provided [f] preserves [sub]. *)

  Lemma subsume_map:
    forall f,
    (forall a1 a2, sub a1 a2 -> sub (f a1) (f a2)) ->
    forall e1 e2,
    subsume e1 e2 ->
    subsume (map f e1) (map f e2).
  Proof.
    intros ? hf ? ? hs. intros ? b2 hlm2.
    generalize (lookup_map_some_reverse _ _ _ hlm2); intros [ ? [ hl2 ? ]]. subst.
    generalize (hs _ _ hl2); intros [ a1 [ ? ? ]].
    eauto using lookup_map_some.
  Qed.

End Subsume.

Hint Resolve osub_reflexive osub_Some_Some subsume_reflexive
subsume_transitive subsume_empty subsume_insert subsume_map : subsume.

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

(* Extending an environment with a list of bindings found in a pattern. *)

(* Note that we cannot define the concatenation of two environments, because
   we view environments as total functions, so we do not have precise control
   over their domain. Only a list has finite domain. *)

(* Concatenation is just an iterated version of [insert 0]. *)

Fixpoint concat (A : Type) (e1 : env A) (e2 : list A) : env A :=
  match e2 with
  | nil =>
      e1
  | cons a e2 =>
      concat (insert 0 a e1) e2
  end.

(* Concatenation acts upon the length of the environment in an obvious
   manner. *)

Lemma omega_hint_1:
  forall n,
  n <= (n + 1) - 1.
Proof.
  intros. omega.
Qed.

Lemma length_concat:
  forall A (e2 : list A) (e1 : env A) n1 n,
  length e1 <= n1 ->
  n1 + length e2 = n ->
  length (concat e1 e2) <= n.
Proof.
  induction e2; simpl; intros.
  replace n with n1 by omega. assumption.
  eauto using length_insert, omega_hint_1 with omega.
Qed.

Hint Resolve length_concat : length construction_closed.

(* If [e1] and [e2] agree up to depth [k], then, after extending them
   with a common suffix [e], they agree up to depth [k + length e]. *)

Lemma agree_concat:
  forall A (e : list A) (e1 e2 : env A) k n,
  agree e1 e2 k ->
  k + length e = n ->
  agree (concat e1 e) (concat e2 e) n.
Proof.
  induction e; simpl; intros.
  replace n with k by omega. assumption.
  eauto using agree_insert with omega.
Qed.

Hint Resolve agree_concat : agree.

(* Concatenation and insertion commute. *)

Lemma insert_concat:
  forall (A : Type) n x nx (o : option A) e1 e2,
  length e2 = n ->
  n + x = nx ->
  raw_insert nx o (concat e1 e2) = concat (raw_insert x o e1) e2.
Proof.
  induction n; intros; subst; destruct e2; simpl in *; try discriminate; auto.
  rewrite insert_insert by omega.
  erewrite <- (IHn (1 + x)) by first [ congruence | eauto ].
  eauto with f_equal omega.
Qed.

(* [replicate n a] is a list of [n] elements, all of which are
   equal to [a]. *)

Fixpoint replicate (A : Type) (n : nat) (a : A) : list A :=
  match n with
  | 0 =>
      @nil _
  | S n =>
      cons a (replicate n a)
  end.

(* The list [replicate n a] has length [n]. *)

Lemma length_replicate:
  forall (A : Type) n (a : A),
  length (replicate n a) = n.
Proof.
  induction n; simpl; auto.
Qed.

(* A special case of [insert_concat]. *)

Lemma insert_concat_replicate:
  forall (A : Type) n x nx (a : option A) (b : A) e1,
  n + x = nx ->
  raw_insert nx a (concat e1 (replicate n b)) = concat (raw_insert x a e1) (replicate n b).
Proof.
  eauto using insert_concat, length_replicate.
Qed.

(* [concat . (replicate . a)] is just an iterated version of [insert . a]. *)

Lemma concat_replicate_is_iterated_insert:
  forall (A : Type) n (a : A) e,
  insert n a (concat e (replicate n a)) =
  concat e (replicate (S n) a).
Proof.
  intros. simpl. eauto using insert_concat, length_replicate.
Qed.

Hint Resolve insert_concat length_replicate insert_concat_replicate
concat_replicate_is_iterated_insert : insert_concat.

(* A special case of [length_concat]. *)

Lemma length_concat_replicate:
  forall A (a : A) (e1 : env A) n1 n2 n,
  length e1 <= n1 ->
  n1 + n2 = n ->
  length (concat e1 (replicate n2 a)) <= n.
Proof.
  intros. eapply length_concat. eauto. rewrite length_replicate. eauto.
Qed.

Hint Resolve length_concat_replicate : length construction_closed.

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

(* Make some definitions opaque, so that Coq does not over-simplify in
   unexpected (and fragile) ways. *)

Global Opaque empty lookup raw_insert map.


(** Pattern-matching for type of set (subset/sigma-algebra): **)
Definition inn (V : Type) (A : Type) (x : Type)  :=
  match (type of V) with
    σ_algebra => True
  | λ_system => True
  end.

Definition innn (V : Type) (A : Type) (x : Type) :=

Definition inn (G : σ_algebra) (A : subset U) :=
  A ∈ underlying_set_of_subsets_sigma G.

Notation "A 'is_in' a F" :=
  match a with
    0 => In _ F A
  | (S n) => inn F A
  end (at level 50).
Variable A : Ensemble U.
Variable G : Ensemble (Ensemble U).
Lemma test : A is_in 0 G.

Notation "A 'is' 'in' F" :=
  A is in _ F (at level 50).

Definition elem {G : σ_algebra} := true.
Definition elem {H : setOfSubsets U} := true.

(** Type-dependent 'in' definition: **)

Definition my_in {V : Type} (A : Type) (x : Type) :=

(** Several 'in' notations using modules: **)
Module ensemble.
Definition Inn {V : Type} (A : Ensemble V) (x : V) := In V A x.
End ensemble.
Module ensensemble.
Definition Inn {V : Type} (F : Ensemble (Ensemble V)) (A : Ensemble V) := In (Ensemble V) F A.
End ensensemble.

Import ensemble.
Import ensensemble.

Notation "x 'inn' A" := (@Inn _ A x) (at level 50).

Variable x : U.
Variable A : Ensemble U.
Variable G : Ensemble (Ensemble U).
Lemma test : x inn A.

(** Pi and Lambda systems **)

Record π_system := make_pi_system
  { underlying_set_of_subsets_pi : setOfSubsets U;
    proof_is_pi_system : is_π_system underlying_set_of_subsets_pi}.
Coercion underlying_set_of_subsets_pi : π_system >-> setOfSubsets.
Hint Resolve proof_is_pi_system : measure_theory.
Hint Resolve underlying_set_of_subsets_pi : measure_theory.

Variable Π : π_system.

Lemma Π_is_π_system : is_π_system Π.

Proof.
It holds that (is_π_system Π).
Qed.
Hint Resolve Π_is_π_system : measure_theory.

Record λ_system := make_lambda_system
  { underlying_set_of_subsets_lambda : setOfSubsets U;
    proof_is_lambda_system : is_λ_system underlying_set_of_subsets_lambda}.
(*Variable L : λ_system.*)
Coercion underlying_set_of_subsets_lambda : λ_system >-> setOfSubsets.
(*Definition Λ : setOfSubsets U := L.*)
Hint Resolve proof_is_lambda_system : measure_theory.
Hint Resolve underlying_set_of_subsets_lambda : measure_theory.
Variable L : λ_system.
Lemma Λ_is_λ_system : is_λ_system L.

Proof.
It holds that (is_λ_system L).
Qed.
Hint Resolve Λ_is_λ_system : measure_theory.

Record π_and_λ_system := make_pi_and_lambda_system
  { underlying_set_of_subsets_pi_and_lambda : setOfSubsets U;
    proof_is_pi_and_lambda_system : (is_λ_system underlying_set_of_subsets_pi_and_lambda
                                  /\ is_π_system underlying_set_of_subsets_pi_and_lambda)}.
Variable J : π_and_λ_system.
Coercion underlying_set_of_subsets_pi_and_lambda : π_and_λ_system >-> setOfSubsets.
Definition K : setOfSubsets U := J.
Hint Resolve proof_is_pi_and_lambda_system : measure_theory.
Hint Resolve underlying_set_of_subsets_pi_and_lambda : measure_theory.

Lemma Λ_is_π_and_λ_system : (is_λ_system K /\ is_π_system K).

Proof.
It holds that ((is_λ_system (underlying_set_of_subsets_pi_and_lambda J))
            /\ (is_π_system (underlying_set_of_subsets_pi_and_lambda J))) (xx).
It holds that (is_λ_system K /\ is_π_system K).
Qed.
Hint Resolve Λ_is_π_and_λ_system : measure_theory.


(*** Coq coding by choukh, Aug 2022 ***)

Require Export Utf8_core Setoid Morphisms.
Global Set Implicit Arguments.
Global Unset Strict Implicit.

(** 逻辑基础 **)

(* 命题外延 *)
Axiom PE : ∀ P Q, P ↔ Q → P = Q.
(* 函数外延 *)
Axiom FE : ∀ A B (f g : A → B), (∀ x, f x = g x) → f = g.

Lemma 谓词外延 A (p q : A → Prop) : (∀ x, p x ↔ q x) → p = q.
Proof. intros H. apply FE. intros x. apply PE, H. Qed.

(* 证明无关性 *)
Fact PI (P : Prop) (H H' : P) : H = H'.
Proof.
  enough (P = True) as ->.
  destruct H, H'. reflexivity. apply PE. easy.
Qed.

(* 排中律 *)
Class LEM : Set := lem : ∀ P, P ∨ ¬ P.
Tactic Notation "排中" constr(P) := destruct (lem P).
Tactic Notation "排中" constr(P) "as" simple_intropattern(L) := destruct (lem P) as L.
Tactic Notation "反证" := edestruct lem as []; eauto; exfalso.

(** 成员关系 **)

Notation "x ∈ p" := (p x) (only parsing, at level 70).
Notation "x ∉ p" := (¬ p x) (only parsing, at level 70).

Notation "∀ x .. y ∈ A , P" :=
  (∀ x, x ∈ A → (.. (∀ y, y ∈ A → P) ..))
  (only parsing, at level 200, x binder, right associativity).

Notation "∃ x .. y ∈ A , P" :=
  (∃ x, x ∈ A ∧ (.. (∃ y, y ∈ A ∧ P) ..))
  (only parsing, at level 200, x binder, right associativity).

(** 子集关系 *)

Notation "'𝒫' A" := (A → Prop) (at level 9).

Definition 包含 A (p q : 𝒫 A) := ∀ x ∈ p, x ∈ q.
Notation "p ⊆ q" := (包含 p q) (at level 70).
Notation "p ⊈ q" := (¬ p ⊆ q) (at level 70).
Notation "p ⊂ q" := (p ⊆ q ∧ q ⊈ p) (at level 70).
Notation "p ⊄ q" := (¬ p ⊂ q) (at level 70).

Notation "∀ x .. y ⊆ A , P" :=
  (∀ x, x ⊆ A → (.. (∀ y, y ⊆ A → P) ..))
  (only parsing, at level 200, x binder, right associativity).

Notation "∃ x .. y ⊆ A , P" :=
  (∃ x, x ⊆ A ∧ (.. (∃ y, y ⊆ A ∧ P) ..))
  (only parsing, at level 200, x binder, right associativity).

Fact 包含_自反 A (p : 𝒫 A) : p ⊆ p.
Proof. firstorder. Qed.

Fact 包含_传递 A (p q r : 𝒫 A) : p ⊆ q → q ⊆ r → p ⊆ r.
Proof. firstorder. Qed.

(* 集论外延 *)
Lemma 包含_反对称 A (p q : 𝒫 A) : p ⊆ q → q ⊆ p → p = q.
Proof. intros. apply 谓词外延; firstorder. Qed.
Notation 外延 := 包含_反对称.

(** 其他集论记号 **)

Notation "A ⁻" := (λ x, ¬ x ∈ A) (only parsing, at level 20).
Notation "A ⋃ B" := (λ x, x ∈ A ∨ x ∈ B) (only parsing, at level 60).
Notation "A ∩ B" := (λ x, x ∈ A ∧ x ∈ B) (only parsing, at level 60).
Notation "{ a , }" := (λ x, x = a) (only parsing).
Notation "{ a , b }" := (λ x, x = a ∨ x = b) (only parsing).
Notation "{ x ∊ A | P }" := (λ x, x ∈ A ∧ P) (only parsing).
Notation "{ x ∊ A | xA 'in' P }" := (λ x, ∃ xA : x ∈ A, P) (only parsing).

(** 子类型 (子集的类型化) **)

Notation Σ := sig.
Notation σ := exist.
Notation π₁ := proj1_sig.
Notation π₂ := proj2_sig.

Lemma σ_函数 A (p : 𝒫 A) x y px py : x = y → σ p x px = σ p y py.
Proof. intros ->. now rewrite (PI px py). Qed.

Lemma π_单射 A (p : 𝒫 A) (xₛ yₛ : Σ p) : π₁ xₛ = π₁ yₛ → xₛ = yₛ.
Proof. destruct xₛ as [x px], yₛ as [y py]. apply σ_函数. Qed.

Lemma σπ_η A (p : 𝒫 A) (xₛ : Σ p) : σ p (π₁ xₛ) (π₂ xₛ) = xₛ.
Proof. now destruct xₛ. Qed.

(** 单射 **)

Definition 单射性 A B (f : A → B) := ∀ x y, f x = f y → x = y.
Definition 单射 A B := ∃ f : A → B, 单射性 f.
Notation "| A | ≤ | B |" := (单射 A B) (format "| A |  ≤  | B |", at level 70).

Global Instance 单射_预序 : PreOrder 单射.
Proof. split.
  - intros A. exists (λ x, x). firstorder.
  - intros A B C [f Hf] [g Hg]. exists (λ x, g (f x)). firstorder.
Qed.

Lemma 单射_从子集 A (p : 𝒫 A) : |Σ p| ≤ |A|.
Proof. exists (@π₁ A p). intros x y. apply π_单射. Qed.

Lemma 单射_到幂集 A : |A| ≤ |𝒫 A|.
Proof. exists eq. now intros x y ->. Qed.

(** 关系式单射 **)

Definition 左完全 A B (R : A → B → Prop) :=
  ∀ x, ∃ y, R x y.

Definition 右完全 A B (R : A → B → Prop) :=
  ∀ y, ∃ x, R x y.

Definition 函数性 A B (R : A → B → Prop) :=
  ∀ x y y', R x y → R x y' → y = y'.

Definition 单射性ᵣ A B (R : A → B → Prop) :=
  ∀ x x' y, R x y → R x' y → x = x'.

Definition 单射ᵣ A B :=
  ∃ (R : A → B → Prop), 左完全 R ∧ 函数性 R ∧ 单射性ᵣ R.
  Notation "| A | ≤ᵣ | B |" := (单射ᵣ A B) (format "| A |  ≤ᵣ  | B |", at level 70).

Lemma 单射_单射ᵣ A B : |A| ≤ |B| → |A| ≤ᵣ |B|.
Proof.
  intros [f Hf]. exists (λ x y, y = f x). repeat split.
  - intros x. now exists (f x).
  - intros x y y' -> ->. reflexivity.
  - intros x x' y -> H. now apply Hf.
Qed.

Fact 幂陪域关系的函数化 A B (R : A → 𝒫 B → Prop) :
  左完全 R → 函数性 R → Σ (λ f, ∀ x, R x (f x)).
Proof.
  intros tot fn. exists (λ x y, ∃ a, R x a ∧ y ∈ a).
  intros x. destruct (tot x) as [y Rxy].
  enough (y = (λ y, ∃ a : 𝒫 B, R x a ∧ a y)) as <- by apply Rxy.
  apply 外延; intros a H. now exists y.
  destruct H as [z [Rxz ax]]. now rewrite (fn x y z).
Qed.

(** 双射 **)

Definition 互逆 A B (f : A → B) (g : B → A) := (∀ x, f (g x) = x) ∧ (∀ y, g (f y) = y).
Definition 双射 A B := ∃ (f : A → B) (g : B → A), 互逆 f g.
Notation "| A | = | B |" := (双射 A B) (format "| A |  =  | B |", at level 70).

Global Instance 双射_等价关系 : Equivalence 双射.
Proof. split.
  - intros A. exists (λ x, x), (λ x, x). firstorder.
  - intros A B (f & g & inv). exists g, f. firstorder.
  - intros A B C (f & g & fg & gf) (h & i & hi & ih).
    exists (λ x, h (f x)), (λ x, g (i x)). firstorder congruence.
Qed.

Fact 双射_单射 A B : |A| = |B| → |A| ≤ |B|.
Proof. intros (f & g & fg & gf). exists f. congruence. Qed.

(* 幂迭代 *)
Fixpoint 𝒫ₙ n A :=
  match n with
  | O => A
  | S n => 𝒫ₙ n (𝒫 A)
  end.

Lemma 幂迭代 A n : 𝒫ₙ n (𝒫 A) = 𝒫 (𝒫ₙ n A).
Proof. revert A; induction n; intros A; firstorder congruence. Qed.

Lemma 单射_到幂迭代 A n : |A| ≤ |𝒫ₙ n A|.
Proof. induction n.
  - reflexivity.
  - etransitivity. apply IHn. simpl. rewrite 幂迭代. apply 单射_到幂集.
Qed.

Definition 无穷 A := |nat| ≤ |A|.

Lemma 无穷_单射 A B : 无穷 A → |A| ≤ |B| → 无穷 B.
Proof. unfold 无穷. etransitivity; eauto. Qed.

Fact 无穷_幂迭代 A n : 无穷 A → 无穷 (𝒫ₙ n A).
Proof. intros H. apply 无穷_单射 with A. trivial. apply 单射_到幂迭代. Qed.

(* 广义连续统假设 *)
Definition GCH := ∀ A B, 无穷 A → |A| ≤ |B| → |B| ≤ |𝒫 A| → |B| ≤ |A| ∨ |𝒫 A| ≤ |B|.

(** Other Notations **)

Tactic Notation "split3" := split; [|split].

Notation "'∃' ! x .. y , P" :=
  (ex (unique (λ x, .. (ex (unique (λ y, P))) ..)))
  (at level 200, x binder, right associativity,
   format "'[' '∃' ! '/ '  x .. y ,  '/ ' P ']'").

Notation "'∃' ! x .. y ∈ A , P" :=
  (∃! x, x ∈ A ∧ (.. (∃! y, y ∈ A ∧ P) ..))
  (at level 200, x binder, right associativity,
   format "'[' '∃' ! '/ '  x .. y  ∈  A ,  '/ ' P ']'").


(* Why arguments of constructor are named? *)
Inductive nat : Type :=
  | O
  | S (n : nat). (* Where name 'n' is used?
  Why it cannot be just S nat?*)


From Cat Require Import Cat.
From Cat.Universal Require Import Product Coproduct.

Set Implicit Arguments.

(**
  See:
  - https://ncatlab.org/nlab/show/biproduct for the old-fashioned definition
  - https://qchu.wordpress.com/2012/09/14/a-meditation-on-semiadditive-categories/
    for some rationale why it was defined like this
  - http://cahierstgdc.com/wp-content/uploads/2020/07/KARVONEN-LXI-3.pdf
    for a better definition that is used in this file
  - https://mathoverflow.net/questions/428546/
    for why (infinite) indexed biproducts don't make much sense
*)

Class isBiproduct
  (C : Cat) {A B : Ob C}
  (P : Ob C) (outl : Hom P A) (outr : Hom P B) (finl : Hom A P) (finr : Hom B P)
  (fpair  : forall {X : Ob C} (f : Hom X A) (g : Hom X B), Hom X P)
  (copair : forall {X : Ob C} (f : Hom A X) (g : Hom B X), Hom P X)
  : Prop :=
{
  isBiproduct_isProduct   :> isProduct C P outl outr (@fpair);
  isBiproduct_isCoproduct :> isCoproduct C P finl finr (@copair);
  isBiproduct_ok : outl .> finl .> outr .> finr == outr .> finr .> outl .> finl;
}.

#[export] Hint Mode isBiproduct ! ! ! ! ! ! ! ! ! ! : core.
#[export] Hint Mode isBiproduct ! ! ! - - - - - - - : core.

Class HasBiproducts (C : Cat) : Type :=
{
  HasProducts_HasBiproducts :> HasProducts C;
  HasCoproducts_HasBiproducts :> HasCoproducts C;
  HasBiproducts_spec : product = coproduct;
}.

Coercion HasProducts_HasBiproducts : HasBiproducts >-> HasProducts.
Coercion HasCoproducts_HasBiproducts : HasBiproducts >-> HasCoproducts.

#[export]
Instance BiproductBifunctor {C : Cat} {hp : HasBiproducts C} : Bifunctor C C C :=
  @CoproductBifunctor C hp.

Class HasBiproducts' (C : Cat) : Type :=
{
  biproduct : Ob C -> Ob C -> Ob C;

  bioutl   : forall {A B : Ob C}, Hom (biproduct A B) A;
  bioutr   : forall {A B : Ob C}, Hom (biproduct A B) B;
  bipair  : forall {A B Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B), Hom Γ (biproduct A B);
  isProduct_HasBiproducts' :>
    forall {A B : Ob C}, isProduct C (biproduct A B) bioutl bioutr (@bipair A B);

  binl     : forall {A B : Ob C}, Hom A (biproduct A B);
  binr     : forall {A B : Ob C}, Hom B (biproduct A B);
  bicopair : forall {A B : Ob C} {P : Ob C} (f : Hom A P) (g : Hom B P), Hom (biproduct A B) P;
  isCoproduct_HasBiproducts :>
    forall {A B : Ob C}, isCoproduct C (@biproduct A B) binl binr (@bicopair A B);

  binl_bioutl :
    forall {A B : Ob C},
      @binl A B .> bioutl == id A;
  binr_bioutr :
    forall {A B : Ob C},
      @binr A B .> bioutr == id B;

  HasBiproducts'_ok :
    forall {A B : Ob C},
      @bioutl A B .> @binl A B .> @bioutr A B .> @binr A B
        ==
      bioutr .> binr .> bioutl .> binl;
}.

Definition zero {C : Cat} {hb : HasBiproducts' C} {A B : Ob C} : Hom A B :=
  @binl _ _ A B .> bioutr.

Definition bidiag {C : Cat} {hp : HasBiproducts' C} {A : Ob C} : Hom A (biproduct A A) :=
  bipair (id A) (id A).

Definition bicodiag {C : Cat} {hp : HasBiproducts' C} {A : Ob C} : Hom (biproduct A A) A :=
  bicopair (id A) (id A).

Definition biadd
  {C : Cat} {hb : HasBiproducts' C}
  {A B : Ob C} (f g : Hom A B) : Hom A B :=
    bipair f g .> bicodiag.

Section BiproductIdentities.

Context
  (C : Cat)
  (hb : HasBiproducts' C)
  (A B : Ob C).

Lemma binl_bioutr :
  forall {X : Ob C} (f : Hom B X),
    @binl _ _ A B .> bioutr .> f == @binl _ _ A X .> bioutr.
Proof.
  intros.
  (* assert (
    bioutr .> binr .> bioutl .> @binl _ _ A B .> bioutr .> f
      ==
    bioutr .> binr .> bioutl .> @binl _ _ A X .> bioutr).
  ). *)
Admitted.

Lemma binl_bioutr' :
  forall {X : Ob C} (f : Hom X A),
    f .> @binl _ _ A B .> bioutr == @binl _ _ X B .> bioutr.
Proof.
Admitted.

Lemma binr_bioutl :
  forall {X : Ob C} (f : Hom A X),
    @binr _ _ A B .> bioutl .> f == @binr _ _ X B .> bioutl.
Proof.
Admitted.

Lemma binr_bioutl' :
  forall {X : Ob C} (f : Hom X B),
    f .> @binr _ _ A B .> bioutl == @binr _ _ A X .> bioutl.
Proof.
  intros.
  assert (H1 : isConstant (@binr _ _ A B .> bioutl)) by admit.
  assert (H2 : isCoconstant (@binr _ _ A B .> bioutl)) by admit.
  unfold isConstant, isCoconstant in H1, H2.
Admitted.

End BiproductIdentities.

Section MoreBiproductIdentities.

Context
  (C : Cat)
  (hb : HasBiproducts' C)
  (A B : Ob C).

Lemma binl_bipair :
  forall {A' B' : Ob C} (f : Hom A A') (g : Hom B B'),
    binl .> bipair (bioutl .> f) (bioutr .> g) == f .> binl.
Proof.
  intros.
  rewrite equiv_product', !comp_assoc, fpair_outl, fpair_outr.
  rewrite binl_bioutl, <- !comp_assoc, binl_bioutl, comp_id_l, comp_id_r.
  now rewrite binl_bioutr, binl_bioutr'.
Qed.

Lemma binr_bipair :
  forall {A' B' : Ob C} (f : Hom A A') (g : Hom B B'),
    binr .> bipair (bioutl .> f) (bioutr .> g) == g .> binr.
Proof.
  intros.
  rewrite equiv_product', !comp_assoc, fpair_outl, fpair_outr.
  rewrite binr_bioutr, <- !comp_assoc, binr_bioutr, comp_id_l, comp_id_r.
  now rewrite binr_bioutl, binr_bioutl'.
Qed.

Lemma bicopair_bioutl :
  forall {A' B' : Ob C} (f : Hom A A') (g : Hom B B'),
    bicopair (f .> binl) (g .> binr) .> bioutl == bioutl .> f.
Proof.
  intros.
  rewrite equiv_coproduct', <- !comp_assoc, finl_copair, finr_copair.
  rewrite binr_bioutl, binr_bioutl'.
  now rewrite binl_bioutl, comp_assoc, binl_bioutl, comp_id_l, comp_id_r.
Defined.

Lemma bicopair_bioutr :
  forall {A' B' : Ob C} (f : Hom A A') (g : Hom B B'),
    bicopair (f .> binl) (g .> binr) .> bioutr == bioutr .> g.
Proof.
  intros.
  rewrite equiv_coproduct', <- !comp_assoc, finl_copair, finr_copair.
  rewrite binl_bioutr, binl_bioutr'.
  now rewrite binr_bioutr, comp_assoc, binr_bioutr, comp_id_l, comp_id_r.
Defined.

End MoreBiproductIdentities.

#[refine]
#[export]
Instance BiproductBifunctor' {C : Cat} {hp : HasBiproducts' C} : Bifunctor C C C :=
{
  biob := fun X Y : Ob C => biproduct X Y;
  bimap :=
    fun (X Y X' Y' : Ob C) (f : Hom X Y) (g : Hom X' Y') =>
      bicopair (f .> binl) (g .> binr);
}.
Proof.
  - now proper.
  - now intros; rewrite equiv_coproduct', copair_comp, !comp_assoc, !finl_copair, !finr_copair.
  - now intros; rewrite equiv_coproduct', finl_copair, finr_copair, !comp_id_l, !comp_id_r.
Defined.

Notation "A ×+ B" := (@biob _ _ _ (@BiproductBifunctor' _ _) A B) (at level 40, only parsing).
Notation "f ×+' g" := (@bimap _ _ _ (@BiproductBifunctor' _ _) _ _ _ _ f g) (at level 40).


Require Export List.
Require Export Option.
Require Import Base.SProp.

Set Allow StrictProp.

Import ListNotations.
Section Lookup.

  Variable A B : Type.
  Variable A_eq_dec : forall a1 a2 : A, {a1 = a2} + {a1 <> a2}.

  Fixpoint al_lookup (l : list (A * B)) (k : A) : option B :=
    match l with
    | [] => None
    | (x :: l) => match x with
                | (a, b) => if A_eq_dec k a then Some b else al_lookup l k
                end
    end.

  Program Fixpoint al_lookup_in (l : list (A * B)) (k : A) : Squash (exists v, In (k,v) l) -> B :=
    fun i =>
      match l with
      | [] => _
      | (x :: l) => match x with
                  | (a,b) => if A_eq_dec k a then b else al_lookup_in l k _
                  end
      end.
  Next Obligation.
    sexfalso. destruct i as [i]; destruct i as [v i]. inversion i.
  Defined.
  Next Obligation.
    destruct i as [i]; destruct i as [v i]; inversion i.
    - destruct H; inversion H0; reflexivity.
    - squash. exists v. exact H0.
  Defined.

  Theorem al_lookup_In : forall (l : list (A * B)) (k : A) (i : exists v, In (k,v) l),
      al_lookup l k = Some (al_lookup_in l k (squash i)).
  Proof.
    intros l k i.
    induction l as [| p l]; simpl.
    inversion i; inversion H.
    destruct p as [a b]. destruct (A_eq_dec k a). reflexivity.
    assert (exists v : B, In (k, v) l). destruct i as [v i]; exists v; inversion i.
    destruct n; inversion H; reflexivity. exact H.
    apply (IHl H).
  Qed.
  Theorem al_lookup_notIn : forall (l : list (A * B)) (k : A),
      al_lookup l k = None -> forall v : B, ~ In (k, v) l.
  Proof.
    intros l k H.
    induction l; auto; intro v.
    simpl in H. destruct a. destruct (A_eq_dec k a).
    inversion H. intro i; inversion i.
    apply n; inversion H0; reflexivity.
    apply (IHl H v H0).
  Qed.
End Lookup.
Arguments al_lookup {_} {_}.
Arguments al_lookup_in {_} {_}.
Arguments al_lookup_In {_} {_}.

Section ProperAssocList.
  Variable A B : Type.

  Definition proper_al : list (A * B) -> Prop :=
    fun l => forall k v v', In (k,v) l -> In (k,v') l -> v = v'.
End ProperAssocList.
Arguments proper_al {_} {_}.

Section Remove.
  Variable A B : Type.
  Variable A_eq_dec : forall a b : A, {a = b} + {a <> b}.

  Fixpoint al_remove (l : list (A * B)) (k : A) : list (A * B) :=
    match l with
    | [] => []
    | x :: l => match x
              with (a, b) =>
                   if A_eq_dec k a
                   then al_remove l k
                   else (a, b) :: al_remove l k
              end
    end.

  Theorem al_remove_In : forall (l : list (A * B)) (k : A) (v : B), ~ In (k, v) (al_remove l k).
  Proof.
    intro l; induction l; intros k v; intro H; simpl in H.
    inversion H.
    destruct a. destruct (A_eq_dec k a).
    apply (IHl k v H).
    inversion H; [destruct n; inversion H0; reflexivity|].
    apply (IHl k v H0).
  Qed.
End Remove.
Arguments al_remove {_} {_}.
Arguments al_remove_In {_} {_}.
Unset Implicit Arguments.