Require Import Ensembles.
Require Import Coq.Lists.List.
Require Import Arith.
Require Import Peano_dec.
Require Import ListExt.

Require Import folProof.
Require Import folLogic2.
Require Import folProp.
Require Import folReplace.
Require Import subProp.
Require Import Compat815.
From Coq Require Import Lia.

From LibHyps Require Export LibHyps.
From hydras Require Export MoreLibHyps.

Section SubAllVars.

Variable L : Language.
Notation Formula := (Formula L) (only parsing).
Notation Formulas := (Formulas L) (only parsing).
Notation System := (System L) (only parsing).
Notation Term := (Term L) (only parsing).
Notation Terms := (Terms L) (only parsing).
Notation SysPrf := (SysPrf L) (only parsing).

Fixpoint subAllTerm (t : fol.Term L) : (nat -> fol.Term L) -> fol.Term L :=
  match t return ((nat -> fol.Term L) -> fol.Term L) with
  | var x => fun m => m x
  | apply f ts => fun m => apply f (subAllTerms _ ts m)
  end

 with subAllTerms (n : nat) (ts : fol.Terms L n) {struct ts} :
 (nat -> fol.Term L) -> fol.Terms L n :=
  match
    ts in (fol.Terms _ n) return ((nat -> fol.Term L) -> fol.Terms L n)
  with
  | Tnil => fun _ => Tnil
  | Tcons n' t ss =>
      fun m => Tcons (subAllTerm t m) (subAllTerms _ ss m)
  end.

Lemma subAllTerm_ext (t : fol.Term L) :
  forall (m1 m2 : nat -> fol.Term L),
    (forall m : nat, In m (freeVarTerm L t) -> m1 m = m2 m) ->
    subAllTerm t m1 = subAllTerm t m2.
Proof.
  elim t using
    Term_Terms_ind
    with
    (P0 := fun (n : nat) (ts : fol.Terms L n) =>
             forall m1 m2 : nat -> fol.Term L,
               (forall m : nat, In m (freeVarTerms L n ts) -> m1 m = m2 m) ->
               subAllTerms n ts m1 = subAllTerms n ts m2); simpl.
  - intros n m1 m2 H; apply H; auto.
  - intros f t0 H m1 m2 H0; rewrite (H m1 m2).
    + reflexivity.
    + intros m H1;  apply H0; apply H1.
  - reflexivity.
  - intros n t0 H t1 H0 m1 m2 H1; rewrite (H m1 m2).
    + rewrite (H0 m1 m2).
      * reflexivity.
      * intros m H2;  apply H1.
        unfold freeVarTerms; fold (freeVarTerms L n t1).
        apply in_or_app; auto.
    + intros m H2; apply H1.
      unfold freeVarTerms; fold (freeVarTerms L n t1); apply in_or_app; auto.
Qed.

Lemma subAllTerms_ext (n : nat) (ts : fol.Terms L n) (m1 m2 : nat -> fol.Term L):
 (forall m : nat, In m (freeVarTerms L n ts) -> m1 m = m2 m) ->
 subAllTerms n ts m1 = subAllTerms n ts m2.
Proof.
  intros H; induction ts as [| n t ts Hrects].
  - reflexivity.
  - simpl; rewrite Hrects.
    + rewrite (subAllTerm_ext t m1 m2); [reflexivity| ].
      intros m H0; apply H.
      unfold freeVarTerms; fold (freeVarTerms L n ts); apply in_or_app; auto.
    + intros m H0; apply H.
      unfold freeVarTerms; fold (freeVarTerms L n ts); apply in_or_app; auto.
Qed.

Fixpoint freeVarMap (l : list nat) : (nat -> fol.Term L) -> list nat :=
  match l with
  | nil => fun _ => nil
  | a :: l' => fun m => freeVarTerm L (m a) ++ freeVarMap l' m
  end.

Lemma freeVarMap_ext (l : list nat) (f1 f2 : nat -> fol.Term L):
 (forall m : nat, In m l -> f1 m = f2 m) -> freeVarMap l f1 = freeVarMap l f2.
Proof.
  intros H; induction l as [| a l Hrecl].
  - reflexivity.
  - simpl; rewrite Hrecl, H.
    + reflexivity.
    + auto with datatypes.
    + intros m H0; apply H; auto with datatypes.
Qed.

Lemma freeVarMap1 (l : list nat) (m : nat -> fol.Term L) (v n : nat):
 In v (freeVarTerm L (m n)) -> In n l -> In v (freeVarMap l m).
Proof.
  intros H H0; induction l as [| a l Hrecl].
  - elim H0.
  - induction H0 as [H0| H0].
    + simpl; rewrite H0; auto with datatypes.
    + simpl; auto with datatypes.
Qed.

Fixpoint subAllFormula (f : Formula) (m : (nat -> Term)) {struct f} : Formula :=
  match f with
  | equal t s => equal (subAllTerm t m) (subAllTerm s m)
  | atomic r ts => atomic r (subAllTerms _ ts m)
  | impH f g =>
      impH (subAllFormula f m) (subAllFormula g m)
  | fol.notH f => notH (subAllFormula f m)
  | fol.forallH n f =>
      let nv :=
        newVar
          (freeVarFormula L f ++
           freeVarMap (freeVarFormula L (forallH n f)) m) in
      forallH nv
        (subAllFormula f
           (fun v : nat =>
            match eq_nat_dec v n with
            | left _ => var nv
            | right _ => m v
            end))
  end.

Lemma subAllFormula_ext :
 forall (f : fol.Formula L) (m1 m2 : nat -> fol.Term L),
 (forall m : nat, In m (freeVarFormula L f) -> m1 m = m2 m) ->
 subAllFormula f m1 = subAllFormula f m2.
Proof.
  intro f; induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf];
    simpl.
  - intros m1 m2 H; rewrite (subAllTerm_ext t m1 m2).
    + rewrite (subAllTerm_ext t0 m1 m2).
      * reflexivity.
      * intros m H0; apply H.
        apply in_or_app; auto.
    + intros m H0; apply H.
      apply in_or_app; auto.
  - intros m1 m2 H; rewrite (subAllTerms_ext _ t m1 m2).
    + reflexivity.
    + apply H.
  - intros m1 m2 H; rewrite (Hrecf1 m1 m2).
    + rewrite (Hrecf0 m1 m2).
      * reflexivity.
      * intros m H0; apply H.
        apply in_or_app; auto.
    + intros m H0; apply H.
      apply in_or_app; auto.
  - intros m1 m2 H; rewrite (Hrecf m1 m2).
    + reflexivity.
    + apply H.
  - intros m1 m2 H;  rewrite
        (freeVarMap_ext (List.remove eq_nat_dec n (freeVarFormula L f)) m1 m2).
    + set
        (m1' :=
           fun v : nat =>
             match eq_nat_dec v n with
             | left _ =>
                 var
                   (newVar
                      (freeVarFormula L f ++
                         freeVarMap (List.remove  eq_nat_dec n
                                       (freeVarFormula L f)) m2))
             | right _ => m1 v
             end).
      set
        (m2' :=
           fun v : nat =>
             match eq_nat_dec v n with
             | left _ =>
                 var
                   (newVar
                      (freeVarFormula L f ++
                         freeVarMap (List.remove eq_nat_dec n
                                       (freeVarFormula L f)) m2))
             | right _ => m2 v
             end).
      rewrite (Hrecf m1' m2').
      * reflexivity.
      * intros m H0; unfold m1', m2'; clear m1' m2'.
        induction (eq_nat_dec m n).
        -- reflexivity.
        -- apply H; apply in_in_remove; auto.
    + intros m H0; apply H, H0.
Qed.

Lemma freeVarSubAllTerm1 (t : fol.Term L) (m : nat -> fol.Term L) (v : nat):
 In v (freeVarTerm L (subAllTerm t m)) ->
 exists n : nat, In n (freeVarTerm L t) /\ In v (freeVarTerm L (m n)).
Proof.
  elim t using Term_Terms_ind
    with
    (P0 := fun (n : nat) (ts : fol.Terms L n) =>
             In v (freeVarTerms L n (subAllTerms n ts m)) ->
             exists a : nat,
               In a (freeVarTerms L n ts) /\ In v (freeVarTerm L (m a))).
  - intros n H; simpl in H; exists n.
    simpl; auto.
  - intros f t0 H H0; simpl in H0; auto.
  - intros H; contradiction.
  - intros n t0 H t1 H0 H1; simpl in H1.
    unfold freeVarTerms in H1; fold (freeVarTerm L (subAllTerm t0 m)) in H1.
    fold (freeVarTerms L n (subAllTerms n t1 m)) in H1.
    induction (in_app_or _ _ _ H1) as [H2 | H2].
    + induction (H H2) as [x H3]; exists x; split.
      * unfold freeVarTerms; fold (freeVarTerm L t0);fold (freeVarTerms L n t1).
        apply in_or_app; tauto.
      * tauto.
    + induction (H0 H2) as [x H3]; exists x; split.
      * unfold freeVarTerms; fold (freeVarTerm L t0); fold (freeVarTerms L n t1).
        apply in_or_app.
        tauto.
      * tauto.
Qed.

Lemma freeVarSubAllTerms1 (n : nat) (ts : fol.Terms L n) (m : nat -> fol.Term L) (v : nat):
 In v (freeVarTerms L n (subAllTerms n ts m)) ->
 exists a : nat, In a (freeVarTerms L n ts) /\ In v (freeVarTerm L (m a)).
Proof.
  induction ts as [| n t ts Hrects].
  - intros H; contradiction.
  - intros H; simpl in H.
    unfold freeVarTerms in H;
      fold (freeVarTerm L (subAllTerm t m)) in H;
      fold (freeVarTerms L n (subAllTerms n ts m)) in H.
    induction (in_app_or _ _ _ H) as [H0 | H0].
    + induction (freeVarSubAllTerm1 _ _ _ H0) as [x H1]; exists x; split.
      * unfold freeVarTerms; fold (freeVarTerm L t); fold (freeVarTerms L n ts).
        apply in_or_app;  tauto.
      * tauto.
    + induction (Hrects H0) as [x H1]; exists x; split.
      * unfold freeVarTerms; fold (freeVarTerm L t); fold (freeVarTerms L n ts).
        apply in_or_app; tauto.
      * tauto.
Qed.

Lemma freeVarSubAllTerm2 (t : fol.Term L) (m : nat -> fol.Term L) (v n : nat):
 In n (freeVarTerm L t) ->
 In v (freeVarTerm L (m n)) -> In v (freeVarTerm L (subAllTerm t m)).
Proof.
  elim t using Term_Terms_ind with
    (P0 := fun (a : nat) (ts : fol.Terms L a) =>
             In n (freeVarTerms L a ts) ->
             In v (freeVarTerm L (m n)) ->
             In v (freeVarTerms L a (subAllTerms a ts m))).
  - intros n0 [H | H] H0; simpl in H |- *.
    + now rewrite H.
    + contradiction H.
  - auto.
  - auto.
  - intros n0 t0 H t1 H0 H1 H2;
      simpl; unfold freeVarTerms; fold (freeVarTerm L (subAllTerm t0 m)).
    fold (freeVarTerms L n0 (subAllTerms n0 t1 m)); apply in_or_app.
    unfold freeVarTerms in H1.
    fold (freeVarTerm L t0) in H1.
    fold (freeVarTerms L n0 t1) in H1.
    induction (in_app_or _ _ _ H1); auto.
Qed.

Lemma freeVarSubAllTerms2 (a : nat) (ts : fol.Terms L a) (m : nat -> fol.Term L)
  (v n : nat):
  In n (freeVarTerms L a ts) ->
  In v (freeVarTerm L (m n)) -> In v (freeVarTerms L a (subAllTerms a ts m)).
Proof.
  intros H H0; induction ts as [| n0 t ts Hrects].
  - apply H.
  - simpl; unfold freeVarTerms;
      fold (freeVarTerm L (subAllTerm t m));
      fold (freeVarTerms L n0 (subAllTerms n0 ts m)).
    apply in_or_app.
    unfold freeVarTerms in H; fold (freeVarTerm L t) in H;
      fold (freeVarTerms L n0 ts) in H.
    induction (in_app_or _ _ _ H) as [H1 | H1].
    + left; eapply freeVarSubAllTerm2.
      * apply H1.
      * assumption.
    + auto.
Qed.

Lemma freeVarSubAllFormula1 :
 forall (f : fol.Formula L) (m : nat -> fol.Term L) (v : nat),
 In v (freeVarFormula L (subAllFormula f m)) ->
 exists n : nat, In n (freeVarFormula L f) /\ In v (freeVarTerm L (m n)).
Proof.
  intro f;
    induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf]; simpl.
  - intros m v H; induction (in_app_or _ _ _ H);
 (induction (freeVarSubAllTerm1 _ _ _ H0); exists x; split;
   [ apply in_or_app; tauto | tauto ]).
  - intros m v H;  apply freeVarSubAllTerms1; apply H.
- intros m v H; induction (in_app_or _ _ _ H) as [H0 | H0];
 (induction (Hrecf1 _ _ H0) || induction (Hrecf0 _ _ H0); exists x; split;
   [ apply in_or_app; tauto | tauto ]).
- intros m v H; apply Hrecf.
  apply H.
