(* -------------------------------------- Homework 4 --------------------------------------
 *
 *)

Require Import Frap.

(* --- SECTION 1: Adding pairs to STLC  --- *)

(* In this section, we'll add programming constructs for manipulating
 * pairs to the simply typed lambda calculus.  As is typical, there
 * will be constructs for building up pairs and also constructs for
 * taking them apart.
*)

Module StlcWithPairs.
  Inductive exp : Set :=
  | Var (x : var)
  | Const (n : nat)
  | Plus (e1 e2 : exp)
  | Mult (e1 e2 : exp)
  | Abs (x : var) (e1 : exp)
  | App (e1 e2 : exp)

  (* Here we add syntax for the new language features:
   *   - `MkPair` is syntax for constructing the pair of `e1` and `e2`. Like `(e1,e2)` in Coq.
   *   - `Fst` is syntax for projecting out the first element of a pair.
   *   - `Snd` is syntax for projecting out the second element of a pair.
   *)
  | MkPair (e1 e2 : exp)
  | Fst (e : exp)
  | Snd (e : exp).

  Inductive value : exp -> Prop :=
  | VConst : forall n, value (Const n)
  | VAbs : forall x e1, value (Abs x e1)

  (* A pair is a value if both its components are values. *)
  | VMkPair : forall v1 v2, value v1 -> value v2 -> value (MkPair v1 v2).

  (* PROBLEM 1 [4 points, ~3 LOC]
   * Extend the definition of substitution to handle the new language features.
   *
   * Hint: You'll need one new case per new constructor of `exp`.
   *
   * Hint: You'll know you got this right if you can prove the Lemma `substitution` below.
   *)
  Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
    match e2 with
      | Var y => if y ==v x then e1 else Var y
      | Const n => Const n
      | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
      | Mult e2' e2'' => Mult (subst e1 x e2') (subst e1 x e2'')
      | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
      | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
      | MkPair e2' e2'' => MkPair (subst e1 x e2') (subst e1 x e2'')
      | Fst e2' => Fst (subst e1 x e2')
      | Snd e2' => Snd (subst e1 x e2')
    end.

  Inductive context : Set :=
  | Hole : context
  | Plus1 : context -> exp -> context
  | Plus2 : exp -> context -> context
  | Mult1 : context -> exp -> context
  | Mult2 : exp -> context -> context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context

  (* We extend the definition of evaluation contexts to include the new features. *)
  | MkPair1 : context -> exp -> context
  | MkPair2 : exp -> context -> context
  | CFst : context -> context
  | CSnd : context -> context.

  Inductive plug : context -> exp -> exp -> Prop :=
  | PlugHole : forall e, plug Hole e e
  | PlugPlus1 : forall e e' C e2,
    plug C e e'
    -> plug (Plus1 C e2) e (Plus e' e2)
  | PlugPlus2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Plus2 v1 C) e (Plus v1 e')
  | PlugMult1 : forall e e' C e2,
    plug C e e'
    -> plug (Mult1 C e2) e (Mult e' e2)
  | PlugMult2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Mult2 v1 C) e (Mult v1 e')
  | PlugApp1 : forall e e' C e2,
    plug C e e'
    -> plug (App1 C e2) e (App e' e2)
  | PlugApp2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (App2 v1 C) e (App v1 e')

  (* PROBLEM 2 [4 points, ~15 LOC]
   * Extend the definition of `plug` to handle the new language features.
   *
   * Hint: You'll need two new constructors for `MkPair` (similar to the constructors for `App` above).
   *
   * Hint: You'll need one new constructor for each of `Fst` and `Snd`.
   *
   * Hint: You'll know you got this right if you can prove the Lemma `generalize_plug` below.
   *)
  | PlugMkPair1 : forall e e' C e2,
    plug C e e'
    -> plug (MkPair1 C e2) e (MkPair e' e2)
  | PlugMkPair2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (MkPair2 v1 C) e (MkPair v1 e')
  | PlugCFst : forall e e' C,
    plug C e e'
    -> plug (CFst C) e (Fst e')
  | PlugCSnd : forall e e' C,
    plug C e e'
    -> plug (CSnd C) e (Snd e').

  Inductive step0 : exp -> exp -> Prop :=
  | Beta : forall x e v,
    value v
    -> step0 (App (Abs x e) v) (subst v x e)
  | Add : forall n1 n2,
    step0 (Plus (Const n1) (Const n2)) (Const (n1 + n2))
  | Multiply : forall n1 n2,
      step0 (Mult (Const n1) (Const n2)) (Const (n1 * n2))
  (* PROBLEM 3 [4 points, ~10 LOC]
   * Extend the definition of `step0` to handle the new language features.
   *
   * Hint: You'll need two new constructors: one for stepping `fst (v1, v2)` and one for `snd (v1, v2)`.
   *
   * Hint: You'll know you got this right if you can prove the Lemma `preservation0` below.
   *)
  | First : forall v1 v2,
      step0 (Fst (MkPair v1 v2)) v1
  | Second : forall v1 v2,
      step0 (Snd (MkPair v1 v2)) v2.

  Inductive step : exp -> exp -> Prop :=
  | StepRule : forall C e1 e2 e1' e2',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step0 e1 e2
    -> step e1' e2'.

  Definition trsys_of (e : exp) := {|
    Initial := {e};
    Step := step
  |}.

  Inductive type :=
  | Nat                  (* Numbers *)
  | Fun (dom ran : type) (* Functions *)

  (* Here is a type for a pair whose first component has type t1 and whose second component has type t2. *)
  | Pair (t1 t2 : type)  (* Pairs *).

  Inductive hasty : fmap var type -> exp -> type -> Prop :=
  | HtVar : forall G x t,
    G $? x = Some t
    -> hasty G (Var x) t
  | HtConst : forall G n,
    hasty G (Const n) Nat
  | HtPlus : forall G e1 e2,
    hasty G e1 Nat
    -> hasty G e2 Nat
    -> hasty G (Plus e1 e2) Nat
  | HtMult : forall G e1 e2,
    hasty G e1 Nat
    -> hasty G e2 Nat
    -> hasty G (Mult e1 e2) Nat

  | HtAbs : forall G x e1 t1 t2,
    hasty (G $+ (x, t1)) e1 t2
    -> hasty G (Abs x e1) (Fun t1 t2)
  | HtApp : forall G e1 e2 t1 t2,
    hasty G e1 (Fun t1 t2)
    -> hasty G e2 t1
    -> hasty G (App e1 e2) t2

  (* PROBLEM 4 [4 points, ~10 LOC]
   * Extend the definition of `hasty` to handle the new language features.
   *
   * Hint: You'll need one new constructor per new constructor of `exp`.
   *
   * Hint: You'll know you got this right if you can prove all the examples and lemmas below.
   *)
  | HtMkPair : forall G e1 e2 t1 t2,
    hasty G e1 t1
    -> hasty G e2 t2
    -> hasty G (MkPair e1 e2) (Pair t1 t2)
  | HtFst : forall G e t1 t2,
    hasty G e (Pair t1 t2)
    -> hasty G (Fst e) t1
  | HtSnd : forall G e t1 t2,
    hasty G e (Pair t1 t2)
    -> hasty G (Snd e) t2.

  Hint Constructors value plug step0 step hasty.

  Infix "-->" := Fun (at level 60, right associativity).
  Coercion Const : nat >-> exp.
  Infix "^+^" := Plus (at level 50).
  Coercion Var : var >-> exp.
  Notation "\ x , e" := (Abs x e) (at level 51).
  Infix "@" := App (at level 49, left associativity).

  Example one_plus_one : hasty $0 (1 ^+^ 1) Nat.
  Proof.
    repeat (econstructor; simplify).
  Qed.

  Example add : hasty $0 (\"n", \"m", "n" ^+^ "m") (Nat --> Nat --> Nat).
  Proof.
    repeat (econstructor; simplify).
  Qed.

  Example eleven : hasty $0 ((\"n", \"m", "n" ^+^ "m") @ 7 @ 4) Nat.
  Proof.
    repeat (econstructor; simplify).
  Qed.

  Example seven_the_long_way : hasty $0 ((\"x", "x") @ (\"x", "x") @ 7) Nat.
  Proof.
    repeat (econstructor; simplify).
  Qed.

  (* PROBLEM 5 [2 points, ~3 tactics]
   * Prove that the following expression has the given type.
   *
   * Hint: If your definitions are right, the same proof as the examples just above here should work.
   *)
  Example pair_of_one_and_the_increment_function : hasty $0 (MkPair 1 (\"x", "x" ^+^ 1)) (Pair Nat (Nat --> Nat)).
  Proof.
    repeat (econstructor; simplify).
  Qed.

  (* PROBLEM 6 [2 points, ~3 tactics]
   * Prove that the following expression has the given type.
   *
   * Hint: If your definitions are right, the same proof as the examples just above here should work.
   *)
  Example swap_pair_nats : hasty $0 (\"p", MkPair (Fst "p") (Snd "p"))  (Pair Nat Nat --> Pair Nat Nat).
  Proof.
    repeat (econstructor; simplify).
  Qed.

  Definition unstuck e := value e
    \/ (exists e' : exp, step e e').

  (* PROBLEM 7 [4 points, ~30 tactics]
   * Extend the proof of `progress` to handle the new language constructs.
   *
   * Hint: It will help to step through a few of the existing cases in the proof
   * to see how they usually work.
   *)
  Lemma progress : forall e t,
    hasty $0 e t
    -> unstuck e.
  Proof.
    unfold unstuck; induct 1; simplify; try equality.
    - left.
      constructor.
    - propositional.
      + right.
        match goal with
        | [ H1 : value e1, H2 : hasty $0 e1 _ |- _ ] => invert H1; invert H2
        end.
        match goal with
        | [ H1 : value e2, H2 : hasty $0 e2 _ |- _ ] => invert H1; invert H2
        end.
        exists (Const (n + n0)).
        eapply StepRule with (C := Hole).
        eauto.
        eauto.
        constructor.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, step e1 _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        exists (Plus x e2).
        eapply StepRule with (C := Plus1 C e2).
        eauto.
        eauto.
        assumption.
    - propositional.
      + right.
        match goal with
        | [ H1 : value e1, H2 : hasty $0 e1 _ |- _ ] => invert H1; invert H2
        end.
        match goal with
        | [ H1 : value e2, H2 : hasty $0 e2 _ |- _ ] => invert H1; invert H2
        end.
        exists (Const (n * n0)).
        eapply StepRule with (C := Hole).
        eauto.
        eauto.
        constructor.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, step e1 _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        exists (Mult x e2).
        eapply StepRule with (C := Mult1 C e2).
        eauto.
        eauto.
        assumption.
    - left.
      constructor.
    - propositional.
      + right.
        match goal with
        | [ H1 : value e1, H2 : hasty $0 e1 _ |- _ ] => invert H1; invert H2
        end.
        exists (subst e2 x e0).
        eapply StepRule with (C := Hole).
        eauto.
        eauto.
        constructor.
        assumption.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, step e1 _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        exists (App x e2).
        eapply StepRule with (C := App1 C e2).
        eauto.
        eauto.
        assumption.
    - propositional.
      + left.
        econstructor; assumption.
      + right.
        invert H3.
        invert H2.
        eauto.
      + right.
        invert H1.
        invert H2.
        eauto.
      + right.
        invert H1.
        invert H2.
        invert H3.
        invert H2.
        eauto.
    - propositional.
      + right.
        invert H0; invert H.
        assert (step (Fst (MkPair v1 v2)) v1).
        * econstructor; constructor.
        * eexists.
          apply H.
      + right.
        invert H0.
        invert H1.
        eauto.
    - propositional.
      + right.
        invert H0; invert H.
        assert (step (Snd (MkPair v1 v2)) v2).
        * econstructor; constructor.
        * eexists.
          apply H.
      + right.
        invert H0.
        invert H1.
        eauto.
  Qed.

  Lemma weakening_override : forall (G G' : fmap var type) x t,
    (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
    -> (forall x' t', G $+ (x, t) $? x' = Some t'
                      -> G' $+ (x, t) $? x' = Some t').
  Proof.
    simplify.
    cases (x ==v x'); simplify; eauto.
  Qed.

  (* PROBLEM 8 [4 points, ~4 tactics]
   * Extend the proof of `weakening` to handle the new language constructs.
   *
   * Hint: It will help to step through a few of the existing cases in the proof
   * to see how they usually work.
   *)
  Lemma weakening : forall G e t,
    hasty G e t
    -> forall G', (forall x t, G $? x = Some t -> G' $? x = Some t)
      -> hasty G' e t.
  Proof.
    induct 1; simplify.
    - constructor.
      apply H0.
      assumption.
    - constructor.
    - constructor.
      apply IHhasty1.
      assumption.
      apply IHhasty2.
      assumption.
    - constructor.
      apply IHhasty1.
      assumption.
      apply IHhasty2.
      assumption.
    - constructor.
      apply IHhasty.
      apply weakening_override.
      assumption.
    - econstructor.
      apply IHhasty1.
      assumption.
      apply IHhasty2.
      assumption.
    - constructor.
      apply IHhasty1.
      assumption.
      apply IHhasty2.
      assumption.
    - econstructor.
      apply IHhasty.
      assumption.
    - econstructor.
      apply IHhasty.
      assumption.
  Qed.

  Lemma substitution : forall G x t' e t e',
    hasty (G $+ (x, t')) e t
    -> hasty $0 e' t'
    -> hasty G (subst e' x e) t.
  Proof.
    induct 1; simplify.
    - cases (x0 ==v x).
      + simplify.
        invert H.
        eapply weakening.
        eassumption.
        simplify.
        equality.
      + simplify.
        constructor.
        assumption.
    - constructor.
    - constructor.
      eapply IHhasty1; equality.
      eapply IHhasty2; equality.
    - constructor.
      eapply IHhasty1; equality.
      eapply IHhasty2; equality.
    - cases (x0 ==v x).
      + constructor.
        eapply weakening.
        eassumption.
        simplify.
        cases (x0 ==v x1).
        * simplify.
          assumption.
        * simplify.
          assumption.
      + constructor.
        eapply IHhasty.
        maps_equal.
        assumption.
    - econstructor.
      eapply IHhasty1; equality.
      eapply IHhasty2; equality.
    - constructor.
      + eapply IHhasty1; equality.
      + eapply IHhasty2; equality.
    - econstructor.
      apply IHhasty; equality.
    - econstructor.
      apply IHhasty; equality.
  Qed.

  (* PROBLEM 10 [4 points, ~7 tactics]
   * Extend the proof of `preservation0` to handle the new language constructs.
   *
   * Hint: It will help to step through a few of the existing cases in the proof
   * to see how they usually work.
   *)
  Lemma preservation0 : forall e1 e2,
    step0 e1 e2
    -> forall t, hasty $0 e1 t
      -> hasty $0 e2 t.
  Proof.
    invert 1; simplify.
    - invert H.
      invert H4.
      eapply substitution.
      + eassumption.
      + assumption.
    - invert H.
      constructor.
    - invert H.
      constructor.
    - invert H.
      invert H2.
      assumption.
    - invert H.
      invert H2.
      assumption.
  Qed.

  (* PROBLEM 11 [4 points, ~15 tactics]
   * Extend the proof of `generalize_plug` to handle the new language constructs.
   *
   * Hint: It will help to step through a few of the existing cases in the proof
   * to see how they usually work.
   *)
  Lemma generalize_plug : forall e1 C e1',
    plug C e1 e1'
    -> forall e2 e2', plug C e2 e2'
      -> (forall t, hasty $0 e1 t -> hasty $0 e2 t)
      -> (forall t, hasty $0 e1' t -> hasty $0 e2' t).
  Proof.
    induct 1; simplify.
    - invert H.
      apply H0.
      assumption.
    - invert H0.
      invert H2.
      constructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * assumption.
      + assumption.
    - invert H1.
      invert H3.
      constructor.
      + assumption.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * assumption.
    - invert H0.
      invert H2.
      constructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * assumption.
      + assumption.
    - invert H1.
      invert H3.
      constructor.
      + assumption.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * assumption.
    - invert H0.
      invert H2.
      econstructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
      + assumption.
    - invert H1.
      invert H3.
      econstructor.
      + eassumption.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
    - invert H0.
      invert H2.
      econstructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
      + assumption.
    - invert H1.
      invert H3.
      econstructor.
      + eassumption.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
    - invert H0.
      invert H2.
      econstructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
    - invert H0.
      invert H2.
      econstructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
  Qed.

  (* This proof should go through without modifications. *)
  Lemma preservation : forall e1 e2,
    step e1 e2
    -> forall t, hasty $0 e1 t
      -> hasty $0 e2 t.
  Proof.
    invert 1; simplify.

    eapply generalize_plug with (e1' := e1).
    - eassumption.
    - eassumption.
    - simplify.
      eapply preservation0.
      + eassumption.
      + assumption.
    - assumption.
  Qed.

  (* This proof should go through without modifications. *)
  Theorem safety : forall e t, hasty $0 e t
    -> invariantFor (trsys_of e) unstuck.
  Proof.
    simplify.
    apply invariant_weaken with (invariant1 := fun e' => hasty $0 e' t).
    - apply invariant_induction; simplify.
      + equality.

      + eapply preservation.
        * eassumption.
        * assumption.
    - simplify.
      eapply progress.
      eassumption.
  Qed.
End StlcWithPairs.

(* This language doesn't have any support for recursion, and, unlike in the
 * untyped lambda calculus, we can't use the Y combinator to get recursion for
 * free. In fact, one can prove (using methods beyond the scope of this course)
 * that all well typed programs in STLC or STLC-with-pairs terminate. Since there
 * are programs that use general recursion or the Y combinator to loop for ever,
 * we know no such thing can be expressed in these languages.
 *)

(* PROBLEM 12 [4 points, ~1 sentences]
 * Is there a program in STLC (or STLC-with-pairs) of type Nat --> Nat that
 * implements the factorial function? If so, write it down. If not, why not?
 * Either way, your answer can be informal.
 *
 * Hint: Notice that the factorial function always terminates. So it would not
 * be correct to say "there is no such program because all programs in STLC
 * terminate but factorial doesn't".
 *)

(* No, because the type system could not infer a type on a recursive function.
   Factorial has a "base case" that leads to termination, but the type system
   cannot perceive this. *)

(* In any case, in order to get full-blown recursion (and potential nontermination)
 * we can add a new feature to the language. *)

(* --- SECTION 2: Adding recursion to STLC via `fix`  --- *)

Module StlcWithFix.
  Inductive exp : Set :=
  | Var (x : var)
  | Const (n : nat)
  | Plus (e1 e2 : exp)
  | Mult (e1 e2 : exp)
  | Abs (x : var) (e1 : exp)
  | App (e1 e2 : exp)

  (* Here we add syntax for recursion. The program `Fix e` evaluates
   * e to a function and then calls that function with the argument `Fix e`. q*)
  | Fix (e : exp)

  (* Let's also add a few other features so that we can write some more interesting programs. *)
  | IfZero (e1 e2 e3 : exp)  (* if e1 evaluates to 0, then evaluate e2, else evaluate e3 *)
  | Minus (e1 e2 : exp)
  .

  Inductive value : exp -> Prop :=
  | VConst : forall n, value (Const n)
  | VAbs : forall x e1, value (Abs x e1).

  (* PROBLEM 13 [4 points, ~2 LOC]
   * Extend the definition of substitution to handle the new language features.
   *
   * We've given you the case for Fix.
   *
   * Hint: You'll need one new case per new constructor of `exp` besides `Fix`.
   *
   * Hint: You'll know you got this right if you can prove the Lemma `substitution` below.
   *)
  Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
    match e2 with
      | Var y => if y ==v x then e1 else Var y
      | Const n => Const n
      | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
      | Mult e2' e2'' => Mult (subst e1 x e2') (subst e1 x e2'')
      | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
      | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')

      (* there's nothing special about substituting into a Fix *)
      | Fix e2' => Fix (subst e1 x e2')

      (* YOUR CODE HERE *)
      | IfZero e2' e2'' e2''' => IfZero (subst e1 x e2') (subst e1 x e2'') (subst e1 x e2''')
      | Minus e2' e2'' => Minus (subst e1 x e2') (subst e1 x e2'')
    end.

  Inductive context : Set :=
  | Hole : context
  | Plus1 : context -> exp -> context
  | Plus2 : exp -> context -> context
  | Mult1 : context -> exp -> context
  | Mult2 : exp -> context -> context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context

  (* We extend the definition of evaluation contexts to include evaluating under `fix`. *)
  | CFix : context -> context
  | CIfZero : context -> exp -> exp -> context
  | Minus1 : context -> exp -> context
  | Minus2 : exp -> context -> context
  .

  Inductive plug : context -> exp -> exp -> Prop :=
  | PlugHole : forall e, plug Hole e e
  | PlugPlus1 : forall e e' C e2,
    plug C e e'
    -> plug (Plus1 C e2) e (Plus e' e2)
  | PlugPlus2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Plus2 v1 C) e (Plus v1 e')
  | PlugMult1 : forall e e' C e2,
    plug C e e'
    -> plug (Mult1 C e2) e (Mult e' e2)
  | PlugMult2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Mult2 v1 C) e (Mult v1 e')
  | PlugApp1 : forall e e' C e2,
    plug C e e'
    -> plug (App1 C e2) e (App e' e2)
  | PlugApp2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (App2 v1 C) e (App v1 e')

  (* There's nothing special about plugging into a Fix. *)
  | PlugFix : forall e e' C,
      plug C e e' ->
      plug (CFix C) e (Fix e')

  (* PROBLEM 14 [4 points, ~10 LOC]
   * Extend the definition of `plug` to handle the new language features.
   *
   * We've added the constructor for Fix above. You just need to handle the other features.
   *
   * Hint: You'll need one new constructor corresponding to IfZero, and two for Minus.
   *
   * Hint: You'll know you got this right if you can prove the Lemma `generalize_plug` below.
   *)
  | PlugIfZero : forall C e e' e2 e3,
    plug C e e'
    -> plug (CIfZero C e2 e3) e (IfZero e' e2 e3)
  | PlugMinus1 : forall e e' C e2,
    plug C e e'
    -> plug (Minus1 C e2) e (Minus e' e2)
  | PlugMinus2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Minus2 v1 C) e (Minus v1 e').

  Inductive step0 : exp -> exp -> Prop :=
  | Beta : forall x e v,
    value v
    -> step0 (App (Abs x e) v) (subst v x e)
  | Add : forall n1 n2,
    step0 (Plus (Const n1) (Const n2)) (Const (n1 + n2))
  | Multiply : forall n1 n2,
      step0 (Mult (Const n1) (Const n2)) (Const (n1 * n2))

  (* Here's how we evaluate fix: substitute it in itself! :mindblown: *)
  | FixUnroll : forall x e,
      step0 (Fix (Abs x e)) (subst (Fix (Abs x e)) x e)

  (* And here's how we evaluate IfZero. *)
  | IfZeroZero : forall e2 e3,
      step0 (IfZero (Const 0) e2 e3) e2
  | IfZeroNonZero : forall n e2 e3,
      step0 (IfZero (Const (S n)) e2 e3) e3

  (* PROBLEM 15 [4 points, ~2 LOC]
   * Extend the definition of `step0` to handle Minus.
   *
   * Hint: It's like the rule for Plus, but it subtracts instead of adds.
   *)
  | Subtract : forall n1 n2,
    step0 (Minus (Const n1) (Const n2)) (Const (n1 - n2)).

  Inductive step : exp -> exp -> Prop :=
  | StepRule : forall C e1 e2 e1' e2',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step0 e1 e2
    -> step e1' e2'.

  Definition trsys_of (e : exp) := {|
    Initial := {e};
    Step := step
  |}.

  Inductive type :=
  | Nat                  (* Numbers *)
  | Fun (dom ran : type) (* Functions *).

  Inductive hasty : fmap var type -> exp -> type -> Prop :=
  | HtVar : forall G x t,
    G $? x = Some t
    -> hasty G (Var x) t
  | HtConst : forall G n,
    hasty G (Const n) Nat
  | HtPlus : forall G e1 e2,
    hasty G e1 Nat
    -> hasty G e2 Nat
    -> hasty G (Plus e1 e2) Nat
  | HtMult : forall G e1 e2,
    hasty G e1 Nat
    -> hasty G e2 Nat
    -> hasty G (Mult e1 e2) Nat

  | HtAbs : forall G x e1 t1 t2,
    hasty (G $+ (x, t1)) e1 t2
    -> hasty G (Abs x e1) (Fun t1 t2)
  | HtApp : forall G e1 e2 t1 t2,
    hasty G e1 (Fun t1 t2)
    -> hasty G e2 t1
    -> hasty G (App e1 e2) t2

  (* PROBLEM 16 [4 points, ~3 LOC]
   * Extend the definition of `hasty` to handle fix.
   *
   * Hint: You'll need one new constructor for fix.
   *
   * Hint: Translate the following typing rule into code:
   *
   *            G |- e : t -> t
   *         ---------------------
   *            G |- fix e : t
   *
   * In other words, if e is a function from t to t, then fix e has type t.
   *)
  | HtFix : forall G e t,
    hasty G e (Fun t t)
    -> hasty G (Fix e) t

  (* PROBLEM 17 [4 points, ~10 LOC]
   * Extend the definition of `hasty` to handle IfZero and Minus.
   *
   * Hint: You'll need one new constructor for IfZero and one for Minus.
   *
   * Hint: For IfZero, translate the following typing rule into code:
   *
   *            G |- e1 : Nat       G |- e2 : t        G |- e3 : t
   *     ---------------------------------------------------------------
   *                          G |- IfZero e1 e2 e3 : t
   *
   * Hint: Minus is similar to Plus.
   *)
  | HtIfZero : forall G e1 e2 e3 t,
    hasty G e1 Nat
    -> hasty G e2 t
    -> hasty G e3 t
    -> hasty G (IfZero e1 e2 e3) t
  | HtMinus : forall G e1 e2,
    hasty G e1 Nat
    -> hasty G e2 Nat
    -> hasty G (Minus e1 e2) Nat.

  Hint Constructors value plug step0 step hasty.

  Infix "-->" := Fun (at level 60, right associativity).
  Coercion Const : nat >-> exp.
  Infix "^+^" := Plus (at level 50).
  Infix "^*^" := Mult (at level 50).
  Infix "^-^" := Minus (at level 50).
  Coercion Var : var >-> exp.
  Notation "\ x , e" := (Abs x e) (at level 51).
  Infix "@" := App (at level 49, left associativity).

  Example one_plus_one : hasty $0 (1 ^+^ 1) Nat.
  Proof.
    repeat (econstructor; simplify).
  Qed.

  Example add : hasty $0 (\"n", \"m", "n" ^+^ "m") (Nat --> Nat --> Nat).
  Proof.
    repeat (econstructor; simplify).
  Qed.

  Example eleven : hasty $0 ((\"n", \"m", "n" ^+^ "m") @ 7 @ 4) Nat.
  Proof.
    repeat (econstructor; simplify).
  Qed.

  Example seven_the_long_way : hasty $0 ((\"x", "x") @ (\"x", "x") @ 7) Nat.
  Proof.
    repeat (econstructor; simplify).
  Qed.

  (* Here's a program that uses all the new features we added to implement factorial. *)
  Definition factorial_exp : exp :=
    Fix (\"rec", (\"n", IfZero "n" 1 ("n" ^*^ ("rec" @ ("n" ^-^ 1))))).

  (* PROBLEM 18 [4 points, ~3 tactics]
   * Prove that the following expression has the given type.
   *
   * Hint: If your definitions are right, the same proof as the examples just above here should work.
   *)
  Example factorial_ht :
    hasty $0 factorial_exp (Nat --> Nat).
  Proof.
    repeat (econstructor; simplify).
  Qed.

  (* Here's a proof that the above factorial expression applied to 5 evaluates to 120. *)
  Example factorial_of_5 :
    trc step (factorial_exp @ 5) 120.
  Proof.
    (* Uncomment this proof once you've added constructors to step0 for Minus. *)
    unfold factorial_exp.
    repeat (econstructor; [now eauto 20|simplify]).
    apply TrcRefl.
  Qed.

  (* PROBLEM 19 [4 points, ~2 LOC]
   * Implement an expression `fib` that returns the nth Fibonacci number.
   *)
  Definition fib_exp : exp :=
    Fix
      (\"rec",
        (\"n",
          IfZero
            "n"
            1
            (IfZero
              ("n" ^-^ 1)
              1
              (("rec" @ ("n" ^-^ 1)) ^+^ ("rec" @ ("n" ^-^ 2)))
        ))).

  (* PROBLEM 20 [4 points, ~3 tactics]
   * Prove that your definition of fib is well typed.
   *
   * Hint: If your definitions are right, the same proof as the examples just above here should work.
   *)
  Example fib_ht :
    hasty $0 fib_exp (Nat --> Nat).
  Proof.
    repeat (econstructor; simplify).
  Qed.

  (* PROBLEM 21 [4 points, ~5 tactics]
   * Prove that your definition of fib correctly computes that the 5th fibonacci
   * number is 5. (We pass 4 as the argument because the argument is 0-indexed.)
   *
   * Hint: If your definitions are right, the same proof as factorial_of_5 should work.
   *)
  Example fib_of_4 :
    trc step (fib_exp @ 4) 5.
  Proof.
    unfold fib_exp.
    repeat (econstructor; [now eauto 20|simplify]).
    apply TrcRefl.
  Qed.

  Definition unstuck e := value e
    \/ (exists e' : exp, step e e').

  (* PROBLEM 22 [4 points, ~35 tactics]
   * Extend the proof of `progress` to handle the new language constructs.
   *
   * Hint: It will help to step through a few of the existing cases in the proof
   * to see how they usually work.
   *)
  Lemma progress : forall e t,
    hasty $0 e t
    -> unstuck e.
  Proof.
    unfold unstuck; induct 1; simplify; try equality.
    - left.
      constructor.
    - propositional.
      + right.
        match goal with
        | [ H1 : value e1, H2 : hasty $0 e1 _ |- _ ] => invert H1; invert H2
        end.
        match goal with
        | [ H1 : value e2, H2 : hasty $0 e2 _ |- _ ] => invert H1; invert H2
        end.
        exists (Const (n + n0)).
        eapply StepRule with (C := Hole).
        eauto.
        eauto.
        constructor.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, step e1 _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        exists (Plus x e2).
        eapply StepRule with (C := Plus1 C e2).
        eauto.
        eauto.
        assumption.
    - propositional.
      + right.
        match goal with
        | [ H1 : value e1, H2 : hasty $0 e1 _ |- _ ] => invert H1; invert H2
        end.
        match goal with
        | [ H1 : value e2, H2 : hasty $0 e2 _ |- _ ] => invert H1; invert H2
        end.
        exists (Const (n * n0)).
        eapply StepRule with (C := Hole).
        eauto.
        eauto.
        constructor.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, step e1 _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        exists (Mult x e2).
        eapply StepRule with (C := Mult1 C e2).
        eauto.
        eauto.
        assumption.
    - left.
      constructor.
    - propositional.
      + right.
        match goal with
        | [ H1 : value e1, H2 : hasty $0 e1 _ |- _ ] => invert H1; invert H2
        end.
        exists (subst e2 x e0).
        eapply StepRule with (C := Hole).
        eauto.
        eauto.
        constructor.
        assumption.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, step e1 _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        exists (App x e2).
        eapply StepRule with (C := App1 C e2).
        eauto.
        eauto.
        assumption.
    - propositional.
      + admit.
      + right.
        invert H0.
        invert H1.
        eauto.
    - propositional.
      + admit.
      + admit.
      + admit.
      + admit.
      + admit.
      + admit.
      + admit.
      + admit.
    - propositional.
      + right.
        match goal with
        | [ H1 : value e1, H2 : hasty $0 e1 _ |- _ ] => invert H1; invert H2
        end.
        match goal with
        | [ H1 : value e2, H2 : hasty $0 e2 _ |- _ ] => invert H1; invert H2
        end.
        exists (Const (n - n0)).
        eapply StepRule with (C := Hole).
        eauto.
        eauto.
        constructor.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        eauto.
      + match goal with
        | [ H : exists x, step e1 _ |- _ ] => invert H
        end.
        match goal with
        | [ H : step _ _ |- _ ] => invert H
        end.
        right.
        exists (Minus x e2).
        eapply StepRule with (C := Minus1 C e2).
        eauto.
        eauto.
        assumption.
  Admitted. (* Change to Qed when done *)

  Lemma weakening_override : forall (G G' : fmap var type) x t,
    (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
    -> (forall x' t', G $+ (x, t) $? x' = Some t'
                      -> G' $+ (x, t) $? x' = Some t').
  Proof.
    simplify.
    cases (x ==v x'); simplify; eauto.
  Qed.

  (* PROBLEM 23 [4 points, ~4 tactics]
   * Extend the proof of `weakening` to handle the new language constructs.
   *
   * Hint: It will help to step through a few of the existing cases in the proof
   * to see how they usually work.
   *)
  Lemma weakening : forall G e t,
    hasty G e t
    -> forall G', (forall x t, G $? x = Some t -> G' $? x = Some t)
      -> hasty G' e t.
  Proof.
    induct 1; simplify.
    - constructor.
      apply H0.
      assumption.
    - constructor.
    - constructor.
      apply IHhasty1.
      assumption.
      apply IHhasty2.
      assumption.
    - constructor.
      apply IHhasty1.
      assumption.
      apply IHhasty2.
      assumption.
    - constructor.
      apply IHhasty.
      apply weakening_override.
      assumption.
    - econstructor.
      apply IHhasty1.
      assumption.
      apply IHhasty2.
      assumption.
    - constructor.
      apply IHhasty.
      assumption.
    - constructor.
      apply IHhasty1.
      assumption.
      apply IHhasty2.
      assumption.
      apply IHhasty3.
      assumption.
    - constructor.
      apply IHhasty1.
      assumption.
      apply IHhasty2.
      assumption.
  Qed.

  (* PROBLEM 24 [4 points, ~4 tactics]
   * Extend the proof of `substitution` to handle the new language constructs.
   *
   * Hint: It will help to step through a few of the existing cases in the proof
   * to see how they usually work.
   *)
  Lemma substitution : forall G x t' e t e',
    hasty (G $+ (x, t')) e t
    -> hasty $0 e' t'
    -> hasty G (subst e' x e) t.
  Proof.
    induct 1; simplify.
    - cases (x0 ==v x).
      + simplify.
        invert H.
        eapply weakening.
        eassumption.
        simplify.
        equality.
      + simplify.
        constructor.
        assumption.
    - constructor.
    - constructor.
      eapply IHhasty1; equality.
      eapply IHhasty2; equality.
    - constructor.
      eapply IHhasty1; equality.
      eapply IHhasty2; equality.
    - cases (x0 ==v x).
      + constructor.
        eapply weakening.
        eassumption.
        simplify.
        cases (x0 ==v x1).
        * simplify.
          assumption.
        * simplify.
          assumption.
      + constructor.
        eapply IHhasty.
        maps_equal.
        assumption.
    - econstructor.
      eapply IHhasty1; equality.
      eapply IHhasty2; equality.
    - econstructor.
      eapply IHhasty; equality.
    - econstructor.
      + eapply IHhasty1; equality.
      + eapply IHhasty2; equality.
      + eapply IHhasty3; equality.
    - constructor.
      + eapply IHhasty1; equality.
      + eapply IHhasty2; equality.
  Qed.

  (* PROBLEM 25 [4 points, ~15 tactics]
   * Extend the proof of `preservation0` to handle the new language constructs.
   *
   * Hint: It will help to step through a few of the existing cases in the proof
   * to see how they usually work.
   *)
  Lemma preservation0 : forall e1 e2,
    step0 e1 e2
    -> forall t, hasty $0 e1 t
      -> hasty $0 e2 t.
  Proof.
    invert 1; simplify.

    - invert H.
      invert H4.
      eapply substitution.
      + eassumption.
      + assumption.
    - invert H.
      constructor.
    - invert H.
      constructor.
    - invert H.
      invert H2.
      eapply substitution.
      + eassumption.
      + econstructor.
        econstructor.
        assumption.
    - invert H.
      assumption.
    - invert H.
      assumption.
    - invert H.
      constructor.
  Qed.

  (* PROBLEM 26 [4 points, ~15 tactics]
   * Extend the proof of `generalize_plug` to handle the new language constructs.
   *
   * Hint: It will help to step through a few of the existing cases in the proof
   * to see how they usually work.
   *)
  Lemma generalize_plug : forall e1 C e1',
    plug C e1 e1'
    -> forall e2 e2', plug C e2 e2'
      -> (forall t, hasty $0 e1 t -> hasty $0 e2 t)
      -> (forall t, hasty $0 e1' t -> hasty $0 e2' t).
  Proof.
    induct 1; simplify.
    - invert H.
      apply H0.
      assumption.
    - invert H0.
      invert H2.
      constructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * assumption.
      + assumption.
    - invert H1.
      invert H3.
      constructor.
      + assumption.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * assumption.
    - invert H0.
      invert H2.
      constructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * assumption.
      + assumption.
    - invert H1.
      invert H3.
      constructor.
      + assumption.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * assumption.
    - invert H0.
      invert H2.
      econstructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
      + assumption.
    - invert H1.
      invert H3.
      econstructor.
      + eassumption.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
    - invert H0.
      invert H2.
      econstructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
    - invert H0.
      invert H2.
      econstructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
      + eassumption.
      + eassumption.
    - invert H0.
      invert H2.
      econstructor.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
      + eassumption.
    - invert H1.
      invert H3.
      econstructor.
      + eassumption.
      + eapply IHplug.
        * eassumption.
        * assumption.
        * eassumption.
  Qed.

  (* This proof should go through without modifications. *)
  Lemma preservation : forall e1 e2,
    step e1 e2
    -> forall t, hasty $0 e1 t
      -> hasty $0 e2 t.
  Proof.
    invert 1; simplify.

    eapply generalize_plug with (e1' := e1).
    - eassumption.
    - eassumption.
    - simplify.
      eapply preservation0.
      + eassumption.
      + assumption.
    - assumption.
  Qed.

  (* This proof should go through without modifications. *)
  Theorem safety : forall e t, hasty $0 e t
    -> invariantFor (trsys_of e) unstuck.
  Proof.
    simplify.
    apply invariant_weaken with (invariant1 := fun e' => hasty $0 e' t).
    - apply invariant_induction; simplify.
      + equality.

      + eapply preservation.
        * eassumption.
        * assumption.
    - simplify.
      eapply progress.
      eassumption.
  Qed.
End StlcWithFix.


Set Implicit Arguments.
Set Asymmetric Patterns.

Require Import CoqStock.comparable.
Require Import Reexamined.regex.

Fixpoint compare_regex {A: Type} {cmp: comparable A} (r s: regex A) : comparison :=
  match r with
  | fail => match s with
    | fail => Eq
    | _ => Lt
    end
  | empty => match s with
    | fail => Gt
    | empty => Eq
    | _ => Lt
    end
  | char x => match s with
    | fail => Gt
    | empty => Gt
    | char y => compare x y
    | _ => Lt
    end
  | or r1 r2 => match s with
    | fail => Gt
    | empty => Gt
    | char _ => Gt
    | or s1 s2 =>
      match compare_regex r1 s1 with
      | Lt => Lt
      | Eq => compare_regex r2 s2
      | Gt => Gt
      end
    | _ => Lt
    end
  | and r1 r2 => match s with
    | fail => Gt
    | empty => Gt
    | char _ => Gt
    | or _ _ => Gt
    | and s1 s2 =>
      match compare_regex r1 s1 with
      | Lt => Lt
      | Eq => compare_regex r2 s2
      | Gt => Gt
      end
    | _ => Lt
    end
  | concat r1 r2 => match s with
    | fail => Gt
    | empty => Gt
    | char _ => Gt
    | or _ _ => Gt
    | and _ _ => Gt
    | concat s1 s2 =>
      match compare_regex r1 s1 with
      | Lt => Lt
      | Eq => compare_regex r2 s2
      | Gt => Gt
      end
    | _ => Lt
    end
  | not r1 => match s with
    | fail => Gt
    | empty => Gt
    | char _ => Gt
    | or _ _ => Gt
    | and _ _ => Gt
    | concat _ _ => Gt
    | not s1 => compare_regex r1 s1
    | _ => Lt
    end
  | star r1 => match s with
    | star s1 => compare_regex r1 s1
    | _ => Gt
    end
  end.

Lemma test_compare_regex_char : forall
  {A: Type}
  {cmp: comparable A}
  (x1 x2: A)
  (p: compare x1 x2 = Lt),
  compare_regex (char x1) (char x2) = Lt.
Proof. intros. simpl. now (rewrite p). Qed.

(*
(or (char x1) (or (char x2) (or (char x2) (char x1))))
or
- x1
- or
  - x2
  - or
    - x2
    - x1
*)
Example example_compare_regex_or_all_left : forall {A: Type} {cmp: comparable A} (x1 x2: A) (p: compare x1 x2 = Lt),
  compare_regex (char x1) (or (char x2) (or (char x2) (char x1))) = Lt.
Proof. intros. simpl. reflexivity. Qed.

(*
(or (or (char x1) (char x2)) (or (char x2) (char x1)))
or
  - or
    - x1
    - x2
  - or
    - x2
    - x1
*)
Example example_compare_regex_or_symmetric: forall {A: Type} {cmp: comparable A} (x1 x2: A) (p: compare x1 x2 = Lt),
  compare_regex (or (char x1) (char x2)) (or (char x2) (char x1)) = Lt.
Proof. intros. simpl. now (rewrite p). Qed.

Lemma regex_proof_compare_eq_is_equal
    : forall {A: Type}
             {cmp: comparable A}
             (r1 r2: regex A)
             (p: compare_regex r1 r2 = Eq)
    , r1 = r2.
Proof.
induction r1.
 - induction r2; simpl; trivial; discriminate. (* fail *)
 - induction r2; simpl; trivial; discriminate. (* empty *)
 - induction r2; simpl; try discriminate. (* char *)
  + remember (compare a a0).
    induction c; simpl; try discriminate.
    * symmetry in Heqc.
      apply proof_compare_eq_is_equal in Heqc.
      rewrite <- Heqc.
      reflexivity.
 - induction r2; simpl; try discriminate. (* or *)
  + remember (compare_regex r1_1 r2_1).
    remember (compare_regex r1_2 r2_2).
    induction c; try discriminate.
    * induction c0; try discriminate.
      -- symmetry in Heqc.
         symmetry in Heqc0.
         remember (IHr1_1 r2_1).
         remember (e Heqc).
         rewrite e.
         remember (IHr1_2 r2_2).
         remember (e1 Heqc0).
         rewrite e2.
         reflexivity.
         apply Heqc.
 - induction r2; simpl; try discriminate. (* and *)
  + remember (compare_regex r1_1 r2_1).
    remember (compare_regex r1_2 r2_2).
    induction c; try discriminate.
    * induction c0; try discriminate.
      -- symmetry in Heqc.
         symmetry in Heqc0.
         remember (IHr1_1 r2_1).
         remember (e Heqc).
         rewrite e.
         remember (IHr1_2 r2_2).
         remember (e1 Heqc0).
         rewrite e2.
         reflexivity.
         apply Heqc.
 - induction r2; simpl; try discriminate. (* concat *)
  + remember (compare_regex r1_1 r2_1).
    remember (compare_regex r1_2 r2_2).
    induction c; try discriminate.
    * induction c0; try discriminate.
      -- symmetry in Heqc.
         symmetry in Heqc0.
         remember (IHr1_1 r2_1).
         remember (e Heqc).
         rewrite e.
         remember (IHr1_2 r2_2).
         remember (e1 Heqc0).
         rewrite e2.
         reflexivity.
         apply Heqc.
 - induction r2; simpl; try discriminate. (* not *)
  + remember (IHr1 r2).
    remember (IHr1 (not r2)).
    intros.
    remember (e p).
    rewrite e1.
    reflexivity.
 - induction r2; simpl; try discriminate. (* star *)
  + remember (IHr1 r2).
    remember (IHr1 (star r2)).
    intros.
    remember (e p).
    rewrite e1.
    reflexivity.
Qed.

Theorem regex_proof_compare_eq_reflex : forall {A: Type} {cmp: comparable A} (r: regex A),
  compare_regex r r = Eq.
Proof.
induction r; try reflexivity; simpl.
- apply proof_compare_eq_reflex.
- rewrite IHr1. rewrite IHr2. reflexivity.
- rewrite IHr1. rewrite IHr2. reflexivity.
- rewrite IHr1. rewrite IHr2. reflexivity.
- rewrite IHr. reflexivity.
- rewrite IHr. reflexivity.
Qed.

Lemma regex_proof_compare_eq_trans
    : forall {A: Type}
             {cmp: comparable A}
             (x y z: regex A)
             (p: compare_regex x y = Eq)
             (q: compare_regex y z = Eq)
    , compare_regex x z = Eq.
Proof.
(* TODO: Good First Issue *)
Admitted.

Lemma regex_proof_compare_lt_trans
    : forall {A: Type}
             {cmp: comparable A}
             (x y z: regex A)
             (p: compare_regex x y = Lt)
             (q: compare_regex y z = Lt)
    , compare_regex x z = Lt.
Proof.
(* TODO: Good First Issue *)
Admitted.

Lemma regex_proof_compare_gt_trans
    : forall {A: Type}
             {cmp: comparable A}
             (x y z: regex A)
             (p: compare_regex x y = Gt)
             (q: compare_regex y z = Gt)
    , compare_regex x z = Gt.
Proof.
(* TODO: Good First Issue *)
Admitted.

Instance comparable_regex {A: Type} {cmp: comparable A} : comparable (regex A) :=
  { compare := compare_regex
  ; proof_compare_eq_is_equal := regex_proof_compare_eq_is_equal
  ; proof_compare_eq_reflex := regex_proof_compare_eq_reflex
  ; proof_compare_eq_trans := regex_proof_compare_eq_trans
  ; proof_compare_lt_trans := regex_proof_compare_lt_trans
  ; proof_compare_gt_trans := regex_proof_compare_gt_trans
  }.

Theorem compare_regex_is_compare: forall
  {A: Type}
  {cmp: comparable A}
  (r s: regex A),
  compare_regex r s = compare r s.
Proof.
simpl.
reflexivity.
Qed.

(* induction_on_compare_regex starts induction on a `compare_regex` expression in the goal.
   It makes sense to remember this comparison, so that it be rewritten to an
   equality in the Eq induction goal.
*)
Ltac induction_on_compare_regex :=
  rewrite compare_regex_is_compare;
  induction_on_compare.

(* test_compare_list simply tests whether nat can be used
   with a function that expects a comparable instance.
   compare_list is defined in comparable,
   specifically for this use case.
*)
Require Import compare_nat.
Definition list_a : list (@regex nat _) := (empty :: fail :: nil).
Definition list_b : list (@regex nat _) := (empty:: (char 1) :: nil).
Definition test_compare_list : Prop :=
  comparable_list list_a list_b = Lt.


(* Considered preliminaries *)
Set Implicit Arguments.
Require Import List Arith Lia Morphisms.
Import ListNotations.
From Undecidability.HOU Require Export std.std.
From Undecidability.HOU Require Import calculus.terms.

Fixpoint sapp {X} (A: list X) (sigma: fin -> X): fin -> X :=
  match A with
  | nil => sigma
  | a :: A => a .: sapp A sigma
  end.

Notation "A .+ sigma" := (sapp A sigma) (at level 67, right associativity).

Lemma sapp_app X (A B: list X) sigma:
  (A ++ B) .+ sigma = A .+ B .+ sigma.
Proof.
  induction A; cbn; eauto.
  f_equal; eauto.
Qed.

Lemma nth_error_sapp X L (x: X) n sigma:
  nth_error L n = Some x -> (L .+ sigma) n = x.
Proof.
  induction L in n |-*; cbn.
  + destruct n; cbn in *;  discriminate.
  + firstorder. destruct n; cbn in *.
    congruence. eauto.
Qed.

Lemma sapp_lt_in X x (A: list X) sigma:
  x < length A -> (A .+ sigma) x ∈ A.
Proof.
  intros H. eapply nth_error_In with (n := x).
  eapply nth_error_lt_Some in H as [a].
  erewrite nth_error_sapp; eauto.
Qed.

Lemma sapp_ge_in X x (A: list X) sigma:
  length A <= x -> sapp A sigma x = sigma (x - length A).
Proof.
  induction A in x |-*.
  - cbn. intros _. destruct x; reflexivity.
  - intros H. destruct x. inv H.
    cbn; rewrite <-IHA; eauto using le_S_n.
Qed.

Lemma ren_plus_base (X: Const): @ren_exp X shift = ren_exp (plus 1).
Proof. reflexivity. Qed.

Lemma ren_comp X delta delta' s:
  @ren_exp X delta (ren_exp delta' s) = ren_exp (delta' >> delta) s.
Proof. asimpl. reflexivity. Qed.

Lemma ren_plus_combine X n m s:
  @ren_exp X (plus n) (ren_exp (plus m) s) = ren_exp (plus (n + m)) s.
Proof.
  rewrite ren_comp. f_equal.
  induction n; cbn; fext; intros; cbn.
  + reflexivity.
  + rewrite <-IHn. reflexivity.
Qed.

Lemma it_up_ren_spec n delta x:
  it n up_ren delta x = if dec2 lt x n then x else n + delta (x - n).
Proof.
  induction n in x, delta |-*; cbn.
  - destruct dec2; intuition. lia.
  - destruct x; cbn; destruct dec2; intuition. lia.
    all: unfold funcomp; erewrite IHn.
    all: destruct dec2; intuition; lia.
Qed.

Lemma it_up_ren_lt n delta x:
  x < n -> it n up_ren delta x = x.
Proof.
  intros; rewrite it_up_ren_spec; destruct dec2; intuition.
Qed.

Lemma it_up_ren_ge n delta x:
  x >= n -> it n up_ren delta x = n + delta (x - n).
Proof.
  intros; rewrite it_up_ren_spec; destruct dec2; intuition; lia.
Qed.

Lemma it_up_spec X n (sigma: fin -> @exp X) x:
  it n up_exp_exp sigma x =
  if dec2 lt x n then var_exp x else ren_exp (plus n) (sigma (x - n)).
Proof.
  induction n in x, sigma |-*; cbn.
  - asimpl; destruct dec2; [lia|]; now destruct x.
  - destruct x; cbn; destruct dec2; intuition; [lia| |].
    all: unfold funcomp; erewrite IHn.
    all: destruct dec2; intuition; try lia; now asimpl.
Qed.

Lemma it_up_lt X n (sigma: fin -> @exp X) x:
  x < n -> it n up_exp_exp sigma x = var_exp x.
Proof.
  intros; rewrite it_up_spec; destruct dec2; intuition.
Qed.

Lemma it_up_ge X n (sigma: fin -> @exp X) x:
  x >= n -> it n up_exp_exp sigma x = ren_exp (plus n) (sigma (x - n)).
Proof.
  intros; rewrite it_up_spec; destruct dec2; intuition; lia.
Qed.

Lemma it_up_var_sapp X A n delta e:
  (forall x, delta x >= x) -> n = length A  ->
  subst_exp (A .+ var_exp) (ren_exp (it n up_ren delta) e) = subst_exp (A .+ delta >> @var_exp X) e.
Proof.
  intros; subst. asimpl. eapply ext_exp.
  intros; unfold funcomp.
  assert (x < length A \/ x >= length A) as [] by lia.
  + rewrite it_up_ren_lt; eauto.
    eapply nth_error_lt_Some in H0 as [a].
    erewrite !nth_error_sapp; eauto.
  + rewrite it_up_ren_ge; simplify; eauto.
    erewrite !sapp_ge_in; simplify; eauto. lia.
Qed.

Lemma select_variables_subst X S I sigma:
    I ⊆ nats (length S) -> map (subst_exp (S .+ sigma))  (map (@var_exp X) I) = select I S.
Proof.
  intros. rewrite map_map; cbn.  induction I; cbn; eauto.
  destruct (nth_error S a) eqn: H1.
  + rewrite IHI; firstorder.
    f_equal. now eapply nth_error_sapp.
  + exfalso. apply nth_error_None in H1.
    specialize (H a).  mp H; [now left|].
    eapply nats_lt in H. lia.
Qed.

Lemma max_le_left n m:  n <= max n m.
Proof. eauto using Nat.max_lub_l. Qed.

Lemma max_le_right n m: m <= max n m.
Proof. eauto using Nat.max_lub_r. Qed.

#[export] Hint Resolve max_le_left max_le_right : core.

(* finite maps *)
Definition dom X (A: list X) := nats (length A).

Lemma dom_length X (A: list X) : length (dom A) = length A.
Proof. unfold dom; now simplify. Qed.

Lemma dom_map X Y (A: list X) (f: X -> Y): dom (map f A) = dom A.
Proof. unfold dom; now simplify. Qed.

Global Hint Rewrite dom_length dom_map: simplify.

Lemma dom_in X x (A: list X):
  x ∈ dom A -> exists y, nth A x = Some y.
Proof.
  now intros ? % nats_lt % nth_error_lt_Some.
Qed.

Lemma dom_nth X x A (y: X):
  nth A x = Some y -> x ∈ dom A.
Proof.
  now intros ? % nth_error_Some_lt % lt_nats.
Qed.

Lemma dom_lt_iff X x (A: list X): x ∈ dom A <-> x < length A.
Proof. split; eauto using nats_lt, lt_nats. Qed.

#[export] Hint Resolve <-dom_lt_iff : core.

Ltac domin H :=
  match type of H with
  | nth _ _ = _ => eapply dom_nth in H as ?
  | _ ∈ dom _ => eapply dom_in in H as [y H]; rewrite ?H
  end.

#[export] Hint Resolve nth_error_In : core.
#[export] Hint Resolve le_plus_r le_plus_l : core.
#[export] Hint Resolve Max.max_lub : core.
#[export] Hint Resolve Nat.le_succ_diag_r le_Sn_le : core.

Global Hint Rewrite Nat.max_lub_iff Max.max_0_r Max.max_0_l: simplify.
Global Hint Rewrite Nat.mul_0_r Nat.mul_succ_r Nat.mul_0_l Nat.mul_succ_l: simplify.
Global Hint Rewrite Nat.add_succ_r : simplify.

Arguments exp : clear implicits.

Coercion app : exp >-> Funclass.
Notation "'lambda' s" := (lam s) (at level 65, right associativity).

Arguments var_exp {_} _.
Notation var := var_exp.

Notation "A → B" := (arr A B) (at level 65, right associativity).

Coercion typevar : nat >-> type.
Definition alpha : type := 0.

Notation "gamma • s" := (subst_exp gamma s) (at level 69, right associativity).
Notation ren := ren_exp.
Notation up := up_exp_exp.


(*** Lists with no repetition ***)

Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Ring.
Require Import ott_list_core.
Require Import ott_list_base.
Require Import ott_list_nth.
Require Import ott_list_mem.

Section All_distinct.
Set Implicit Arguments.
Variable A : Set.
Variable eq_dec : forall (x y:A), {x=y} + {x<>y}.

Notation one_distinct := (fun x xs => negb (list_mem eq_dec x xs)).

Fixpoint all_distinct (xs:list A) : bool :=
  match xs with
    | nil => true
    | x::xt => andb (one_distinct x xt) (all_distinct xt)
  end.
Fixpoint disjoint (xs ys:list A) {struct xs} : bool :=
  match xs with
    | nil => true
    | x::xt => andb (one_distinct x ys) (disjoint xt ys)
  end.

Ltac destruct_andb :=
  repeat match goal with
           | H : Is_true (?a && ?b) |- _ =>
               (* N.B. [andb_prop2] is called [andb_prop_elim] after V8.1 *)
               destruct (andb_prop2 a b H); clear H
         end.

Lemma one_distinct_eq_fold_right :
  forall x0 xs,
    one_distinct x0 xs =
    fold_right (fun x b => if eq_dec x x0 then false else b) true xs.
Proof.
  induction xs; simpl in * . reflexivity.
  destruct (eq_dec a x0); simpl in *; congruence.
Qed.
Lemma disjoint_eq_fold_right :
  forall xs ys,
    disjoint xs ys = fold_right (fun x => andb (one_distinct x ys)) true xs.
Proof. intros; induction xs; simpl in *; congruence. Qed.

Lemma one_distinct_app :
  forall x xs ys,
    one_distinct x (xs++ys) = one_distinct x xs && one_distinct x ys.
Proof.
  intros; induction xs; simpl in * . reflexivity.
  destruct (eq_dec a x); auto with bool.
Qed.
Lemma all_distinct_app :
  forall xs ys,
    all_distinct (xs++ys) =
    all_distinct xs && all_distinct ys && disjoint xs ys.
Proof.
  intros; induction xs; simpl in * . ring.
  rewrite one_distinct_app. rewrite IHxs. ring.
Qed.

Lemma one_distinct_app_left :
  forall x xs ys,
    Is_true (one_distinct x (xs++ys)) -> Is_true (one_distinct x xs).
Proof.
  intros; simpl in * .
  simplify_lists. apply Is_true_eq_left. assert (H' := Is_true_eq_true _ H).
  unfold negb in * . destruct (list_mem eq_dec x xs); auto.
Qed.
Lemma all_distinct_app_left :
  forall xs ys, Is_true (all_distinct (xs++ys)) -> Is_true (all_distinct xs).
Proof.
  intros. rewrite all_distinct_app in H.
  destruct_andb; assumption.
Qed.
Lemma one_distinct_app_right :
  forall x xs ys,
    Is_true (one_distinct x (xs++ys)) -> Is_true (one_distinct x xs).
Proof.
  intros; simpl in * .
  simplify_lists. apply Is_true_eq_left. assert (H' := Is_true_eq_true _ H).
  unfold negb in * . destruct (list_mem eq_dec x xs); auto.
Qed.
Lemma all_distinct_app_right :
  forall xs ys, Is_true (all_distinct (xs++ys)) -> Is_true (all_distinct xs).
Proof.
  intros. rewrite all_distinct_app in H.
  destruct_andb; assumption.
Qed.

Lemma disjoint_nil_left : forall xs, disjoint nil xs = true.
Proof. reflexivity. Qed.
Lemma disjoint_nil_right : forall xs, disjoint xs nil = true.
Proof. induction xs; simpl; congruence. Qed.
Lemma disjoint_comm :
  forall xs ys, disjoint xs ys = disjoint ys xs.
Proof.
  induction xs; intros; simpl in * .
  rewrite disjoint_nil_right; reflexivity.
  induction ys; simpl in * . rewrite IHxs; reflexivity.
  rewrite <- IHys; repeat rewrite IHxs; simpl.
  destruct (eq_dec a0 a); destruct (eq_dec a a0); try subst a0.
  reflexivity. elim n; reflexivity. elim n; reflexivity. ring.
Qed.
Lemma disjoint_app_distr_left :
  forall xs ys zs, disjoint xs (ys++zs) = disjoint xs ys && disjoint xs zs.
Proof.
  intros. induction xs; simpl in * . reflexivity.
  rewrite IHxs; rewrite one_distinct_app. ring.
Qed.
Lemma disjoint_app_distr_right :
  forall xs ys zs, disjoint (xs++ys) zs = disjoint xs zs && disjoint ys zs.
Proof.
  intros. rewrite disjoint_comm. rewrite disjoint_app_distr_left.
  do 2 rewrite (disjoint_comm zs). reflexivity.
Qed.

Lemma rev_one_distinct :
  forall x xs, one_distinct x (rev xs) = one_distinct x xs.
Proof.
  intros; induction xs; simpl in * . reflexivity.
  rewrite one_distinct_app; rewrite IHxs; simpl.
  destruct (eq_dec a x); ring.
Qed.
Lemma rev_disjoint_right :
  forall xs ys, disjoint xs (rev ys) = disjoint xs ys.
Proof.
  intros; induction xs; simpl in * . reflexivity.
  rewrite rev_one_distinct; rewrite IHxs; reflexivity.
Qed.
Lemma rev_disjoint_left :
  forall xs ys, disjoint (rev xs) ys = disjoint xs ys.
Proof.
  intros; induction xs; simpl in * . reflexivity.
  rewrite disjoint_app_distr_right; simpl. rewrite IHxs; ring.
Qed.
Lemma rev_all_distinct :
  forall xs, all_distinct (rev xs) = all_distinct xs.
Proof.
  intros; induction xs; simpl in * . reflexivity.
  rewrite all_distinct_app; simpl. rewrite IHxs.
  rewrite rev_disjoint_left; rewrite disjoint_comm; simpl; ring.
Qed.

Lemma all_distinct_indices_aux :
  forall xs i j,
    i <= j ->
    Is_true (all_distinct xs) ->
    nth_error xs i = nth_error xs j ->
    i < length xs ->
    i = j.
Proof.
  intros xs i j Ineq.
  replace j with (i + (j-i)). 2: solve [auto with arith].
  generalize (j-i); clear Ineq j; intros k Distinct Nths Bound.
  destruct k. solve [auto with arith]. elimtype False.
  generalize dependent xs; induction i; intros; destruct xs; simpl in * .
  omega.
  destruct (andb_prop2 _ _ Distinct) as [Notin _]; clear Distinct Bound.
  generalize dependent k; induction xs; intros; simpl in * .
  destruct k; discriminate.
  destruct (eq_dec a0 a). exact Notin.
  destruct k; simpl in *; [injection Nths | idtac]; solve [eauto].
  omega.
  eapply IHi; eauto. destruct_andb; assumption.
  omega.
Qed.
Lemma all_distinct_indices :
  forall xs i j,
    Is_true (all_distinct xs) ->
    nth_error xs i = nth_error xs j ->
    i < length xs ->
    i = j.
Proof.
  intros. destruct (le_ge_dec i j).
  eapply all_distinct_indices_aux; eauto.
  symmetry. eapply all_distinct_indices_aux; eauto. omega.
Qed.

End All_distinct.

Notation one_distinct := (fun eq_dec x xs => negb (list_mem eq_dec x xs)).

Hint Rewrite one_distinct_app all_distinct_app : lists.
Hint Rewrite disjoint_nil_left disjoint_nil_right : lists.
Hint Rewrite disjoint_app_distr_left disjoint_app_distr_right : lists.
Hint Rewrite rev_one_distinct rev_disjoint_right rev_disjoint_left
             rev_all_distinct : lists.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.Combinatorics.FiniteSets.
Require Import UniMath.CategoryTheory.Core.Categories.

Require Import prelude.
Require Import syntax.containers.
Require Import syntax.hit_signature.
Require Import syntax.W_types.
Require Import algebra.set_algebra.

Local Open Scope container_scope.

Definition nat_container
  : container
  := unitset ⊕ I.

Definition nat_sig : hit_signature.
Proof.
  use make_hit_signature.
  - exact nat_container.
  - exact (constant_container emptyset).
  - cbn ; exact fromempty.
  - cbn ; exact fromempty.
Defined.

Definition is_finitary_nat_sig
  : is_finitary_hit nat_sig.
Proof.
  split.
  - intro x.
    destruct x ; cbn -[isfinite].
    + apply isfiniteempty.
    + apply isfiniteunit.
  - intro.
    apply isfiniteempty.
Qed.

Section NatAlgebra.
  Variable (X : hit_algebra nat_sig).

  Definition nat_carrier
    : hSet
    := pr11 X.

  Definition nat_Z
    : nat_carrier
    := pr21 X (inl tt ,, fromempty).

  Definition nat_S
    : nat_carrier → nat_carrier
    := λ x, pr21 X (inr tt ,, λ _, x).
End NatAlgebra.

Definition make_nat_algebra
           (X : hSet)
           (Z : X)
           (S : X → X)
  : hit_algebra nat_sig.
Proof.
  simple refine ((X ,, _) ,, λ i p, fromempty i) ; cbn.
  intro x.
  induction x as [x arg].
  induction x ; cbn in *.
  - exact Z.
  - exact (S (arg tt)).
Defined.

Definition nat_nat_sig
  : hit_algebra nat_sig.
Proof.
  use make_nat_algebra.
  - exact natset.
  - exact 0.
  - exact S.
Defined.


From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Require Import Rstruct CPoly CPoly_trigo CPoly_interpolation.
Import Rtrigo_def Rtrigo1.
Require Import Reals Coquelicot.Coquelicot Interval.Tactic Psatz.

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

(*****************************************************************************)
(*                                                                           *)
(*    Interpolation theorems for cos                                         *)
(*                                                                           *)
(*****************************************************************************)

Section Cos.

Variable n : nat.
Variable a b : R.
Hypothesis aLb : a < b.

Let l := cheby_nodes n.+1.
Let ls := scheby_nodes a b n.+1.
Let cinter := interpolation cos ls.
Let cerror := ierror cos ls.

Definition cos_coef i :=
  (if i == 0%nat then 1 else 2) / INR (n.+1) *
   \sum_(j < n.+1) cos (((b - a) * (l`_j) + a + b) / 2)%R * ('T_i).[l`_j].

Lemma cos_cheby_eq :
   cinter = \sum_(i < n.+1) cos_coef i *: 'T^(a, b)_i.
Proof.
have aDb : a != b by apply/eqP; lra.
rewrite [LHS](@sdsprod_cheby_eq a b n) //.
- apply: eq_bigr => i _.
  congr (_ *: _).
  by apply: sdsprod_coef_interpolation_pT.
apply: leq_trans (interpolation_size _ _) _.
by rewrite size_scheby_nodes.
Qed.

Lemma Derive_n_cos k x :
  Derive_n cos k x =
    (if odd k then (-1) ^ k./2 * - sin x else (-1) ^ k./2 * cos x).
Proof.
by apply/is_derive_n_unique/Coquelicot.is_derive_n_cos.
Qed.

Lemma ierror_cos x z :
  a <= x <= b ->
  (forall y, a <= y <= b ->
    if odd n then Rabs (cos y) <= z else Rabs (sin y) <= z) ->
  Rabs (cerror x) <= (b - a)^+ n.+1 / ((expn 2 n.+1.*2.-1 * n.+1 `!) %:R) * z.
Proof.
move=> xB HD.
apply: ierror_scheby => //.
- have H : a - 1 < a by lra.
  by exact H.
- have H : b < b + 1 by lra.
  by exact: H.
- move=> y k yB kLn.
  apply: Coquelicot.ex_derive_n_is_derive_n.
  by apply: Coquelicot.is_derive_n_cos.
- move=> y k kLn yB.
  apply: continuous_ext => [u|].
    apply/sym_equal.
    by exact: Derive_n_cos.
  case: odd; apply: continuous_scal; try apply: continuous_const.
    apply: continuous_opp.
    by apply: Coquelicot.continuous_sin.
  by apply: Coquelicot.continuous_cos.
move=> y yB.
rewrite Derive_n_cos /=.
have := HD _ yB; case: odd => /=.
  by rewrite Rabs_mult pow_1_abs; lra.
by rewrite Rabs_mult pow_1_abs; split_Rabs; lra.
Qed.

Lemma cos_scheby_ge x :
  a <= x <= b ->
  (   (forall x, a <= x <= b -> (if odd n then sin x else cos x) <= 0)
    \/
      (forall x, a <= x <= b -> (if odd n then sin x else cos x) >= 0)) ->
  Rabs (cerror x) <= Rmax (Rabs (cerror a)) (Rabs (cerror b)).
Proof.
move=> xB HD.
have oddE k : (-1) ^ k = if odd k then -1 else 1.
  by elim: k => //= k ->; case: odd => /=; lra.
apply: interpolation_scheby_ge => //.
- have H : a - 1 < a by lra.
  by exact: H.
- have H : b < b + 1 by lra.
  by exact: H.
- move=> m y mLn yB.
  apply: continuous_ext => [u|].
    apply/sym_equal.
    by exact: Derive_n_cos.
  case: odd; apply: continuous_scal; try apply: continuous_const.
    apply: continuous_opp.
    by apply: Coquelicot.continuous_sin.
  by apply: Coquelicot.continuous_cos.
- move: HD.
  have [On|En] := boolP (odd n) => [] [HD|HD];
    have [On1|En1] := boolP (odd n./2).
  - right => y yB; rewrite Derive_n_cos /= On oddE On1 /=.
    by have := HD _ yB; lra.
  - left => y yB; rewrite Derive_n_cos /= On oddE (negPf En1) /=.
    by have := HD _ yB; lra.
  - left => y yB; rewrite Derive_n_cos /= On oddE On1 /=.
    by have := HD _ yB; lra.
  - right => y yB; rewrite Derive_n_cos /= On oddE (negPf En1) /=.
    by have := HD _ yB; lra.
  - left => y yB; rewrite Derive_n_cos /= (negPf En) oddE On1 /=.
    by have := HD _ yB; lra.
  - right => y yB; rewrite Derive_n_cos /= (negPf En) oddE (negPf En1) /=.
    by have := HD _ yB; lra.
  - right => y yB; rewrite Derive_n_cos /= (negPf En) oddE On1 /=.
    by have := HD _ yB; lra.
  - left => y yB; rewrite Derive_n_cos /= (negPf En) oddE (negPf En1) /=.
    by have := HD _ yB; lra.
move=> m y mLn yB.
apply: Coquelicot.ex_derive_n_is_derive_n.
by apply: Coquelicot.is_derive_n_cos.
Qed.

End Cos.

(*****************************************************************************)
(*                                                                           *)
(*    Interpolation theorems for exp                                         *)
(*                                                                           *)
(*****************************************************************************)

Section Exp.

Variable n : nat.
Variable a b : R.
Hypothesis aLb : a < b.

Let l := cheby_nodes n.+1.
Let ls := scheby_nodes a b n.+1.
Let einter := interpolation exp ls.
Let eerror := ierror exp ls.

Definition exp_coef i :=
  (if i == 0%nat then 1 else 2) / INR (n.+1) *
   \sum_(j < n.+1) exp (((b - a) * (l`_j) + a + b) / 2)%R * ('T_i).[l`_j].

Lemma exp_cheby_eq :
   einter = \sum_(i < n.+1) exp_coef i *: 'T^(a, b)_i.
Proof.
have aDb : a != b by apply/eqP; lra.
rewrite [LHS](@sdsprod_cheby_eq a b n) //.
- apply: eq_bigr => i _.
  congr (_ *: _).
  by apply: sdsprod_coef_interpolation_pT.
apply: leq_trans (interpolation_size _ _) _.
by rewrite size_scheby_nodes.
Qed.

Lemma Derive_n_exp k x : Derive_n exp k x =  exp x.
Proof.
by apply/is_derive_n_unique/Coquelicot.is_derive_n_exp.
Qed.

Lemma exp_scheby_ge x :
  a <= x <= b -> True ->
  Rabs (eerror x) <= Rmax (Rabs (eerror a)) (Rabs (eerror b)).
Proof.
move=> xB HD.
apply: interpolation_scheby_ge => //.
- have H : a - 1 < a by lra.
  by exact: H.
- have H : b < b + 1 by lra.
  by exact: H.
- move=> m y mLn yB.
  apply: continuous_ext => [u|].
    apply/sym_equal.
    by exact: Derive_n_exp.
  by apply: Coquelicot.continuous_exp.
- right => y yD.
  rewrite Derive_n_exp.
  by have := exp_pos y; lra.
move=> m y mLn yB.
apply: Coquelicot.ex_derive_n_is_derive_n.
by apply: Coquelicot.is_derive_n_exp.
Qed.

End Exp.

(*****************************************************************************)
(*                                                                           *)
(*    Interpolation theorems for 1/x                                         *)
(*                                                                           *)
(*****************************************************************************)

Section Inv.

Variable n : nat.
Variable a b : R.
Hypothesis aLb : a < b.

Let l := cheby_nodes n.+1.
Let ls := scheby_nodes a b n.+1.
Let iinter := interpolation Rinv ls.
Let ierror := ierror Rinv ls.

Definition inv_coef i :=
  (if i == 0%nat then 1 else 2) / INR (n.+1) *
   \sum_(j < n.+1) /(((b - a) * (l`_j) + a + b) / 2)%R * ('T_i).[l`_j].

Lemma inv_cheby_eq :
   iinter = \sum_(i < n.+1) inv_coef i *: 'T^(a, b)_i.
Proof.
have aDb : a != b by apply/eqP; lra.
rewrite [LHS](@sdsprod_cheby_eq a b n) //.
- apply: eq_bigr => i _.
  congr (_ *: _).
  by apply: sdsprod_coef_interpolation_pT.
apply: leq_trans (interpolation_size _ _) _.
by rewrite size_scheby_nodes.
Qed.

Lemma Derive_n_inv k x :
  x <> 0 ->
  Derive_n Rinv k x =  (-1) ^ k * INR (k`!) * / x ^ k.+1.
Proof.
move=> xD0.
rewrite -add1n.
suff -> : (-1) ^ k * INR k`! = \big[Rmult/1]_(i < k)  - INR (1 + i).
  by apply/is_derive_n_unique/(Coquelicot.is_derive_n_inv _).
elim: k => [|k IH].
  by rewrite big_ord0 fact0 Rmult_1_r.
rewrite factS mult_INR big_ord_recr -IH.
by toR; lra.
Qed.

Lemma continuous_pow m x : continuous (pow^~ m) x.
Proof.
elim: m => [|m IH] //=.
  by apply: continuous_const.
apply: continuous_mult IH.
apply: continuous_id.
Qed.

Lemma inv_scheby_ge x :
  a <= x <= b -> ~ (a <= 0 <= b) ->
  Rabs (ierror x) <= Rmax (Rabs (ierror a)) (Rabs (ierror b)).
Proof.
move=> xB zB.
have FPos : 0 < INR (n.+2)`! by apply/lt_0_INR/ltP/fact_gt0.
have F z : z * z = z ^ 2 by lra.
have [aN|aP] : (a < 0 \/ a > 0) by lra.
  have bN : b < 0 by lra.
  have Ha : a - 1 < a by lra.
  have Hb : b < b - b / 2 by lra.
  apply: interpolation_scheby_ge Ha Hb _ _ _ _ => //.
  - move=> m y mLn yB.
    apply: continuous_ext_loc.
      pose z := Rmin (y - 2 * a) (b / 2 - y).
      have Pz : 0 < z by apply: Rmin_pos; lra.
      exists (mkposreal _ Pz) => z1 /AbsRing_norm_compat2 Hz1.
      apply/sym_equal/Derive_n_inv.
      rewrite /abs /minus /plus /opp /z /= Rmult_1_l in Hz1.
      by move: Hz1; rewrite /Rmin; case: Rle_dec; split_Rabs; lra.
    apply: continuous_scal; first apply: continuous_const.
    apply: Coquelicot.continuous_Rinv_comp.
      by apply: continuous_pow.
    by apply: pow_nonzero; lra.
  - have [On|En] := boolP (odd n).
      left => x1 Hx1.
      rewrite Derive_n_inv; try lra.
      rewrite -expr_Rexp -GRing.signr_odd [_ ^+ _]/= On GRing.expr1.
      apply/Rlt_le.
      suff : 0 < / x1 ^ n.+3 by toR; nra.
      apply: Rinv_0_lt_compat.
      rewrite -[_.+3]odd_double_half /= On add0n -addnn.
      rewrite Rdef_pow_add F.
      apply: pow2_gt_0.
      by apply: pow_nonzero; lra.
    left => x1 Hx1.
    rewrite Derive_n_inv; try lra.
    rewrite -expr_Rexp -GRing.signr_odd [_ ^+ _]/= (negPf En) GRing.expr0.
    apply/Rlt_le.
    suff : / x1 ^ n.+3 < 0 by toR; nra.
    apply: Rinv_lt_0_compat.
    rewrite -[_.+3]odd_double_half /= En.
    rewrite -addnn !pow_add F pow_1.
    suff : 0 < (x1 ^ (uphalf n).+1) ^ 2 by nra.
    apply: pow2_gt_0.
    by apply: pow_nonzero; lra.
  move=> m y Hm Hl.
  apply: Coquelicot.ex_derive_n_is_derive_n.
  by apply: Coquelicot.is_derive_n_inv; lra.
have bN : 0 < b by lra.
have Ha : a - a / 2 < a by lra.
have Hb : b < b + 1 by lra.
apply: interpolation_scheby_ge Ha Hb _ _ _ _ => //.
- move=> m y mLn yB.
  apply: continuous_ext_loc.
  pose z := Rmin (y - a / 2) (b + 1 - y).
    have Pz : 0 < z by apply: Rmin_pos; lra.
    exists (mkposreal _ Pz) => z1 /AbsRing_norm_compat2 Hz1.
    apply/sym_equal/Derive_n_inv.
    rewrite /abs /minus /plus /opp /z /= Rmult_1_l in Hz1.
    by move: Hz1; rewrite /Rmin; case: Rle_dec; split_Rabs; lra.
  apply: continuous_scal; first apply: continuous_const.
  apply: Coquelicot.continuous_Rinv_comp.
    by apply: continuous_pow.
  by apply: pow_nonzero; lra.
- have [On|En] := boolP (odd n).
    left => x1 Hx1.
    rewrite Derive_n_inv; try lra.
    rewrite -expr_Rexp -GRing.signr_odd [_ ^+ _]/= On GRing.expr1.
    apply/Rlt_le.
    suff : 0 < / x1 ^ n.+3 by toR; nra.
    apply: Rinv_0_lt_compat.
    rewrite -[_.+3]odd_double_half /= On add0n -addnn.
    rewrite Rdef_pow_add F.
    apply: pow2_gt_0.
    by apply: pow_nonzero; lra.
  right => x1 Hx1.
  rewrite Derive_n_inv; try lra.
  rewrite -expr_Rexp -GRing.signr_odd [_ ^+ _]/= (negPf En) GRing.expr0.
  apply/Rgt_ge/Rlt_gt.
  suff : 0 < / x1 ^ n.+3 by toR; nra.
  apply: Rinv_0_lt_compat.
  rewrite -[_.+3]odd_double_half /= En.
  rewrite -addnn !pow_add F pow_1.
  suff : 0 < (x1 ^ (uphalf n).+1) ^ 2 by nra.
  apply: pow2_gt_0.
  by apply: pow_nonzero; lra.
move=> m y Hm Hl.
apply: Coquelicot.ex_derive_n_is_derive_n.
by apply: Coquelicot.is_derive_n_inv; lra.
Qed.

End Inv.

(*****************************************************************************)
(*                                                                           *)
(*    Interpolation theorems for ln                                          *)
(*                                                                           *)
(*****************************************************************************)

Section Ln.

Variable n : nat.
Variable a b : R.
Hypothesis aLb : a < b.

Let l := cheby_nodes n.+1.
Let ls := scheby_nodes a b n.+1.
Let linter := interpolation ln ls.
Let lerror := ierror ln ls.

Definition ln_coef i :=
  (if i == 0%nat then 1 else 2) / INR (n.+1) *
   \sum_(j < n.+1) ln (((b - a) * (l`_j) + a + b) / 2)%R * ('T_i).[l`_j].

Lemma ln_cheby_eq :
   linter = \sum_(i < n.+1) ln_coef i *: 'T^(a, b)_i.
Proof.
have aDb : a != b by apply/eqP; lra.
rewrite [LHS](@sdsprod_cheby_eq a b n) //.
- apply: eq_bigr => i _.
  congr (_ *: _).
  by apply: sdsprod_coef_interpolation_pT.
apply: leq_trans (interpolation_size _ _) _.
by rewrite size_scheby_nodes.
Qed.

Lemma Derive_n_ln k x :
  0 < x ->
  Derive_n ln k.+1 x =  (-1) ^ k * INR (k`!) * / x ^ k.+1.
Proof.
move=> xP.
rewrite -add1n.
suff -> : (-1) ^ k * INR k`! = \big[Rmult/1]_(i < k)  - INR (1 + i).
  by apply/is_derive_n_unique/(Coquelicot.is_derive_n_ln _).
elim: k => [|k IH].
  by rewrite big_ord0 fact0 Rmult_1_r.
rewrite factS mult_INR big_ord_recr -IH.
by toR; lra.
Qed.

Lemma ln_scheby_ge x :
  a <= x <= b -> 0 < a ->
  Rabs (lerror x) <= Rmax (Rabs (lerror a)) (Rabs (lerror b)).
Proof.
move=> xB zB.
have FPos : 0 < INR (n.+1)`! by apply/lt_0_INR/ltP/fact_gt0.
have F z : z * z = z ^ 2 by lra.
have bN : 0 < b by lra.
have Ha : a - a / 2 < a by lra.
have Hb : b < b + 1 by lra.
apply: interpolation_scheby_ge Ha Hb _ _ _ _ => //.
- move=> m y mLn yB.
  case: m mLn => [_|m mLn].
    by apply: Coquelicot.continuous_ln; lra.
  apply: continuous_ext_loc.
  pose z := Rmin (y - a / 2) (b + 1 - y).
    have Pz : 0 < z by apply: Rmin_pos; lra.
    exists (mkposreal _ Pz) => z1 /AbsRing_norm_compat2 Hz1.
    apply/sym_equal/Derive_n_ln.
    rewrite /abs /minus /plus /opp /z /= Rmult_1_l in Hz1.
    by move: Hz1; rewrite /Rmin; case: Rle_dec; split_Rabs; lra.
  apply: continuous_scal; first apply: continuous_const.
  apply: Coquelicot.continuous_Rinv_comp.
    by apply: continuous_pow.
  by apply: pow_nonzero; lra.
- have [On|En] := boolP (odd n).
    right => x1 Hx1.
    rewrite Derive_n_ln; try lra.
    rewrite -expr_Rexp -GRing.signr_odd [_ ^+ _]/= On Rmult_1_l.
    apply/Rgt_ge/Rlt_gt.
    suff : 0 < / x1 ^ n.+2 by toR; nra.
    by apply/Rinv_0_lt_compat/pow_lt; lra.
  left => x1 Hx1.
  rewrite Derive_n_ln; try lra.
  rewrite -expr_Rexp -GRing.signr_odd [_ ^+ _]/= (negPf En).
  rewrite  GRing.expr1.
  apply: Rlt_le.
  suff : 0 < / x1 ^ n.+2 by toR; nra.
  by apply/Rinv_0_lt_compat/pow_lt; lra.
move=> m y Hm Hl.
apply: Coquelicot.ex_derive_n_is_derive_n.
by apply: Coquelicot.is_derive_n_ln; lra.
Qed.

End Ln.

(*****************************************************************************)
(*                                                                           *)
(*    Interpolation theorems for sin                                         *)
(*                                                                           *)
(*****************************************************************************)

Section Sin.

Variable n : nat.
Variable a b : R.
Hypothesis aLb : a < b.

Let l := cheby_nodes n.+1.
Let ls := scheby_nodes a b n.+1.
Let sinter := interpolation sin ls.
Let serror := ierror sin ls.

Definition sin_coef i :=
  (if i == 0%nat then 1 else 2) / INR (n.+1) *
   \sum_(j < n.+1) sin (((b - a) * (l`_j) + a + b) / 2)%R * ('T_i).[l`_j].

Lemma sin_cheby_eq :
   sinter = \sum_(i < n.+1) sin_coef i *: 'T^(a, b)_i.
Proof.
have aDb : a != b by apply/eqP; lra.
rewrite [LHS](@sdsprod_cheby_eq a b n) //.
- apply: eq_bigr => i _.
  congr (_ *: _).
  by apply: sdsprod_coef_interpolation_pT.
apply: leq_trans (interpolation_size _ _) _.
by rewrite size_scheby_nodes.
Qed.

Lemma Derive_n_sin k x :
  Derive_n sin k x =
    (if odd k then (-1) ^ k./2 * cos x else (-1) ^ k./2 * sin x).
Proof.
by apply/is_derive_n_unique/Coquelicot.is_derive_n_sin.
Qed.

Lemma ierror_sin x z :
  a <= x <= b ->
  (forall y, a <= y <= b ->
    if odd n then Rabs (sin y) <= z else Rabs (cos y) <= z) ->
  Rabs (serror x) <= (b - a)^+ n.+1 / ((expn 2 n.+1.*2.-1 * n.+1 `!) %:R) * z.
Proof.
move=> xB HD.
apply: ierror_scheby => //.
- have H : a - 1 < a by lra.
  by exact H.
- have H : b < b + 1 by lra.
  by exact: H.
- move=> y k yB kLn.
  apply: Coquelicot.ex_derive_n_is_derive_n.
  by apply: Coquelicot.is_derive_n_sin.
- move=> y k kLn yB.
  apply: continuous_ext => [u|].
    apply/sym_equal.
    by exact: Derive_n_sin.
  case: odd; apply: continuous_scal; try apply: continuous_const.
    by apply: Coquelicot.continuous_cos.
  by apply: Coquelicot.continuous_sin.
move=> y yB.
rewrite Derive_n_sin /=.
have := HD _ yB; case: odd => /=.
  by rewrite Rabs_mult pow_1_abs; lra.
by rewrite Rabs_mult pow_1_abs; lra.
Qed.

Lemma sin_scheby_ge x :
  a <= x <= b ->
  (   (forall x, a <= x <= b -> (if odd n then cos x else sin x) <= 0)
    \/
      (forall x, a <= x <= b -> (if odd n then cos x else sin x) >= 0)) ->
  Rabs (serror x) <= Rmax (Rabs (serror a)) (Rabs (serror b)).
Proof.
move=> xB HD.
have oddE k : (-1) ^ k = if odd k then -1 else 1.
  by elim: k => //= k ->; case: odd => /=; lra.
apply: interpolation_scheby_ge => //.
- have H : a - 1 < a by lra.
  by exact: H.
- have H : b < b + 1 by lra.
  by exact: H.
- move=> m y mLn yB.
  apply: continuous_ext => [u|].
    apply/sym_equal.
    by exact: Derive_n_sin.
  case: odd; apply: continuous_scal; try apply: continuous_const.
    by apply: Coquelicot.continuous_cos.
  by apply: Coquelicot.continuous_sin.
- move: HD.
  have [On|En] := boolP (odd n) => [] [HD|HD];
    have [On1|En1] := boolP (odd n./2).
  - left => y yB; rewrite Derive_n_sin /= On oddE On1 /=.
    by have := HD _ yB; lra.
  - right => y yB; rewrite Derive_n_sin /= On oddE (negPf En1) /=.
    by have := HD _ yB; lra.
  - right => y yB; rewrite Derive_n_sin /= On oddE On1 /=.
    by have := HD _ yB; lra.
  - left => y yB; rewrite Derive_n_sin /= On oddE (negPf En1) /=.
    by have := HD _ yB; lra.
  - left => y yB; rewrite Derive_n_sin /= (negPf En) oddE On1 /=.
    by have := HD _ yB; lra.
  - right => y yB; rewrite Derive_n_sin /= (negPf En) oddE (negPf En1) /=.
    by have := HD _ yB; lra.
  - right => y yB; rewrite Derive_n_sin /= (negPf En) oddE On1 /=.
    by have := HD _ yB; lra.
  - left => y yB; rewrite Derive_n_sin /= (negPf En) oddE (negPf En1) /=.
    by have := HD _ yB; lra.
move=> m y mLn yB.
apply: Coquelicot.ex_derive_n_is_derive_n.
by apply: Coquelicot.is_derive_n_sin.
Qed.

End Sin.

(*****************************************************************************)
(*                                                                           *)
(*    Interpolation theorems for atan                                         *)
(*                                                                           *)
(*****************************************************************************)

Section Atan.

Variable n : nat.
Variable a b : R.
Hypothesis aLb : a < b.

Let l := cheby_nodes n.+1.
Let ls := scheby_nodes a b n.+1.
Let atinter := interpolation atan ls.
Let aterror := ierror atan ls.

Definition atan_coef i :=
  (if i == 0%nat then 1 else 2) / INR (n.+1) *
   \sum_(j < n.+1) atan (((b - a) * (l`_j) + a + b) / 2)%R * ('T_i).[l`_j].

Lemma atan_cheby_eq :
   atinter = \sum_(i < n.+1) atan_coef i *: 'T^(a, b)_i.
Proof.
have aDb : a != b by apply/eqP; lra.
rewrite [LHS](@sdsprod_cheby_eq a b n) //.
- apply: eq_bigr => i _.
  congr (_ *: _).
  by apply: sdsprod_coef_interpolation_pT.
apply: leq_trans (interpolation_size _ _) _.
by rewrite size_scheby_nodes.
Qed.

Definition coef_poly_atan (m i : nat) (k2 := (m - i)%nat) (k := k2./2) :=
  if odd k2 then 0 else
  (-1)^+ k * 'C(m.+1, k2.+1) %:R.

Definition poly_atan m : {poly R} := \poly_(i < m.+1) coef_poly_atan m i.

Import GRing.Theory.

Fixpoint eval_atan_rec m (bv : bool) i j x res :=
  if m is m1.+2 then
  let i1 := i.+2 in
  let j1 := ((j * m  %/ i1) * m.-1 %/ i1.+1)%nat in
  let res1 := res * x * x + (-1) ^+ bv * j1%:R in
  eval_atan_rec m1 (~~ bv) i1 j1 x res1
  else if m is 1%nat then x * res else res.

Lemma eval_atan_rec_cor m m1 bv i j x res :
  ~~ odd i ->
  (m1 <= m)%nat ->
  (m = m1 + i)%nat ->
  (j = 'C(m.+1, i.+1))%nat ->
  (bv = odd i./2.+1)%nat ->
  res = (\poly_(u < (m - m1).+1) coef_poly_atan m (u + m1)).[x] ->
  eval_atan_rec m1 bv i j x res = (\poly_(i < m.+1) coef_poly_atan m i).[x].
Proof.
have [v VV] := ubnP (m1.+1).
elim: v m1 VV bv i j res =>
   // v IH [|[|m1]] /= mLv bv i j res iE m1Lm mE jE bvE resE.
- rewrite resE subn0; congr (_.[_]).
  by apply: eq_poly => i1; rewrite addn0.
- rewrite resE subn1 prednK //.
  rewrite (_ : forall x y, x * y = (x * y)%RR) //.
  rewrite -{1}[x]hornerX -hornerM; congr (_.[_]).
  apply/polyP => /= w.
  rewrite coefXM !coef_poly addn1.
  case: w => //=.
  rewrite /coef_poly_atan ifT //.
  rewrite subn0 -[odd _]negbK -[~~ (odd _)]/(odd (S m)).
  by rewrite mE /= iE.
rewrite IH //=.
- by rewrite ltnS in mLv; apply: leq_trans mLv.
- by rewrite iE.
- by rewrite (leq_trans _ m1Lm) // ltnW.
- by rewrite 2!addnS.
- rewrite jE (_ : m1.+2 = m.+1 - i.+1)%nat; last by rewrite subSS mE addnK.
  rewrite [(_ * (_ - _))%nat]mulnC -mul_bin_left //.
  rewrite [(_ * 'C(_, _))%nat]mulnC mulnK //.
  rewrite (_ : m1.+1 = m.+1 - i.+2)%nat; last first.
    by rewrite mE -addSn 2!addSnnS addnK.
  rewrite [(_ * (_ - _))%nat]mulnC -mul_bin_left //.
  by rewrite [(_ * 'C(_, _))%nat]mulnC mulnK //.
- by rewrite bvE.
rewrite resE jE.
rewrite !(_ : forall x y, x * y = (x * y)%RR) //.
rewrite -{2 3}[x]hornerX -!hornerM -(hornerC (_ * _%:R) x).
rewrite !(_ : forall x y, x + y = (x + y)%RR) //.
rewrite -hornerD; congr (_.[_]).
apply/polyP => /= w.
rewrite coefD coefC !coefMX !coef_poly.
case: w => [|[|w]] /=.
- rewrite add0r add0n /= /coef_poly_atan.
  have ->/=: (m - m1 = i.+2)%nat.
    rewrite mE 2!addSn 2?subSn ?leq_addr //.
      by rewrite addnC addnK.
    by rewrite -addnS leq_addr.
  rewrite iE /= bvE -[in RHS]signr_odd; congr (_ * _)%RR.
  rewrite (_ : m1.+2 = m.+1 - i.+1)%nat; last by rewrite subSS mE addnK.
  rewrite [(_ * (_ - _))%nat]mulnC -mul_bin_left //.
  rewrite [(_ * 'C(_, _))%nat]mulnC mulnK //.
  rewrite (_ : m1.+1 = m.+1 - i.+2)%nat; last first.
    by rewrite mE -addSn 2!addSnnS addnK.
  rewrite [(_ * (_ - _))%nat]mulnC -mul_bin_left //.
  by rewrite [(_ * 'C(_, _))%nat]mulnC mulnK.
- rewrite ltnS subn_gt0 -ltnS (leq_trans m1Lm) //=.
  by rewrite add0r /coef_poly_atan mE addSnnS addnC addnK /= iE.
rewrite addr0 !ltnS -2!ltnS -2?subSn ?subSS ?addnS //=.
by rewrite (leq_trans m1Lm).
Qed.

Definition eval_atan m x := eval_atan_rec m true 0 m.+1 x m.+1%:R.

Lemma eval_atan_cor m x :
  eval_atan m x = (\poly_(i < m.+1) coef_poly_atan m i).[x].
Proof.
apply: eval_atan_rec_cor => //.
- by rewrite addn0.
- by rewrite bin1.
rewrite subnn /coef_poly_atan.
rewrite horner_poly big_ord1 subnn /= expr0 mulr1 bin1.
by rewrite Rmult_1_l.
Qed.

Lemma size_poly_atan m : size (poly_atan m) = m.+1.
Proof.
apply: size_poly_eq.
rewrite /coef_poly_atan /=.
rewrite subnn /= bin1.
apply: GRing.mulf_neq0.
  apply: GRing.expf_neq0.
  by rewrite GRing.oppr_eq0 GRing.oner_neq0.
by rewrite Num.Theory.pnatr_eq0.
Qed.

Lemma poly_atan_0 : poly_atan 0%nat = 1%:P.
Proof.
apply/polyP => i; rewrite coefC coef_poly /coef_poly_atan /=.
by case: i; rewrite //= binn !Rmult_1_l.
Qed.

Import GRing.Theory.

Lemma poly_atan_deriv m :
 ((m.+1)%:R%:P * poly_atan m.+1 =
   (2%:R * m.+1%:R)%:P * 'X * (poly_atan m)-
        ('X^2 + 1%:P) * (poly_atan m)^`())%RR.
Proof.
apply/polyP => i.
rewrite mulrDl mul1r coefCM coefB coefD.
rewrite -mulrA coefCM coefXnM coefXM.
rewrite coef_deriv /coef_poly_atan !coef_poly.
rewrite /coef_poly_atan size_poly_atan !ltnS.
case: m => [|[|m]]; rewrite /= ?rm0.
- by case: i => [|[|i]]; rewrite /= ?rm0 //; toR; lra.
- case: i => [|[|[|i]]]; rewrite //= ?rm0; try (toR; lra).
    by rewrite binn binSn !exprS !expr0 ?rm1; toR; lra.
  rewrite -['C(3, _)]/3%nat binS ?rm1.
  by toR; lra.
case: i => [|[|i]]; rewrite ?rm0 !subSS !subn0 /=.
- rewrite negbK binn binSn.
  case: odd; rewrite /= ?rm0 //.
  rewrite !exprS Rmult_1_r -[in RHS]mulr_natl.
  by toR; lra.
- case: odd; rewrite /= ?rm0 //.
  rewrite !exprS.
  rewrite binSn binn.
  set v := _ ^+ _.
  rewrite !rm1 Rmult_1_r -!mulrnAr !natrS.
  rewrite (_ : _ *+2 = m.+3%:R * m.+2%:R)%RR.
    rewrite -[in RHS]mulr_natl !natrS; toR; lra.
  rewrite -bin_sub 1?ltnW // subSS subSn // subSn // subnn.
  by rewrite mulr2n -natrD addnn -muln2 bin_ffact ffactnS ffactn1 natrM.
rewrite !ltnS.
case: (leqP i m.+1) => [|H]; last first.
  rewrite !rm0.
  by rewrite ifN ?rm0 // ltnNge (leq_trans _ H) // ltnW.
rewrite leq_eqVlt => /orP[/eqP->|].
  rewrite subnn /= ifN ?ltnNge 1?ltnW //.
  rewrite !rm0 !bin1 /=.
  rewrite -[_ *+ m.+2]mulr_natl !natrS.
  by toR; lra.
rewrite ltnS leq_eqVlt => /orP[/eqP<-|H1].
  by rewrite subSn // subnn ltnn !rm0.
rewrite H1 /=.
rewrite subSn 1?ltnW // subnS.
set u := (_ - _)%nat.
rewrite -(subnKC (ltnW H1)) {}/u.
move: H1; rewrite -subn_gt0; case: subn => [|k]; rewrite //= ?negbK !addnS => Hk.
have [H2|H2] := boolP (odd _).
  by rewrite !rm0.
rewrite [LHS]mulrCA -2!natrM.
have->: ((i + k).+4 * 'C((i + k).+1.+4, k.+3) =
  'C((i + k).+4, k.+1) *i.+3 +
  (i.+1 + k.+1.*2).+4 * 'C((i + k).+4, k.+3))%nat.
  rewrite binS mulnDr.
  suff-> : ((i + k).+4 * 'C((i + k).+4, k.+2) =
         'C((i + k).+4, k.+1) * i.+3 +
           k.+3 * 'C((i + k).+4, k.+3))%nat.
    by rewrite addnCA -mulnDl -addnn !addSn !addnS addnA.
  rewrite [(_ * i.+3)%nat]mulnC (_ : i.+3 = (i + k).+4 - k.+1)%nat; last first.
    by rewrite subSS !subSn ?addnK ?leq_addl // ltnW // ltnS // ?leq_addl // ltnW // ltnS // leq_addl.
  rewrite -mul_bin_left.
  rewrite [X in (_ = _ + X)%nat]mul_bin_left.
  rewrite -mulnDl; congr (_ * _)%nat.
  by rewrite [RHS]addnC subnK // ltnS ltnW // !ltnS ltnW // ltnS leq_addl.
rewrite exprS.
move: (_^+ _) 'C(_,_) 'C(_,_) => u1 v1 v2.
rewrite -[_ *+ i.+3]mulr_natl.
rewrite -[_ *+ i.+1]mulr_natl.
rewrite -addnn !(natrM, natrD, natrS).
toR; lra.
Qed.

Lemma Derive_n_atan k x :
  Derive_n atan k.+1 x = (-1)^+ k * k`!%:R * (poly_atan k).[x] / (1 + x ^ 2)^k.+1.
Proof.
elim: k x => [x|k IH x].
  rewrite /= poly_atan_0 hornerE.
  apply: is_derive_unique.
  rewrite !Rmult_1_r /Rdiv Rmult_1_l.
  by exact: Coquelicot.is_derive_atan.
apply: etrans.
  apply: Derive_ext => y.
  by exact: IH.
rewrite Derive_div; last 3 first.
  - apply: ex_derive_mult.
      by apply: ex_derive_const.
    by exact: ex_derive_horner.
  - apply: ex_derive_pow.
    apply: ex_derive_plus.
      by apply: ex_derive_const.
    apply: ex_derive_pow.
    by apply: ex_derive_id.
 - by apply: pow_nonzero; nra.
rewrite factS mulnC natrM ![in RHS]Rmult_assoc.
rewrite (_ : k.+1%:R = k.+1%:R%:P.[x]); last by rewrite hornerE.
rewrite -[_.[x] * _.[x]](@hornerM [comRingType of R]).
rewrite poly_atan_deriv.
rewrite ![in RHS]hornerE !Derive_scal !Derive_horner .
rewrite Derive_pow; last first.
  apply: ex_derive_plus.
    by apply: ex_derive_const.
  apply: ex_derive_pow.
  by apply: ex_derive_id.
rewrite Derive_plus; last 2 first.
- by apply: ex_derive_const.
- by apply/ex_derive_pow/ex_derive_id.
rewrite Derive_const Derive_pow; last first.
  by exact: ex_derive_id.
rewrite Derive_id.
rewrite -natr_INR !natrS /= exprS.
rewrite !(Rmult_1_l, Rmult_1_r, Rplus_0_l).
rewrite (_ : x * x + 1 = 1 + x * x)%RR; last by toR; lra.
toR.
set u1 := _.[_].
set u2 := _.[_].
set v1 := 1 + _.
set v2 := _ ^ _.
field; split.
  by rewrite /v2 /v1; apply: pow_nonzero; nra.
by rewrite /v1; nra.
Qed.

Lemma ierror_atan x z :
  a <= x <= b ->
  (forall y, a <= y <= b ->
      Rabs (poly_atan n).[y] / (1 + y ^ 2)^n.+1 <= z) ->
  Rabs (aterror x) <= (b - a)^+ n.+1 / ((expn 2 n.+1.*2.-1 * n.+1) %:R) * z.
Proof.
move=> xB HD.
have-> : (b - a)^+ n.+1 / ((expn 2 n.+1.*2.-1 * n.+1) %:R) * z =
         (b - a)^+ n.+1 / ((expn 2 n.+1.*2.-1 * n.+1`!) %:R) * (n`!%:R * z).
  rewrite factS !natrM !natrS; toR; field; repeat split.
  - apply: (not_INR _ 0%nat) => //.
    by case: _`! (fact_gt0 n).
  - have : 0 <= INR n by apply: pos_INR.
    by lra.
  apply: (not_INR _ 0%nat) => //.
  by case: expn (expn_gt0 2 n.*2.+1).
apply: ierror_scheby => //.
- have H : a - 1 < a by lra.
  by exact H.
- have H : b < b + 1 by lra.
  by exact: H.
- move=> y k yB kLn.
  apply: Coquelicot.ex_derive_n_is_derive_n.
  by apply: Private.IT1.IT.TM.TMI.is_derive_n_atan.
- move=> y [/=|k] kLn yB.
    by apply: Coquelicot.continuous_atan.
  apply: continuous_ext => [u|].
    apply/sym_equal.
    by exact: Derive_n_atan.
  apply: continuous_mult.
    apply: ex_derive_continuous.
    apply: ex_derive_mult.
      by apply: ex_derive_const.
    by apply: ex_derive_horner.
  apply: Coquelicot.continuous_Rinv_comp; last first.
    by apply: pow_nonzero; nra.
  apply: ex_derive_continuous.
  apply: ex_derive_pow.
  apply: ex_derive_plus.
    by apply: ex_derive_const.
  apply: ex_derive_pow.
  by apply: ex_derive_id.
move=> y yB.
rewrite Derive_n_atan Rabs_mult.
rewrite [X in _ * X <= _]Rabs_pos_eq.
  rewrite !Rabs_mult Rabs_exprN1 Rmult_1_l.
  rewrite Rabs_pos_eq; last first.
    by rewrite natr_INR; apply: pos_INR.
  rewrite Rmult_assoc.
  apply: Rmult_le_compat_l.
    by rewrite natr_INR; apply: pos_INR.
  by exact: HD.
apply/Rlt_le/Rinv_0_lt_compat.
by apply: pow_lt; nra.
Qed.

Lemma atan_scheby_ge x :
  a <= x <= b ->
  (   (forall x, a <= x <= b -> (poly_atan n.+1).[x] <= 0)
    \/
      (forall x, a <= x <= b -> (poly_atan n.+1).[x] >= 0)) ->
  Rabs (aterror x) <= Rmax (Rabs (aterror a)) (Rabs (aterror b)).
Proof.
move=> xB HD.
apply: interpolation_scheby_ge => //.
- have H : a - 1 < a by lra.
  by exact: H.
- have H : b < b + 1 by lra.
  by exact: H.
- move=> [|m] y mLn yB.
    by apply: Coquelicot.continuous_atan.
  apply: continuous_ext => [u|].
    apply/sym_equal.
    by exact: Derive_n_atan.
  apply: continuous_mult.
    apply: ex_derive_continuous.
    apply: ex_derive_mult.
      by apply: ex_derive_const.
    by apply: ex_derive_horner.
  apply: Coquelicot.continuous_Rinv_comp; last first.
    by apply: pow_nonzero; nra.
  apply: ex_derive_continuous.
  apply: ex_derive_pow.
  apply: ex_derive_plus.
    by apply: ex_derive_const.
  apply: ex_derive_pow.
  by apply: ex_derive_id.
- case: HD => HD.
    case : (boolP (odd n)) => E.
      left => y Hy.
      rewrite Derive_n_atan.
      apply: Rmult_le_0_r; last first.
        apply/Rlt_le/Rinv_0_lt_compat.
        by apply: pow_lt; nra.
      apply: Rmult_le_0_l; last by apply: HD.
      apply: Rmult_le_pos.
        by rewrite -signr_odd /= E expr0; toR; lra.
      by rewrite natr_INR; apply: pos_INR.
    right => y Hy.
    rewrite Derive_n_atan.
    rewrite -signr_odd [odd _]/= E expr1.
    apply/Rle_ge/Rmult_le_pos.
      apply: Stdlib.Rmult_le_neg_neg.
        by rewrite natr_INR; have := pos_INR n.+1`!; toR; lra.
      by apply: HD.
    apply/Rlt_le/Rinv_0_lt_compat.
    by apply: pow_lt; nra.
  case : (boolP (odd n)) => E.
    right => y Hy.
    rewrite Derive_n_atan.
    rewrite -signr_odd [odd _]/= E expr0 Rmult_1_l.
    apply/Rle_ge/Rmult_le_pos.
      apply: Rmult_le_pos.
        by rewrite natr_INR; apply: pos_INR.
      by apply/Rge_le/HD.
    apply/Rlt_le/Rinv_0_lt_compat.
    by apply: pow_lt; nra.
  left => y Hy.
  rewrite Derive_n_atan.
  rewrite -signr_odd [odd _]/= E expr1.
  apply: Rmult_le_0_r.
    apply: Rmult_le_0_r.
      apply: Rmult_le_0_r; first by toR; lra.
      by rewrite natr_INR; apply: pos_INR.
    by apply/Rge_le/HD.
  apply/Rlt_le/Rinv_0_lt_compat.
  by apply: pow_lt; nra.
move=> m y mLn yB.
apply: Coquelicot.ex_derive_n_is_derive_n.
by apply: Private.IT1.IT.TM.TMI.is_derive_n_atan.
Qed.

End Atan.

(*****************************************************************************)
(*                                                                           *)
(*    Interpolation theorems for sqrt                                        *)
(*                                                                           *)
(*****************************************************************************)

Section DoubleFact.

Fixpoint dfact_rec (n : nat) :=
  if n is n1.+2 then muln n (dfact_rec n1) else 1%nat.

Definition dfact := nosimpl dfact_rec.

Lemma dfact0 : dfact 0 = 1%nat.
Proof. by []. Qed.

Lemma dfact1 : dfact 1 = 1%nat.
Proof. by []. Qed.

Lemma dfactSS (n : nat) : dfact n.+2 = muln n.+2 (dfact n).
Proof. by []. Qed.

Lemma dfact_evenE (n : nat) : dfact (n.*2) = muln (expn 2 n) (factorial n).
Proof.
elim: n => // n IH.
rewrite doubleS dfactSS IH factS !mulnA.
congr (_ * _)%nat.
by rewrite expnS [RHS]mulnAC mulnS add2n mul2n.
Qed.

End DoubleFact.

Section Sqrt.

Variable n : nat.
Variable a b : R.
Hypothesis aLb : a < b.

Let l := cheby_nodes n.+1.
Let ls := scheby_nodes a b n.+1.
Let sinter := interpolation sqrt ls.
Let serror := ierror sqrt ls.

Definition sqrt_coef i :=
  (if i == 0%nat then 1 else 2) / INR (n.+1) *
   \sum_(j < n.+1) sqrt (((b - a) * (l`_j) + a + b) / 2)%R * ('T_i).[l`_j].

Lemma sqrt_cheby_eq :
   sinter = \sum_(i < n.+1) sqrt_coef i *: 'T^(a, b)_i.
Proof.
have aDb : a != b by apply/eqP; lra.
rewrite [LHS](@sdsprod_cheby_eq a b n) //.
- apply: eq_bigr => i _.
  congr (_ *: _).
  by apply: sdsprod_coef_interpolation_pT.
apply: leq_trans (interpolation_size _ _) _.
by rewrite size_scheby_nodes.
Qed.

Lemma Derive_n_sqrt k x :
  0 < x ->
  Derive_n sqrt k x =  (-1) ^ k.-1 *  (/INR (expn 2 k)) * INR (dfact (k.*2 - 3)) *  sqrt x / x ^ k.
Proof.
move=> xP.
suff -> : (-1) ^ k.-1 *  (/INR (expn 2 k)) * INR (dfact (k.*2 - 3))  =
          \big[Rmult/1]_(i < k) (/ 2 - INR i).
  rewrite [_ / _]Rmult_assoc.
  suff -> : sqrt x * / x ^ k = Rpower x (/ 2 - INR k).
    by apply/is_derive_n_unique/Coquelicot.is_derive_n_sqrt.
  by rewrite Rpower_plus Rpower_Ropp Rpower_sqrt // Rpower_pow.
elim: k => [|[|[|k]] IH].
- by rewrite big_ord0 /=; field.
- by rewrite big_ord1 /=; field.
- by rewrite big_ord_recl big_ord1 /=; field.
rewrite big_ord_recr -IH [nat_of_ord _]/=.
rewrite doubleS -[_.*2.+2]add2n -addnBA // add2n dfactSS.
rewrite [RHS]Rmult_assoc [_ * (_ - _)]Rmult_comm.
rewrite [INR (_ * _)]mult_INR -!Rmult_assoc; congr (_ * _).
rewrite (_ : _ ^ _ = (-1) ^ k.+2.-1  * (-1)); last by rewrite /=; ring.
rewrite 2![LHS]Rmult_assoc [RHS]Rmult_assoc; congr (_ * _).
rewrite expnS mult_INR (_ : (_ - _).+2 = k.*2.+3); last by [].
set u := INR (expn _ _).
rewrite -!mul2n !S_INR !mult_INR /=.
field.
apply/not_0_INR.
by apply/eqP; rewrite expn_eq0.
Qed.

Lemma sqrt_scheby_ge x :
  a <= x <= b -> 0 < a ->
  Rabs (serror x) <= Rmax (Rabs (serror a)) (Rabs (serror b)).
Proof.
move=> xB zB.
have FPos : 0 < INR (n.+1)`! by apply/lt_0_INR/ltP/fact_gt0.
have F z : z * z = z ^ 2 by lra.
have bN : 0 < b by lra.
have Ha : a - a / 2 < a by lra.
have Hb : b < b + 1 by lra.
apply: interpolation_scheby_ge Ha Hb _ _ _ _ => //.
- move=> m y mLn yB.
  case: m mLn => [_|m mLn].
    by apply: Coquelicot.continuous_sqrt; lra.
  apply: continuous_ext_loc.
  pose z := Rmin (y - a / 2) (b + 1 - y).
    have Pz : 0 < z by apply: Rmin_pos; lra.
    exists (mkposreal _ Pz) => z1 /AbsRing_norm_compat2 Hz1.
    apply/sym_equal/Derive_n_sqrt.
    rewrite /abs /minus /plus /opp /z /= Rmult_1_l in Hz1.
    by move: Hz1; rewrite /Rmin; case: Rle_dec; split_Rabs; lra.
  apply: continuous_scal; last first.
    apply: Coquelicot.continuous_Rinv_comp.
      by apply: continuous_pow.
    by apply: pow_nonzero; lra.
  apply: continuous_scal; last first.
    by apply: Coquelicot.continuous_sqrt.
  by apply: continuous_const.
- have [On|En] := boolP (odd n).
    right => x1 Hx1.
    rewrite Derive_n_sqrt; try lra.
    apply/Rle_ge/Rmult_le_pos; last first.
      by apply/Rlt_le/Rinv_0_lt_compat/pow_lt; lra.
    apply: Rmult_le_pos; last by apply: sqrt_pos.
    apply: Rmult_le_pos; last by apply: pos_INR.
    apply: Rmult_le_pos; last first.
      apply/Rlt_le/Rinv_0_lt_compat/lt_0_INR.
      by apply/ltP; rewrite expn_gt0.
    rewrite -expr_Rexp -GRing.signr_odd [_ ^+ _]/= On /= GRing.expr0.
    by toR; lra.
  left => x1 Hx1.
  rewrite Derive_n_sqrt; try lra.
  apply: Rmult_le_0_r; last first.
    by apply/Rlt_le/Rinv_0_lt_compat/pow_lt; lra.
  apply: Rmult_le_0_r; last by apply: sqrt_pos.
  apply: Rmult_le_0_r; last by apply: pos_INR.
  apply: Rmult_le_0_r; last first.
    apply/Rlt_le/Rinv_0_lt_compat/lt_0_INR.
    by apply/ltP; rewrite expn_gt0.
  rewrite -expr_Rexp -GRing.signr_odd [_ ^+ _]/= En /= GRing.expr1.
  by toR; lra.
move=> m y Hm Hl.
apply: Coquelicot.ex_derive_n_is_derive_n.
by apply: Coquelicot.is_derive_n_sqrt; lra.
Qed.

End Sqrt.