(** * Miscellaneous Well-Foundedness Facts *)
Require Import Coq.Setoids.Setoid Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Classes.Morphisms Coq.Init.Wf.
Require Import Coq.Lists.SetoidList.

Set Implicit Arguments.
Set Asymmetric Patterns.

Scheme Induction for Acc Sort Prop.
Scheme Induction for Acc Sort Set.
Scheme Induction for Acc Sort Type.

Section wf.
  Section wrap_wf.
    Context {A R} (Rwf : @well_founded A R).

    Definition lt_wf_idx_step
               (lt_wf_idx : nat -> well_founded R)
               (n : nat)
      : well_founded R.
    Proof.
      destruct n.
      { clear -Rwf; apply Rwf. }
      { constructor; intros; apply lt_wf_idx; assumption. }
    Defined.

    Fixpoint lt_wf_idx (n : nat) : well_founded R
      := lt_wf_idx_step (@lt_wf_idx) n.
  End wrap_wf.

  Section rel_hetero.
    Local Notation "R ==> S"
      := (@respectful_hetero _ _ _ _ R (fun _ _ => S))
         : signature_scope.
    Local Notation Proper S R
      := (S%signature R R) (only parsing).

    Context {A A'}
            (RA : A -> A' -> Prop)
            (P : A -> Type) (P' : A' -> Type)
            (RP : forall a a', RA a a' -> P a -> P' a' -> Prop)
            {R : relation A} {R' : relation A'}
            (HR : (RA ==> RA ==> Basics.impl)%signature R R')
            (Rwf : well_founded R) (Rwf' : well_founded R')
            (F : forall x, (forall y, R y x -> P y) -> P x)
            (F' : forall x, (forall y, R' y x -> P' y) -> P' x)
            (HF : forall a a' (r : RA a a')
                         (f := (fun (y : A) (_ : R y a) => Fix Rwf P F y))
                         (f' := (fun (y' : A') (_ : R' y' a') => Fix Rwf' P' F' y'))
                         (Hf : forall y y' (ry : RA y y') (r : R y a) (r' : R' y' a'),
                             RP _ _ ry (f y r) (f' y' r')),
                RP a a' r (F a f) (F' a' f'))
            (F_ext : forall x f g,
                (forall y p, f y p = g y p) -> F x f = F x g)
            (F'_ext : forall x f g,
                (forall y p, f y p = g y p) -> F' x f = F' x g).

    Lemma Fix_Proper_hetero
          {a a'}
          (Ha : RA a a')
      : @RP a a' Ha (Fix Rwf P F a) (Fix Rwf' P'  F' a').
    Proof.
      revert a' Ha.
      induction (Rwf a) as [a Hlt IHwf].
      intros a' Ha.
      rewrite (Fix_eq Rwf), (Fix_eq Rwf') by assumption.
      apply HF; intros.
      apply IHwf; assumption.
    Qed.
  End rel_hetero.

  Global Instance well_founded_subrelation {A}
    : Proper (flip subrelation ==> impl) (@well_founded A).
  Proof.
    intros R R' HR Rwf a.
    induction (Rwf a) as [a Ra R'a].
    constructor; intros y Hy.
    apply R'a, HR, Hy.
  Defined.

  Fixpoint no_wf_cycle_helper {A} {R : relation A} x y
           (H0 : R x y) (H1 : R y x) (wf : Acc R x)
    : False
    := match wf with
       | Acc_intro f => @no_wf_cycle_helper A R y x H1 H0 (f _ H1)
       end.

  Global Instance no_wf_cycle {A R} (Rwf : @well_founded A R) : Asymmetric R.
  Proof.
    intros x y H0 H1.
    specialize (Rwf x).
    eapply no_wf_cycle_helper; [ .. | eassumption ]; eassumption.
  Qed.

  Inductive RT_closure {A} (R : relation A) : relation A :=
  | cinject {x y} : R x y -> RT_closure R x y
  | crefl {x} : RT_closure R x x
  | ctrans {x y z} : RT_closure R x y -> RT_closure R y z -> RT_closure R x z.

  Fixpoint Acc_subrelation {A} (R1 R2 : relation A) (v : A) (Hacc : Acc R1 v)
        (HR : forall x y, RT_closure R2 y v -> R2 x y -> R1 x y) {struct Hacc}
    : Acc R2 v.
  Proof.
    destruct Hacc as [Hacc].
    constructor.
    intros y Hy.
    specialize (fun pf => @Acc_subrelation A R1 R2 y (Hacc y pf)).
    specialize (@Acc_subrelation (HR _ _ (@crefl _ _ _) Hy)).
    apply Acc_subrelation; clear -HR Hy.
    intros x y' Hxy Hr2.
    apply HR; clear HR; [ | assumption ].
    clear -Hy Hxy.
    eapply ctrans; [ eassumption | eapply cinject; eassumption ].
  Defined.

  Section wf_acc_of.
    Context A (RA : relation A).

    Definition well_founded_acc_relation_of
              B (f : B -> A) (fA : forall b, Acc RA (f b))
      : relation B
      := fun b0 b1 => match fA b1 with
                      | Acc_intro fAb1 => exists pf,
                                          fAb1 (f b0) pf = fA b0
                      end.

    Lemma well_founded_well_founded_acc_relation_of B f fA
      : well_founded (@well_founded_acc_relation_of B f fA).
    Proof.
      intro b.
      constructor.
      unfold well_founded_acc_relation_of.
      generalize (fA b).
      generalize (f b).
      lazymatch goal with
      | [ |- forall a' wf', @?P a' wf' ]
        => apply (@Acc_ind_dep A RA P)
      end.
      intros a Ha IH y [pf Hy].
      constructor.
      intros z Hz.
      specialize (IH (f y) pf z).
      apply IH; clear IH.
      destruct Hy.
      apply Hz.
    Defined.

    Fixpoint Acc_RA_of B (f : B -> A) b (ac : Acc RA (f b))
      : Acc (fun x y => RA (f x) (f y)) b.
    Proof.
      refine match ac with
             | Acc_intro fg => Acc_intro _ (fun y Ry => @Acc_RA_of _ _ _ (fg _ _))
             end.
      assumption.
    Defined.

    Lemma well_founded_RA_of B (f : B -> A) (wf_A : well_founded RA)
      : well_founded (fun x y => RA (f x) (f y)).
    Proof.
      intro a.
      apply Acc_RA_of, wf_A.
    Defined.
  End wf_acc_of.

  Section wf_acc_of_option.
    Context A (RA : relation A).

    Definition well_founded_acc_relation_of_opt
              B (f : B -> option A) (fA : forall b, match f b with
                                                    | Some fb => Acc RA fb
                                                    | None => True
                                                    end)
      : relation B
      := fun b0 b1
         => match f b1 as fb1 return match fb1 with
                                     | Some fb => Acc RA fb
                                     | None => True
                                     end -> _
            with
            | Some fb1
              => fun fAb
                 => match fAb with
                    | Acc_intro fAb1
                      => match f b0 as fb0 return match fb0 with
                                                  | Some fb => Acc RA fb
                                                  | None => True
                                                  end -> _
                         with
                         | Some fb0
                           => fun fAb0 => exists pf,
                                  fAb1 fb0 pf = fAb0
                         | None => fun _ => False
                         end (fA b0)
                    end
            | None => fun _ => False
            end (fA b1).

    Lemma well_founded_well_founded_acc_relation_of_opt B f fA
      : well_founded (@well_founded_acc_relation_of_opt B f fA).
    Proof.
      intro b.
      constructor.
      unfold well_founded_acc_relation_of_opt.
      generalize (fA b).
      generalize (f b).
      intros [fb|].
      { revert fb.
        lazymatch goal with
        | [ |- forall a' wf', @?P a' wf' ]
          => apply (@Acc_ind_dep A RA P)
        end.
        intros a Ha IH y.
        constructor.
        generalize dependent (fA y).
        destruct (f y) as [fy|] eqn:Hfy.
        { intros y0 [pf Hy].
          intros z Hz.
          specialize (IH fy pf z).
          apply IH; clear IH.
          destruct Hy.
          apply Hz. }
        { intros ? []. } }
      { intros ?? []. }
    Defined.

    Fixpoint Acc_RA_of_opt B (f : B -> option A) b v (Heq : f b = Some v)
             (ac : Acc RA v) {struct ac}
      : Acc (fun x y => match f x, f y with
                        | Some fx, Some fy => RA fx fy
                        | _, _ => False
                        end) b.
    Proof.
      destruct ac as [fg].
      constructor.
      intros y Ry.
      specialize (fun v H Rv => Acc_RA_of_opt B f y v H (fg _ Rv)); clear fg.
      destruct (f y) as [fy|] eqn:Hfy.
      { specialize (Acc_RA_of_opt _ eq_refl).
        destruct (f b) as [fb|] eqn:Hfb.
        { inversion Heq; clear Heq; subst.
          specialize (Acc_RA_of_opt Ry).
          assumption. }
        { destruct Ry. } }
      { destruct Ry. }
    Defined.

    Lemma well_founded_RA_of_opt B (f : B -> option A) (wf_A : well_founded RA)
      : well_founded (fun x y => match f x, f y with
                                 | Some fx, Some fy => RA fx fy
                                 | _, _ => False
                                 end).
    Proof.
      intro a.
      destruct (f a) eqn:H.
      { eapply Acc_RA_of_opt, wf_A; eassumption. }
      { constructor.
        intro y.
        destruct (f y); [ rewrite H | ]; intros []. }
    Defined.
  End wf_acc_of_option.

  Section wf_prodA.
    Context A B (eqA RA : relation A) (RB : relation B).

    Definition prod_relationA : relation (A * B)
      := fun ab a'b' =>
           RA (fst ab) (fst a'b') \/ (eqA (fst a'b') (fst ab) /\ RB (snd ab) (snd a'b')).

    Context (prod_relationA_Proper
             : forall b'', Proper (eqA ==> impl) (fun a => Acc prod_relationA (a, b''))).

    Global Instance prod_relationA_Proper_from_Equivalence
          (RA_Proper : Proper (eq ==> eqA ==> flip impl) RA)
          (eqA_Proper : Proper (eqA ==> eq ==> flip impl) eqA)
      : forall b'', Proper (eqA ==> impl) (fun a => Acc prod_relationA (a, b'')).
    Proof.
      intros b'' a b H wf.
      revert dependent b.
      destruct wf as [f].
      constructor.
      intros y Hlt; apply f.
      unfold prod_relationA in Hlt |- *; simpl in *.
      destruct Hlt as [Hlt|[Hlt0 Hlt1]]; [ left | right; split; try assumption ].
      { eapply RA_Proper; [ reflexivity | exact H | exact Hlt ]. }
      { eapply eqA_Proper; [ exact H | reflexivity | exact Hlt0 ]. }
    Defined.

    Section step.
      Context (well_founded_prod_relationA_helper
               : forall a b (wf_A : Acc RA a) (wf_B : well_founded RB),
                  Acc prod_relationA (a, b)).

      Definition well_founded_prod_relationA_helper_step
                 a b
                 (wf_A : Acc RA a) (wf_B : well_founded RB)
                 (wf_B_rec : forall (fa : forall y : A, RA y a -> Acc RA y) b' (wf_B' : Acc RB b'), Acc prod_relationA (a, b'))
        : Acc prod_relationA (a, b)
        := match wf_A with
           | Acc_intro fa => @wf_B_rec fa b (wf_B b)
           end.
      Definition wf_B_rec_step
                 (wf_B : well_founded RB)
                 a (fa : forall y : A, RA y a -> Acc RA y)
                 (wf_B_rec : forall b' (wf_B' : Acc RB b'), Acc prod_relationA (a, b'))
                 b' (wf_B' : Acc RB b')
        :  Acc prod_relationA (a, b').
      Proof.
        refine (Acc_intro _ _).
        intros [a'' b''] [pf'|[pfa pfb]].
        { refine (@well_founded_prod_relationA_helper
                    _ _
                    (fa _ pf')
                    wf_B). }
        { refine match wf_B' with
                 | Acc_intro fb => @prod_relationA_Proper
                                     _ _ _ pfa
                                     (@wf_B_rec _ (fb _ pfb))
                 end. }
      Defined.
    End step.

    Fixpoint well_founded_prod_relationA_helper
             a b
             (wf_A : Acc RA a) (wf_B : well_founded RB) {struct wf_A}
      : Acc prod_relationA (a, b)
      := @well_founded_prod_relationA_helper_step
           a b wf_A wf_B
           (fun fa
            => fix wf_B_rec b' (wf_B' : Acc RB b') : Acc prod_relationA (a, b')
            := @wf_B_rec_step
                 (@well_founded_prod_relationA_helper)
                 wf_B
                 a fa (@wf_B_rec)
                 b' wf_B').

    Definition well_founded_prod_relationA : well_founded RA -> well_founded RB -> well_founded prod_relationA.
    Proof.
      intros wf_A wf_B [a b]; hnf in *.
      apply well_founded_prod_relationA_helper; auto.
    Defined.
  End wf_prodA.

  Section wf_prod.
    Context A B (RA : relation A) (RB : relation B).

    Definition prod_relation : relation (A * B)
      := Eval cbv [prod_relationA] in prod_relationA eq RA RB.

    Definition well_founded_prod_relation : well_founded RA -> well_founded RB -> well_founded prod_relation.
    Proof.
      apply well_founded_prod_relationA.
      intros b'' a b H H'.
      induction H.
      exact H'.
    Defined.
  End wf_prod.

  Section wf_sig.
    Context A B (RA : relation A) (RB : forall a : A, relation (B a)).

    Definition sigT_relation : relation (sigT B)
      := fun ab a'b' =>
           RA (projT1 ab) (projT1 a'b') \/ (exists pf : projT1 a'b' = projT1 ab, RB (projT2 ab)
                                                                                (eq_rect _ B (projT2 a'b') _ pf)).

    Fixpoint well_founded_sigT_relation_helper
             a b
             (wf_A : Acc RA a) (wf_B : forall a, well_founded (@RB a)) {struct wf_A}
    : Acc sigT_relation (existT _ a b).
    Proof.
      refine match wf_A with
               | Acc_intro fa => (fix wf_B_rec b' (wf_B' : Acc (@RB a) b') : Acc sigT_relation (existT _ a b')
                                  := Acc_intro
                                       _
                                       (fun ab =>
                                          match ab as ab return sigT_relation ab (existT _ a b') -> Acc sigT_relation ab with
                                            | existT a'' b'' =>
                                              fun pf =>
                                                match pf with
                                                  | or_introl pf'
                                                    => @well_founded_sigT_relation_helper
                                                         _ _
                                                         (fa _ pf')
                                                         wf_B
                                                  | or_intror (ex_intro pfa pfb)
                                                    => match wf_B' with
                                                         | Acc_intro fb
                                                           => _(*eq_rect
                                                            _
                                                            (fun a'' => Acc sigT_relation (existT B a'' _(*b''*)))
                                                            (wf_B_rec _ (fb _ _(*pfb*)))
                                                            _
                                                            pfa*)
                                                       end
                                                end
                                          end)
                                 ) b (wf_B a b)
             end;
      simpl in *.
      destruct pfa; simpl in *.
      exact (wf_B_rec _ (fb _ pfb)).
    Defined.

    Definition well_founded_sigT_relation : well_founded RA
                                            -> (forall a, well_founded (@RB a))
                                            -> well_founded sigT_relation.
    Proof.
      intros wf_A wf_B [a b]; hnf in *.
      apply well_founded_sigT_relation_helper; auto.
    Defined.
  End wf_sig.

  Section wf_projT1.
    Context A (B : A -> Type) (R : relation A).

    Definition projT1_relation : relation (sigT B)
      := fun ab a'b' =>
           R (projT1 ab) (projT1 a'b').

    Definition well_founded_projT1_relation : well_founded R -> well_founded projT1_relation.
    Proof.
      intros wf [a b]; hnf in *.
      induction (wf a) as [a H IH].
      constructor.
      intros y r.
      specialize (IH _ r (projT2 y)).
      destruct y.
      exact IH.
    Defined.
  End wf_projT1.

  Section wf_iterated_prod_ofA.
    Context A (eqA R : relation A) (Rwf : well_founded R)
            (RA_Proper : Proper (eq ==> eqA ==> flip impl) R)
            (eqA_Proper : Proper (eqA ==> eq ==> flip impl) eqA).

    Fixpoint iterated_prod (n : nat) : Type
      := match n with
         | 0 => unit
         | S n' => A * iterated_prod n'
         end%type.

    Fixpoint iterated_prod_relationA {n} : relation (iterated_prod n)
      := match n return relation (iterated_prod n) with
         | 0 => fun _ _ => False
         | S n' => prod_relationA eqA R (@iterated_prod_relationA n')
         end.

    Fixpoint nat_eq_transfer (P : nat -> Type) (n m : nat) : P n -> (P m) + (EqNat.beq_nat n m = false)
      := match n, m return P n -> (P m) + (EqNat.beq_nat n m = false) with
         | 0, 0 => fun x => inl x
         | S n', S m' => @nat_eq_transfer (fun v => P (S v)) n' m'
         | _, _ => fun _ => inr eq_refl
         end.

    Fixpoint nat_eq_transfer_refl (P : nat -> Type) (n : nat) : forall v : P n, nat_eq_transfer P n n v = inl v
      := match n return forall v : P n, nat_eq_transfer P n n v = inl v with
         | 0 => fun v => eq_refl
         | S n' => @nat_eq_transfer_refl (fun k => P (S k)) n'
         end.

    Fixpoint nat_eq_transfer_neq (P : nat -> Type) (n m : nat)
      : forall v : P n, (if EqNat.beq_nat n m as b return ((P m) + (b = false)) -> Prop
                         then fun _ => True
                         else fun v => v = inr eq_refl)
                          (nat_eq_transfer P n m v)
      := match n, m return forall v : P n, (if EqNat.beq_nat n m as b return ((P m) + (b = false)) -> Prop
                                            then fun _ => True
                                            else fun v => v = inr eq_refl)
                                             (nat_eq_transfer P n m v)
         with
         | 0, 0 => fun _ => I
         | S n', S m' => @nat_eq_transfer_neq (fun v => P (S v)) n' m'
         | _, _ => fun _ => eq_refl
         end.

    Definition iterated_prod_relationA_of
               B (sz : B -> nat) (f : forall b, iterated_prod (sz b))
      : relation B
      := fun x y => match nat_eq_transfer _ (sz x) (sz y) (f x) with
                    | inl fx => iterated_prod_relationA fx (f y)
                    | inr _ => False
                    end.

    Definition iterated_prod_relationA_of_opt
               B (sz : nat) (f : B -> option (iterated_prod sz))
      : relation B
      := fun x y => match f x, f y with
                    | Some fx, Some fy => iterated_prod_relationA fx fy
                    | _, _ => False
                    end.

    Lemma well_founded_iterated_prod_relationA {n} : well_founded (@iterated_prod_relationA n).
    Proof.
      induction n as [|n IHn]; simpl.
      { constructor; intros ? []. }
      { apply well_founded_prod_relationA; try exact _; assumption. }
    Defined.

    Lemma well_founded_iterated_prod_relationA_of_opt {B n f} : well_founded (@iterated_prod_relationA_of_opt B n f).
    Proof.
      unfold iterated_prod_relationA_of_opt.
      apply well_founded_RA_of_opt, well_founded_iterated_prod_relationA.
    Defined.

    Local Ltac handle_nat_eq_transfer
      := repeat lazymatch goal with
                | [ |- forall n0 n1, @?P n0 n1 ]
                  => let n0' := fresh "n" in
                     let n1' := fresh "n" in
                     let H := fresh in
                     let H' := fresh in
                     intros n0' n1';
                     destruct (@nat_eq_transfer (P n0') n0' n1') as [H|H];
                     [ clear n1'; revert n0'
                     | apply H
                     | lazymatch goal with
                       | [ |- appcontext[@nat_eq_transfer iterated_prod n1' n0'] ]
                         => pose proof (@nat_eq_transfer_neq iterated_prod n1' n0') as H';
                            cbv beta in *;
                            generalize dependent (nat_eq_transfer iterated_prod n1' n0');
                            let Heq := fresh in
                            destruct (EqNat.beq_nat n1' n0') eqn:Heq;
                            [ apply EqNat.beq_nat_true_iff in Heq; subst; rewrite <- EqNat.beq_nat_refl in H;
                              exfalso; clear -H; congruence
                            | ]
                       | [ |- appcontext[@nat_eq_transfer iterated_prod n0' n1'] ]
                         => pose proof (@nat_eq_transfer_neq iterated_prod n0' n1') as H';
                            cbv beta in *;
                            generalize dependent (nat_eq_transfer iterated_prod n0' n1');
                            rewrite H
                       end
                     ]
                end;
         repeat match goal with
                | _ => reflexivity
                | [ H : False |- _ ] => exfalso; exact H
                | [ H : forall v, _ = inr _ |- _ ] => rewrite H
                | _ => intro
                end.

    Lemma RT_closure_same_size B (sz : B -> nat) (f : forall b, iterated_prod (sz b))
          a b
          (H : RT_closure (iterated_prod_relationA_of sz f) a b)
      : sz a = sz b.
    Proof.
      induction H as [x y H | | ].
      { unfold iterated_prod_relationA_of in *.
        generalize dependent (f x).
        generalize dependent (f y).
        generalize dependent (sz x).
        generalize dependent (sz y).
        handle_nat_eq_transfer. }
      { reflexivity. }
      { etransitivity; eassumption. }
    Defined.

    Lemma well_founded_iterated_prod_relationA_of
          B (sz : B -> nat) (f : forall b, iterated_prod (sz b))
      : well_founded (@iterated_prod_relationA_of B sz f).
    Proof.
      intro b.
      pose proof (@well_founded_RA_of_opt (iterated_prod (sz b)) iterated_prod_relationA B) as wf.
      specialize (wf (fun b' => match nat_eq_transfer _ (sz b') (sz b) (f b') with
                                | inl v => Some v
                                | inr _ => None
                                end)).
      specialize (wf well_founded_iterated_prod_relationA).
      eapply Acc_subrelation; [ eapply wf | clear wf ].
      intros x y H.
      apply RT_closure_same_size in H.
      unfold iterated_prod_relationA_of.
      generalize dependent (f b).
      generalize dependent (f x).
      generalize dependent (f y).
      generalize dependent (sz y).
      intros ??; subst.
      clear y.
      generalize dependent (sz b).
      generalize dependent (sz x).
      clear.
      handle_nat_eq_transfer.
      rewrite !nat_eq_transfer_refl in *.
      assumption.
    Defined.
  End wf_iterated_prod_ofA.

  Section wf_iterated_prod_of.
    Context A (R : relation A) (Rwf : well_founded R).

    Definition iterated_prod_relation {n} : relation (iterated_prod A n)
      := iterated_prod_relationA eq R.

    Definition iterated_prod_relation_of
      : forall B (sz : B -> nat) (f : forall b, iterated_prod A (sz b)),
        relation B
      := iterated_prod_relationA_of eq R.

    Definition iterated_prod_relation_of_opt
      : forall B (sz : nat) (f : B -> option (iterated_prod A sz)),
        relation B
      := iterated_prod_relationA_of_opt eq R.

    Lemma well_founded_iterated_prod_relation {n} : well_founded (@iterated_prod_relation n).
    Proof.
      apply well_founded_iterated_prod_relationA; try exact _; assumption.
    Defined.

    Lemma well_founded_iterated_prod_relation_of_opt {B n f} : well_founded (@iterated_prod_relation_of_opt B n f).
    Proof.
      apply well_founded_iterated_prod_relationA_of_opt; try exact _; assumption.
    Defined.

    Lemma well_founded_iterated_prod_relation_of
          B (sz : B -> nat) (f : forall b, iterated_prod A (sz b))
      : well_founded (@iterated_prod_relation_of B sz f).
    Proof.
      apply well_founded_iterated_prod_relationA_of; try exact _; assumption.
    Defined.
  End wf_iterated_prod_of.

  Section wf_functionsA.
    Context A (eqA R : relation A)
            (R_Proper : Proper (eq ==> eqA ==> flip impl) R)
            (R_Proper2 : Proper (eq ==> eqA ==> impl) R)
            (eqA_Proper : Proper (eqA ==> eq ==> flip impl) eqA)
            (eqA_Proper2 : Proper (eq ==> eqA ==> flip impl) eqA)
            (eqA_Symmetric : Symmetric eqA).

    Local Infix "<" := R.
    Local Notation "x <= y" := (eqA x y \/ x < y).

    Context (bot : A) (bot_bot : forall a, bot <= a)
            (Rwf : well_founded R)
            (B C : Type)
            (eqv : relation B)
            {Heqv : Reflexive eqv}
            (F : C -> (B -> A))
            (F_Proper : forall a b k k', eqv k' k -> eqA (F a k) (F b k) -> eqA (F a k') (F b k')).

    Definition is_finite_forA' (ls : list B) (f : B -> A)
      := forall x, ~SetoidList.InA eqv x ls -> eqA (f x) bot.

    Definition is_finite_forA (ls : list B) (c : C) := is_finite_forA' ls (F c).

    Definition function_relationA : relation (B -> A)
      := fun f g => (forall x, f x <= g x)
                    /\ exists x, ~(eqA (f x) (g x)).

    Definition iterated_prod_of_function_for (ls : list B) (f : B -> A)
      : iterated_prod A (List.length ls)
      := list_rect (fun ls => iterated_prod A (List.length ls))
                   tt
                   (fun x _ v => (f x, v))
                   ls.

    Global Instance is_finite_forA'_Proper_fr
      : Proper (eq ==> function_relationA ==> flip impl) is_finite_forA'.
    Proof.
      unfold is_finite_forA', function_relationA.
      intros ls g ?; subst g.
      intros f g [Hle Hne] Hfin x Hnin.
      specialize (Hle x); specialize (Hfin x Hnin).
      destruct Hle as [Heq|Hlt]; [ rewrite Heq; assumption | ].
      specialize (bot_bot (f x)).
      destruct bot_bot as [Heq|Hlt']; [ symmetry; assumption | ].
      rewrite Hfin in Hlt.
      clear -Hlt Hlt' Rwf.
      exfalso; eapply no_wf_cycle; eassumption.
    Qed.

    Global Instance is_finite_forA_Proper_fr
      : Proper (eq ==> (fun x y => function_relationA (F x) (F y)) ==> flip impl) is_finite_forA.
    Proof.
      unfold is_finite_forA.
      intros ??????.
      eapply is_finite_forA'_Proper_fr; eassumption.
    Qed.

    Global Instance is_finite_forA'_Proper_frc
      : Proper (eq ==> RT_closure function_relationA ==> flip impl) is_finite_forA'.
    Proof.
      intros ls ls' ? f g H Hfin.
      induction H as [ ?? H | | ].
      { eapply is_finite_forA'_Proper_fr; eassumption. }
      { subst; assumption. }
      { subst; eauto with nocore. }
    Qed.

    Global Instance is_finite_forA_Proper_frc
      : Proper (eq ==> (fun x y => RT_closure function_relationA (F x) (F y)) ==> flip impl) is_finite_forA.
    Proof.
      unfold is_finite_forA.
      intros ??????.
      eapply is_finite_forA'_Proper_frc; eassumption.
    Qed.

    Global Instance is_finite_forA_Proper_frc'
      : Proper (eq ==> RT_closure (fun x y => function_relationA (F x) (F y)) ==> flip impl) is_finite_forA.
    Proof.
      intros ls ls' ? f g H Hfin.
      induction H as [ ?? H | | ].
      { eapply is_finite_forA_Proper_fr; eassumption. }
      { subst; assumption. }
      { subst; eauto with nocore. }
    Qed.

    Lemma function_subrelationA ls c (H : is_finite_forA ls c)
      : forall x y : C,
        RT_closure (fun x0 y0 : C => function_relationA (F x0) (F y0)) y c ->
        function_relationA (F x) (F y) ->
        (fun x0 y0 : C =>
           iterated_prod_relationA_of eqA R (fun _ : B -> A => length ls)
                                      (iterated_prod_of_function_for ls) (F x0) (F y0)) x y.
    Proof.
      intros g h Hhf Hgh; cbv beta.
      assert (Hfinh : is_finite_forA ls h) by (rewrite Hhf; assumption).
      assert (Hfing : is_finite_forA ls g) by (unfold is_finite_forA; rewrite Hgh; assumption).
      unfold iterated_prod_relationA_of, function_relationA, iterated_prod_of_function_for in *.
      rewrite nat_eq_transfer_refl.
      destruct Hgh as [Hle Hne].
      destruct Hne as [b Hne].
      assert (Hin : ~~SetoidList.InA eqv b ls).
      { intro Hnin.
        rewrite Hfinh in Hne by assumption.
        eauto with nocore. }
      rewrite SetoidList.InA_alt in Hin.
      move ls at bottom.
      clear H Hfinh Hfing.
      induction ls as [|x xs IHxs];
        [
        | destruct (Hle x) as [Heqx|Hlex];
          [ right; split;
            [ | apply IHxs; clear IHxs ]
          | left ] ];
        simpl; unfold prod_relationA; simpl in *;
          repeat match goal with
                 | _ => congruence
                 | _ => tauto
                 | [ H : ex _ |- _ ] => destruct H
                 | [ H : and _ _ |- _ ] => destruct H
                 | [ H : or _ _ |- _ ] => destruct H
                 | _ => progress subst
                 | _ => progress eauto
                 | _ => solve [ exfalso; eauto ]
                 | [ H : ~~(exists x, _ /\ False) |- _ ]
                   => exfalso; apply H; clear
                 | _ => intro
                 | [ |- and _ _ ] => split
                 | [ H : ~~_ |- False ] => apply H; clear H
                 end.
    Qed.

    Definition function_relationA_of_Acc ls (c : C) (H : is_finite_forA ls c)
      : Acc (fun x y => function_relationA (F x) (F y)) c.
    Proof.
      pose proof (@well_founded_RA_of
                    _ _ _ F
                    (@well_founded_iterated_prod_relationA_of
                       _ eqA R Rwf _ _ _ (fun _ => List.length ls) (iterated_prod_of_function_for ls))
                    c)
        as wf.
      eapply Acc_subrelation; [ eexact wf | ].
      apply function_subrelationA; assumption.
    Defined.
  End wf_functionsA.

  Section wf_functions.
    Context A (R : relation A).

    Local Infix "<" := R.
    Local Notation "x <= y" := (x = y \/ x < y).

    Context (bot : A) (bot_bot : forall a, bot <= a)
            (Rwf : well_founded R)
            {B : Type}.

    Definition function_relation : relation (B -> A)
      := @function_relationA A eq R B.

    Definition is_finite_for (ls : list B) (f : B -> A)
      := forall x, ~List.In x ls -> f x = bot.

    Lemma is_finite_for_iff ls f
      : is_finite_for ls f <-> @is_finite_forA A eq bot B (B -> A) eq (fun f => f) ls f.
    Proof.
      unfold is_finite_for, is_finite_forA, is_finite_forA'.
      setoid_rewrite InA_alt.
      split; intros H x H'; apply H; intro H''; apply H'.
      { eexists; split; [ reflexivity | assumption ]. }
      { destruct H'' as [? [? ?]]; subst; assumption. }
    Qed.

    Definition function_relation_Acc ls (f : B -> A) (H : is_finite_for ls f)
      : Acc function_relation f.
    Proof.
      rewrite is_finite_for_iff in H.
      apply function_relationA_of_Acc with (bot := bot) (eqv := eq) (ls := ls);
        try exact _; try assumption.
      intros; subst; assumption.
    Defined.
  End wf_functions.
End wf.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing Norm_Funct %\ensuremath{\|\cdot\|}% *)

Require Export CoRN.reals.NRootIR.
Require Export CoRN.ftc.FunctSums.
Require Import CoRN.tactics.CornTac.

Section Definitions_and_Basic_Results.

(**
* Continuity

Constructively, continuity is the most fundamental property of any
function---so strongly that no example is known of a constructive
function that is not continuous.  However, the classical definition of
continuity is not good for our purposes, as it is not true, for
example, that a function which is continuous in a compact interval is
uniformly continuous in that same interval (for a discussion of this
see Bishop 1967).  Thus, our notion of continuity will be the uniform
one#. #%\footnote{%Similar remarks apply to convergence of sequences
of functions, which we will define ahead, and elsewhere; we will
refrain from discussing this issue at those places.%}.%

%\begin{convention}% Throughout this section, [a] and [b] will be real
numbers, [I] will denote the compact interval [[a,b]] and
[F, G, H] will denote arbitrary partial functions with domains
respectively [P, Q] and [R].
%\end{convention}%

** Definitions and Basic Results

Here we define continuity and prove some basic properties of continuous functions.
*)

Variables a b : IR.
Hypothesis Hab : a [<=] b.
(* begin hide *)
Let I := Compact Hab.
(* end hide *)

Variable F : PartIR.
(* begin hide *)
Let P := Dom F.
(* end hide *)

Definition Continuous_I := included I P and (forall e, [0] [<] e -> {d : IR | [0] [<] d |
 forall x y, I x -> I y -> forall Hx Hy, AbsIR (x[-]y) [<=] d -> AbsIR (F x Hx[-]F y Hy) [<=] e}).

(**
For convenience, we distinguish the two properties of continuous functions.
*)

Lemma contin_imp_inc : Continuous_I -> included (Compact Hab) P.
Proof.
 intro H; elim H; intros; assumption.
Qed.

Lemma contin_prop : Continuous_I -> forall e, [0] [<] e -> {d : IR | [0] [<] d |
 forall x y, I x -> I y -> forall Hx Hy, AbsIR (x[-]y) [<=] d -> AbsIR (F x Hx[-]F y Hy) [<=] e}.
Proof.
 intro H; elim H; do 2 intro; assumption.
Qed.

(**
Assume [F] to be continuous in [I].  Then it has a least upper bound and a greater lower bound on [I].
*)

Hypothesis contF : Continuous_I.

(* begin hide *)
Let Hinc' := contin_imp_inc contF.
(* end hide *)

Lemma Continuous_I_imp_tb_image : totally_bounded (fun_image F I).
Proof.
 assert (H := compact_is_totally_bounded a b Hab).
 elim contF; intros H0 H1.
 split.
  elim H; clear H; intros H2 H3.
  elim H2; clear H2; intros x H.
  exists (Part F x (H0 _ H)).
  exists x; split.
   auto.
  split.
   apply H0; auto.
  algebra.
 intros e H2.
 elim (H1 _ H2).
 intros d H3 H4.
 clear H1.
 elim H; clear H.
 intros non_empty H.
 elim H with d; clear H.
  intros l Hl' Hl.
  2: assumption.
 exists (map2 F l (fun (x : IR) (Hx : member x l) => H0 x (Hl' x Hx))).
  intros x H.
  clear Hl; induction  l as [| a0 l Hrecl].
   exfalso; assumption.
  simpl in H; elim H; clear H; intro H1.
   cut (forall x : IR, member x l -> compact a b Hab x).
    intro H.
    apply Hrecl with H.
    eapply map2_wd.
    apply H1.
   intros x0 H.
   apply Hl'; left; assumption.
  exists a0.
  split.
   apply Hl'; right; algebra.
  split.
   apply H0; apply Hl'; right; algebra.
  intro; eapply eq_transitive_unfolded.
   2: apply eq_symmetric_unfolded; apply H1.
  algebra.
 intros x H; simpl in |- *.
 elim H; intros x0 H1.
 elim H1; clear H1; intros Hy' H1.
 elim H1; intros Hy'' Hy.
 elim (Hl x0 Hy'); intros x1 Hx1 H5.
 exists (F x1 (H0 x1 (Hl' x1 Hx1))).
  apply map2_pres_member; assumption.
 astepr (F x0 Hy''[-]F x1 (H0 x1 (Hl' x1 Hx1))).
 apply AbsIR_imp_AbsSmall.
 apply H4.
   assumption.
  apply Hl'; assumption.
 apply AbsSmall_imp_AbsIR; assumption.
Qed.

Lemma Continuous_I_imp_lub : {x : IR | fun_lub_IR F I x}.
Proof.
 unfold fun_lub_IR in |- *.
 apply totally_bounded_has_lub.
 apply Continuous_I_imp_tb_image.
Qed.

Lemma Continuous_I_imp_glb : {x : IR | fun_glb_IR F I x}.
Proof.
 unfold fun_glb_IR in |- *.
 apply totally_bounded_has_glb.
 apply Continuous_I_imp_tb_image.
Qed.

(**
We now make this glb and lub into operators.
*)

Definition lub_funct := ProjT1 Continuous_I_imp_lub.
Definition glb_funct := ProjT1 Continuous_I_imp_glb.

(**
These operators have the expected properties.
*)

Lemma lub_is_lub : fun_lub_IR F I lub_funct.
Proof.
 exact (ProjT2 Continuous_I_imp_lub).
Qed.

Lemma glb_is_glb : fun_glb_IR F I glb_funct.
Proof.
 exact (ProjT2 Continuous_I_imp_glb).
Qed.

Lemma glb_prop : forall x : IR, I x -> forall Hx, glb_funct [<=] F x Hx.
Proof.
 intros.
 elim glb_is_glb.
 intros.
 apply a0.
 exists x.
 split; algebra.
Qed.

Lemma lub_prop : forall x : IR, I x -> forall Hx, F x Hx [<=] lub_funct.
Proof.
 intros.
 elim lub_is_lub.
 intros.
 apply a0.
 exists x.
 split; algebra.
Qed.

(**
The norm of a function is defined as being the supremum of its absolute value; that is equivalent to the following definition (which is often more convenient to use).
*)

Definition Norm_Funct := Max lub_funct [--]glb_funct.

(**
The norm effectively bounds the absolute value of a function.
*)

Lemma norm_bnd_AbsIR : forall x, I x -> forall Hx, AbsIR (F x Hx) [<=] Norm_Funct.
Proof.
 intros.
 generalize lub_is_lub.
 generalize glb_is_glb.
 intros; simpl in |- *; unfold ABSIR in |- *.
 apply Max_leEq.
  apply leEq_transitive with lub_funct.
   apply lub_prop; auto.
  unfold Norm_Funct in |- *; apply lft_leEq_Max.
 apply leEq_transitive with ( [--]glb_funct).
  apply inv_resp_leEq.
  apply glb_prop; auto.
 unfold Norm_Funct in |- *; apply rht_leEq_Max.
Qed.

(**
The following is another way of characterizing the norm:
*)

Lemma Continuous_I_imp_abs_lub : {z : IR | forall x, I x -> forall Hx, AbsIR (F x Hx) [<=] z}.
Proof.
 exists Norm_Funct.
 exact norm_bnd_AbsIR.
Qed.

(**
We now prove some basic properties of the norm---namely that it is positive, and that it provides a least upper bound for the absolute value of its argument.
*)

Lemma positive_norm : [0] [<=] Norm_Funct.
Proof.
 apply leEq_transitive with (AbsIR (FRestr Hinc' a (compact_inc_lft _ _ _))).
  apply AbsIR_nonneg.
 simpl in |- *; apply norm_bnd_AbsIR; unfold I in |- *; apply compact_inc_lft.
Qed.

Lemma norm_fun_lub : forall e, [0] [<] e -> {x : IR | I x and (forall Hx, Norm_Funct[-]e [<] AbsIR (F x Hx))}.
Proof.
 intros e H.
 cut {x : IR | I x and (forall Hx' : P x, Norm_Funct [<] AbsIR (F x Hx') [+]e)}.
  intro H0.
  elim H0; intros y Hy.
  elim Hy; clear H0 Hy; intros Hy Hy'.
  exists y; split.
   auto.
  intro; apply shift_minus_less; apply Hy'.
 generalize lub_is_lub.
 generalize glb_is_glb.
 intros H0 H1.
 cut {x : IR | I x and (forall Hx' : P x, F x Hx' [<] glb_funct[+]e [/]TwoNZ)}.
  cut {x : IR | I x and (forall Hx' : P x, lub_funct[-]e [/]TwoNZ [<] F x Hx')}.
   intros H2 H3.
   elim H2; intros x Hx.
   elim Hx; clear H2 Hx; intros Hx Hx0.
   elim H3; intros x' Hx'.
   elim Hx'; clear H3 Hx'; intros Hx' Hx'0.
   elim (less_cotransitive_unfolded _ _ _ (pos_div_two _ _ H) ( [--]glb_funct[-]lub_funct)); intro H2.
    exists x'; split.
     auto.
    unfold Norm_Funct in |- *.
    intro; eapply less_wdl.
     2: apply eq_symmetric_unfolded; apply leEq_imp_Max_is_rht.
     apply shift_less_plus.
     rstepl ( [--] (glb_funct[+]e)).
     eapply less_leEq_trans.
      2: apply inv_leEq_AbsIR.
     apply inv_resp_less.
     eapply less_transitive_unfolded.
      apply Hx'0 with (Hx' := Hx'1).
     apply plus_resp_less_lft.
     apply pos_div_two'; assumption.
    astepl ([0][+]lub_funct); apply less_leEq; apply shift_plus_less.
    assumption.
   exists x; split.
    auto.
   unfold Norm_Funct in |- *.
   intro; apply less_leEq_trans with (lub_funct[+]e [/]TwoNZ).
    apply Max_less.
     apply shift_less_plus'; astepl ZeroR.
     apply pos_div_two; assumption.
    apply shift_less_plus'; assumption.
   apply shift_leEq_plus.
   rstepl (lub_funct[-]e [/]TwoNZ).
   eapply leEq_transitive.
    apply less_leEq; apply Hx0 with (Hx' := Hx'1).
   apply leEq_AbsIR.
  elim H1; clear H1; intros H2 H3.
  elim (H3 _ (pos_div_two _ _ H)).
  intros x Hx; elim Hx; clear Hx; intros y Hx'; elim Hx'; clear Hx';
    intros Hx' Hx''; elim Hx''; clear Hx''; intros Hx'' Hx'''.
  exists y; split.
   auto.
  intro; apply shift_minus_less; apply shift_less_plus'.
  eapply less_wdl; [ apply q | algebra ].
 elim H0; clear H0; intros H2 H3.
 elim (H3 _ (pos_div_two _ _ H)).
 intros x Hx; elim Hx; clear Hx; intros y Hx'; elim Hx'; clear Hx';
   intros Hx' Hx''; elim Hx''; clear Hx''; intros Hx'' Hx'''.
 exists y; split.
  auto.
 intro; apply shift_less_plus'.
 eapply less_wdl; [ apply q | algebra ].
Qed.

Lemma leEq_Norm_Funct : forall e, (forall x, I x -> forall Hx, AbsIR (F x Hx) [<=] e) -> Norm_Funct [<=] e.
Proof.
 intros e H.
 astepr ([0][+]e); apply shift_leEq_plus.
 apply approach_zero_weak.
 intros d Hd.
 apply shift_minus_leEq.
 elim (norm_fun_lub d Hd); intros x Hx.
 elim Hx; clear Hx; intros Hx Hx'.
 apply plus_cancel_leEq_rht with ( [--] (AbsIR (F x (Hinc' x Hx)))).
 astepl (Norm_Funct[-]AbsIR (F x (Hinc' x Hx))).
 apply less_leEq; apply less_leEq_trans with d.
  apply shift_minus_less; apply shift_less_plus'; apply Hx'.
 rstepr (d[+] (e[-]AbsIR (F x (Hinc' x Hx)))).
 astepl (d[+][0]); apply plus_resp_leEq_lft.
 apply shift_leEq_minus; astepl (AbsIR (F x (Hinc' x Hx))); apply H; assumption.
Qed.

Lemma less_Norm_Funct : forall e, (forall x, I x -> forall Hx, AbsIR (F x Hx) [<] e) -> Norm_Funct [<=] e.
Proof.
 intros x H.
 apply leEq_Norm_Funct.
 intros; apply less_leEq; apply H; assumption.
Qed.

End Definitions_and_Basic_Results.

Arguments Continuous_I [a b].
Arguments Norm_Funct [a b Hab F].

Section Local_Results.

(**
** Algebraic Properties

We now state and prove some results about continuous functions.  Assume that [I] is included in the domain of both [F] and [G].
*)

Variables a b : IR.
Hypothesis Hab : a [<=] b.
(* begin hide *)
Let I := Compact Hab.
(* end hide *)

Variables F G : PartIR.

(* begin hide *)
Let P := Dom F.
Let Q := Dom G.
(* end hide *)

Hypothesis incF : included (Compact Hab) P.
Hypothesis incG : included (Compact Hab) Q.

(**
The first result does not require the function to be continuous; however, its preconditions are easily verified by continuous functions, which justifies its inclusion in this section.
*)

Lemma cont_no_sign_change : forall e, [0] [<] e -> forall x y, I x -> I y ->
 forall Hx Hy, AbsIR (F x Hx[-]F y Hy) [<=] e -> e [<] AbsIR (F x Hx) ->
 ([0] [<] F x Hx -> [0] [<] F y Hy) and (F x Hx [<] [0] -> F y Hy [<] [0]).
Proof.
 intros e H x y H0 H1 Hx Hy H2 H3.
 set (fx := F x Hx) in *.
 set (fy := F y Hy) in *.
 split; intro H4.
  cut (e [<] fx).
   intro H5.
   astepl (e[-]e).
   apply shift_minus_less; apply shift_less_plus'.
   apply less_leEq_trans with (fx[-]fy).
    apply minus_resp_less; assumption.
   eapply leEq_transitive; [ apply leEq_AbsIR | assumption ].
  elim (less_AbsIR _ _ H H3); intro H6.
   assumption.
  exfalso.
  cut ([0] [<] [--]e).
   intro; cut (e [<] [0]).
    exact (less_antisymmetric_unfolded _ _ _ H).
   astepl ( [--][--]e); astepr ( [--]ZeroR); apply inv_resp_less; assumption.
  apply less_transitive_unfolded with fx; assumption.
 astepr (e[-]e).
 apply shift_less_minus.
 apply less_leEq_trans with (fy[-]fx).
  2: eapply leEq_transitive.
   3: apply H2.
  2: eapply leEq_wdr; [ apply leEq_AbsIR | apply AbsIR_minus ].
 unfold cg_minus in |- *; apply plus_resp_less_lft.
 elim (less_AbsIR _ _ H H3); intro H6.
  apply less_transitive_unfolded with ZeroR.
   apply less_transitive_unfolded with fx; assumption.
  astepl ( [--]ZeroR); apply inv_resp_less; assumption.
 astepl ( [--][--]e); apply inv_resp_less; assumption.
Qed.

Lemma cont_no_sign_change_pos : forall e, [0] [<] e -> forall x y, I x -> I y -> forall Hx Hy,
 AbsIR (F x Hx[-]F y Hy) [<=] e -> e [<] AbsIR (F x Hx) -> e [<] F x Hx -> [0] [<] F y Hy.
Proof.
 intros e H x y H0 H1 Hx Hy H2 H3 H4.
 elim (cont_no_sign_change e H x y H0 H1 Hx Hy H2 H3); intros H5 H6.
 apply H5.
 apply less_transitive_unfolded with e; auto.
Qed.

Lemma cont_no_sign_change_neg : forall e, [0] [<] e -> forall x y, I x -> I y -> forall Hx Hy,
 AbsIR (F x Hx[-]F y Hy) [<=] e -> e [<] AbsIR (F x Hx) -> F x Hx [<] [--]e -> F y Hy [<] [0].
Proof.
 intros e H x y H0 H1 Hx Hy H2 H3 H4.
 elim (cont_no_sign_change e H x y H0 H1 Hx Hy H2 H3); intros H5 H6.
 apply H6.
 apply less_transitive_unfolded with ( [--]e).
  assumption.
 astepr ( [--]ZeroR); apply inv_resp_less; assumption.
Qed.

(**
Being continuous is an extensional property.
*)

Lemma Continuous_I_wd : Feq I F G -> Continuous_I Hab F -> Continuous_I Hab G.
Proof.
 intros H H0.
 elim H0; clear H0; intros Hinc H0.
 elim H; clear H; intros incF' H'.
 elim H'; clear H'; intros incG' H.
 split.
  apply incG'.
 intros e He; elim (H0 e He); clear H0; intros d H0 H1.
 exists d.
  assumption.
 intros x y H2 H3 Hx Hy H4.
 apply leEq_wdl with (AbsIR (F x (incF' x H2) [-]F y (incF' y H3))).
  apply H1; assumption.
 simpl in H.
 apply AbsIR_wd.
 apply cg_minus_wd; apply H; assumption.
Qed.

(**
A continuous function remains continuous if you restrict its domain.
*)

Lemma included_imp_contin : forall c d Hcd,
 included (compact c d Hcd) (Compact Hab) -> Continuous_I Hab F -> Continuous_I Hcd F.
Proof.
 intros c d Hcd H H0.
 elim H0; clear H0; intros incF' contF.
 split.
  apply included_trans with (Compact Hab); [ apply H | apply incF' ].
 intros e He; elim (contF e He); intros e' H0 H1.
 exists e'.
  assumption.
 intros; apply H1.
   apply H; assumption.
  apply H; assumption.
 assumption.
Qed.

(**
Constant functions and identity are continuous.
*)

Lemma Continuous_I_const : forall c : IR, Continuous_I Hab [-C-]c.
Proof.
 intro.
 split.
  Included.
 intros; exists OneR.
  apply pos_one.
 intros.
 apply leEq_wdl with (AbsIR [0]).
  astepl ZeroR; apply less_leEq; assumption.
 algebra.
Qed.

Lemma Continuous_I_id : Continuous_I Hab FId.
Proof.
 split.
  Included.
 intros; exists e.
  assumption.
 intros; assumption.
Qed.

(**
Assume [F] and [G] are continuous in [I].  Then functions derived from these through algebraic operations are also continuous, provided (in the case of reciprocal and division) some extra conditions are met.
*)

Hypothesis contF : Continuous_I Hab F.
Hypothesis contG : Continuous_I Hab G.

Lemma Continuous_I_plus : Continuous_I Hab (F{+}G).
Proof.
 clear incF incG.
 elim contF; intros incF' contF'.
 elim contG; intros incG' contG'.
 split.
  Included.
 intros.
 elim (contF' (e [/]TwoNZ)).
  elim (contG' (e [/]TwoNZ)).
   clear contF contG contF' contG'.
   2: apply pos_div_two; assumption.
  2: apply pos_div_two; assumption.
 intros df H0 H1 dg H2 H3.
 exists (Min df dg).
  apply less_Min; assumption.
 intros.
 simpl in |- *.
 apply leEq_wdl with (AbsIR (F x (ProjIR1 Hx) [-]F y (ProjIR1 Hy) [+]
   (G x (ProjIR2 Hx) [-]G y (ProjIR2 Hy)))).
  rstepr (e [/]TwoNZ[+]e [/]TwoNZ).
  eapply leEq_transitive.
   apply triangle_IR.
  apply plus_resp_leEq_both.
   simpl in |- *; apply H3; try assumption.
   apply leEq_transitive with (Min df dg); [ assumption | apply Min_leEq_rht ].
  simpl in |- *; apply H1; try assumption.
  apply leEq_transitive with (Min df dg); [ assumption | apply Min_leEq_lft ].
 apply AbsIR_wd; rational.
Qed.

Lemma Continuous_I_inv : Continuous_I Hab {--}F.
Proof.
 clear incF.
 elim contF; intros incF' contF'.
 split.
  Included.
 intros e H.
 elim (contF' e H).
 intros d H0 H1.
 exists d.
  assumption.
 intros; simpl in |- *.
 apply leEq_wdl with (AbsIR (F x Hx[-]F y Hy)).
  apply H1; assumption.
 eapply eq_transitive_unfolded.
  apply AbsIR_inv.
 apply AbsIR_wd; rational.
Qed.

Lemma Continuous_I_mult : Continuous_I Hab (F{*}G).
Proof.
 clear incF incG.
 elim contF; intros incF' contF'.
 elim contG; intros incG' contG'.
 split; [ Included | intros e H ].
 cut {xf : IR | forall (x : IR) (Hx : I x) (Hx' : P x), AbsIR (F x Hx') [<=] xf}.
  cut {xg : IR | forall (x : IR) (Hx : I x) (Hx' : Q x), AbsIR (G x Hx') [<=] xg}.
   2: unfold I, Q in |- *; apply Continuous_I_imp_abs_lub; assumption.
  2: unfold I, P in |- *; apply Continuous_I_imp_abs_lub; assumption.
 intros H0 H1.
 elim H0; clear H0; intros x H2.
 elim H1; clear H1; intros x0 H0.
 elim (contF' (e [/]TwoNZ[/] Max x [1][//]max_one_ap_zero _)); clear contF.
  elim (contG' (e [/]TwoNZ[/] Max x0 [1][//]max_one_ap_zero _)); clear contG.
   intros dg H1 H3 df H4 H5.
   2: apply div_resp_pos.
    2: apply pos_max_one.
   2: apply pos_div_two; assumption.
  2: apply div_resp_pos.
   2: apply pos_max_one.
  2: apply pos_div_two; assumption.
 exists (Min df dg).
  apply less_Min; assumption.
 intros; simpl in |- *.
 rstepr (e [/]TwoNZ[+]e [/]TwoNZ).
 apply leEq_wdl with (AbsIR (F x1 (ProjIR1 Hx) [*] (G x1 (ProjIR2 Hx) [-]G y (ProjIR2 Hy)) [+]
   (F x1 (ProjIR1 Hx) [-]F y (ProjIR1 Hy)) [*]G y (ProjIR2 Hy))).
  eapply leEq_transitive.
   apply triangle_IR.
  apply plus_resp_leEq_both.
   eapply leEq_wdl.
    2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
   apply leEq_transitive with (x0[*]AbsIR (G x1 (ProjIR2 Hx) [-]G y (ProjIR2 Hy))).
    apply mult_resp_leEq_rht.
     apply H0; assumption.
    apply AbsIR_nonneg.
   apply leEq_transitive with (Max x0 [1][*]AbsIR (G x1 (ProjIR2 Hx) [-]G y (ProjIR2 Hy))).
    apply mult_resp_leEq_rht; [ apply lft_leEq_Max | apply AbsIR_nonneg ].
   astepl (AbsIR (G x1 (ProjIR2 Hx) [-]G y (ProjIR2 Hy)) [*]Max x0 [1]).
   apply shift_mult_leEq with (max_one_ap_zero x0);
     [ apply pos_max_one | simpl in |- *; apply H3 ]; try assumption.
   apply leEq_transitive with (Min df dg); [ assumption | apply Min_leEq_rht ].
  eapply leEq_wdl.
   2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
  apply leEq_transitive with (AbsIR (F x1 (ProjIR1 Hx) [-]F y (ProjIR1 Hy)) [*]x).
   apply mult_resp_leEq_lft; [ apply H2 | apply AbsIR_nonneg ]; assumption.
  apply leEq_transitive with (AbsIR (F x1 (ProjIR1 Hx) [-]F y (ProjIR1 Hy)) [*]Max x [1]).
   apply mult_resp_leEq_lft; [ apply lft_leEq_Max with (y := OneR) | apply AbsIR_nonneg ].
  apply shift_mult_leEq with (max_one_ap_zero x);
    [ apply pos_max_one | simpl in |- *; apply H5 ]; try assumption.
  apply leEq_transitive with (Min df dg); [ assumption | apply Min_leEq_lft ].
 apply AbsIR_wd; rational.
Qed.

Lemma Continuous_I_max : Continuous_I Hab (FMax F G).
Proof.
 clear incF incG.
 elim contF; intros incF contF'.
 elim contG; intros incG contG'.
 split.
  Included.
 intros e He.
 elim (contF' (e [/]TwoNZ) (pos_div_two _ _ He)); intros dF dFpos HdF.
 elim (contG' (e [/]TwoNZ) (pos_div_two _ _ He)); intros dG dGpos HdG.
 clear contF contG contF' contG'.
 exists (Min dF dG).
  apply less_Min; auto.
 intros x y Hx' Hy' Hx Hy Hxy.
 assert (AbsIR (x[-]y) [<=] dF).
  eapply leEq_transitive; [ apply Hxy | apply Min_leEq_lft ].
 assert (AbsIR (x[-]y) [<=] dG).
  eapply leEq_transitive; [ apply Hxy | apply Min_leEq_rht ].
 assert (HF := HdF x y Hx' Hy' (ProjIR1 Hx) (ProjIR1 Hy) H).
 assert (HG := HdG x y Hx' Hy' (ProjIR2 Hx) (ProjIR2 Hy) H0).
 Opaque AbsIR Max.
 simpl in |- *.
 Transparent AbsIR Max.
 set (Fx := F x (ProjIR1 Hx)) in *.
 set (Fy := F y (ProjIR1 Hy)) in *.
 set (Gx := G x (ProjIR2 Hx)) in *.
 set (Gy := G y (ProjIR2 Hy)) in *.
 elim (AbsIR_imp_AbsSmall _ _ HF); intros HF1 HF2.
 elim (AbsIR_imp_AbsSmall _ _ HG); intros HG1 HG2.
 apply leEq_wdl with (AbsIR (Max Fx Gx[-]Max Fx Gy[+] (Max Fx Gy[-]Max Fy Gy))).
  2: apply AbsIR_wd; rational.
 rstepr (e [/]TwoNZ[+]e [/]TwoNZ).
 eapply leEq_transitive.
  apply triangle_IR.
 apply plus_resp_leEq_both; apply AbsSmall_imp_AbsIR; split.
    apply shift_zero_leEq_minus'.
    rstepr (e [/]TwoNZ[+]Max Fx Gx[-]Max Fx Gy).
    apply shift_zero_leEq_minus.
    apply Max_leEq.
     apply leEq_transitive with (e [/]TwoNZ[+]Fx).
      apply shift_leEq_plus; astepl ZeroR; apply less_leEq; apply pos_div_two; auto.
     apply plus_resp_leEq_lft; apply lft_leEq_Max.
    apply leEq_transitive with (e [/]TwoNZ[+]Gx).
     2: apply plus_resp_leEq_lft; apply rht_leEq_Max.
    apply shift_leEq_plus.
    apply inv_cancel_leEq; rstepr (Gx[-]Gy); auto.
   apply shift_minus_leEq; apply Max_leEq.
    apply leEq_transitive with (e [/]TwoNZ[+]Fx).
     apply shift_leEq_plus; astepl ZeroR; apply less_leEq; apply pos_div_two; auto.
    apply plus_resp_leEq_lft; apply lft_leEq_Max.
   apply leEq_transitive with (e [/]TwoNZ[+]Gy).
    2: apply plus_resp_leEq_lft; apply rht_leEq_Max.
   apply shift_leEq_plus; auto.
  apply shift_zero_leEq_minus'.
  rstepr (e [/]TwoNZ[+]Max Fx Gy[-]Max Fy Gy).
  apply shift_zero_leEq_minus.
  apply Max_leEq.
   apply leEq_transitive with (e [/]TwoNZ[+]Fx).
    apply shift_leEq_plus.
    apply inv_cancel_leEq; rstepr (Fx[-]Fy); auto.
   apply plus_resp_leEq_lft; apply lft_leEq_Max.
  apply leEq_transitive with (e [/]TwoNZ[+]Gy).
   2: apply plus_resp_leEq_lft; apply rht_leEq_Max.
  apply shift_leEq_plus; astepl ZeroR; apply less_leEq; apply pos_div_two; auto.
 apply shift_minus_leEq; apply Max_leEq.
  apply leEq_transitive with (e [/]TwoNZ[+]Fy).
   apply shift_leEq_plus; auto.
  apply plus_resp_leEq_lft; apply lft_leEq_Max.
 apply leEq_transitive with (e [/]TwoNZ[+]Gy).
  apply shift_leEq_plus; astepl ZeroR; apply less_leEq; apply pos_div_two; auto.
 apply plus_resp_leEq_lft; apply rht_leEq_Max.
Qed.

(* begin show *)
Hypothesis Hg' : bnd_away_zero I G.
Hypothesis Hg'' : forall x Hx, I x -> G x Hx [#] [0].
(* end show *)

Lemma Continuous_I_recip : Continuous_I Hab {1/}G.
Proof.
 clear incF incG.
 elim contG; intros incG' contG'.
 split.
  Included; assumption.
 elim Hg'; intros Haux Hg2.
 elim Hg2; clear Haux Hg2; intros c H H0.
 intros.
 elim contG' with (c[*]c[*]e); clear contG contG'.
  intros d H2 H3.
  exists d.
   assumption.
  intros x y H4 H5 Hx Hy H6.
  simpl in |- *.
  set (Hxx := incG' x H4) in *.
  set (Hyy := incG' y H5) in *.
  apply leEq_wdl with (AbsIR (G y Hyy[-]G x Hxx[/] _[//]
    mult_resp_ap_zero _ _ _ (Hg'' x Hxx H4) (Hg'' y Hyy H5))).
   apply leEq_wdl with (AbsIR (G y Hyy[-]G x Hxx) [/] _[//] AbsIR_resp_ap_zero _
     (mult_resp_ap_zero _ _ _ (Hg'' x Hxx H4) (Hg'' y Hyy H5))).
    apply leEq_transitive with (AbsIR (G y Hyy[-]G x Hxx) [/] _[//]
      mult_resp_ap_zero _ _ _ (pos_ap_zero _ _ H) (pos_ap_zero _ _ H)).
     rstepl (AbsIR (G y Hyy[-]G x Hxx) [*] ([1][/] _[//] AbsIR_resp_ap_zero _
       (mult_resp_ap_zero _ _ _ (Hg'' x Hxx H4) (Hg'' y Hyy H5)))).
     rstepr (AbsIR (G y Hyy[-]G x Hxx) [*] ([1][/] _[//]
       mult_resp_ap_zero _ _ _ (pos_ap_zero _ _ H) (pos_ap_zero _ _ H))).
     apply mult_resp_leEq_lft.
      apply recip_resp_leEq.
       astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive; assumption.
      eapply leEq_wdr.
       2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
      apply mult_resp_leEq_both; try (apply less_leEq; assumption).
       eapply leEq_wdr; [ apply (H0 x Hxx H4) | algebra ].
      eapply leEq_wdr; [ apply (H0 y Hyy H5) | algebra ].
     apply AbsIR_nonneg.
    apply shift_div_leEq'.
     astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive; assumption.
    eapply leEq_wdl.
     2: apply AbsIR_minus.
    apply H3; assumption.
   apply eq_symmetric_unfolded; apply AbsIR_division.
  apply AbsIR_wd.
  rational.
 astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive.
  astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive; assumption.
 assumption.
Qed.

Lemma Continuous_I_NRoot : forall n Hn, (forall x Hx, I x -> [0][<=]F x Hx) ->
 Continuous_I Hab (FNRoot F n Hn).
Proof.
 intros n Hn H.
 split.
  Included.
 intros e He.
 destruct contF as [contF'' contF'].
 destruct (contF' (e[^]n)) as [d Hd H0]; clear contF contF'.
  apply nexp_resp_pos; assumption.
 exists d.
  assumption.
 intros x y Hx0 Hy0 Hx Hy Hxy.
 set (x':=FNRoot F n Hn x Hx).
 set (y':=FNRoot F n Hn y Hy).
 stepl (Max x' y'[-]Min x' y'); [|apply eq_symmetric;apply Abs_Max].
 apply shift_minus_leEq.
 apply power_cancel_leEq with n; try assumption.
  apply plus_resp_nonneg.
   apply less_leEq; assumption.
  apply leEq_Min; apply: NRoot_nonneg.
 apply leEq_transitive with (e[^]n[+]Min x' y'[^]n).
  apply shift_leEq_plus.
  set (Hx':=(ProjT1 (ext2_a IR (Dom F) (fun (x0 : IR) (Hx1 : Dom F x0) => [0][<=]F x0 Hx1) x Hx))).
  set (Hy':=(ProjT1 (ext2_a IR (Dom F) (fun (x0 : IR) (Hx1 : Dom F x0) => [0][<=]F x0 Hx1) y Hy))).
  stepl (AbsIR (F x Hx'[-]F y Hy')).
   apply H0; try assumption.
  stepr (AbsIR (x'[^]n[-]y'[^]n)).
   apply AbsIR_wd.
   apply: bin_op_wd_unfolded; apply eq_symmetric; try apply un_op_wd_unfolded; apply: NRoot_power.
  csetoid_rewrite (Abs_Max (x'[^]n) (y'[^]n)).
  apply: bin_op_wd_unfolded; try apply un_op_wd_unfolded.
   change (Max ((FId{^}n) x' True_constr) ((FId{^}n) y' True_constr)[=]((FId{^}n) (Max x' y') True_constr)).
   apply Max_monotone.
   simpl; intros r s _ _ X0 X1 X2.
   apply: nexp_resp_leEq; try assumption.
   eapply leEq_transitive;[|apply X0].
   apply leEq_Min; apply: NRoot_nonneg.
  change (Min ((FId{^}n) x' True_constr) ((FId{^}n) y' True_constr)[=]((FId{^}n) (Min x' y') True_constr)).
  apply Min_monotone.
  simpl; intros r s _ _ X0 X1 X2.
  apply: nexp_resp_leEq; try assumption.
  eapply leEq_transitive;[|apply X0].
  apply leEq_Min; apply: NRoot_nonneg.
 apply power_plus_leEq; try assumption.
  apply less_leEq; assumption.
 apply leEq_Min; apply: NRoot_nonneg.
Qed.

End Local_Results.

#[global]
Hint Resolve contin_imp_inc: included.

Section Corolaries.

Variables a b : IR.
Hypothesis Hab : a [<=] b.
(* begin hide *)
Let I := Compact Hab.
(* end hide *)

Variables F G : PartIR.

(* begin hide *)
Let P := Dom F.
Let Q := Dom G.
(* end hide *)

Hypothesis contF : Continuous_I Hab F.
Hypothesis contG : Continuous_I Hab G.

(**
The corresponding properties for subtraction, division and
multiplication by a scalar are easily proved as corollaries;
exponentiation is proved by induction, appealing to the results on
product and constant functions.
*)

Lemma Continuous_I_minus : Continuous_I Hab (F{-}G).
Proof.
 apply Continuous_I_wd with (F{+}{--}G).
  FEQ.
 apply Continuous_I_plus.
  apply contF.
 apply Continuous_I_inv; apply contG.
Qed.

Lemma Continuous_I_scal : forall c : IR, Continuous_I Hab (c{**}F).
Proof.
 intros.
 unfold Fscalmult in |- *.
 apply Continuous_I_mult.
  apply Continuous_I_const.
 apply contF.
Qed.

Lemma Continuous_I_nth : forall n : nat, Continuous_I Hab (F{^}n).
Proof.
 simple induction n.
  apply Continuous_I_wd with ( [-C-]OneR).
   apply FNth_zero'; apply contin_imp_inc; auto.
  apply Continuous_I_const.
 clear n; intros.
 apply Continuous_I_wd with (F{*}F{^}n).
  apply FNth_mult'; apply contin_imp_inc; auto.
 apply Continuous_I_mult; assumption.
Qed.

Lemma Continuous_I_min : Continuous_I Hab (FMin F G).
Proof.
 unfold FMin in |- *.
 apply Continuous_I_inv; apply Continuous_I_max; apply Continuous_I_inv; auto.
Qed.

Lemma Continuous_I_abs : Continuous_I Hab (FAbs F).
Proof.
 unfold FAbs in |- *.
 apply Continuous_I_max; try apply Continuous_I_inv; auto.
Qed.

Hypothesis Hg' : bnd_away_zero I G.
Hypothesis Hg'' : forall x Hx, I x -> G x Hx [#] [0].

Lemma Continuous_I_div : Continuous_I Hab (F{/}G).
Proof.
 apply Continuous_I_wd with (F{*}{1/}G).
  FEQ.
 apply Continuous_I_mult.
  assumption.
 apply Continuous_I_recip; assumption.
Qed.

End Corolaries.

Section Other.

Section Sums.

(**
We finally prove that the sum of an arbitrary family of continuous functions is still a continuous function.
*)

Variables a b : IR.
Hypothesis Hab : a [<=] b.
Hypothesis Hab' : a [<] b.

(* begin hide *)
Let I := Compact Hab.
(* end hide *)

Lemma Continuous_I_Sum0 : forall f : nat -> PartIR,
 (forall n, Continuous_I Hab (f n)) -> forall n, Continuous_I Hab (FSum0 n f).
Proof.
 intros.
 induction  n as [| n Hrecn].
  eapply Continuous_I_wd.
   apply FSum0_0.
   2: apply Continuous_I_const.
  intro; apply contin_imp_inc; auto.
 eapply Continuous_I_wd.
  apply FSum0_S.
  intro; apply contin_imp_inc; auto.
 apply Continuous_I_plus; auto.
Qed.

Lemma Continuous_I_Sumx : forall n (f : forall i, i < n -> PartIR),
 (forall i Hi, Continuous_I Hab (f i Hi)) -> Continuous_I Hab (FSumx n f).
Proof.
 intro; induction  n as [| n Hrecn]; intros f contF.
  simpl in |- *; apply Continuous_I_const.
 simpl in |- *; apply Continuous_I_plus.
  apply Hrecn.
  intros; apply contF.
 apply contF.
Qed.

Lemma Continuous_I_Sum : forall f : nat -> PartIR,
 (forall n, Continuous_I Hab (f n)) -> forall m n, Continuous_I Hab (FSum m n f).
Proof.
 intros.
 eapply Continuous_I_wd.
  apply Feq_symmetric; apply FSum_FSum0'.
  intro; apply contin_imp_inc; auto.
 apply Continuous_I_minus; apply Continuous_I_Sum0; auto.
Qed.

End Sums.

(**
For practical purposes, these characterization results are useful:
*)

Lemma lub_charact : forall a b Hab F (contF : Continuous_I Hab F) z,
 fun_lub_IR F (compact a b Hab) z -> z [=] lub_funct a b Hab F contF.
Proof.
 intros a b Hab F contF z H.
 elim H; intros Hz Hz'; clear H.
 assert (H := lub_is_lub _ _ _ _ contF).
 set (y := lub_funct _ _ _ _ contF) in *.
 elim H; intros Hy Hy'; clear H.
 apply leEq_imp_eq; apply shift_zero_leEq_minus'; apply inv_cancel_leEq;
   astepr ZeroR; apply approach_zero; intros e He.
  rstepl (z[-]y).
  apply shift_minus_less.
  elim (Hz' e He); intros x Hx.
  intro H.
  apply less_leEq_trans with (x[+]e).
   apply shift_less_plus'; auto.
  astepr (y[+]e).
  apply plus_resp_leEq; apply Hy.
  auto.
 rstepl (y[-]z).
 apply shift_minus_less.
 elim (Hy' e He); intros x Hx.
 intro H.
 apply less_leEq_trans with (x[+]e).
  apply shift_less_plus'; auto.
 astepr (z[+]e).
 apply plus_resp_leEq; apply Hz.
 auto.
Qed.

Lemma glb_charact : forall a b Hab F (contF : Continuous_I Hab F) z,
 fun_glb_IR F (compact a b Hab) z -> z [=] glb_funct a b Hab F contF.
Proof.
 intros a b Hab F contF z H.
 elim H; intros Hz Hz'; clear H.
 assert (H := glb_is_glb _ _ _ _ contF).
 set (y := glb_funct _ _ _ _ contF) in *.
 elim H; intros Hy Hy'; clear H.
 apply leEq_imp_eq; apply shift_zero_leEq_minus'; apply inv_cancel_leEq;
   astepr ZeroR; apply approach_zero; intros e He.
  rstepl (z[-]y).
  apply shift_minus_less.
  elim (Hy' e He); intros x Hx.
  intro H.
  apply leEq_less_trans with x.
   apply Hz; auto.
  apply shift_less_plus; auto.
 rstepl (y[-]z).
 apply shift_minus_less.
 elim (Hz' e He); intros x Hx.
 intro H.
 apply leEq_less_trans with x.
  apply Hy; auto.
 apply shift_less_plus; auto.
Qed.

(**
The following result is also extremely useful, as it allows us to set a lower bound on the glb of a function.
*)

Lemma leEq_glb : forall a b Hab (F : PartIR) contF x,
 (forall y, Compact Hab y -> forall Hy, x [<=] F y Hy) -> x [<=] glb_funct a b Hab F contF.
Proof.
 intros a b Hab F contF x H.
 elim (glb_is_glb _ _ _ _ contF); intros.
 astepr (glb_funct _ _ _ _ contF[+][0]); apply shift_leEq_plus'.
 apply approach_zero_weak.
 intros e H0.
 elim (b0 _ H0); intro y; intros.
 apply less_leEq; eapply leEq_less_trans.
  2: apply q.
 apply minus_resp_leEq.
 elim p; intros z Hz.
 elim Hz; intros H1 H2.
 elim H2; intros H3 H4.
 astepr (F z H3); auto.
Qed.

(**
The norm is also an extensional property.
*)

Lemma Norm_Funct_wd : forall a b Hab F G, Feq (compact a b Hab) F G ->
 forall contF contG, Norm_Funct (Hab:=Hab) (F:=F) contF [=] Norm_Funct (Hab:=Hab) (F:=G) contG.
Proof.
 intros a b Hab F G H contF contG.
 elim H; intros incF H''.
 elim H''; clear H''; intros incG H''.
 unfold Norm_Funct in |- *; apply bin_op_wd_unfolded.
  generalize (lub_is_lub _ _ _ _ contF); intro Hlub.
  apply lub_charact.
  elim Hlub; clear Hlub; intros H0 H1.
  split.
   intros x H2.
   apply H0.
   apply fun_image_wd with G.
    apply Feq_symmetric; auto.
   auto.
  intros e H2.
  elim (H1 e H2); intro x; intros.
  exists x.
   apply fun_image_wd with F; auto.
  auto.
 apply un_op_wd_unfolded.
 generalize (glb_is_glb _ _ _ _ contF); intro Hglb.
 apply glb_charact.
 elim Hglb; intros H0 H1.
 split.
  intros x H2.
  apply H0.
  apply fun_image_wd with G.
   apply Feq_symmetric; auto.
  auto.
 intros e H2.
 elim (H1 e H2); intro x; intros.
 exists x.
  apply fun_image_wd with F; auto.
 auto.
Qed.

(**
The value of the norm is covariant with the length of the interval.
*)

Lemma included_imp_norm_leEq : forall a b c d Hab Hcd F contF1 contF2,
 included (compact c d Hcd) (compact a b Hab) ->
 Norm_Funct (Hab:=Hcd) (F:=F) contF2 [<=] Norm_Funct (Hab:=Hab) (F:=F) contF1.
Proof.
 intros.
 apply leEq_Norm_Funct; intros.
 apply norm_bnd_AbsIR; auto.
Qed.

End Other.

#[global]
Hint Resolve Continuous_I_const Continuous_I_id Continuous_I_plus
  Continuous_I_inv Continuous_I_minus Continuous_I_mult Continuous_I_scal
  Continuous_I_recip Continuous_I_max Continuous_I_min Continuous_I_div
  Continuous_I_nth Continuous_I_abs Continuous_I_NRoot: continuous.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Adjunction.Natural.Transformation.
Require Export Category.Adjunction.Natural.Transformation.Universal.
Require Export Category.Construction.Comma.
Require Export Category.Construction.Comma.Adjunction.Lib.
Require Export Category.Construction.Product.
Require Export Category.Instance.Cat.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section AdjunctionComma.

(* Wikipedia: "Lawvere showed that the functors F : C → D and G : D → C are
   adjoint if and only if the comma categories (F ↓ Id[D]) and (Id[C] ↓ G) are
   isomorphic, and equivalent elements in the comma category can be projected
   onto the same element of C × D. This allows adjunctions to be described
   without involving sets, and was in fact the original motivation for
   introducing comma categories."

   From ncatlab: "To give an adjunction i ⊣ r it suffices to give, for each k
   : x → pe in B ↓ p, an object rk in E such that prk = x and an arrow irk =
   1x → k in B ↓ p that is universal from i to k."

   Lawvere's own statement of the theorem, from his thesis (page 40):

   "For each functor f : A ⟶ B, there exists a functor g : B ⟶ A such that g
   is adjoint to f iff for every object B ∈ |B| there exists an object A ∈ |A|
   and a map φ : B ~> Af in B such that for every object A′ ∈ |A| and every
   map x : B ~> A′f in B, there exists a unique map y : A ~> A′ in A such that
   x = φ(yf) in B."

   Repeating this using the names and syntax of this module:

   "∀ (G : C ⟶ D) (F : D ⟶ C), F ⊣ G ↔
      ∀ d : D, ∃ (c : C) (phi : d ~{D}~> G c),
        ∀ (c′ : C) (psi : d ~{D}~> G c′), ∃! y : c ~{C}~> c′,
          psi ≈ fmap[G] y ∘ phi" *)

Context {C : Category}.
Context {D : Category}.
Context {F : D ⟶ C}.
Context {G : C ⟶ D}.

Definition fiber_eqv_unit (E : @fibered_equivalence _ _ F G) {a} :
  a ~{ D }~> G (F a) :=
  fmap (snd (``(projF E) (Left_Functor a))⁻¹)
    ∘ projT2 (to (fiber_iso E) (Left_Functor a))
    ∘ fst (to (``(projF E) (Left_Functor a))).

Definition fiber_eqv_counit (E : @fibered_equivalence _ _ F G) {a} :
  F (G a) ~{ C }~> a :=
  snd (``(projG E) (Right_Functor a))⁻¹
    ∘ projT2 ((fiber_iso E)⁻¹ (Right_Functor a))
    ∘ fmap (fst (to (``(projG E) (Right_Functor a)))).

Set Transparent Obligations.

Program Definition fiber_eqv_unit_transform (E : @fibered_equivalence _ _ F G) :
  Id ⟹ G ○ F := {|
  transform := _ fiber_eqv_unit;
  naturality := fun x y f =>
    Left_Functoriality E x y (f, fmap[F] f);
  naturality_sym := fun x y f =>
    symmetry (Left_Functoriality E x y (f, fmap[F] f))
|}.

Program Definition fiber_eqv_counit_transform (E : @fibered_equivalence _ _ F G) :
  F ○ G ⟹ Id := {|
  transform := _ fiber_eqv_counit;
  naturality := fun x y f =>
    Right_Functoriality E x y (fmap[G] f, f);
  naturality_sym := fun x y f =>
    symmetry (Right_Functoriality E x y (fmap[G] f, f))
|}.

Program Instance comma_projG_iso (E : @fibered_equivalence _ _ F G) f :
  `1 f ≅ `1 (from (fiber_iso E) f) := (`1 (projG E) f).

Definition comma_from (E : @fibered_equivalence _ _ F G)
           a b (f : a ~> G b) : F a ~> b :=
  snd (comma_projG_iso E ((a, b); f))⁻¹
    ∘ `2 (from (fiber_iso E) ((a, b); f))
    ∘ fmap[F] (fst (to (comma_projG_iso E ((a, b); f)))).

Lemma fiber_eqv_counit_fmap_unit (E : @fibered_equivalence _ _ F G) {a} :
  fiber_eqv_counit E ∘ fmap[F] (fiber_eqv_unit E) ≈ id[F a].
Proof.
  simpl; intros.
  pose proof (naturality[fiber_eqv_counit_transform E]); simpl in X.
  unfold fiber_eqv_counit_transform_obligation_1 in X.
  unfold fiber_eqv_unit.
  do 2 rewrite fmap_comp.
  do 2 rewrite comp_assoc.
  rewrite <- X.
  rewrite <- !comp_assoc.
  remember (_ ∘ (fiber_eqv_counit E ∘ _)) as p.
  pose proof (@monic _ _ _ _ (iso_monic (`1 (projF E) (Left_Functor a)))
                     (a, F a) (id, p) (id, id)).
  simpl in X0.
  refine (snd (X0 _)).
  split.
    reflexivity.
  clear X0.
  rewrite Heqp.
  rewrite !comp_assoc.
  rewrite (snd (iso_to_from (`1 (projF E) (Left_Functor a)))).
  rewrite id_left, id_right.
  rewrite <- comp_assoc.
  rewrite <- fmap_comp.
Admitted.                       (* DEFERRED *)

Lemma fiber_eqv_fmap_counit_unit (E : @fibered_equivalence _ _ F G) {a} :
  fmap[G] (fiber_eqv_counit E) ∘ fiber_eqv_unit E ≈ id[G a].
Proof.
  simpl; intros.
  pose proof (naturality[fiber_eqv_unit_transform E]); simpl in X.
  unfold fiber_eqv_unit_transform_obligation_1 in X.
  unfold fiber_eqv_counit.
  do 2 rewrite fmap_comp.
  do 2 rewrite <- comp_assoc.
  rewrite X.
  rewrite !comp_assoc.
  remember ((_ ∘ fiber_eqv_unit E) ∘ _) as p.
  pose proof (@epic _ _ _ _ (iso_from_epic (`1 (projG E) (Right_Functor a)))
                     (G a, a) (p, id) (id, id)).
  simpl in X0.
  refine (fst (X0 _)).
  split; [|reflexivity].
  clear X0.
  rewrite Heqp.
  rewrite <- !comp_assoc.
Admitted.                       (* DEFERRED *)

Theorem Adjunction_Comma : F ⊣ G  ↔  @fibered_equivalence _ _ F G.
Proof.
  split; intros H. {
    refine {| fiber_iso := Comma_F_Id_Id_G_Iso H |}.
    - abstract (
        simpl; unshelve eexists; intros; split;
        destruct f; simpl; cat).
    - abstract (
        simpl; unshelve eexists; intros; split;
        destruct f; simpl; cat).
  }

  apply Adjunction_from_Transform.

  exact (Build_Adjunction_Transform
           (fiber_eqv_unit_transform H)
           (fiber_eqv_counit_transform H)
           (@fiber_eqv_counit_fmap_unit H)
           (@fiber_eqv_fmap_counit_unit H)).
Qed.

End AdjunctionComma.


Require Export Sequent.
Require Export SignedSubformula.

Require Import Base.Lists.
Require Import Base.Arith.
Require Import Base.Permutation.
Require Import Tactics.FormulaEquality.
Require Import Tactics.TermEquality.
Require Import Tactics.WellFormedFormulaNoProofs.
Require Import Tactics.TermHasSortNoFormulas.
Require Import Program.Wf.
Require Import Coq.Arith.Wf_nat.

Set Bullet Behavior "Strict Subproofs".

Module Type CompatibleSupercontext (G : GroundInfo) (GTerm : Term G) (GFormula : Formula G GTerm)
       (TE : TermEquality G GTerm) (FE : FormulaEquality G GTerm GFormula TE)
       (SS : SignedSubformula G GTerm GFormula TE FE)
       (THS : TermHasSort'' G GTerm TE)
       (WFF : WellFormedFormula' G GTerm TE THS GFormula FE)
       (S : Sequent G GTerm GFormula TE FE THS WFF).
  Import G. Import GTerm. Import GFormula. Import ListNotations.
  Import THS. Import WFF. Import S. Import SS.

  Open Scope term_scope. Open Scope formula_scope. Open Scope list_scope. Open Scope proof_scope.

  Reserved Notation "Delta ≪ Gamma ⊢csc b" (at level 50).

  Inductive CompatibleSupercontext : Context -> Context -> Belief -> Prop :=
  | CSCRefl : forall Gamma b, Gamma ≪ Gamma ⊢csc b
  | CSCUnion : forall Delta E Gamma b,
      Delta ≪ Gamma ⊢csc b -> E ≪ Gamma ⊢csc b ->
      (Delta ++ E) ≪ Gamma ⊢csc b
  | CSCPermutation : forall Delta1 Delta2 Gamma1 Gamma2 b,
      Permutation Delta1 Delta2 -> Permutation Gamma1 Gamma2 ->
      Delta1 ≪ Gamma1 ⊢csc b -> Delta2 ≪ Gamma2 ⊢csc b
  (* The following two constructors are provable from the rest, up to some technicalities.
     Technically, we need to have a different -- but equivalent -- presentation of CSC for the second, and the first is only provable up to alpha-equivalence.
     Here we axiomatize them, so that we don't have to build up the framework of alpha-equivalence.
   *)
  | CSCAtomic : forall Delta Gamma phi m b,
      AtomicFormula phi -> ⊢wff phi -> ProperModality m ->
      Delta ≪ Gamma ⊢csc (phi @ m) ->
      Delta ≪ Gamma ⊢csc b
  | CSCWeakening : forall Delta Gamma b1 b2,
      Delta ≪ Gamma ⊢csc b1 ->
      (b2 :: Delta) ≪ (b2 :: Gamma) ⊢csc b1
  | CSCAndL : forall Delta Gamma b phi psi m,
      Path (phi & psi @ m) Gamma ->
      Delta ≪ (phi @ m :: psi @ m :: Gamma) ⊢csc b ->
      Delta ≪ Gamma ⊢csc b
  | CSCAndR1 : forall Delta Gamma phi psi m,
      Delta ≪ Gamma ⊢csc phi @ m ->
      Delta ≪ Gamma ⊢csc phi & psi @ m
  | CSCAndR2 : forall Delta Gamma phi psi m,
      Delta ≪ Gamma ⊢csc psi @ m ->
      Delta ≪ Gamma ⊢csc phi & psi @ m
  | CSCOrL1 : forall Delta Gamma b phi psi m,
      Path (phi ⊕ psi @ m) Gamma ->
      Delta ≪ (phi @ m :: Gamma) ⊢csc b ->
      Delta ≪ Gamma ⊢csc b
  | CSCOrL2 : forall Delta Gamma b phi psi m,
      Path (phi ⊕ psi @ m) Gamma ->
      Delta ≪ (psi @ m :: Gamma) ⊢csc b ->
      Delta ≪ Gamma ⊢csc b
  | CSCOrR1 : forall Delta Gamma phi psi m,
      Delta ≪ Gamma ⊢csc phi @ m ->
      Delta ≪ Gamma ⊢csc phi ⊕ psi @ m
  | CSCOrR2 : forall Delta Gamma phi psi m,
      Delta ≪ Gamma ⊢csc psi @ m ->
      Delta ≪ Gamma ⊢csc phi ⊕ psi @ m
  | CSCImpL1 : forall Delta Gamma b phi l psi m,
      Path (phi ==⟨ l ⟩> psi @ m) Gamma ->
      Delta ≪ (psi @ m :: Gamma) ⊢csc b ->
      Delta ≪ Gamma ⊢csc b
  | CSCImpL2 : forall Delta Gamma b phi l psi m,
      Path (phi ==⟨ l ⟩> psi @ m) Gamma ->
      Delta ≪ Gamma ⊢csc phi @ ⟨l⟩ ->
      Delta ≪ Gamma ⊢csc b
  | CSCImpR : forall Delta Gamma phi l psi m,
      Delta ≪ (phi @ ⟨ l ⟩ :: Gamma) ⊢csc (psi @ m) ->
      Delta ≪ Gamma ⊢csc (phi ==⟨l⟩> psi @ m)
  | CSCForallL : forall Delta Gamma sigma phi t m b,
      Path (∀ sigma; phi @ m) Gamma ->
      lc_term t -> ⊢s t ::: sigma ->
      Delta ≪ (open_formula phi t @ m :: Gamma) ⊢csc b ->
      Delta ≪ Gamma ⊢csc b
  | CSCForallR : forall Delta Gamma sigma y phi m,
      VarSort y = sigma -> y ∉FVC Gamma -> y ∉FVF phi -> y ∉FVM m ->
      Delta ≪ Gamma ⊢csc (open_formula phi (varTerm y)) @ m ->
      Delta ≪ Gamma ⊢csc ∀ sigma; phi @ m
  | CSCExistsL : forall Delta Gamma sigma phi y m b,
      Path (∃ sigma; phi @ m) Gamma ->
      VarSort y = sigma -> y ∉FVC Gamma -> y ∉FVB b ->
      Delta ≪ (open_formula phi (varTerm y) @ m :: Gamma) ⊢csc b ->
      Delta ≪ Gamma ⊢csc b
  | CSCExistsR : forall Delta Gamma sigma t phi m,
      lc_term t -> ⊢s t ::: sigma ->
      Delta ≪ Gamma ⊢csc open_formula phi t @ m ->
      Delta ≪ Gamma ⊢csc ∃ sigma; phi @ m
  | CSCsaysL : forall Delta Gamma p l phi m b,
      Path (p □ ⟨l⟩ phi @ m) Gamma ->
      Delta ≪ (phi @ m ⋅ p⟨l⟩ :: Gamma) ⊢csc b ->
      Delta ≪ Gamma ⊢csc b
  | CSCsaysR : forall Delta Gamma p l phi m,
      Delta ≪ Gamma ⊢csc phi @ m ⋅ p⟨l⟩ ->
      Delta ≪ Gamma ⊢csc p □ ⟨l⟩ phi @ m
  | CSCMER : forall Delta Gamma phi m (pth : PathToDoubleInModality m),
      Delta ≪ Gamma ⊢csc phi @ (CollapseDoubleInModality pth) ->
      Delta ≪ Gamma ⊢csc phi @ m
  | CSCMEL : forall Delta Gamma phi m (pth : PathToDoubleInModality m) b,
      Path (phi @ (CollapseDoubleInModality pth)) Gamma ->
      Delta ≪ (phi @ m :: Gamma) ⊢csc b ->
      Delta ≪ Gamma ⊢csc b
  | CSCMCR : forall Delta Gamma phi m (pth : PathToDoubleInModality m),
      Delta ≪ Gamma ⊢csc phi @ m ->
      Delta ≪ Gamma ⊢csc phi @ (CollapseDoubleInModality pth)
  | CSCMCL : forall Delta Gamma phi m (pth : PathToDoubleInModality m) b,
      Path (phi @ m) Gamma ->
      Delta ≪ (phi @ (CollapseDoubleInModality pth) :: Gamma) ⊢csc b ->
      Delta ≪ Gamma ⊢csc b
  | CSCRVariance : forall Delta Gamma l1 l2 phi m (pth : PathToLabelInModality m l1),
      Gamma ⊢ l1 ⊑ l2 @ (VarModality pth l2) ->
      Delta ≪ Gamma ⊢csc phi @ m ->
      Delta ≪ Gamma ⊢csc phi @ (ReplaceLabelInModality m l1 l2 pth)
  | CSCLVariance : forall Delta Gamma l1 l2 phi m (pth : PathToLabelInModality m l1) b,
      Path (phi @ m) Gamma ->
      Gamma ⊢ l1 ⊑ l2 @ (VarModality pth l2) ->
      Delta ≪ (phi @ ReplaceLabelInModality m l1 l2 pth :: Gamma) ⊢csc b ->
      Delta ≪ Gamma ⊢csc b
  | CSCFwdR : forall Delta Gamma phi m p q (pth : PathToPrinInModality m p),
      Gamma ⊢ (canRead q (LabelAtPrin pth)) @ (FwdModality pth p) ->
      Gamma ⊢ (canWrite p (LabelAtPrin pth)) @ (FwdModality pth q) ->
      Delta ≪ Gamma ⊢csc phi @ m ->
      Delta ≪ Gamma ⊢csc phi @ (ReplacePrinInModality pth q)
  | CSCFwdL : forall Delta Gamma phi m p q
                (pth : PathToPrinInModality m q) b,
      Path (phi @ m) Gamma ->
      Gamma ⊢ (canWrite q (LabelAtPrin pth)) @ (FwdModality pth p) ->
      Gamma ⊢ (canRead p (LabelAtPrin pth)) @ (FwdModality pth q) ->
      Delta ≪ (phi @ ReplacePrinInModality pth p :: Gamma) ⊢csc b ->
      Delta ≪ Gamma ⊢csc b
  where "Delta ≪ Gamma ⊢csc b" := (CompatibleSupercontext Delta Gamma b).

  Definition CSCPermL :
    forall Delta1 Delta2 Gamma b,
      Delta1 ≪ Gamma ⊢csc b -> Permutation Delta1 Delta2 -> Delta2 ≪ Gamma ⊢csc b :=
    fun Delta1 Delta2 Gamma b Δcsc perm =>
      CSCPermutation Delta1 Delta2 Gamma Gamma b perm (Permutation_refl Gamma) Δcsc.
  Definition CSCPermR :
    forall Delta Gamma1 Gamma2 b,
      Delta ≪ Gamma1 ⊢csc b -> Permutation Gamma1 Gamma2 -> Delta ≪ Gamma2 ⊢csc b :=
    fun Delta Gamma1 Gamma2 b Δcsc perm =>
      CSCPermutation Delta Delta Gamma1 Gamma2 b (Permutation_refl Delta) perm Δcsc.

  Open Scope bool_scope.

  Definition ContextEqBool : Context -> Context -> bool :=
    fun Gamma Delta => if ContextEqDec Gamma Delta then true else false.

  Infix "=ctxt=" := ContextEqBool (at level 20).

  Lemma ContextEqBoolRefl : forall Gamma, Gamma =ctxt= Gamma = true.
  Proof.
    intros Gamma.
    unfold ContextEqBool. destruct (ContextEqDec Gamma Gamma); auto.
  Qed.

  Lemma ContextEqBoolEqual : forall {Gamma Delta}, Gamma =ctxt= Delta = true -> Gamma = Delta.
  Proof.
    intros Gamma Delta H.
    unfold ContextEqBool in H. destruct (ContextEqDec Gamma Delta); auto.
    inversion H.
  Qed.

  Fixpoint ContextAppearsInProof {Gamma : Context} {b : Belief} (Delta : Context) (pf : Gamma ⊢ b) : bool :=
    match pf with
    | axiom Gamma _ _ _ => Gamma =ctxt= Delta
    | TTR Gamma _ _ _ => Gamma =ctxt= Delta
    | FFL Gamma _ _ _ _ _ _ _ _ => Gamma =ctxt= Delta
    | AndL Gamma _ _ _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | AndR Gamma _ _ _ pf1 pf2 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1 || ContextAppearsInProof Delta pf2
    | OrL Gamma _ _ _ _ _ pf1 pf2 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1 || ContextAppearsInProof Delta pf2
    | OrR1 Gamma _ _ _ pf1 _ => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | OrR2 Gamma _ _ _ pf1 _ => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | ImpL Gamma _ _ _ _ _ _ pf1 pf2 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1 || ContextAppearsInProof Delta pf2
    | ImpR Gamma _ _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | forallL Gamma _ _ _ _ _ _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | forallR Gamma _ _ _ _ _ _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | existsL Gamma _ _ _ _ _ _ _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | existsR Gamma _ _ _ _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | flowsToRefl Gamma _ _ _ _ _ => Gamma =ctxt= Delta
    | flowsToTransR Gamma _ _ _ _ pf1 pf2 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1 || ContextAppearsInProof Delta pf2
    | saysR Gamma _ _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | saysL Gamma _ _ _ _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | modalityExpandR Gamma _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | modalityCollapseR Gamma _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | modalityExpandL Gamma _ _ _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | modalityCollapseL Gamma _ _ _ _ _ pf1 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1
    | RVariance Gamma _ _ _ _ _ pf1 pf2 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1 || ContextAppearsInProof Delta pf2
    | LVariance Gamma _ _ _ _ _ _ _ pf1 pf2 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1 || ContextAppearsInProof Delta pf2
    | FwdR Gamma _ _ _ _ _ pf1 pf2 pf3 =>
      Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1 || ContextAppearsInProof Delta pf2 || ContextAppearsInProof Delta pf3
    | FwdL Gamma _ _ _ _ _ _ _ pf1 pf2 pf3 =>
      Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1 || ContextAppearsInProof Delta pf2 || ContextAppearsInProof Delta pf3
    | CRVariance Gamma _ _ _ _ pf1 pf2 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1 || ContextAppearsInProof Delta pf2
    | CWVariance Gamma _ _ _ _ pf1 pf2 => Gamma =ctxt= Delta || ContextAppearsInProof Delta pf1 || ContextAppearsInProof Delta pf2
    end.

  Lemma ContextAppearsHere : forall {Gamma : Context} {b : Belief} (pf : Gamma ⊢ b), ContextAppearsInProof Gamma pf = true.
  Proof.
    intros Gamma b pf.
    induction pf; simpl; try (rewrite ContextEqBoolRefl; simpl; auto).
  Qed.

  Hint Constructors CompatibleSupercontext.
  Theorem CompatibleSupercontextProperty : forall {Gamma : Context} {b : Belief} (Delta : Context) (pf : Gamma ⊢ b),
      ContextAppearsInProof Delta pf = true -> Delta ≪ Gamma ⊢csc b.
  Proof.
    intros Gamma b Delta pf H.
    induction pf; simpl in *;
      repeat match goal with
             | [ H : ?Delta ≪ ?Gamma ⊢csc ?l1 ⊑ ?l2 @ ?m |- ?Delta ≪ ?Gamma ⊢csc _ ] =>
               apply CSCAtomic with (phi := l1 ⊑ l2) (m := m); [constructor | exact H]
             | [ H : _ || _ = true |- _ ] =>
               apply Bool.orb_prop in H; destruct H
             | [ H : Gamma =ctxt= Delta = true |- _ ] =>
               match goal with
               | [ _ : Gamma = Delta |- _ ] => fail 1
               | _ => pose proof (ContextEqBoolEqual H)
               end
             | [e : ?Gamma = ?Delta |- ?Delta ≪ ?Gamma ⊢csc ?b ] => rewrite e; apply CSCRefl
             | [e : ?Delta = ?Gamma |- ?Delta ≪ ?Gamma ⊢csc ?b ] => rewrite e; apply CSCRefl
             | [ H1 : ?P, H2 : ?P -> _ |- _ ] => specialize (H2 H1)
             end; auto.
    7: apply CSCForallR with (y := y); auto.
    8: apply CSCExistsR with (t := t); auto.
    all: eauto.
    all: eapply CSCAtomic; eauto.
    all: try (constructor; auto;
              match goal with
              | [H : ContextAppearsInProof ?Delta ?pf = true |- _ ] =>
                clear H; apply provenProperBelief in pf; simpl in pf; destruct pf;
                match goal with
                | [H' : ⊢wff _ |- _ ] => inversion H'; auto
                end
              end; fail).
    all: try (match goal with
              | [H : ContextAppearsInProof _ ?pf = true |- _ ] =>
                clear H; apply provenProperBelief in pf; simpl in pf; destruct pf; auto
              end).
  Qed.

  Theorem CompatibleSupercontextProper : forall (Delta Gamma : Context) (b : Belief),
      ProperContext Gamma -> ProperBelief b -> Delta ≪ Gamma ⊢csc b -> ProperContext Delta.
  Proof.
    intros Delta Gamma b H H0 H1.
    induction H1; auto.
    - apply AppProperContext;
      [apply IHCompatibleSupercontext1 | apply IHCompatibleSupercontext2]; auto.
    - apply ProperContextIff with (Gamma := Delta1).
      intros b0. split. intro Hd1. apply Permutation_in with (l := Delta1); auto.
      intro Hd2; apply Permutation_in with(l := Delta2); auto.
      symmetry; auto.
      apply IHCompatibleSupercontext; auto.
      apply ProperContextIff with (Gamma := Gamma2); auto.
      intro b0; split; intro; eapply Permutation_in; [symmetry| | |]; eauto.
    - apply IHCompatibleSupercontext; auto.
      simpl; split; auto.
    - apply ProperContextCons; auto.
      apply ConsProperContext in H; destruct H; auto.
      apply IHCompatibleSupercontext; auto.
      apply ConsProperContext in H; destruct H; auto.
    - apply IHCompatibleSupercontext; auto.
      assert (ProperBelief (phi & psi @ m))
      by (apply BeliefInProperContextIsProper with (Gamma := Gamma); auto;
          apply PathToIn; auto).
      simpl in H3. destruct H3. inversion H4.
      apply ProperContextCons; [| apply ProperContextCons]; simpl; [split|split|]; auto.
    - apply IHCompatibleSupercontext; auto.
      destruct H0; simpl; split; auto. inversion H2; auto.
    - apply IHCompatibleSupercontext; auto.
      destruct H0; simpl; split; auto. inversion H2; auto.
    - apply IHCompatibleSupercontext; auto.
      apply ProperContextCons; auto.
      apply PathToIn in H1. apply BeliefInProperContextIsProper in H1; auto.
      inversion H1. inversion H4. split; auto.
    - apply IHCompatibleSupercontext; auto.
      apply ProperContextCons; auto.
      apply PathToIn in H1. apply BeliefInProperContextIsProper in H1; auto.
      inversion H1. inversion H4. split; auto.
    - apply IHCompatibleSupercontext; auto.
      inversion H0. inversion H3. split; auto.
    - apply IHCompatibleSupercontext; auto.
      inversion H0. inversion H3. split; auto.
    - apply IHCompatibleSupercontext; auto.
      apply ProperContextCons; auto.
      apply PathToIn in H1. apply BeliefInProperContextIsProper in H1; auto.
      inversion H1. inversion H4. split; auto.
    - apply IHCompatibleSupercontext; auto.
      apply PathToIn in H1. apply BeliefInProperContextIsProper in H1; auto.
      inversion H1. inversion H4. split; auto. constructor; auto.
    - inversion H0; inversion H3. apply IHCompatibleSupercontext.
           apply ProperContextCons; auto.
      all: split; auto. constructor; auto.
    - apply IHCompatibleSupercontext; auto.
      apply PathToIn in H1. apply BeliefInProperContextIsProper in H1; auto.
      inversion H1. inversion H6.
      pose (x := freshVar (L ++ varsInFormula phi) sigma).
      assert (~ In x L) as HxL
        by (intro Hx; apply freshVarNotIn with (vs := L ++ varsInFormula phi) (sigma := sigma);
            apply in_or_app; left; fold x; auto).
      assert (⊢s varTerm x ::: sigma) as x_term_sort
          by (unfold x;
              rewrite <- freshVarSameSort with (vs := L ++ varsInFormula phi) (sigma := sigma) at 2;
              apply varS).
      specialize (H8 x HxL x_term_sort).
      apply WellFormedSubst with (t := t) (x := x) in H8; auto.
      rewrite open_formula_subst in H8; auto.
      rewrite notFreeInFormulaSubstEq in H8; auto.
      simpl in H8.
      destruct (varEqDec x x) as [e|n]; [clear e| exfalso; apply n; reflexivity].
      apply ProperContextCons; [split|]; auto.
      intro fvf; apply FreeVarsInFormula in fvf.
      apply freshVarNotIn with (vs := L ++ varsInFormula phi) (sigma := sigma).
      fold x. apply in_or_app; right; auto.
      unfold x. rewrite freshVarSameSort; auto.
    - apply IHCompatibleSupercontext; auto.
      inversion H0. inversion H7.
      pose (x := freshVar (L ++ varsInFormula phi) sigma).
      assert (~ In x L) as HxL
        by (intro Hx; apply freshVarNotIn with (vs := L ++ varsInFormula phi) (sigma := sigma);
            apply in_or_app; left; fold x; auto).
      assert (⊢s varTerm x ::: sigma) as x_term_sort
          by (unfold x;
              rewrite <- freshVarSameSort with (vs := L ++ varsInFormula phi) (sigma := sigma) at 2;
              apply varS).
      specialize (H9 x HxL x_term_sort).
      apply WellFormedSubst with (t := varTerm y) (x := x) in H9; auto.
      rewrite open_formula_subst in H9; auto.
      rewrite notFreeInFormulaSubstEq in H9; auto.
      simpl in H9.
      destruct (varEqDec x x) as [e|n]; [clear e| exfalso; apply n; reflexivity].
      split; auto.
      intro fvf; apply FreeVarsInFormula in fvf.
      apply freshVarNotIn with (vs := L ++ varsInFormula phi) (sigma := sigma).
      fold x. apply in_or_app; right; auto. constructor; auto. constructor; auto.
      unfold x. rewrite freshVarSameSort; auto. rewrite <- H1. constructor.
    - apply IHCompatibleSupercontext; auto.
      apply PathToIn in H1. apply BeliefInProperContextIsProper in H1; auto.
      inversion H1. inversion H7.
      pose (x := freshVar (L ++ varsInFormula phi) sigma).
      assert (~ In x L) as HxL
        by (intro Hx; apply freshVarNotIn with (vs := L ++ varsInFormula phi) (sigma := sigma);
            apply in_or_app; left; fold x; auto).
      assert (⊢s varTerm x ::: sigma) as x_term_sort
          by (unfold x;
              rewrite <- freshVarSameSort with (vs := L ++ varsInFormula phi) (sigma := sigma) at 2;
              apply varS).
      specialize (H9 x HxL x_term_sort).
      apply WellFormedSubst with (t := varTerm y) (x := x) in H9; auto.
      rewrite open_formula_subst in H9; auto.
      rewrite notFreeInFormulaSubstEq in H9; auto.
      simpl in H9.
      destruct (varEqDec x x) as [e|n]; [clear e| exfalso; apply n; reflexivity].
      apply ProperContextCons; [split|]; auto.
      intro fvf; apply FreeVarsInFormula in fvf.
      apply freshVarNotIn with (vs := L ++ varsInFormula phi) (sigma := sigma).
      fold x. apply in_or_app; right; auto. constructor; auto. constructor; auto.
      unfold x. rewrite freshVarSameSort; auto. rewrite <- H2. constructor.
    - apply IHCompatibleSupercontext; auto.
      inversion H0. inversion H5.
      pose (x := freshVar (L ++ varsInFormula phi) sigma).
      assert (~ In x L) as HxL
        by (intro Hx; apply freshVarNotIn with (vs := L ++ varsInFormula phi) (sigma := sigma);
            apply in_or_app; left; fold x; auto).
      assert (⊢s varTerm x ::: sigma) as x_term_sort
          by (unfold x;
              rewrite <- freshVarSameSort with (vs := L ++ varsInFormula phi) (sigma := sigma) at 2;
              apply varS).
      specialize (H7 x HxL x_term_sort).
      apply WellFormedSubst with (t := t) (x := x) in H7; auto.
      rewrite open_formula_subst in H7; auto.
      rewrite notFreeInFormulaSubstEq in H7; auto.
      simpl in H7.
      destruct (varEqDec x x) as [e|n]; [clear e| exfalso; apply n; reflexivity].
      split; auto.
      intro fvf; apply FreeVarsInFormula in fvf.
      apply freshVarNotIn with (vs := L ++ varsInFormula phi) (sigma := sigma).
      fold x. apply in_or_app; right; auto.
      unfold x. rewrite freshVarSameSort; auto.
    - apply IHCompatibleSupercontext; auto.
      apply ProperContextCons; auto.
      apply PathToIn in H1; apply BeliefInProperContextIsProper in H1; auto.
      destruct H1. inversion H3. split; auto. constructor; auto.
    - apply IHCompatibleSupercontext; auto.
      destruct H0. inversion H2. split; auto. constructor; auto.
    - apply IHCompatibleSupercontext; auto.
      inversion H0; split; auto. apply CollapseDoubleProper; auto.
    - apply PathToIn in H1. apply BeliefInProperContextIsProper in H1; auto.
      destruct H1. apply IHCompatibleSupercontext; auto.
      apply ProperContextCons; auto. split; auto.
      apply CollapseDoubleProper' with (pth := pth); auto.
    - apply IHCompatibleSupercontext; auto.
      inversion H0; split; auto. apply CollapseDoubleProper' with (pth := pth); auto.
    - apply PathToIn in H1. apply BeliefInProperContextIsProper in H1; auto.
      destruct H1. apply IHCompatibleSupercontext; auto.
      apply ProperContextCons; auto. split; auto.
      apply CollapseDoubleProper; auto.
    - apply IHCompatibleSupercontext; auto. destruct H0; split; auto.
      apply ReplaceLabelInModalityProper' with (l := l1) (l' := l2) (pth := pth); auto.
      apply provenProperBelief in H1. destruct H1. inversion H4; auto.
    - apply IHCompatibleSupercontext; auto; apply ProperContextCons; auto.
      apply PathToIn in H1. apply BeliefInProperContextIsProper in H1; auto.
      destruct H1. split; auto. apply ReplaceLabelInModalityProper; auto.
      apply provenProperBelief in H2; destruct H2. inversion H5; auto.
    - apply IHCompatibleSupercontext; auto.
      destruct H0; split; auto.
      apply ReplacePrinInModalityProper' with (pth := pth) (q := q); auto.
      apply provenProperBelief in H2. destruct H2. inversion H5; auto.
    - apply IHCompatibleSupercontext; auto. apply ProperContextCons; auto.
      apply PathToIn in H1; apply BeliefInProperContextIsProper in H1; auto.
      destruct H1; split; auto.
      apply ReplacePrinInModalityProper; auto.
      apply provenProperBelief in H3. destruct H3. inversion H6; auto.
  Qed.

  Lemma CompatibleSupercontextSuper : forall {Delta Gamma : Context} {b : Belief},
      Delta ≪ Gamma ⊢csc b -> forall b', In b' Gamma -> In b' Delta.
  Proof.
    intros Delta Gamma b H.
    induction H; intros b' b'Γ; auto;
      try (destruct b'Γ; [left; auto | right; apply IHCompatibleSupercontext; auto]; fail);
      try (apply IHCompatibleSupercontext; right; auto; fail).
    - apply in_or_app; left; apply IHCompatibleSupercontext1; auto.
    - apply Permutation_in with (l := Delta1); auto.
      apply IHCompatibleSupercontext; auto.
      apply Permutation_in with (l := Gamma2); auto.
      symmetry; auto.
    - apply IHCompatibleSupercontext. right; right; auto.
  Qed.
End CompatibleSupercontext.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C IB XB IA XA X : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ IB B /\ (wd_ IA A /\ (wd_ XA B /\ (wd_ XB A /\ (wd_ X A /\ (wd_ X B /\ (wd_ XB B /\ (wd_ XA A /\ (col_ A B X /\ (col_ XA X A /\ (col_ XB X B /\ (col_ B XA C /\ (col_ A XB C /\ (col_ A XA IA /\ col_ B XB IB))))))))))))))))) -> col_ A B IB)).
Proof.
  time tac.
Qed.

End FOFProblem.