-  intros m v H; set
    (nv :=
       newVar
         (freeVarFormula L f ++
            freeVarMap (List.remove eq_nat_dec n (freeVarFormula L f)) m)).

   assert
     (H0: In v
            (freeVarFormula L
               (subAllFormula f
                  (fun v : nat =>
                     match eq_nat_dec v n with
                     | left _ => var nv
                     | right _ => m v
                     end)))) by ( eapply in_remove; apply H).
   destruct  (Hrecf _ _ H0) as [x [H2 H3]].
   induction (eq_nat_dec x n) as [a | ?].
   + elim (in_remove_neq _ _ _ _ _ H).
     induction H3 as [H1| H1].
     auto.
     contradiction.
   + exists x.
     split.
     * apply in_in_remove; auto.
     * auto.
Qed.

Lemma freeVarSubAllFormula2 :
 forall (f : fol.Formula L) (m : nat -> fol.Term L) (v n : nat),
 In n (freeVarFormula L f) ->
 In v (freeVarTerm L (m n)) ->
 In v (freeVarFormula L (subAllFormula f m)).
Proof.
  intro f; induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf];
    simpl.
  - intros m v n H H0; apply in_or_app.
    induction (in_app_or _ _ _ H) as [H1 | H1].
    + left; eapply freeVarSubAllTerm2.
      * apply H1.
      * apply H0.
    + right; eapply freeVarSubAllTerm2.
      * apply H1.
      * apply H0.
  - intros m v n H H0; eapply freeVarSubAllTerms2.
    + apply H.
    + apply H0.
  - intros m v n H H0; apply in_or_app.
    induction (in_app_or _ _ _ H) as [H1 | H1].
    + left; eapply Hrecf1.
      * apply H1.
      * apply H0.
    + right; eapply Hrecf0.
      * apply H1.
      * apply H0.
  - intros m v n H H0; eapply Hrecf.
    + apply H.
    + apply H0.
  - intros m v n0 H H0; apply in_in_remove.
     + intro H1;
        eapply
          (newVar1
             (freeVarFormula L f ++
                freeVarMap (List.remove eq_nat_dec n
                              (freeVarFormula L f)) m)).
      rewrite <-  H1; clear H1; apply in_or_app.
      right.
      clear Hrecf.
      induction (List.remove eq_nat_dec n (freeVarFormula L f));
        simpl in |- *.
      * contradiction H.
      * apply in_or_app; simpl in H.
        destruct  H as [H | H].
        -- rewrite H; auto.
        -- auto.
     + eapply Hrecf.
       * eapply in_remove; apply H.
       * induction (eq_nat_dec n0 n) as [a | b].
         -- now elim (in_remove_neq _ _ _ _ _ H).
         -- auto.
Qed.

Lemma subSubAllTerm (t : fol.Term L) (m : nat -> fol.Term L) (v : nat) (s : fol.Term L):
 substituteTerm L (subAllTerm t m) v s =
 subAllTerm t (fun n : nat => substituteTerm L (m n) v s).
Proof.
  elim t using
    Term_Terms_ind
    with
    (P0 := fun (n : nat) (ts : fol.Terms L n) =>
             substituteTerms L n (subAllTerms n ts m) v s =
               subAllTerms n ts (fun n : nat => substituteTerm L (m n) v s)).
   - intro n; simpl; auto.
   - intros f t0 H; simpl; rewrite H; auto.
   - auto.
   - intros n t0 H t1 H0; simpl; now rewrite H, H0.
Qed.

Lemma subSubAllTerms (n : nat) (ts : fol.Terms L n) (m : nat -> fol.Term L)
  (v : nat) (s : fol.Term L) :
  substituteTerms L n (subAllTerms n ts m) v s =
    subAllTerms n ts (fun n : nat => substituteTerm L (m n) v s).
Proof.
  induction ts as [| n t ts Hrects].
  - auto.
  - simpl; now rewrite subSubAllTerm, Hrects.
Qed.

Lemma subSubAllFormula :
  forall (T : fol.System L) (f : fol.Formula L) (m : nat -> fol.Term L)
         (v : nat) (s : fol.Term L),
    folProof.SysPrf L T
      (iffH (substituteFormula L (subAllFormula f m) v s)
         (subAllFormula f (fun n : nat => substituteTerm L (m n) v s))).
Proof.
  intros T f.  revert T.
  elim f using Formula_depth_ind2; simpl in |- *.
  -  intros t t0 T m v s; rewrite (subFormulaEqual L).
     do 2 rewrite subSubAllTerm.
     apply (iffRefl L).
  - intros r t T m v s; rewrite (subFormulaRelation L).
    rewrite subSubAllTerms;  apply (iffRefl L).
  - intros f0 H f1 H0 T m v s; rewrite (subFormulaImp L).
    apply (reduceImp L).
    + apply H.
    + apply H0.
  - intros f0 H T m v s; rewrite (subFormulaNot L).
    apply (reduceNot L).
    apply H.
  - intros v a H T m v0 s;
      set
        (nv1 :=
           newVar
             (freeVarFormula L a ++
                freeVarMap (List.remove eq_nat_dec v (freeVarFormula L a)) m)).
    set
      (nv2 :=
         newVar
           (freeVarFormula L a ++
              freeVarMap (List.remove eq_nat_dec v (freeVarFormula L a))
              (fun n : nat => substituteTerm L (m n) v0 s))).
    apply (sysExtend L) with (Empty_set (fol.Formula L)).
    + unfold Included; intros x H0; destruct H0.
    + decompose record
        (subFormulaForall2 L
           (subAllFormula a
              (fun v1 : nat =>
                 match eq_nat_dec v1 v with
                 | left _ => var nv1
                 | right _ => m v1
                 end)) nv1 v0 s) /r; intros x H1  H0 H2 H4.
      rewrite H4; clear H4.
      induction (eq_nat_dec nv1 v0) as [a0 | ?].
      * assert
          (H3: forall n : nat,
              In n (freeVarFormula L (forallH  v a)) ->
              substituteTerm L (m n) v0 s = m n).
        { intros n H3;  apply subTermNil.
           intros H4.
           elim
             (newVar1
                (freeVarFormula L a ++
                   freeVarMap (List.remove eq_nat_dec v (freeVarFormula L a)) m)).
           fold nv1; rewrite a0.
           apply in_or_app; right.
           eapply freeVarMap1.
           apply H4.
           apply H3.
        }
        assert (H4: nv1 = nv2).
        { unfold nv1, nv2;
            rewrite
              (freeVarMap_ext (List.remove eq_nat_dec v (freeVarFormula L a))
                 (fun n : nat => substituteTerm L (m n) v0 s) m).
          - reflexivity.
          - apply H3.
        }
        rewrite H4.
        rewrite
          (subAllFormula_ext a
             (fun v1 : nat =>
                match eq_nat_dec v1 v with
                | left _ => var nv2
                | right _ => substituteTerm L (m v1) v0 s
                end)
             (fun v1 : nat =>
                match eq_nat_dec v1 v with
                | left _ => var nv2
                | right _ => m v1
                end)).
      -- apply (iffRefl L).
      --    intros m0 H5; induction (eq_nat_dec m0 v).
            ++ reflexivity.
            ++ apply H3; simpl; apply in_in_remove; auto.
       *  apply (iffTrans L) with
           (forallH x
              (substituteFormula L
                 (subAllFormula a
                    (fun v1 : nat =>
                       match eq_nat_dec v1 v with
                       | left _ => var x
                       | right _ => m v1
                       end)) v0 s)).
         -- apply (reduceForall L).
            ++ apply (notInFreeVarSys L).
            ++ apply (reduceSub L).
               ** apply (notInFreeVarSys L).
               ** apply (iffTrans L) with
                    (subAllFormula a
                       (fun v1 : nat =>
                          substituteTerm L
                            match eq_nat_dec v1 v with
                            | left _ => var nv1
                            | right _ => m v1
                            end nv1 (var x))).
                  ---  fold (folProof.SysPrf L);
                       apply
                         H
                         with
                         (b := a)
                         (v := nv1)
                         (s := var x)
                         (m := fun v1 : nat =>
                                 match eq_nat_dec v1 v with
                                 | left _ => var nv1
                                 | right _ => m v1
                                 end).
                       apply depthForall.
                  --- rewrite
                      (subAllFormula_ext a
                         (fun v1 : nat =>
                            match eq_nat_dec v1 v with
                            | left _ => var x
                            | right _ => m v1
                            end)
                         (fun v1 : nat =>
                            substituteTerm L
                              match eq_nat_dec v1 v with
                              | left _ => var nv1
                              | right _ => m v1
                              end nv1 (var x))).
                      +++ apply (iffRefl L).
                      +++    intros m0 H3.
                             induction (eq_nat_dec m0 v).
                             *** rewrite (subTermVar1 L); reflexivity.
                             *** rewrite (subTermNil L).
                                 reflexivity.
                                 intro H4;
                                   elim
                                     (newVar1
                                        (freeVarFormula L a ++
                                           freeVarMap (List.remove eq_nat_dec v
                                                         (freeVarFormula L a)) m)).
                                 fold nv1; apply in_or_app.
                                 right.
                                 eapply freeVarMap1.
                                 apply H4.
                                 apply in_in_remove; auto.
         -- apply (iffTrans L)
              with
              (forallH x
                 (subAllFormula a
                    (fun v1 : nat =>
                       match eq_nat_dec v1 v with
                       | left _ => var x
                       | right _ => substituteTerm L (m v1) v0 s
                       end))).
            ++ apply (reduceForall L).
               ** apply (notInFreeVarSys L).
               ** eapply (iffTrans L).
                  --- apply H with
                        (b := a)
                        (v := v0)
                        (s := s)
                        (m := fun v1 : nat =>
                                match eq_nat_dec v1 v with
                                | left _ => var x
                                | right _ => m v1
                                end).
                      apply depthForall.
                  ---    rewrite
                      (subAllFormula_ext a
                         (fun v1 : nat =>
                            match eq_nat_dec v1 v with
                            | left _ => var x
                            | right _ => substituteTerm L (m v1) v0 s
                            end)
                         (fun n : nat =>
                            substituteTerm L
                              match eq_nat_dec n v with
                              | left _ => var x
                              | right _ => m n
                              end v0 s)).
                         +++ apply (iffRefl L).
                         +++    intros m0 H3; induction (eq_nat_dec m0 v).
                                ***  rewrite subTermNil.
                                     reflexivity.
                                     simpl; tauto.
                                *** reflexivity.
            ++ apply (iffTrans L) with
                 (forallH nv2
                    (substituteFormula L
                       (subAllFormula a
                          (fun v1 : nat =>
                             match eq_nat_dec v1 v with
                             | left _ => var x
                             | right _ => substituteTerm L (m v1) v0 s
                             end)) x (var nv2))).
               ** apply (rebindForall L).
                  intros H3; simpl in H3.
                  assert
                    (H4: In nv2
                           (freeVarFormula L
                              (subAllFormula a
                                 (fun v1 : nat =>
                                    match eq_nat_dec v1 v with
                                    | left _ => var x
                                    | right _ => substituteTerm L (m v1) v0 s
                                    end))))
                  by (eapply in_remove; apply H3).
                  decompose record (freeVarSubAllFormula1 _ _ _ H4) /r; intros x0 H6 H7.
                  induction (eq_nat_dec x0 v) as [a0 | ?].
                  --- induction H7 as [H5| H5].
                      +++ elim (in_remove_neq _ _ _ _ _ H3); auto.
                      +++    auto.
                  ---
                    elim
                      (newVar1
                         (freeVarFormula L a ++
                            freeVarMap (List.remove  eq_nat_dec v (freeVarFormula L a))
                            (fun n : nat => substituteTerm L (m n) v0 s))).
                    fold nv2; apply in_or_app.
                    right;  eapply freeVarMap1.
                    +++ apply H7.
                    +++ apply in_in_remove; auto.
               ** apply (reduceForall L).
                  --- apply (notInFreeVarSys L).
                  --- eapply (iffTrans L).
                      +++ apply H.
                          apply depthForall.
                      +++ simpl;
                            rewrite
                              (subAllFormula_ext a
                                 (fun v1 : nat =>
                                    match eq_nat_dec v1 v with
                                    | left _ => var nv2
                                    | right _ => substituteTerm L (m v1) v0 s
                                    end)
                                 (fun n : nat =>
                                    substituteTerm L
                                      match eq_nat_dec n v with
                                      | left _ => var x
                                      | right _ => substituteTerm L (m n) v0 s
                                      end x (var nv2))).
                          *** apply (iffRefl L).
                          *** intros m0 H3; induction (eq_nat_dec m0 v).
                              rewrite (subTermVar1 L).
                              reflexivity.
                              rewrite (subTermNil L (substituteTerm L (m m0) v0 s)).
                              reflexivity.
                              intros H4; induction (freeVarSubTerm3 _ _ _ _ _ H4).
                              elim H2.
                              apply in_in_remove.
                             intros H6;
                                elim
                                  (newVar1
                                     (freeVarFormula L a ++
                                        freeVarMap (List.remove  eq_nat_dec v
                                                      (freeVarFormula L a)) m)).
                              fold nv1; rewrite <- H6.
                              apply in_or_app.
                              right; eapply freeVarMap1.
                              eapply in_remove.
                              apply H5.
                              apply in_in_remove; auto.
                              eapply freeVarSubAllFormula2.
                              apply H3.
                              induction (eq_nat_dec m0 v).
                              elim b0; auto.
                              eapply in_remove.
                              apply H5.
                              auto.
Qed.

Lemma subAllTermId (t : fol.Term L):
  subAllTerm t (fun x : nat => var x) = t.
Proof.
  elim t using  Term_Terms_ind
    with
    (P0 := fun (n : nat) (ts : fol.Terms L n) =>
             subAllTerms n ts (fun x : nat => var x) = ts);
    simpl.
  - reflexivity.
  - intros f t0 H; now rewrite H.
  - reflexivity.
  - intros n t0 H t1 H0; now rewrite H, H0.
Qed.

Lemma subAllTermsId  (n : nat) (ts : fol.Terms L n):
  subAllTerms n ts (fun x : nat => var x) = ts.
Proof.
  induction ts as [| n t ts Hrects].
  - reflexivity.
  - simpl; now rewrite Hrects, subAllTermId.
Qed.

Lemma subAllFormulaId (T : fol.System L) (f : fol.Formula L):
 folProof.SysPrf L T
   (iffH (subAllFormula f (fun x : nat => var x)) f).
Proof.
  apply (sysExtend L) with (Empty_set (fol.Formula L)).
  - intros x H; contradiction H.
  - induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf];
      simpl.
    + repeat rewrite subAllTermId; apply (iffRefl L).
    + rewrite subAllTermsId; apply (iffRefl L).
    + apply (reduceImp L).
      * apply Hrecf1.
      * apply Hrecf0.
    + apply (reduceNot L).
      apply Hrecf.
    + set
        (nv :=
           newVar
             (freeVarFormula L f ++
                freeVarMap (List.remove  eq_nat_dec n (freeVarFormula L f))
                (fun x : nat => var x))).
      apply
        (iffTrans L)
        with (forallH n (subAllFormula f (fun x : nat => var x))).
      * apply (iffTrans L) with
          (forallH nv
             (substituteFormula L (subAllFormula f (fun x : nat => var x)) n
                (var nv))).
        -- replace
            (subAllFormula f
               (fun v : nat =>
                  match eq_nat_dec v n with
                  | left _ => var nv
                  | right _ => var v
                  end))
            with
            (subAllFormula f
               (fun x : nat => substituteTerm L (var x) n (var nv))).
           ++ apply (reduceForall L).
              ** apply (notInFreeVarSys L).
              ** apply (iffSym L).
                 apply subSubAllFormula with (m := fun x : nat => var x).
           ++ apply subAllFormula_ext.
              intros m H; simpl.
              induction (eq_nat_dec n m); induction (eq_nat_dec m n);
                reflexivity || (assert False by auto; contradiction).
        -- apply (iffSym L).
           apply (rebindForall L).
           intro H;
             assert
               (H0: In nv (freeVarFormula L (subAllFormula f
                                               (fun x : nat => var x))))
           by (eapply in_remove; apply H).
           decompose record (freeVarSubAllFormula1 _ _ _ H0) /r; intros x H2 H3.
           elim
             (newVar1
                (freeVarFormula L f ++
                   freeVarMap (List.remove eq_nat_dec n (freeVarFormula L f))
                   (fun x : nat => var x))).
           fold nv; apply in_or_app; right.
           eapply freeVarMap1.
           ++ apply H3.
           ++ apply in_in_remove.
              ** destruct H3 as [H1| H1].
                 --- rewrite H1.
                     eapply in_remove_neq.
                     apply H.
                 --- contradiction.
              ** apply H2.
      * apply (reduceForall L).
        -- apply (notInFreeVarSys L).
        -- apply Hrecf.
Qed.

Lemma subAllSubAllTerm (t : fol.Term L) :
 forall  (m1 m2 : nat -> fol.Term L),
 subAllTerm (subAllTerm t m1) m2 =
 subAllTerm t (fun n : nat => subAllTerm (m1 n) m2).
Proof.
  elim t using
    Term_Terms_ind
    with
    (P0 := fun (n : nat) (ts : fol.Terms L n) =>
             forall m1 m2 : nat -> fol.Term L,
               subAllTerms n (subAllTerms n ts m1) m2 =
                 subAllTerms n ts (fun n : nat => subAllTerm (m1 n) m2));
    simpl.
  - reflexivity.
  - intros f t0 H m1 m2; now rewrite H.
  - reflexivity.
  - intros n t0 H t1 H0 m1 m2; now rewrite H, H0.
Qed.

Lemma subAllSubAllTerms (n : nat) (ts : fol.Terms L n) (m1 m2 : nat -> fol.Term L):
 subAllTerms n (subAllTerms n ts m1) m2 =
 subAllTerms n ts (fun n : nat => subAllTerm (m1 n) m2).
Proof.
  induction ts as [| n t ts Hrects]; simpl.
  - reflexivity.
  - now rewrite Hrects, subAllSubAllTerm.
Qed.

Lemma subAllSubAllFormula (T : fol.System L) (f : fol.Formula L):
 forall  (m1 m2 : nat -> fol.Term L),
 folProof.SysPrf L T
   (iffH (subAllFormula (subAllFormula f m1) m2)
      (subAllFormula f (fun n : nat => subAllTerm (m1 n) m2))).
Proof.
  revert T.
  induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf].
  - intros T m1 m2; simpl; repeat rewrite subAllSubAllTerm; apply (iffRefl L).
  - intros T m1 m2; simpl; rewrite subAllSubAllTerms.
    apply (iffRefl L).
  - intros T m1 m2; simpl; apply (reduceImp L).
    + apply Hrecf1.
    + apply Hrecf0.
  - intros T m1 m2; simpl; apply (reduceNot L).
    apply Hrecf.
  - intros T m1 m2; simpl;
      set
        (nv1 :=
           freeVarFormula L f ++
             freeVarMap (List.remove eq_nat_dec n (freeVarFormula L f)) m1).
    set
      (nv2 :=
         freeVarFormula L f ++
           freeVarMap (List.remove eq_nat_dec n (freeVarFormula L f))
           (fun n0 : nat => subAllTerm (m1 n0) m2)).
    set
      (nv3 :=
         freeVarFormula L
           (subAllFormula f
              (fun v : nat =>
                 match eq_nat_dec v n with
                 | left _ => var (newVar nv1)
                 | right _ => m1 v
                 end)) ++
           freeVarMap
           (List.remove eq_nat_dec (newVar nv1)
              (freeVarFormula L
                 (subAllFormula f
                    (fun v : nat =>
                       match eq_nat_dec v n with
                       | left _ => var (newVar nv1)
                       | right _ => m1 v
                       end)))) m2).
    apply
      (iffTrans L)
      with
      (forallH (newVar nv3)
         (substituteFormula L
            (subAllFormula f
               (fun v : nat =>
                  match eq_nat_dec v n with
                  | left _ => var (newVar nv2)
                  | right _ => subAllTerm (m1 v) m2
                  end)) (newVar nv2) (var (newVar nv3)))).
    + eapply (sysExtend L) with (Empty_set (fol.Formula L)).
      * intros x H; contradiction  H.
      * apply (reduceForall L).
        -- apply (notInFreeVarSys L).
        -- eapply (iffTrans L).
           ++ apply Hrecf.
           ++ set
               (a1 :=
                  fun v : nat =>
                    match eq_nat_dec v n with
                    | left _ => var (newVar nv2)
                    | right _ => subAllTerm (m1 v) m2
                    end).
              simpl; set
                       (a2 :=
                          fun n0 : nat =>
                            subAllTerm
                              match eq_nat_dec n0 n with
                              | left _ => var (newVar nv1)
                              | right _ => m1 n0
                              end
                              (fun v : nat =>
                                 match eq_nat_dec v (newVar nv1) with
                                 | left _ => var (newVar nv3)
                                 | right _ => m2 v
                                 end)).
              replace (subAllFormula f a2) with
                (subAllFormula f
                   (fun x : nat =>
                      substituteTerm L (a1 x) (newVar nv2) (var (newVar nv3)))).
           ** apply (iffSym L).
              apply subSubAllFormula.
           ** apply subAllFormula_ext.
              intros m H.
              unfold a1, a2; induction (eq_nat_dec m n).
              --- rewrite (subTermVar1 L).
                  simpl; induction (eq_nat_dec (newVar nv1) (newVar nv1)) as [? | b].
                  +++ reflexivity.
                  +++ now elim b.
              --- auto.
                  rewrite subSubAllTerm.
                  apply subAllTerm_ext.
                  intros m0 H0; induction (eq_nat_dec m0 (newVar nv1)) as [a | ?].
                  +++ elim (newVar1 nv1).
                      rewrite <- a.
                      unfold nv1; apply in_or_app; right.
                      eapply freeVarMap1.
                      *** apply H0.
                      *** apply in_in_remove; auto.
                  +++ apply (subTermNil L).
                      intro H1.
                      elim (newVar1 nv2).
                      unfold nv2 at 2; apply in_or_app; right.
                      eapply freeVarMap1.
                      *** eapply freeVarSubAllTerm2.
                          apply H0.
                          apply H1.
                      *** apply in_in_remove; auto.
    + apply (iffSym L).
      apply (rebindForall L).
      intro H;
        assert
          (H0:In (newVar nv3)
                (freeVarFormula L
                   (subAllFormula f
                      (fun v : nat =>
                         match eq_nat_dec v n with
                         | left _ => var (newVar nv2)
                         | right _ => subAllTerm (m1 v) m2
                         end))))
        by (eapply in_remove; apply H).
      decompose record (freeVarSubAllFormula1 _ _ _ H0) /r; intros x H2 H3.
      induction (eq_nat_dec x n).
      * induction H3 as [H1| H1].
        -- elim (in_remove_neq _ _ _ _ _ H).
           ++ auto.
        -- contradiction.
      * decompose record (freeVarSubAllTerm1 _ _ _ H3) /r; intros x0 H4 H5.
        elim (newVar1 nv3).
        unfold nv3 at 2; apply in_or_app.
        right; eapply freeVarMap1.
        -- apply H5.
        -- apply in_in_remove.
           ++ intro H1; elim (newVar1 nv1).
              rewrite <- H1; unfold nv1; apply in_or_app; right.
              eapply freeVarMap1.
              apply H4.
              apply in_in_remove; auto.
           ++ eapply freeVarSubAllFormula2.
              ** apply H2.
              ** induction (eq_nat_dec x n) as [a | ?].
                 --- now elim b.
                 --- assumption.
Qed.

Section subAllCloseFrom.

Fixpoint closeFrom (a n : nat) (f : fol.Formula L) {struct n} :
 fol.Formula L :=
  match n with
  | O => f
  | S m => forallH (a + m) (closeFrom a m f)
  end.

Opaque le_lt_dec.

Lemma liftCloseFrom  (n : nat) :
 forall(f : fol.Formula L) (T : fol.System L) (m : nat),
 (forall v : nat, In v (freeVarFormula L f) -> v < m) ->
 n <= m ->
 folProof.SysPrf L T (closeFrom 0 n f) ->
 folProof.SysPrf L T
   (closeFrom m n
      (subAllFormula f
         (fun x : nat =>
          match le_lt_dec n x with
          | left _ => var x
          | right _ => var (m + x)
          end))).
Proof.
  induction n as [| n Hrecn]; simpl.
  - intros; replace
              (subAllFormula f
                 (fun x : nat =>
                    match le_lt_dec 0 x with
                    | left _ => var x
                    | right _ => var (m + x)
                    end)) with (subAllFormula f (fun x : nat => var x)).
    + apply (impE L) with f.
      * apply (iffE2 L).
        apply subAllFormulaId.
      * apply H1.
    + apply subAllFormula_ext.
      intros m0 H2; induction (le_lt_dec 0 m0) as [? | b].
      * reflexivity.
      * elim (Nat.nlt_0_r _ b).
  - intros f T m H H0 H1;
      apply (impE L) with (forallH n (closeFrom 0 n f)).
    + apply sysExtend with (Empty_set (fol.Formula L)).
      * intros x H2; contradiction H2.
      * apply (impI L);  apply (forallI L).
        -- intros [x [H2 H3]];
             destruct H3 as [x H3| x H3]; destruct H3.
           assert
             (H3:forall q : nat,
                 n <= q ->
                 m <= q ->
                 ~ In q (freeVarFormula L (forallH n (closeFrom 0 n f)))).
           { clear H2 H1 T Hrecn.
             induction n as [| n Hrecn]; simpl in |- *.
           - intros q H1 H2 H3; assert (H': q < m).
             { apply H; eapply in_remove; apply H3; lia. }
             lia.
           - intros q H1 H2 H3; elim Hrecn with (q := q).
             + apply le_S_n.
               apply le_S.
               auto.
             + apply le_S_n.
               apply le_S.
               auto.
             + auto.
             + simpl; eapply in_remove.
               apply H3.
           }
           apply H3 with (q := m + n).
           ++ apply Compat815.le_plus_r.
           ++ apply Nat.le_add_r.
           ++ apply H2.
        -- apply (impE L) with
             (closeFrom m n
                (substituteFormula L
                   (subAllFormula f
                      (fun x : nat =>
                         match le_lt_dec n x with
                         | left _ => var x
                         | right _ => var (m + x)
                         end)) n (var (m + n)))).
           ++ apply sysWeaken; clear H1 H T Hrecn.
              cut
                (folProof.SysPrf L (Empty_set (fol.Formula L))
                   (impH
                      (substituteFormula L
                         (subAllFormula f
                            (fun x : nat =>
                               match le_lt_dec n x with
                               | left _ => var x
                               | right _ => var (m + x)
                               end)) n (var (m + n)))
                      (subAllFormula f
                         (fun x : nat =>
                            match le_lt_dec (S n) x with
                            | left _ => var x
                            | right _ => var (m + x)
                            end)))).
              ** generalize
                  (substituteFormula L
                     (subAllFormula f
                        (fun x : nat =>
                           match le_lt_dec n x with
                           | left _ => var x
                           | right _ => var (m + x)
                           end)) n (var (m + n))).
                 generalize
                   (subAllFormula f
                      (fun x : nat =>
                         match le_lt_dec (S n) x with
                         | left _ => var x
                         | right _ => var (m + x)
                         end)).
           clear f H0; intros f f0 H.
           induction n as [| n Hrecn]; simpl.
           --- apply H.
           --- apply (impI L).
               apply (forallI L).
               intros [x [H0 H1]];
                 induction H1 as [x H1| x H1]; [ induction H1 | induction H1 ].
               +++ now elim (in_remove_neq _ _ _ _ _ H0).
               +++ apply impE with (closeFrom m n f0).
                   *** apply sysWeaken.
                       apply Hrecn.
                   *** eapply forallSimp.
                       apply Axm; right; constructor.
              ** replace
                  (subAllFormula f
                     (fun x : nat =>
                        match le_lt_dec (S n) x with
                        | left _ => var x
                        | right _ => var (m + x)
                        end))
                  with
                  (subAllFormula f
                     (fun x : nat =>
                        substituteTerm L
                          match le_lt_dec n x with
                          | left _ => var x
                          | right _ => var (m + x)
                          end n (var (m + n)))).
                 --- apply (iffE1 L).
                     apply
                       subSubAllFormula
                       with
                       (m := fun x : nat =>
                               match le_lt_dec n x with
                               | left _ => var x
                               | right _ => var (m + x)
                               end).
                 --- apply subAllFormula_ext.
                     intros m0 H1; induction (le_lt_dec n m0) as [a | ?].
                     +++  induction (le_lt_dec (S n) m0).
                          *** apply (subTermVar2 L); lia.
                          *** rewrite Nat.lt_eq_cases in a.
                              destruct a.
                              assert False by lia; contradiction.
                              rewrite H; apply (subTermVar1 L).
                     +++  induction (le_lt_dec (S n) m0).
                          lia.
                          apply (subTermVar2 L).
                          unfold not in |- *; intros.
                          rewrite H in H0.
                          rewrite Nat.le_ngt in H0.
                          lia.
           ++  assert
             (H2: forall (f : fol.Formula L) (s r m p : nat),
                 m < s ->
                 s + r <= p ->
                 folProof.SysPrf L (Empty_set (fol.Formula L))
                   (impH  (substituteFormula L (closeFrom s r f) m (var p))
                      (closeFrom s r (substituteFormula L f m (var p))))).
               { clear H0 H H1 m T f n Hrecn.
                 intros f s n.
                 induction n as [| n Hrecn]; simpl.
                 - intros m p H H0; apply (impRefl L).
                 - intros m p H H0; rewrite (subFormulaForall L).
                   induction (eq_nat_dec (s + n) m) as [a | b].
                   + rewrite <- a in H; lia.
                   + induction (In_dec eq_nat_dec (s + n) (freeVarTerm L (var p)))
                       as [a | ?].
                     * induction a as [H1| H1].
                       -- rewrite Nat.add_succ_r in H0; simpl in H0.
                          rewrite <- H1 in H0; lia.
                       -- contradiction.
                     * apply (impI L).
                       apply (forallI L).
                       intros [x [H1 H2]];
                         induction H2 as [x H2| x H2]; [ induction H2 | induction H2 ].
                       -- now elim (in_remove_neq _ _ _ _ _ H1).
                       -- apply impE
                            with (substituteFormula L (closeFrom s n f) m (var p)).
                          ++ apply sysWeaken.
                             ** apply Hrecn.
                                --- auto.
                                --- apply le_S_n.
                                    apply le_S; lia.
                          ++ eapply (forallSimp L).
                             apply Axm; right; constructor.
               }
               apply (impE L) with
                 (substituteFormula L
                    (closeFrom m n
                       (subAllFormula f
                          (fun x : nat =>
                             match le_lt_dec n x with
                             | left _ => var x
                             | right _ => var (m + x)
                             end))) n (var (m + n))).
               ** apply sysWeaken, H2.
           --- apply H0;  auto.
           --- auto.
               ** apply (forallE L).
                  apply (impE L) with (forallH n (closeFrom 0 n f)).
                  --- apply sysExtend with (Empty_set (fol.Formula L)).
                      +++ intros x H3; destruct H3.
                      +++ apply (impI L), (forallI L).
                          *** intros [x [H3 H4]];
                                induction H4 as [x H4| x H4];
                                [ induction H4 | induction H4 ].
                              now elim (in_remove_neq _ _ _ _ _ H3).
                          *** apply Hrecn.
                              apply H.
                              apply le_S_n.
                              apply le_S.
                              auto.
                              eapply (forallSimp L).
                              apply Axm; right; constructor.
                  --- apply Axm; right; constructor.
    + apply H1.
Qed.

Lemma subAllCloseFrom1 :
  forall (n m : nat) (map : nat -> fol.Term L) (f : fol.Formula L)
         (T : fol.System L),
    (forall v : nat,
        v < n -> forall w : nat, In w (freeVarTerm L (map (m + v))) -> w < m) ->
    folProof.SysPrf L T (closeFrom m n f) ->
    folProof.SysPrf L T
      (subAllFormula f
         (fun x : nat =>
            match le_lt_dec m x with
            | left _ =>
                match le_lt_dec (m + n) x with
                | left _ => var x
                | right _ => map x
                end
            | right _ => var x
            end)).
Proof.
  intro n; induction n as [| n Hrecn]; simpl.
  - intros m map f T H H0; replace
      (subAllFormula f
         (fun x : nat =>
            match le_lt_dec m x with
            | left _ =>
                match le_lt_dec (m + 0) x with
                | left _ => var x
                | right _ => map x
                end
            | right _ => var x
            end))
      with (subAllFormula f (fun x : nat => var x)).
    + apply (impE L) with f.
      * apply (iffE2 L); apply subAllFormulaId.
      * apply H0.
    + apply subAllFormula_ext.
      intros m0 H1; rewrite <- plus_n_O.
      destruct (le_lt_dec m m0); reflexivity.
  - intros m map f T H H0; apply  (impE L)  with
      (substituteFormula L
         (subAllFormula f
            (fun x : nat =>
               match le_lt_dec m x with
               | left _ =>
                   match le_lt_dec (m + n) x with
                   | left _ => var x
                   | right _ => map x
                   end
               | right _ => var x
               end)) (m + n) (map (m + n))).
    + replace
        (subAllFormula f
           (fun x : nat =>
              match le_lt_dec m x with
              | left _ =>
                  match le_lt_dec (m + S n) x with
                  | left _ => var x
                  | right _ => map x
                  end
              | right _ => var x
              end))
        with
        (subAllFormula f
           (fun x : nat =>
              substituteTerm L
                match le_lt_dec m x with
                | left _ =>
                    match le_lt_dec (m + n) x with
                    | left _ => var x
                    | right _ => map x
                    end
                | right _ => var x
                end (m + n) (map (m + n)))).
      * apply (iffE1 L);
          apply subSubAllFormula with
          (m := fun x : nat =>
                  match le_lt_dec m x with
                  | left _ =>
                      match le_lt_dec (m + n) x with
                      | left _ => var x
                      | right _ => map x
                      end
                  | right _ => var x
                  end).
      * apply subAllFormula_ext.
        intros m0 H1; induction (le_lt_dec m m0) as [a | ?].
        -- rewrite  <-  Compat815.plus_Snm_nSm.
           induction (le_lt_dec (S m + n) m0) as [a0 | ?].
           ++ simpl in a0; induction (le_lt_dec (m + n) m0).
              ** apply (subTermVar2 L).
               intros H2; rewrite H2 in a0; lia.
              ** lia.
           ++ induction (le_lt_dec (m + n) m0) as [a0 | ?].
              ** replace (m + n) with m0.
                 apply (subTermVar1 L).
                 simpl in b.
                 rewrite Nat.lt_eq_cases in a0.
                 destruct a0.
                 --- lia.
                 --- auto.
              ** apply (subTermNil L).
                 intros H2; assert (H3: m + (m0 - m) = m0)
                 by (rewrite Nat.add_comm; apply Nat.sub_add, a).
                 assert (H4: m + n < m).
                 { apply H with (m0 - m).
                   apply Nat.add_lt_mono_l with m.
                   rewrite H3.
                   rewrite Nat.add_succ_r .
                   apply b.
                   rewrite H3.
                   apply H2.
                 }
                 lia.
        -- apply (subTermVar2 L).
            intro H2; rewrite <- H2 in b; elim (Compat815.lt_not_le _ _ b).
            apply Nat.le_add_r.
    + apply (forallE L).
      apply (impE L) with (forallH (m + n) (closeFrom m n f)).
      * apply sysExtend with (Empty_set (fol.Formula L)).
        -- intros x H1; induction H1.
        -- apply (impI L), (forallI L).
           ++ intros [x [H1 H2]];
                induction H2 as [x H2| x H2]; [ induction H2 | induction H2 ].
              now elim (in_remove_neq _ _ _ _ _ H1).
           ++ apply Hrecn.
              ** intros v H1; eapply H; apply Nat.lt_lt_succ_r, H1.
              ** eapply (forallSimp L).
                 apply Axm; right; constructor.
      * apply H0.
Qed.

Lemma subAllCloseFrom :
  forall (n : nat) (m : nat -> fol.Term L) (f : fol.Formula L)
         (T : fol.System L),
    folProof.SysPrf L T (closeFrom 0 n f) ->
    folProof.SysPrf L T
      (subAllFormula f
         (fun x : nat =>
            match le_lt_dec n x with
            | left _ => var x
            | right _ => m x
            end)).
Proof.
  intros n m f T H;
    assert
      (H0: exists r : nat,
          (forall v : nat, v < n -> newVar (freeVarTerm L (m v)) <= r)).
  { clear H T f; induction n as [| n Hrecn].
    - exists 0; intros v H; lia.
    - destruct Hrecn as [x H]; exists (max (newVar (freeVarTerm L (m n))) x).
      + intros v H0; assert (H1: v <= n) by lia.
        induction (Compat815.le_lt_or_eq _ _ H1).
        * apply Nat.le_trans with x.
          -- apply H; auto.
          -- apply Nat.le_max_r.
        * rewrite H2; apply Nat.le_max_l.
  }
  destruct H0 as (x, H0).
  set (r := max (max n (newVar (freeVarFormula L f))) x).
  set
    (f' :=
       subAllFormula f
         (fun x : nat =>
            match le_lt_dec n x with
            | left _ => var x
            | right _ => var (r + x)
            end)).
  set (m' := fun x : nat => m (x - r)).
  apply
    (impE L)
    with
    (subAllFormula f'
       (fun x : nat =>
          match le_lt_dec r x with
          | left _ =>
              match le_lt_dec (r + n) x with
              | left _ => var x
              | right _ => m' x
              end
          | right _ => var x
          end)).
  - replace
      (subAllFormula f
         (fun x0 : nat =>
            match le_lt_dec n x0 with
            | left _ => var x0
            | right _ => m x0
            end))
      with
      (subAllFormula f
         (fun x : nat =>
            subAllTerm
              match le_lt_dec n x with
              | left _ => var x
              | right _ => var (r + x)
              end
              (fun x0 : nat =>
                 match le_lt_dec r x0 with
                 | left _ =>
                     match le_lt_dec (r + n) x0 with
                     | left _ => var x0
                     | right _ => m' x0
                     end
                 | right _ => var x0
                 end))).
    + apply (iffE1 L).
      unfold f'; apply subAllSubAllFormula with
        (m1 := fun x0 : nat =>
                 match le_lt_dec n x0 with
                 | left _ => var x0
                 | right _ => var (r + x0)
                 end)
        (m2 := fun x0 : nat =>
                 match le_lt_dec r x0 with
                 | left _ =>
                     match le_lt_dec (r + n) x0 with
                     | left _ => var x0
                     | right _ => m' x0
                     end
                 | right _ => var x0
                 end).
    + unfold m'; apply subAllFormula_ext; intros m0 H1.
      induction (le_lt_dec n m0) as [a | ?].
      * simpl; induction (le_lt_dec r m0) as [a0 | ?].
        -- rewrite  Nat.le_ngt in a0; destruct a0.
           apply Nat.lt_le_trans with (newVar (freeVarFormula L f)).
           ++ now apply newVar2.
           ++ unfold r; eapply Nat.le_trans.
              ** apply Nat.le_max_r.
              ** apply Nat.le_max_l.
        -- reflexivity.
      * simpl; induction (le_lt_dec r (r + m0)) as [a | ?].
        -- induction (le_lt_dec (r + n) (r + m0)).
           ++ lia.
           ++ f_equal; lia.
        -- lia.
  - apply subAllCloseFrom1.
    + intros v H1 w H2; apply Nat.lt_le_trans with (newVar (freeVarTerm L (m v))).
      * apply newVar2.
        unfold m' in H2; now replace (r + v - r) with v in H2 by lia.
      * apply Nat.le_trans with x.
        -- now apply H0.
        -- unfold r; apply Nat.le_max_r.
    + unfold f'; clear f'; apply liftCloseFrom.
      * intros v H1; apply Nat.lt_le_trans with (newVar (freeVarFormula L f)).
        -- now apply newVar2.
        -- unfold r; eapply Nat.le_trans.
           ++ apply Nat.le_max_r.
           ++ apply Nat.le_max_l.
      * unfold r; eapply Nat.le_trans.
        -- apply Nat.le_max_l.
        -- apply Nat.le_max_l.
      * apply H.
Qed.

Lemma reduceSubAll :
  forall (T : fol.System L) (map : nat -> fol.Term L) (A B : fol.Formula L),
    (forall v : nat, ~ In_freeVarSys L v T) ->
    folProof.SysPrf L T (iffH A B) ->
    folProof.SysPrf L T (iffH (subAllFormula A map) (subAllFormula B map)).
Proof.
  assert
    (H: forall (T : fol.System L) (map : nat -> fol.Term L) (A B : fol.Formula L),
        (forall v : nat, ~ In_freeVarSys L v T) ->
        folProof.SysPrf L T (iffH  A B) ->
        folProof.SysPrf L T
          (impH  (subAllFormula A map) (subAllFormula B map))).
  { intros T map A B H H0;
      replace (impH  (subAllFormula A map) (subAllFormula B map))
      with
      (subAllFormula (impH  A B) map).
    - set (n := newVar (freeVarFormula L (impH A B))).
      replace (subAllFormula (impH A B) map)
        with
        (subAllFormula (impH A B)
           (fun x : nat =>
              match le_lt_dec n x with
              | left _ => var x
              | right _ => map x
              end)).
      + apply subAllCloseFrom.
        induction n as [| n Hrecn].
        * simpl; apply (iffE1 L), H0.
        * simpl; apply (forallI L).
          -- apply H.
          -- apply Hrecn.
      + apply subAllFormula_ext.
        intros m H1; induction (le_lt_dec n m) as [a | ?].
        * rewrite Nat.le_ngt in a; destruct a.
          unfold n; now apply newVar2.
        * auto.
    - reflexivity.
  }
  intros T map A B H0 H1; apply (iffI L).
  - apply H; auto.
  - apply H; auto.
    now apply (iffSym L).
Qed.

End subAllCloseFrom.

Lemma subToSubAll (T : fol.System L) (A : fol.Formula L) (v : nat) (s : fol.Term L):
 folProof.SysPrf L T
   (iffH (substituteFormula L A v s)
      (subAllFormula A
         (fun x : nat =>
          match eq_nat_dec v x with
          | left _ => s
          | right _ => var x
          end))).
Proof.
  apply (iffTrans L) with
    (substituteFormula L (subAllFormula A (fun x : nat => var x)) v s).
  apply sysExtend with (Empty_set (fol.Formula L)).
  - intros x H; contradiction H.
  - apply (reduceSub L).
    intros [x [H H0]]; induction H0.
    apply (iffSym L),  subAllFormulaId.
  - eapply (iffTrans L).
    + apply subSubAllFormula.
    + replace
        (subAllFormula A
           (fun x : nat =>
              match eq_nat_dec v x with
              | left _ => s
              | right _ => var x
              end))
        with
        (subAllFormula A
           (fun n : nat => substituteTerm L ((fun x : nat => var x) n) v s)).
      * apply (iffRefl L).
      * apply subAllFormula_ext; intros m H; now simpl.
Qed.

Lemma subAllSubFormula :
  forall (T : fol.System L) (A : fol.Formula L) (v : nat)
         (s : fol.Term L) (map : nat -> fol.Term L),
    folProof.SysPrf L T
      (iffH (subAllFormula (substituteFormula L A v s) map)
         (subAllFormula A
            (fun x : nat =>
               match eq_nat_dec v x with
               | left _ => subAllTerm s map
               | right _ => map x
               end))).
Proof.
  intros T A v s map; apply (sysExtend L) with (Empty_set (fol.Formula L)).
  - intros x H; contradiction H.
  - eapply (iffTrans L).
    + apply reduceSubAll.
      * intros v0 [x [H H0]]; contradiction H0.
      * apply subToSubAll.
    + eapply (iffTrans L).
      * apply subAllSubAllFormula.
      * replace
          (subAllFormula A
             (fun x : nat =>
                match eq_nat_dec v x with
                | left _ => subAllTerm s map
                | right _ => map x
                end))
          with
          (subAllFormula A
             (fun n : nat =>
                subAllTerm
                  ((fun x : nat =>
                      match eq_nat_dec v x with
                      | left _ => s
                      | right _ => var x
                      end) n) map)).
        -- apply (iffRefl L).
        -- apply subAllFormula_ext.
           intros m H; induction (eq_nat_dec v m); auto.
Qed.

End SubAllVars.


Require Export Image.

Arguments injective {U} {V}.
Definition surjective {X Y:Type} (f:X->Y) :=
  forall y:Y, exists x:X, f x = y.
Definition bijective {X Y:Type} (f:X->Y) :=
  injective f /\ surjective f.

Inductive invertible {X Y:Type} (f:X->Y) : Prop :=
  | intro_invertible: forall g:Y->X,
  (forall x:X, g (f x) = x) -> (forall y:Y, f (g y) = y) ->
  invertible f.

Require Import Description.
Require Import FunctionalExtensionality.

Lemma unique_inverse: forall {X Y:Type} (f:X->Y), invertible f ->
  exists! g:Y->X, (forall x:X, g (f x) = x) /\
             (forall y:Y, f (g y) = y).
Proof.
intros.
destruct H.
exists g.
red; split.
tauto.
intros.
destruct H1.
extensionality y.
transitivity (g (f (x' y))).
rewrite H2.
reflexivity.
rewrite H.
reflexivity.
Qed.

Definition function_inverse {X Y:Type} (f:X->Y)
  (i:invertible f) : { g:Y->X | (forall x:X, g (f x) = x) /\
                                (forall y:Y, f (g y) = y) }
  :=
     (constructive_definite_description _
      (unique_inverse f i)).

Lemma bijective_impl_invertible: forall {X Y:Type} (f:X->Y),
  bijective f -> invertible f.
Proof.
intros.
destruct H.
assert (forall y:Y, {x:X | f x = y}).
intro.
apply constructive_definite_description.
pose proof (H0 y).
destruct H1.
exists x.
red; split.
assumption.
intros.
apply H.
transitivity y.
auto with *.
auto with *.
pose (g := fun y:Y => proj1_sig (X0 y)).
pose proof (fun y:Y => proj2_sig (X0 y)).
simpl in H1.
exists g.
intro.
apply H.
unfold g; rewrite H1.
reflexivity.
intro.
unfold g; apply H1.
Qed.

Lemma invertible_impl_bijective: forall {X Y:Type} (f:X->Y),
  invertible f -> bijective f.
Proof.
intros.
destruct H.
split.
red; intros.
congruence.
red; intro.
exists (g y).
apply H0.
Qed.


(* ================================ *)
(* ========== CH02_def.v ========== *)
(* ================================ *)

Require Export CH01_ccw.

Open Scope nat_scope.

(* ================================ *)
(* ========== ########## ========== *)
(* ================================ *)

Definition invisible_succ (m:fmap)(d:dart)(p:point) : Prop :=
  (ccw (fpoint m d) (fpoint m (cA m zero d)) p).

Definition invisible_pred (m:fmap)(d:dart)(p:point) : Prop :=
  (ccw (fpoint m (cA_1 m zero d)) (fpoint m d) p).

Definition visible_succ (m:fmap)(d:dart)(p:point) : Prop :=
  (ccw (fpoint m d) p (fpoint m (cA m zero d))).

Definition visible_pred (m:fmap)(d:dart)(p:point) : Prop :=
  (ccw (fpoint m (cA_1 m zero d)) p (fpoint m d)).

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

Lemma invisible_succ_dec : forall (m:fmap)(d:dart)(p:point),
   {invisible_succ m d p} + {~ invisible_succ m d p}.
Proof.
intros m d p.
unfold invisible_succ.
generalize (ccw_dec (fpoint m d) (fpoint m (cA m zero d)) p).
tauto.
Qed.

Lemma invisible_pred_dec : forall (m:fmap)(d:dart)(p:point),
   {invisible_pred m d p} + {~ invisible_pred m d p}.
Proof.
intros m d p.
unfold invisible_pred.
generalize (ccw_dec (fpoint m (cA_1 m zero d)) (fpoint m d) p).
tauto.
Qed.

Lemma visible_succ_dec : forall (m:fmap)(d:dart)(p:point),
   {visible_succ m d p} + {~ visible_succ m d p}.
Proof.
intros m d p.
unfold visible_succ.
generalize (ccw_dec (fpoint m d) p (fpoint m (cA m zero d))).
tauto.
Qed.

Lemma visible_pred_dec : forall (m:fmap)(d:dart)(p:point),
   {visible_pred m d p} + {~ visible_pred m d p}.
Proof.
intros m d p.
unfold visible_pred.
generalize (ccw_dec (fpoint m (cA_1 m zero d)) p (fpoint m d)).
tauto.
Qed.

(* ================================ *)
(* ========== ########## ========== *)
(* ================================ *)

Definition left_dart (m:fmap)(d:dart)(p:point) : Prop :=
  invisible_succ m (cF_1 m d) p /\ visible_succ m d p.

Definition right_dart (m:fmap)(d:dart)(p:point) : Prop :=
  visible_pred m d p /\ invisible_pred m (cF_1 m d) p.

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

Lemma left_dart_dec : forall (m:fmap)(d:dart)(p:point),
  {left_dart m d p} + {~ left_dart m d p}.
Proof.
intros m d p; unfold left_dart.
generalize (invisible_succ_dec m (cF_1 m d) p).
generalize (visible_succ_dec m d p).
tauto.
Qed.

Lemma right_dart_dec : forall (m:fmap)(d:dart)(p:point),
  {right_dart m d p} + {~ right_dart m d p}.
Proof.
intros m d p; unfold right_dart.
generalize (visible_pred_dec m d p).
generalize (invisible_pred_dec m (cF_1 m d) p).
tauto.
Qed.

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

Function search_left (m:fmap)(d:dart)(p:point)(i:nat)
  {measure (fun n:nat => (degreef m d) - n) i} : dart :=
  if (le_lt_dec (degreef m d) i) then nil else
  let di := Iter (cF m) i d in
  if (left_dart_dec m di p) then di else search_left m d p (i+1).
Proof.
intros m d p i H1 H2 H3 H4; lia.
Qed.

Function search_right (m:fmap)(d:dart)(p:point)(i:nat)
  {measure (fun n:nat => (degreef m d) - n) i} : dart :=
  if (le_lt_dec (degreef m d) i) then nil else
  let di := (Iter (cF m) i d) in let di0 := (cA m zero di) in
  if (right_dart_dec m di0 p) then di0 else search_right m d p (i+1).
Proof.
intros m d p i H1 H2 H3 H4; lia.
Qed.

(* ================================ *)
(* ========== ########## ========== *)
(* ================================ *)

Fixpoint max_dart (m:fmap) {struct m} : dart :=
  match m with
    V => 0
  | I m0 x t p =>
    if (le_lt_dec x (max_dart m0)) then (max_dart m0) else x
  | L m0 k x y => max_dart m0
  end.

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

Definition mapdart := (fmap * dart)%type.

Definition CH2 (x1:dart)(t1:tag)(p1:point)(x2:dart)(t2:tag)(p2:point)(max:dart) : mapdart :=
  let m1 := I (I (I (I V x1 t1 p1) x2 t2 p2) (max+1) t1 p1) (max+2) t2 p2 in
  let m2 := Merge (Merge m1 one (max+1) x1) one (max+2) x2 in
  (Merge (Merge m2 zero x1 (max+2)) zero x2 (max+1), x1).

Definition CHID (md:mapdart)(x:dart)(t:tag)(p:point)(max:dart) : mapdart :=
  let m := fst md in let d := snd md in
  let l := search_left m d p 0 in
  if (eq_dart_dec l nil) then (I m x t p, d)
  else let r := search_right m l p 0 in
       let l0 := cA m zero l in
       let r_0 := cA_1 m zero r in
       let m1 := Split m zero l l0 in
       let m2 := if (eq_dart_dec l0 r) then m1
                 else Split m1 zero r_0 r in
       let m3 := (I (I m2 x t p) max t p) in
       let m4 := Merge m3 one max x in
       let m5 := Merge m4 zero l max in
       let m6 := Merge m5 zero x r in (m6, x).

Fixpoint CHI (m:fmap)(md:mapdart)(max:dart) {struct m} : mapdart :=
  match m with
  | I m0 x t p => (CHI m0 (CHID md x t p max) (max+1))
  | _ => md
  end.

Definition CH (m:fmap) : mapdart :=
  match m with
  | I (I m0 x1 t1 p1) x2 t2 p2 =>
    CHI m0 (CH2 x1 t1 p1 x2 t2 p2 (max_dart m)) ((max_dart m)+3)
  | _ => (m,nil)
  end.

(*
Fixpoint delete (m:fmap)(mr:fmap)(d:dart) {struct m} : fmap :=
  match m with
    V => V
  | I m0 x t p =>
    if (eqc_dec mr x d) then I (delete m0 mr d) x t p
    else delete m0 mr d
  | L m0 k x y =>
    if (eqc_dec mr x d) then L (delete m0 mr d) k x y
    else delete m0 mr d
  end.

Definition convexhull (m:fmap) : fmap :=
  let m0 := CH m in delete (fst m0) (fst m0) (snd m0).
*)

(* ================================ *)
(* ========== ########## ========== *)
(* ================================ *)

Extraction Language OCaml.
Extract Inductive sumbool => "bool" [ "true" "false" ].
Extract Constant R => "float".
Extract Constant R0 => "0.0".
Extract Constant R1 => "1.0".
Extract Constant Rplus => "fun x y -> x+.y".
Extract Constant Rmult => "fun x y -> x*.y".
Extract Constant Ropp => "fun x -> -.x".
Extract Constant total_order_T => "fun x y -> if (x<y) then (Inleft true) else if (x=y) then (Inleft false) else (Inright)".
Extraction "fmaps" CH.


Require Export list.

Hint Rewrite diff_nil : fast.
Set Implicit Arguments.
Section AssociationList.
Variables Key Value : Type.
Definition AssocList : Type := list (Key * Value).
Definition ALDom : AssocList -> list Key := map (fun x => fst x).
Definition ALRange : AssocList -> list Value := map (fun x => snd x).

Theorem ALDomCombine :
  forall lv lnt,
    length lv = length lnt
    -> ALDom (combine lv lnt) = lv.
Proof.
  induction lv; sp; simpl; destruct lnt; allsimpl; sp; try omega.
  f_equal; auto.
Qed.

Theorem ALRangeCombine :
  forall lv lnt,
    length lv = length lnt
    -> ALRange (combine lv lnt) = lnt.
Proof.
  induction lv; sp; simpl; destruct lnt; allsimpl; sp; try omega.
  f_equal; auto.
Qed.

Lemma ALInEta : forall sub v t,
  LIn (v,t) sub -> (LIn v (ALDom sub)) # (LIn t (ALRange sub)).
Proof.
  induction sub as [| ? Hind]; introv Hin; auto.
  allsimpl. dorn Hin; subst; auto;[].
  apply IHHind in Hin. repnd.
  split; right; auto.
Qed.

Definition ALMap {TK TV : Type}
  (fk : Key -> TK)
  (fv : Value -> TV) (al : AssocList):=
map (fun p => (fk (fst p), fv (snd p))) al.

Definition ALMapRange {T : Type} (f : Value -> T) (al : AssocList):=
ALMap (fun x=>x) f al.

Variable DeqKey : (Deq Key).
(** All definitions/lemmas below need decidable equality on Key.
    If not, they should placed before the line above *)
Fixpoint ALFind
    (al : AssocList) (key : Key): option Value :=
match al with
| nil => None
| (k, v) :: xs => if DeqKey key k
                  then Some v
                  else ALFind xs key
end.

Definition ALFindDef
    (al : AssocList) (key : Key) (def: Value):  Value :=
match (ALFind al key) with
| Some v => v
| None => def
end.

(** Same as [AlFind] above, but the output contains proofs of
    correctness. *)
Lemma ALFind2 :
  forall  (sub: AssocList) (a : Key) ,
    { b: Value & LIn (a,b) sub}
    + !(LIn a (ALDom sub)).
Proof.
   induction sub as [| (a', b') sub Hind]; intro a.
   - right.  sp.
   - destruct (DeqKey a a') as [Hc|Hc]; subst.
      + left. exists b'. left; refl.
      + destruct (Hind a) as [Hl | Hr]; exrepnd ;[left | right].
          * exists b. right; auto.
          * intro Hf. apply Hr. simpl in Hf. destruct (split sub).
              dorn Hf; sp.
Defined.

Definition ALFindDef2
    (al : AssocList) (key : Key) (def: Value):  Value :=
match (ALFind2 al key) with
| inl (existT  v _) => v
| inr _ => def
end.

(** In proofs, it is often convenient to replace
  [ALFindDef] with [ALFindDef2] so that we get some
  correctness hypotheses for free on destruction*)
Lemma ALFindDef2Same : forall
  (key : Key) (def: Value) (al : AssocList),
  ALFindDef al key def=ALFindDef2 al key def.
Proof.
  induction al as [|h th Hind]; auto;[]. destruct h as [k v].
  allunfold ALFindDef. allunfold ALFindDef2.
  simpl. cases_ifd Hd; auto.
  - rw Hdt; auto.
  - unfold ALFindDef2 in Hind.
    rw  Hind.  destruct_head_match; simpl; auto.
    destruct s; auto.
Qed.

Fixpoint ALFilter (sub : AssocList) (keys : list Key) : AssocList :=
  match sub with
  | nil => nil
  | (k, v) :: xs =>
      if (in_deq _ DeqKey k keys)
      then ALFilter xs keys
      else (k, v) :: ALFilter xs keys
  end.

Lemma ALFilter_nil_r :
  forall sub, ALFilter sub [] = sub.
Proof.
  induction sub; simpl; sp.
  rewrite IHsub; auto.
Qed.

Lemma ALDomFilterCommute :
  forall l sub,
    diff DeqKey l (ALDom sub) = ALDom (ALFilter sub l).
Proof.
  induction sub; simpl; sp; allsimpl.
  - apply diff_nil.
  - rewrite diff_cons_r.
    rw memberb_din.
    cases_if; simpl; f_equal; auto.
Qed.

Lemma ALFindSome :
  forall sub : AssocList,
  forall v : Key,
  forall u : Value,
    ALFind sub v = Some u
    -> LIn (v, u) sub.
Proof.
  induction sub; simpl; sp.
  inversion H.
  destruct (DeqKey v a0); cpx.
Qed.

Lemma ALFindNone :
  forall sub v,
    ALFind sub v = None
    -> ! LIn v (ALDom sub).
Proof.
  induction sub; simpl; sp;
  inversion H;
  destruct (DeqKey v a0); cpx.
  apply IHsub in H1. cpx.
Qed.

Lemma ALFindFilterSome :
  forall l v t sub,
    (ALFind (ALFilter sub l) v = Some t)
    <=> (ALFind sub v = Some t # ! LIn v l).
Proof.
  induction sub; simpl; sp; split; introv H; sp; allsimpl.
  - destruct (in_deq Key DeqKey a0 l); allsimpl.
    + rw IHsub in H; sp;case_if as Hd; subst;auto; try contradiction.
    + case_if as Hd; subst; auto; try contradiction.
      rw IHsub in H; exrepnd; auto.

  - destruct (in_deq Key DeqKey a0 l); allsimpl.
    + apply IHsub in H; exrepnd; auto.
    + destruct (DeqKey v a0); allsimpl; subst; sp;[].
      rw IHsub in H; exrepnd; auto.

  - destruct (in_deq Key DeqKey a0 l); allsimpl.
    + apply IHsub; split; auto.
      destruct (DeqKey v a0); allsimpl; subst; sp.

    + destruct (DeqKey v a0); allsimpl; subst; sp.
       apply IHsub; split; auto.
Qed.

Lemma ALFindFilterNone :
  forall l v sub,
    (ALFind (ALFilter sub l) v = None)
    <=> (ALFind sub v = None [+] LIn v l).
  induction sub; simpl; sp; split; introv H; sp; allsimpl.
  - destruct (in_deq Key DeqKey a0 l); allsimpl;
    destruct (DeqKey v a0) as [ddd | ddd]; allsimpl;
    subst;
    try(rw IHsub in H);
    exrepnd; auto;cpx.
  - destruct (in_deq Key DeqKey a0 l); allsimpl;
    destruct (DeqKey v a0) as [ddd | ddd]; allsimpl;
    subst;cpx;apply IHsub; cpx.
  - destruct (in_deq Key DeqKey a0 l); allsimpl;
    destruct (DeqKey v a0) as [ddd | ddd]; allsimpl;
    subst;cpx;apply IHsub; cpx.
Qed.

Lemma ALFilterSwap :
  forall l1 l2 sub,
    ALFilter (ALFilter sub l1) l2
    = ALFilter (ALFilter sub l2) l1.
Proof.
  induction sub; simpl; sp.
  allsimpl; cases_if as H1d; cases_if as H2d;
  allsimpl; try (rw H1d); try (rw H2d);
  cpx; try (rw IHsub); cpx.
Qed.

Lemma ALFilterAppR :
  forall sub vs1 vs2,
    ALFilter sub (vs1 ++ vs2)
    = ALFilter (ALFilter sub vs1) vs2.
Proof.
  induction sub; simpl; sp.
  rw <- memberb_din.
  rw <- memberb_din.
  rw memberb_app.
  destructr (memberb DeqKey a0 vs1) as [m1 | m1]; simpl.
  apply IHsub.
  rw <- memberb_din.
  allsimpl. destruct (memberb DeqKey a0 vs2) as [m2 | m2];
  simpl; subst;
  try(rw IHsub); auto.
Qed.

Lemma ALFilterAppAsDiff :
  forall sub l1 l2,
    ALFilter sub (l1 ++ l2)
    = ALFilter sub (l1 ++ diff DeqKey l1 l2).
Proof.
  induction sub; simpl; sp; allsimpl;[].
  cases_ifd  Hd; cases_ifd  Hdd; cpx;
  allrw in_app_iff;
  allrw in_diff.
  - provefalse. apply Hddf.
    dorn Hdt; cpx;[].
    pose proof (in_deq _ DeqKey a0 l1) as X.
    dorn X; cpx.
  - provefalse. apply Hdf.
    dorn Hddt; exrepnd; cpx.
  - f_equal. auto.
Qed.

(** [lv] is needs to make the induction
    hypothesis strong enough *)
Lemma ALFilterDom : forall  sub lv,
  ALFilter sub (lv++ALDom sub) =[].
Proof.
  induction sub as [|(v,u) sub Hind] ; introv ; auto;[].
  allsimpl.
  cases_ifd Hd; cpx; allsimpl; allrw in_app_iff;
  cpx.
  - rw cons_as_app. rw app_assoc. rw Hind; auto.
  - provefalse. apply Hdf. right. cpx.
Qed.

Fixpoint ALKeepFirst (sub : AssocList) (vars : list Key) : AssocList :=
match sub with
| nil => nil
| (v, t) :: xs =>
    if in_deq _ DeqKey v vars
    then (v, t) :: ALKeepFirst
                   xs
                   (diff DeqKey [v] vars)
    else ALKeepFirst xs vars
end.

Lemma ALKeepFirstNil :
  forall sub,
    ALKeepFirst sub [] = [].
Proof.
  induction sub; simpl; sp.
Qed.

Lemma ALFindSomeKeepFirstSingleton:
  forall sub v t,
    ALFind sub v = Some t
    -> ALKeepFirst sub [v] = [(v,t)].
Proof.
  induction sub as [|(v,t) sub Hind];
  introv Heq; allsimpl; cpx.
  destruct (DeqKey v0 v) as [xx|xx];
  subst;allsimpl; cpx;[].
  rewrite DeqTrue.
  rw ALKeepFirstNil; auto.
Qed.

Lemma ALFindNoneKeepFirstSingleton:
  forall sub v,
    ALFind sub v = None
    -> ALKeepFirst sub [v] = [].
Proof.
  induction sub as [|(v,t) sub Hind];
  introv Heq; allsimpl; cpx.
  destruct (DeqKey v0 v) as [xx|xx];
  subst;allsimpl; cpx.
Qed.
Hint Rewrite ALKeepFirstNil ALFilterDom ALFilter_nil_r : fast.

Lemma ALKeepFirstLin:
  forall sub v vs t,
    LIn (v,t) (ALKeepFirst sub vs)
    <=> (ALFind sub v = Some t # LIn v vs).
Proof.
  induction sub; simpl; sp;[split;sp|].
  destruct (DeqKey v a0);
  destruct (in_deq Key DeqKey a0 vs);
  subst; cpx; split; introns Hyp; allsimpl; exrepnd; cpx.
  - dorn Hyp; cpx. apply IHsub in Hyp.
    exrepnd.
    apply in_remove in Hyp; cpx.
  - apply IHsub in Hyp; exrepnd; cpx.
  - dorn Hyp; cpx. apply IHsub in Hyp.
    exrepnd.
    apply in_remove in Hyp; cpx.
  - right. apply IHsub; dands; cpx.
    apply in_remove; dands; cpx.
Qed.

Lemma ALKeepFirstLinApp:
  forall sub v vs vss t,
    LIn (v,t) (ALKeepFirst sub (vs))
    -> LIn (v,t) (ALKeepFirst sub (vs++ vss)).
Proof.
  introv X.
  apply ALKeepFirstLin in X.
  apply ALKeepFirstLin.
  exrepnd; dands; auto.
  apply in_app_iff.
  cpx.
Qed.

Lemma ALFilterLIn :
  forall v t sub vars,
    LIn (v, t) (ALFilter sub vars)
    <=>
    (
      LIn (v, t) sub
      #
      ! LIn v vars
    ).
Proof.
  induction sub; simpl; sp.
  split; sp. cases_if;
  simpl; allrw; split; sp; cpx.
  contradiction.
Qed.

Lemma ALFilterSubset :
  forall sub vars,
    subset (ALFilter sub vars) sub.
Proof.
  introv Hin.
  destruct x;
  rw ALFilterLIn in Hin; cpx.
Qed.

Lemma ALKeepFirstSubst :
  forall sub vars,
    subset (ALKeepFirst sub vars) sub.
Proof.
  introv Hin.
  destruct x;
  rw ALKeepFirstLin in Hin; exrepnd;
  cpx.
  apply ALFindSome; cpx.
Qed.

Hint Resolve ALFilterSubset ALKeepFirstSubst :
  SetReasoning.

Lemma ALKeepFirstAppLin:
  forall lv1 lv2 sub v u,
  LIn (v,u) (ALKeepFirst sub (lv1++lv2))
  -> LIn (v,u) (ALKeepFirst sub lv1) [+]
     LIn (v,u) (ALKeepFirst sub lv2).
Proof. introv Hin.
  apply ALKeepFirstLin in Hin.
  repnd.
  apply in_app_iff in Hin. dorn Hin;[left|right];
  apply ALKeepFirstLin;sp.
Qed.

Lemma ALKeepFirstFilterDiff:
forall sub lvk lvf,
  (ALKeepFirst  sub (diff DeqKey lvf lvk))
  =
  (ALKeepFirst (ALFilter sub lvf) lvk).
Proof.
  induction sub; allsimpl;
  autorewrite with fast; cpx;[].
  intros. allsimpl.
  destruct a.
  cases_ifd H1d; cases_ifd H2d;
   allrw in_diff; exrepnd; allsimpl; cpx.
  - cases_ifd H3d; cpx. f_equal.
    rw <- diff_remove. apply IHsub.
  - cases_ifd H3d; cpx. provefalse.
    apply H1df. dands;cpx.
Qed.

Lemma ALFilterAppSub :
  forall sub1 sub2 l,
  ALFilter (sub1++sub2) l
  = (ALFilter sub1 l)++(ALFilter sub2 l).
Proof.
  induction sub1; simpl; sp;[].
  rw IHsub1.
  cases_ifd Hd; cpx.
Qed.

Lemma ALFindApp :
  forall v sub1 sub2,
    ALFind (sub1 ++ sub2) v
    = match ALFind sub1 v with
        | Some t => Some t
        | None => ALFind sub2 v
      end.
Proof.
  induction sub1; simpl; sp.
  cases_if; auto.
Qed.

Lemma ALFindRangeMapSome :
  forall v t sub f,
    ALFind sub v = Some t
    -> ALFind (ALMapRange f sub) v
        = Some (f t).
Proof.
  induction sub; simpl; sp; allsimpl;[].
  cases_ifd Hd; cpx.
Qed.

Lemma ALFindRangeMapNone :
  forall v sub f,
    ALFind sub v = None
    -> ALFind (ALMapRange f sub) v = None.
Proof.
  induction sub; simpl; sp; allsimpl.
  cases_ifd Hd; cpx.
Qed.

Fixpoint ALRangeRel  (R : Value -> Value-> [univ])
    (subl subr : AssocList) : [univ] :=
match (subl, subr) with
| ([],[]) => True
| ((vl,tl) :: sl , (vr,tr) :: sr) => (vl=vr # R tl tr # ALRangeRel R sl sr)
| ( _ , _) => False
end.

Lemma ALRangeRelApp : forall R subl1 subl2 subr1 subr2,
  (ALRangeRel  R subl1 subl2 # ALRangeRel R subr1 subr2)
  ->   ALRangeRel R (subl1 ++ subr1)  (subl2 ++ subr2).
Proof.
  induction subl1 as [|(v1,t1) subl1 Hind]; introv Hsr;
  destruct subl2 as [|(v2,t2) subl2]; inverts Hsr; allsimpl;sp.
Qed.

Lemma ALRangeRelRefl : forall R,
  refl_rel R -> refl_rel (ALRangeRel R).
Proof.
  introv Hr. unfold refl_rel in Hr. unfold refl_rel.
  induction x as [|(v1,t1) subl1 Hind];  allsimpl;sp.
Qed.

Lemma ALRangeRelSameDom : forall R
  (subl subr : AssocList),
  ALRangeRel R subl subr
  -> ALDom subl = ALDom subr.
Proof.
  induction subl as [| (kl,vl) subl Hind]; introv Hal;
  destruct subr as [| (kr,vr) subr]; allsimpl; repnd; dands; cpx.
  f_equal; cpx.
Qed.

Lemma ALRangeRelFind : forall R
  (subl subr : AssocList) k t,
  ALRangeRel R subl subr
  -> ALFind subl k = Some t
  -> { tr : Value & ALFind subr k = Some tr # R t tr}.
Proof.
  induction subl as [| (kl,vl) subl Hind]; cpx; introv HAl Hf.
  allsimpl. destruct subr as [| (kr,vr) subr]; cpx;[].
  allsimpl. repnd. subst.
  cases_ifd Hd; cpx.
  eexists; eauto.
Qed.

Lemma ALRangeRelFilter : forall R
  (subl subr : AssocList) l,
  ALRangeRel R subl subr
  ->  ALRangeRel R
        (ALFilter  subl l)
        (ALFilter  subr l).
Proof.
  induction subl as [| (kl,vl) subl Hind]; introv Hal;
  destruct subr as [| (kr,vr) subr]; allsimpl; repnd; dands; subst; cpx.
  cases_if; cpx.
Qed.

(* hints should be placed (again) after this line.
  the ones in the section get deactivated
 *)
End AssociationList.
Hint Rewrite ALKeepFirstNil ALFilterDom ALFilter_nil_r
  ALRangeCombine ALDomCombine: fast.

Hint Resolve ALFilterSubset ALKeepFirstSubst :
  SetReasoning.

Definition ALSwitch {K V} (sub : AssocList K V)  : AssocList V K :=
  map (fun x => (snd x, fst x)) sub.

Lemma ALSwitchCombine : forall {K V} (lv: list V) (lk : list K) ,
  combine lv lk = ALSwitch (combine lk lv).
Proof.
  induction lv; allsimpl.
  - destruct lk; cpx.
  - destruct lk; cpx.
    allsimpl. f_equal. cpx.
Qed.

Lemma ALMapRangeFilterCommute :
  forall K V l T (deq : Deq K) (f: V -> T) (sub : AssocList K V),
  (ALFilter deq (ALMapRange f sub) l)  = ALMapRange f (ALFilter deq sub l).
Proof.
  induction sub; simpl; sp; allsimpl.
  cases_if; simpl; auto; f_equal; auto.
Qed.

Lemma ALFindMapSome :
  forall {KA KB VA VB : Type}
    (DKA : Deq KA)
    (DKB : Deq KB)
    (fk : KA -> KB)
    (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA)
      v t, ALFind DKA sub v = Some t
  -> ALFind DKB (ALMap fk fv sub) (fk v)
        = Some (fv t).
Proof.
  introv Hik.
  induction sub;simpl; introv Heq; sp; allsimpl;[].
  cases_ifd Hd; cpx.
  + f_equal. apply Hik in Hdt.
    destruct Hdt. rewrite DeqTrue in Heq.
    invertsn Heq. refl.
  + apply IHsub. revert Heq. cases_ifd Hdd;
    subst; cpx.
Qed.

Lemma ALFindMapNone :
  forall {KA KB VA VB : Type}
    (DKA : Deq KA)
    (DKB : Deq KB)
    (fk : KA -> KB)
    (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA)
      v, ALFind DKA sub v = None
  -> ALFind DKB (ALMap fk fv sub) (fk v)
        = None.
Proof.
  introv Hik.
  induction sub;simpl; introv Heq; sp; allsimpl;[].
  cases_ifd Hd; cpx.
  + f_equal. apply Hik in Hdt.
    destruct Hdt. rewrite DeqTrue in Heq.
    invertsn Heq.
  + apply IHsub. revert Heq. cases_ifd Hdd;
    subst; cpx.
Qed.

Lemma ALFindEndoMapSome :
  forall {KA VA VB: Type}
    (DKA : Deq KA)
    (fk : KA -> KA)
    (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA)
      v, ALFind DKA sub v = None
  -> ALFind DKA (ALMap fk fv sub) (fk v)
        = None.
Proof.
  intros. eapply ALFindMapNone; eauto.
Qed.

Lemma ALMapFilterCommute :
  forall {KA KB VA VB : Type}
  (DKA : Deq KA)
  (DKB : Deq KB)
  (fk : KA -> KB)
  (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA) l,
      (ALFilter DKB (ALMap fk fv sub) (map fk l))
          = ALMap fk fv (ALFilter DKA sub l).
Proof.
  introv Hin.
  induction sub; simpl; sp; allsimpl.
  cases_ifd Hd; cases_ifd Hc;
    simpl; auto; f_equal; auto.
  - apply in_map_iff in Hdt. exrepnd. apply Hin in Hdt0.
    subst. cpx.
  - rw in_map_iff in Hdf. provefalse.
    apply Hdf. eexists; eauto.
Qed.

(** endo maps avoid the need to provide another
    decider for keys *)
Lemma ALEndoMapFilterCommute :
  forall {KA VA VB : Type}
  (DKA : Deq KA)
  (fk : KA -> KA)
  (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA) l,
      (ALFilter DKA (ALMap fk fv sub) (map fk l))
          = ALMap fk fv (ALFilter DKA sub l).
Proof.
  intros. apply ALMapFilterCommute; auto.
Qed.

Lemma ALMapRangeFindCommute :
  forall K V T (v: K) (deq : Deq K) (f: V -> T) (sub : AssocList K V),
  (ALFind deq (ALMapRange f sub) v)  = option_map f (ALFind deq sub v).
Proof.
  induction sub; simpl; sp; allsimpl.
  cases_if; simpl; auto; f_equal; auto.
Qed.


(*|
###############################################################
How do we know all Coq constructors are injective and disjoint?
###############################################################

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

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

According to `this course
<http://www.cis.upenn.edu/~bcpierce/sf/current/MoreCoq.html>`__, all
constructors (for inductive types) are injective and disjoint:

    ...Similar principles apply to all inductively defined types: all
    constructors are injective, and the values built from distinct
    constructors are never equal. For lists, the ``cons`` constructor
    is injective and ``nil`` is different from every non-empty list.
    For booleans, ``true`` and ``false`` are unequal.

(And the ``inversion`` tactic based on this assumption)

I am just wondering how do we know this assumption holds?

How do we know that, e.g., we cannot define natural numbers based on

1) a "Successor" and maybe a "Double" constructor like this:

   .. coq::
|*)

Inductive num : Type :=
| O : num
| S : num -> num
| D : num -> num.

(*|
   and

2) some ``plus`` function so that one number ``2`` can be reached via
   two different sequences/routes of constructors, ``S (S O)`` and ``D
   (S O)``?

What's the mechanism in Coq that ensures the above will never happen?

P.S. I am not suggesting the above ``num`` example is possible. I am
just wondering what makes it impossible.
|*)

(*|
Answer
******

When you define an inductive data type in Coq, you are essentially
defining a *tree* type. Each constructor gives a kind of node that is
allowed to occur in your tree, and its arguments determine the
children and elements that that node can have. Finally, functions
defined on inductive types (with the ``match`` clause) can check the
constructors that were used to produce a value of that type in
*arbitrary* ways. This makes Coq constructors very different from
constructors you see in an OO language, for instance. An object
constructor is implemented as a regular function that initializes a
value of a given type; Coq constructors, on the other hand, are
enumerating the possible values that the *representation* of our type
allows. To understand this difference better, we can compare the
different functions we can define on an object in a traditional OO
language, and on an element of an inductive type in Coq. Let's use
your ``num`` type as an example. Here's an object-oriented definition:

.. code-block:: java

    class Num {
        int val;

        private Num(int v) {
            this.val = v;
        }

        /* These are the three "constructors", even though they
           wouldn't correspond to what is called a "constructor" in
           Java, for instance */

        public static zero() {
            return new Num(0);
        }

        public static succ(Num n) {
            return new Num(n.val + 1);
        }

        public static doub(Num n) {
            return new Num(2 * n.val);
        }
    }

And here's a definition in Coq:
|*)

Reset Initial. (* .none *)
Inductive num : Type :=
| zero : num
| succ : num -> num
| doub : num -> num.

(*|
In the OO example, when we write a function that takes a ``Num``
argument, there's no way of knowing which "constructor" was used to
produce that value, because this information is not stored in the
``val`` field. In particular ``Num.doub(Num.succ(Num.zero()))`` and
``Num.succ(Num.succ(Num.zero()))`` would be equal values.

In the Coq example, on the other hand, things change, because we *can*
determine which constructor was used to form a ``num`` value, thanks
to the ``match`` statement. For instance, using Coq strings, we could
write a function like this:
|*)

Require Import Coq.Strings.String.

Open Scope string_scope.

Definition cons_name (n : num) : string :=
  match n with
  | zero   => "zero"
  | succ _ => "succ"
  | doub _ => "doub"
  end.

(*|
In particular, even though your intended meaning for the constructors
implies that ``succ (succ zero)`` and ``doub (succ zero)`` should be
"morally" equal, we can distinguish them by applying the ``cons_name``
function to them:
|*)

Compute cons_name (doub (succ zero)). (* .unfold *)
Compute cons_name (succ (succ zero)). (* .unfold *)

(*|
As a matter of fact, we can use ``match`` to distinguish between
``succ`` and ``doub`` in *arbitrary* ways:

.. code-block:: coq

    match n with
    | zero   => false
    | succ _ => false
    | doub _ => true
    end.

Now, ``a = b`` in Coq means that there is no possible way we can
distinguish between ``a`` and ``b``. The above examples show why
``doub (succ zero)`` and ``succ (succ zero)`` cannot be equal, because
we can write functions that don't respect the meaning that we had in
mind when we wrote that type.

This explains why constructors are disjoint. That they are injective
is actually also a consequence of pattern-matching. For instance,
suppose that we wanted to prove the following statement:
|*)

Goal forall n m, succ n = succ m -> n = m.

(*| We can begin the proof with |*)

  intros n m H.

(*| Leading us to |*)

  Show. (* .unfold .messages *)

(*| Notice that this goal is by simplification equivalent to |*)

  change (match succ n with
          | succ n' => n' = m
          | _       => True
          end). (* .none *)
  Show. (* .unfold .messages *)

(*| If we do ``rewrite H``, we obtain |*)

  rewrite H. (* .none *)
  change (match succ m with
          | succ n' => n' = m
          | _       => True
          end). (* .none *)
  Show. (* .unfold .messages *)

(*| which simplifies to |*)

  simpl. (* .none *) Show. (* .unfold .messages *)

(*|
At this point, we can conclude with ``reflexivity``. This technique is
quite general, and is actually at the core of what ``inversion`` does.
|*)


Require Import List.
Require Import Blocks.

Parameter list_A list_C input output: list nat.
Parameter reliable_communication reliable_checker continuous_block: Prop.

Definition consistent_chain(l m: list nat):=
valid_list l -> valid_or_unknown_list m.

Definition not_orphan:= ~(hd 0 list_A = 2).

Definition correct_format(l: list nat):= continuous_block /\ (valid_or_unknown_list l) /\
~(hd 0 list_A = 1) /\ not_orphan.

Definition B_valid:= valid_list list_A /\ valid_list list_C.
Definition B_accepted(l: list nat):= correct_format l /\ (valid_list output).

Axiom list_A_is_valid: valid_list list_A.
Axiom list_A_is_not_nil: ~(list_A = nil).
Axiom reliable_communication_imply_continuous_block:
reliable_communication -> continuous_block.
Axiom reliable_input: reliable_communication -> (input = list_C).
Axiom reliable_output: reliable_checker -> (valid_list input <-> valid_list output).

Lemma exist_invalid_list: exists l: list nat, ~valid_or_unknown_list l.
Proof.
exists(1::nil).
auto.
Qed.

Theorem error_without_consistent_between_listBC:
reliable_communication /\ reliable_checker ->
exists list_B, (B_valid -> ~(B_accepted list_B)).
Proof.
intros.
destruct exist_invalid_list.
exists x.
intro.
assert(~correct_format x).
{ unfold correct_format.
  tauto. }
unfold B_accepted.
tauto.
Qed.


Require Export Syntax.
Require Export Map.

Definition env := partial_map var ty.

Definition activeEnv (Gamma : env) : env :=
  fun x =>
    match Gamma x with
      | Some t => if is_active t then Some t else None
      | None => None
    end.

Reserved Notation " Gamma '|-' expr '\in' ty " (at level 40).

Inductive hasType (Gamma : env) : expr -> ty -> Prop :=
  | T_Var :
      forall x t
        (Hlookup : Gamma x = Some t),
        Gamma |- EVar x \in t
  | T_Unit :
        Gamma |- EUnit \in TUnit
  | T_Loc :
      forall l,
        Gamma |- ELoc l \in TPas
  | T_Id :
      forall id,
        Gamma |- EId id \in TAct
  | T_Trans :
      forall l,
        Gamma |- (ETId l) \in TTrans
  | T_NewPassive :
        Gamma |- ENew TPas \in TPas
  | T_NewActive :
        Gamma |- ENew TAct \in TAct
  | T_NewTrans :
        Gamma |- ENew TTrans \in TTrans
  | T_Mutate :
      forall e,
        Gamma |- e \in TPas ->
        Gamma |- EMut e \in TUnit
  | T_Lam :
      forall x t1 e t2
        (bodyHasType : extend Gamma x t1 |- e \in t2),
        Gamma |- ELam x t1 e \in TArr t1 t2
  | T_Apply :
      forall e1 e2 t1 t2,
        Gamma |- e1 \in TArr t1 t2 ->
        Gamma |- e2 \in t1 ->
        Gamma |- EApp e1 e2 \in t2
  | T_Send :
      forall x e e' a,
        Gamma |- e \in a ->
        forall (Hactive : is_active a = true),
        extend (activeEnv Gamma) x TPas |- e' \in TUnit ->
        freeLocs e' = nil ->
        Gamma |- ESend e x TPas e' \in TUnit
  where " Gamma '|-' expr '\in' ty " := (hasType Gamma expr ty).

Tactic Notation "hasType_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var"
  | Case_aux c "T_Unit"
  | Case_aux c "T_Loc"
  | Case_aux c "T_Id"
  | Case_aux c "T_Trans"
  | Case_aux c "T_NewPassive"
  | Case_aux c "T_NewActive"
  | Case_aux c "T_NewTrans"
  | Case_aux c "T_Mutate"
  | Case_aux c "T_Lam"
  | Case_aux c "T_Apply"
  | Case_aux c "T_Send"
  ]
.


(*
 * Copyright (C) BedRock Systems Inc. 2020-2023
 *
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
Require Export iris.algebra.lib.excl_auth.
Require Export bedrock.prelude.base.
Set Printing Coercions.

(** * Extension to [excl_auth] *)
(** Extend [iris.algebra.lib.excl_auth] with fractional authoritative
elements [excl_auth_frac] (notation [●E{q} a]) such that

- fraction [1] coincides with the existing [excl_auth_auth] (notation
  [●E a])

- the operation [⋅] on such elements is addition of fractions

- [●E{q} a] valid implies fraction [q] valid

- [●E{q1} a1 ⋅ ●E{q2} a2] valid implies [a1 ≡ a2]

- [●E{q} a ⋅ ◯E b] valid implies [a ≡ b]

This is entirely straightforward because the underlying authoritative
construction supports such fractions. *)

(** Fractional authoritative elements for [excl_auth]. *)
Definition excl_auth_frac {A : ofe} (q : Qp) (a : A) : excl_authR A :=
  ●{#q} (Excl' a).
#[global] Instance: Params (@excl_auth_frac) 1 := {}.
#[global] Hint Opaque excl_auth_frac : typeclass_instances.

Notation "●E{ q } a" := (excl_auth_frac q a) (at level 10, format "●E{ q }  a").

Section excl_auth_frac.
  Context {A : ofe}.
  Implicit Types a b : A.
  Import proofmode_classes.

  Lemma excl_auth_auth_frac a : ●E a = ●E{1} a.
  Proof. done. Qed.

  #[global] Instance excl_auth_frac_ne q : NonExpansive (@excl_auth_frac A q).
  Proof. solve_proper. Qed.
  #[global] Instance excl_auth_frac_proper q : Proper ((≡) ==> (≡)) (@excl_auth_frac A q).
  Proof. apply: ne_proper. Qed.

  #[global] Instance excl_auth_frac_discrete q a `{!Discrete a} : Discrete (●E{q} a).
  Proof. apply auth_auth_discrete. apply Some_discrete, _. apply _. Qed.

  Lemma excl_auth_frac_op p q a : ●E{p + q} a ≡ ●E{p} a ⋅ ●E{q} a.
  Proof. by rewrite -auth_auth_dfrac_op. Qed.

  #[global] Instance excl_auth_frac_is_op q q1 q2 a :
    IsOp q q1 q2 → IsOp' (●E{q} a) (●E{q1} a) (●E{q2} a).
  Proof. rewrite /excl_auth_frac. apply _. Qed.

  Lemma excl_auth_frac_validN n q a : ✓{n} (●E{q} a) ↔ (q ≤ 1)%Qp.
  Proof. rewrite /excl_auth_frac. by rewrite auth_auth_dfrac_validN right_id. Qed.
  Lemma excl_auth_frac_valid q a : ✓ (●E{q} a) ↔ (q ≤ 1)%Qp.
  Proof. rewrite /excl_auth_frac. by rewrite auth_auth_dfrac_valid right_id. Qed.

  Lemma excl_auth_auth_frac_op_validN n q1 q2 a1 a2 :
    ✓{n} (●E{q1} a1 ⋅ ●E{q2} a2) ↔ (q1 + q2 ≤ 1)%Qp ∧ a1 ≡{n}≡ a2.
  Proof.
    rewrite/excl_auth_frac.
    by rewrite auth_auth_dfrac_op_validN (inj_iff Some) (inj_iff Excl) right_id.
  Qed.
  Lemma excl_auth_auth_frac_op_valid q1 q2 a1 a2 :
    ✓ (●E{q1} a1 ⋅ ●E{q2} a2) ↔ (q1 + q2 ≤ 1)%Qp ∧ a1 ≡ a2.
  Proof.
    rewrite/excl_auth_frac.
    by rewrite auth_auth_dfrac_op_valid (inj_iff Some) (inj_iff Excl) right_id.
  Qed.
  Lemma excl_auth_auth_frac_op_valid_L `{!LeibnizEquiv A} q1 q2 a1 a2 :
    ✓ (●E{q1} a1 ⋅ ●E{q2} a2) ↔ (q1 + q2 ≤ 1)%Qp ∧ a1 = a2.
  Proof. unfold_leibniz. apply excl_auth_auth_frac_op_valid. Qed.

  Lemma excl_auth_frac_op_invN n p a q b : ✓{n} (●E{p} a ⋅ ●E{q} b) → a ≡{n}≡ b.
  Proof.
    rewrite /excl_auth_frac=>/auth_auth_dfrac_op_invN.
    by rewrite (inj_iff Some) (inj_iff Excl).
  Qed.
  Lemma excl_auth_frac_op_inv p a q b : ✓ (●E{p} a ⋅ ●E{q} b) → a ≡ b.
  Proof.
    rewrite/excl_auth_frac=>/auth_auth_dfrac_op_inv.
    by rewrite (inj_iff Some) (inj_iff Excl).
  Qed.
  Lemma excl_auth_frac_op_inv_L `{!LeibnizEquiv A} p a q b :
    ✓ (●E{p} a ⋅ ●E{q} b) → a = b.
  Proof. unfold_leibniz. apply excl_auth_frac_op_inv. Qed.

  Lemma excl_auth_frac_agreeN q n a b : ✓{n} (●E{q} a ⋅ ◯E b) → a ≡{n}≡ b.
  Proof.
    rewrite/excl_auth_frac=>/auth_both_dfrac_validN-[] _ []Hinc Hv. move: Hinc.
    move/Some_includedN_exclusive/(_ Hv){Hv}. by rewrite (inj_iff Excl).
  Qed.
  Lemma excl_auth_frac_agree q a b : ✓ (●E{q} a ⋅ ◯E b) → a ≡ b.
  Proof.
    intros. apply equiv_dist=>n.
    by apply (excl_auth_frac_agreeN q), cmra_valid_validN.
  Qed.
  Lemma excl_auth_frac_agree_L `{!LeibnizEquiv A} q a b : ✓ (●E{q} a ⋅ ◯E b) → a = b.
  Proof. unfold_leibniz. apply excl_auth_frac_agree. Qed.

End excl_auth_frac.


Require Import XR_frac_part.
Require Import XR_Rle.
Require Import XR_plus_Int_part1.
Require Import XR_Rplus_eq_compat_l.
Require Import XR_plus_IZR.
Require Import XR_Rplus_eq_compat_r.

Local Open Scope R_scope.

Lemma plus_frac_part1 :
  forall r1 r2:R,
    R1 <= frac_part r1 + frac_part r2->
    frac_part (r1 + r2) = frac_part r1 + frac_part r2 - R1.
Proof.
  intros x y.
  intro h.
  unfold frac_part.
  assert (pi := plus_Int_part1).
  specialize (pi x y).
  specialize (pi h).
  rewrite pi.
  clear pi h.
  unfold Rminus.
  repeat rewrite Rplus_assoc.
  apply Rplus_eq_compat_l.
  repeat rewrite plus_IZR.
  repeat rewrite Ropp_plus_distr.
  simpl.
  repeat rewrite <- Rplus_assoc.
  repeat apply Rplus_eq_compat_r.
  rewrite Rplus_comm.
  reflexivity.
Qed.