Set Implicit Arguments.
Require Import TLC.LibTactics.
Require Import TLC.LibIntTactics.
Require Import TLC.LibListZ.
(* Load the CFML library, with time credits. *)
Require Import CFML.CFLibCredits.
(* Load the big-O library. *)
Require Import Dominated.
Require Import UltimatelyGreater.
Require Import Monotonic.
Require Import elia.
Require Import PolTac.PolTac.
(* Load the custom CFML tactics with support for big-Os *)
Require Import CFMLBigO.
(* Load the examples CF definitions. *)
Require Import Composing_specs_ml.

Notation "'len'" := LibListZ.length.

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

Lemma length_spec_explicit : forall A (l: list A),
  app length [l]
    PRE (\$ (len l + 1))
    POST (fun y => \[ y = len l ]).
Proof.
  intros. induction l as [| x l].
  { xcf. xpay. xvals. xmatch. xrets~. }
  { xcf. xpay. now rewrite credits_split_eq; hsimpl.
    xvals. xmatch. xapps. rewrite length_cons, !credits_split_eq. hsimpl.
    xrets. now rewrite length_cons. }
Qed.

Class length_spec_constants_pack := {
  length_cost_a : Z;
  length_cost_b : Z;
  length_spec_constants : forall A (l: list A),
    app length [l]
      PRE (\$ (length_cost_a * len l + length_cost_b))
      POST (fun y => \[ y = len l ]);
}.

Instance length_spec_constants_proof : length_spec_constants_pack.
Proof.
  refine {| length_cost_a := 1; length_cost_b := 1; length_spec_constants := _ |}.
  (* cheat a bit, and simply repackage [length_spec_explicit] *)
  intros. xapp_spec length_spec_explicit. hsimpl_credits. math.
Qed.

Lemma length_spec_bigO :
  specZ [costf \in_O (fun n => n)] (forall A (l: list A),
    app length [l]
      PRE (\$ costf (len l))
      POST (fun y => \[ y = len l ])).
Proof.
  (* also cheat a bit, and re-package length_spec_explicit *)
  xspecO (fun n => n + 1). intros; now xapp_spec length_spec_explicit.
  monotonic. dominated.
Qed.

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

Lemma length2_spec_explicit : forall A (l: list A),
  app length2 [l]
    PRE (\$ (2 * len l + 3))
    POST (fun y => \[ y = 2 * len l ]).
Proof.
  intros. xcf. weaken.
  xpay.
  xapps_spec length_spec_explicit.
  xapps_spec length_spec_explicit.
  xrets. math. math.
Qed.

Class length2_spec_constants_pack := {
  length2_cost_a : Z;
  length2_cost_b : Z;
  length2_spec_constants : forall A (l: list A),
    app length2 [l]
      PRE (\$ (length2_cost_a * len l + length2_cost_b))
      POST (fun y => \[ y = 2 * len l ]);
}.

Instance length2_spec_constants_proof : length2_spec_constants_pack.
Proof.
  (* Heavy handed version using defer+elia *)
  begin defer assuming a b.
  refine {| length2_cost_a := a; length2_cost_b := b;
            length2_spec_constants := _ |}.
  intros. xcf. weaken. xpay.
  xapps_spec length_spec_constants.
  xapps_spec length_spec_constants.
  xrets. math.
  (* Ideally (instead of what follows):
     - [generalize (len l) (length_nonneg l); defer.]
     - then have an automated solver *)
  { defer?: (2 * length_cost_a <= a). defer?: (2 * length_cost_b + 1 <= b).
    math_nia. }
  end defer. elia.
Qed.

Lemma length2_spec_bigO :
  specZ [costf \in_O (fun n => n)] (forall A (l: list A),
    app length2 [l]
      PRE (\$ costf (len l))
      POST (fun y => \[ y = 2 * len l ])).
Proof.
  xspecO_refine straight_line. intros.
  xcf. xpay.
  xapps_spec (spec length_spec_bigO). (*hack*) set (ll:=len l). piggybank: *rhs.
  xapps_spec (spec length_spec_bigO). (*hack*) set (ll:=len l). piggybank: *rhs.
  xrets. math.
  cleanup_cost. monotonic. dominated.
Qed.

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

Lemma loop_spec_bigO :
  specZ [costf \in_O (fun n => n^2)] (forall A (l: list A),
    app loop [l]
      PRE (\$ costf (len l))
      POST (fun (_:Z) => \[ True ])).
Proof.
  xspecO_refine recursive. intros costf M D g.
  induction l.
  { xcf. weaken. xpay. xmatch. xrets~. rew_cost.
    rewrite length_nil. defer. }
  { xcf. weaken. xpay. xmatch.
    xapps; =>_. xapps_spec (spec length_spec_bigO). xrets~.
    rewrite length_cons. rew_cost.
    generalize (len l) (length_nonneg l). defer. }
  close_cost.
  exists (fun n => n * cost length_spec_bigO n + n + 1). repeat split.
  math.
  intros.
(*  apply Z.max_case.
  { pols. forwards: cost_monotonic length_spec_bigO z (1+z); math_nia. }
  { pols.
  forwards: cost_nonneg length_spec_bigO z.
  forwards: cost_nonneg length_spec_bigO (1+z). math_nia.*) admit.

  cleanup_cost.
  monotonic. (* ugh *) admit.
  setoid_rewrite Z.pow_2_r. dominated.
  setoid_rewrite <-Z.mul_1_l at 1. apply dominated_mul; dominated.
Admitted.


Require Import ZArith.

Require Import Statement ThreadedPredicative Wpr.

Require Import Lia.

Open Scope stmt_scope.

Definition spec := ⟨fun '(i,n) '(i',n') => i <= n /\ i' = n /\ n = n'⟩.

Definition prog := WWhile (fun '(i,n) => i <> n) Do '(i,n) := (i+1,n) Done.

Theorem correctness : prog ⊑ spec.
Proof.
  intros (i,n) ((u,v),(HHin,_)); clear u v.
  set (K := wpr prog (pred spec)).
  generalize i HHin; clear i HHin.
  induction n; intros i HHin.
  { apply wpr_while_construct; right; simpl. lia. }
  { apply Lt.le_lt_or_eq in HHin.
    destruct HHin as [ HHin | HHin ].
    { assert (i <= n) as HHin' by lia.
      cut ((fun '(i,n) '(i',n') => i' <= n' /\ K (i,S n) (i',S n')) (i, n) (i, n)).
      { intros (HH1,HH2); auto. }
      { apply (IHn _ HHin'); clear i n HHin HHin' IHn.
        intros (i,n) (i',n'). intros [ (HHin,(HHi'n',HHind)) | HH ]; split; try lia.
        { apply wpr_while_construct; left; split; auto. lia. }
        { simpl in HH; apply wpr_while_construct; left; split; try lia; fold prog K.
          apply wpr_while_construct; right; simpl. lia.
        }
      }
    }
    { apply wpr_while_construct; right; simpl. lia. }
  }
Qed.


From Coq Require Import ssreflect ssrfun.
Set Bullet Behavior "Strict Subproofs".

Require Import GHC.Base.
Require Import GHC.Enum.

(******************************************************************************)
(** `iterates'` and `iterates` functions -- used for specification **)

Fixpoint iterates' {A} (n : nat) (f : A -> A) (z : A) : list A :=
  match n with
  | O    => nil
  | S n' => z :: iterates' n' f (f z)
  end.

Fixpoint iterates {A} (n : nat) (f : A -> A) (z : A) : list A :=
  z :: match n with
       | O    => nil
       | S n' => iterates n' f (f z)
       end.

Theorem iterates_iterates' {A} (n : nat) (f : A -> A) (z : A) :
  iterates n f z = iterates' (S n) f z.
Proof. by elim: n z => [|n IH] z //=; rewrite IH. Qed.

Theorem iterates'_ext {A} (n : nat) (f1 f2 : A -> A) (z : A) :
  f1 =1 f2 ->
  iterates' n f1 z = iterates' n f2 z.
Proof. by move=> f_eq; elim: n z => [|n IH] z //=; rewrite f_eq IH. Qed.

Theorem iterates_ext {A} (n : nat) (f1 f2 : A -> A) (z : A) :
  f1 =1 f2 ->
  iterates n f1 z = iterates n f2 z.
Proof. rewrite !iterates_iterates'; apply iterates'_ext. Qed.

Theorem iterates'_map {A} (n : nat) (f : A -> A) (z : A) :
  iterates' n f z = Coq.Lists.List.map (fun n => Nat.iter n f z) (seq 0 n).
Proof.
  elim: n z => [|n IH] z //=.
  rewrite -seq_shift map_map IH /=.
  f_equal; apply map_ext => i.
  by elim: i => [|i IH'] //=; rewrite IH'.
Qed.

Theorem iterates_map {A} (n : nat) (f : A -> A) (z : A) :
  iterates n f z = Coq.Lists.List.map (fun n => Nat.iter n f z) (seq 0 (S n)).
Proof. rewrite iterates_iterates'; apply iterates'_map. Qed.

Theorem iterates'_length {A} (n : nat) (f : A -> A) (z : A) :
  length (iterates' n f z) = n.
Proof. by rewrite iterates'_map map_length seq_length. Qed.

Theorem iterates_length {A} (n : nat) (f : A -> A) (z : A) :
  length (iterates n f z) = S n.
Proof. rewrite iterates_iterates'; apply iterates'_length. Qed.

Theorem iterates'_In {A} (n : nat) (f : A -> A) (z : A) (a : A) :
  In a (iterates' n f z) <-> ex2 (fun i => i < n)%nat (fun i => a = Nat.iter i f z).
Proof.
  rewrite iterates'_map in_map_iff.
  split=> [[i [def_a i_in_seq]] | [i LT def_a]]; subst; exists i; try split; try done.
  - move: i_in_seq => /in_seq [] //=.
  - apply in_seq => //=; split => //.
    apply Nat.le_0_l.
Qed.

Theorem iterates_In {A} (n : nat) (f : A -> A) (z : A) (a : A) :
  In a (iterates n f z) <-> ex2 (fun i => i <= n)%nat (fun i => a = Nat.iter i f z).
Proof.
  rewrite iterates_iterates' iterates'_In.
  split=> [[i LT def_a] | [i LE def_a]]; exists i=> //; omega.
Qed.

(******************************************************************************)
(** Lemmas about `Nat.iter` **)

Lemma iter_plus_nat (m n : nat) : Nat.iter m S n = (m + n)%nat.
Proof. by elim: m => [|m IH] //=; rewrite IH. Qed.

Lemma iter_plus_N (m : nat) (n : N) : Nat.iter m N.succ n = (N.of_nat m + n)%N.
Proof. by elim: m => [|m IH] //; rewrite Nat2N.inj_succ N.add_succ_l /= IH. Qed.

Lemma iter_plus_Z (m : nat) (n : Z) : Nat.iter m Z.succ n = (Z.of_nat m + n)%Z.
Proof. by elim: m => [|m IH] //; rewrite Nat2Z.inj_succ Z.add_succ_l /= IH. Qed.

(******************************************************************************)
(** `eftInt`, including `eftInt_aux` and `enumFromTo` **)

(* Unrolling `eftInt_aux` *)

Definition eftInt_aux_rhs (y x : Int) (pf : (x <= y)%Z) : list Int :=
  x :: match Z.eq_dec x y with
       | left  _   => nil
       | right neq => eftInt_aux y (x+1) (eftInt_aux_pf pf neq)
       end%Z.

Lemma eftInt_aux_unroll (to from : Int) (pf : (from <= to)%Z) :
  eftInt_aux to from pf = eftInt_aux_rhs to from pf.
Proof.
  rewrite /eftInt_aux /eftInt_aux_func Wf.WfExtensionality.fix_sub_eq_ext /= /eftInt_aux_rhs.
  by case: (Z.eq_dec from to).
Qed.

(* Specifying `eftInt_aux`, `eftInt`, and `enumFromTo` in terms of
   `iterate`/`iterate'` *)

Theorem eftInt_aux_iterates (to from : Int) (pf : (from <= to)%Z) :
  eftInt_aux to from pf = iterates (Z.to_nat (to - from)) Z.succ from.
Proof.
  remember (Z.to_nat (to - from)) as diff eqn:def_diff.
  elim: diff to from pf def_diff => [|diff IH] to from pf def_diff /=;
    rewrite eftInt_aux_unroll /eftInt_aux_rhs.
  - case: (Z.eq_dec _ _) => [// | NEQ].
    suff LE: (to - from <= 0)%Z by omega.
    move: def_diff; case: (to - from)%Z => //=.
    move=> p ZERO; move: (Pos2Nat.is_pos p) => POS; omega.
  - case: (Z.eq_dec _ _) => [? | NEQ]; first by subst; rewrite Z.sub_diag in def_diff.
    rewrite IH //.
    by rewrite Z.sub_add_distr Z2Nat.inj_sub //= -def_diff /Pos.to_nat /= Nat.sub_0_r.
Qed.

Theorem eftInt_iterates' (from to : Int) :
  eftInt from to = iterates' (Z.to_nat (to - from + 1)) Z.succ from.
Proof.
  rewrite /eftInt; case: (Z_gt_dec _ _) => [GT | LE].
  - have: (to - from < 0)%Z by omega.
    case: (to - from)%Z => //=.
    case=> //=.
  - rewrite eftInt_aux_iterates iterates_iterates'; f_equal.
    rewrite Z.add_1_r Z2Nat.inj_succ //; omega.
Qed.

Theorem enumFromTo_Int_iterates' (from to : Int) :
  enumFromTo from to = iterates' (Z.to_nat (to - from + 1)) Z.succ from.
Proof. apply eftInt_iterates'. Qed.

(* Specifying `eftInt_aux`, `eftInt`, and `enumFromTo` in terms of membership *)

Theorem eftInt_aux_In (to from : Int) (pf : (from <= to)%Z) (a : Int) :
  In a (eftInt_aux to from pf) <-> (from <= a <= to)%Z.
Proof.
  rewrite eftInt_aux_iterates iterates_In.
  split=> [[i LE ->{a}] | [LE_a a_LE]].
  - rewrite iter_plus_Z.
    move: LE => /inj_le; rewrite Z2Nat.id => [|LE]; omega.
  - remember (Z.to_nat (to - from)) as diff eqn:def_diff.
    elim: diff from pf def_diff LE_a => [|diff IH] from pf def_diff LE_a.
    + exists 0 => //=.
      suff LE: (to - from <= 0)%Z by apply Z.le_antisymm; omega.
      move: def_diff; case: (to - from)%Z => //= p.
      move: (Pos2Nat.is_pos p) => *; omega.
    + case: (Z.eq_dec from a) => [? | NEQ]; first by subst a; exists 0 => //=; omega.
      have LE_a': (from < a)%Z by omega.
      case: (IH (Z.succ from)) => [| | | i LE_i def_a]; try omega.
      * by rewrite Z.sub_succ_r Z2Nat.inj_pred -def_diff.
      * exists (S i); first by apply le_n_S.
        by rewrite def_a /Nat.iter nat_rect_succ_r.
Qed.

Theorem eftInt_In (from to : Int) (a : Int) :
  In a (eftInt from to) <-> (from <= a <= to)%Z.
Proof.
  rewrite /eftInt; case: (Z_gt_dec _ _) => ?; [simpl; omega | apply eftInt_aux_In].
Qed.

Theorem enumFromTo_Int_In (from to : Int) (a : Int) :
  In a (enumFromTo from to) <-> (from <= a <= to)%Z.
Proof. apply eftInt_In. Qed.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

Require Import ssreflect ssrbool ssrfun.
Require Import Arith Psatz.
Require Import List.
Import ListNotations.

Set Default Proof Using "Type".
Set Default Goal Selector "!".

(* misc facts *)

(* induction/recursion principle wrt. a decreasing measure f *)
(* example: elim /(measure_rect length) : l. *)
Lemma measure_rect {X : Type} (f : X -> nat) (P : X -> Type) :
  (forall x, (forall y, f y < f x -> P y) -> P x) -> forall (x : X), P x.
Proof.
  exact: (well_founded_induction_type (Wf_nat.well_founded_lt_compat X f _ (fun _ _ => id)) P).
Qed.

(* transforms a goal (A -> B) -> C into goals A and B -> C *)
Lemma unnest {A B C: Prop} : A -> (B -> C) -> (A -> B) -> C.
Proof. auto. Qed.

(* duplicates argument *)
Lemma copy {A: Prop} : A -> A * A.
Proof. done. Qed.

Lemma eta_reduction {X Y: Type} (f: X -> Y) : (fun x => f x) = f.
Proof. done. Qed.

(* list facts *)

Lemma nil_or_ex_max (A : list nat) : A = [] \/ exists a, In a A /\ Forall (fun b => a >= b) A.
Proof.
  elim: A; first by left.
  move=> a A [-> | [b [? Hb]]]; right.
  - exists a. constructor; by [left | constructor].
  - case: (le_lt_dec a b)=> ?.
    + exists b. constructor; by [right | constructor].
    + exists a. constructor; first by left.
      constructor; first done.
      apply: Forall_impl Hb. by lia.
Qed.

(* count_occ facts *)
Lemma count_occ_cons {X : Type} {D : forall x y : X, {x = y} + {x <> y}} {A a c}:
count_occ D (a :: A) c = count_occ D (locked [a]) c + count_occ D A c.
Proof.
  rewrite /count_occ /is_left -lock. by case: (D a c).
Qed.

(* Forall facts *)
Lemma Forall_singleton_iff {X: Type} {P: X -> Prop} {x} : Forall P [x] <-> P x.
Proof.
  rewrite Forall_cons_iff. by constructor; [case |].
Qed.

(* usage: rewrite ? Forall_norm *)
Definition Forall_norm := (@Forall_app, @Forall_singleton_iff, @Forall_cons_iff, @Forall_nil_iff).

(* seq facts *)
Lemma seq_last start length : seq start (S length) = (seq start length) ++ [start + length].
Proof.
  by rewrite (ltac:(lia) : S length = length + 1) seq_app.
Qed.

(* repeat facts *)
Lemma Forall_repeat {X: Type} {a} {A: list X} : Forall (fun b => a = b) A -> A = repeat a (length A).
Proof.
  elim: A; first done.
  move=> b A IH. rewrite Forall_norm => [[? /IH ->]]. subst b.
  cbn. by rewrite repeat_length.
Qed.


Require Export euclidean__axioms.
Require Export lemma__congruencesymmetric.
Definition lemma__congruencetransitive : forall A B C D E F, (euclidean__axioms.Cong A B C D) -> ((euclidean__axioms.Cong C D E F) -> (euclidean__axioms.Cong A B E F)).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro F.
intro H.
intro H0.
assert (* Cut *) (euclidean__axioms.Cong C D A B) as H1.
- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C A B D H).
- assert (* Cut *) (euclidean__axioms.Cong A B E F) as H2.
-- apply (@euclidean__axioms.cn__congruencetransitive A B E F C D H1 H0).
-- exact H2.
Qed.


From VLSM.Lib Require Import SsrExport.

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

(** * Definition of possibly-infinite traces *)

Ltac invs h := inversion h; subst => {h}.

Section sec_traces.

Context {A B : Type}.

(** ** Core trace definition and decomposition *)

(**
  This definition is similar to that for lazy lists from Chapter 13
  of the #Coq'Art book#.
  However, to support traces following labeled transition relations, constructors
  have additional elements.
*)

CoInductive trace : Type :=
| Tnil : A -> trace
| Tcons : A -> B -> trace -> trace.

Definition hd tr :=
match tr with
| Tnil a => a
| Tcons a b tr0 => a
end.

Definition trace_decompose (tr : trace) : trace :=
match tr with
| Tnil a => Tnil a
| Tcons a b tr' => Tcons a b tr'
end.

Lemma trace_destr : forall tr, tr = trace_decompose tr.
Proof. by case. Qed.

(** ** Bisimulations between traces *)

CoInductive bisim : trace -> trace -> Prop :=
| bisim_nil : forall a,
   bisim (Tnil a) (Tnil a)
| bisim_cons : forall a b tr tr',
   bisim tr tr' ->
   bisim (Tcons a b tr) (Tcons a b tr').

Lemma bisim_refl : forall tr, bisim tr tr.
Proof.
cofix CIH.
case => [a | a b tr]; first exact: bisim_nil.
exact/bisim_cons/CIH.
Qed.

Lemma bisim_sym : forall tr1 tr2, bisim tr1 tr2 -> bisim tr2 tr1.
Proof.
cofix CIH.
case => [a | a b tr1] tr2 Hbs; invs Hbs; first exact: bisim_nil.
exact/bisim_cons/CIH.
Qed.

Lemma bisim_trans : forall tr1 tr2 tr3,
 bisim tr1 tr2 -> bisim tr2 tr3 -> bisim tr1 tr3.
Proof.
cofix CIH.
case => [a | a b tr1] tr2 tr0 Hbs Hbs'; invs Hbs; invs Hbs'; first exact: bisim_nil.
exact: (bisim_cons _ _ (CIH _ _ _ H3 H4)).
Qed.

Lemma bisim_hd : forall tr0 tr1, bisim tr0 tr1 -> hd tr0 = hd tr1.
Proof. by move => tr0 tr1 []. Qed.

(** ** Appending traces to one another *)

CoFixpoint trace_append (tr tr' : trace) : trace :=
match tr with
| Tnil a => tr'
| Tcons a b tr0 => Tcons a b (trace_append tr0 tr')
end.

#[local] Infix "+++" := trace_append (at level 60, right associativity).

Lemma trace_append_nil : forall a tr, (Tnil a) +++ tr = tr.
Proof.
move => a tr.
rewrite [Tnil a +++ tr]trace_destr.
by case tr.
Qed.

Lemma trace_append_cons : forall a b tr tr',
 (Tcons a b tr) +++ tr' = Tcons a b (tr +++ tr').
Proof.
move => a b tr tr'.
rewrite [Tcons a b tr +++ tr']trace_destr.
by case tr.
Qed.

Lemma trace_append_bism : forall tr1 tr2 tr3 tr4,
 bisim tr1 tr2 -> bisim tr3 tr4 -> bisim (tr1 +++ tr3) (tr2 +++ tr4).
Proof.
cofix CIH.
move => tr1 tr2 tr3 tr4 [a1 | a1 b1 tr1' tr2' Hbs1'] Hbs2.
- rewrite 2!trace_append_nil. exact: Hbs2.
- rewrite 2!trace_append_cons.
  exact/bisim_cons/CIH.
Qed.

End sec_traces.

Infix "+++" := trace_append (at level 60, right associativity).


Require Import Coq.ZArith.ZArith.

Section Imp.

Context {Var: Type}.

Definition stack := Var -> Z.
Definition heap := Z -> option Z.
Definition state: Type := stack * heap.

Definition update_stack (st : stack) (x : Var) (n : Z) (st': stack): Prop :=
  st' x = n /\
  (forall x0, x0 <> x -> st x0 = st' x0).

Definition update_heap (st : heap) (x : Z) (n : option Z) (st': heap): Prop :=
  st' x = n /\
  (forall x0, x0 <> x -> st x0 = st' x0).

Inductive aexp : Type :=
  | AVar : Var -> aexp
  | ANum : Z -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (st : stack) (a : aexp) : Z :=
  match a with
  | AVar x => st x
  | ANum n => n
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : stack) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => Zeq_bool (aeval st a1) (aeval st a2)
  | BLe a1 a2   => Zle_bool (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

Inductive cmd : Type :=
  | CSkip : cmd
  | CSet : Var -> aexp -> cmd
  | CLoad : Var -> Var -> cmd
  | CStore : Var -> Var -> cmd
  | CSeq : cmd -> cmd -> cmd
  | CIf : bexp -> cmd -> cmd -> cmd
  | CWhile : bexp -> cmd -> cmd.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CSet x a) (at level 60).
Notation "x '::=' '<<' y '>>'" :=
  (CLoad x y) (at level 58).
Notation "'<<' x '>>' '::=' y" :=
  (CStore x y) (at level 58).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Reserved Notation " t '/' st '==>' t' '/' st' "
                  (at level 40, st at level 39, t' at level 39).

Inductive cstep : (cmd * state) -> (cmd * state) -> Prop :=
  | CS_Set : forall st st' i n a,
      aeval (fst st) a = n ->
      update_stack (fst st) i n (fst st') ->
      snd st = snd st' ->
      (i ::= a) / st ==> SKIP / st'
  | CS_Load : forall (st st': state) i x n,
      snd st (fst st x) = Some n ->
      update_stack (fst st) i n (fst st') ->
      snd st = snd st' ->
      (i ::= << x >>) / st ==> SKIP / st'
  | CS_Store : forall (st st': state) i x n,
      snd st (fst st x) = Some n ->
      update_heap (snd st) (fst st x) (Some (fst st i)) (snd st') ->
      fst st = fst st' ->
      (CStore x i) / st ==> SKIP / st'
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st ==> c1' / st' ->
      (c1 ;; c2) / st ==> (c1' ;; c2) / st'
  | CS_SeqFinish : forall st c2,
      (SKIP ;; c2) / st ==> c2 / st
  | CS_IfTrue : forall st b c1 c2,
      beval (fst st) b = true ->
      IFB b THEN c1 ELSE c2 FI / st ==> c1 / st
  | CS_IfFalse : forall st b c1 c2,
      beval (fst st) b = false ->
      IFB b THEN c1 ELSE c2 FI / st ==> c2 / st
  | CS_WhileTrue : forall st b c1,
      beval (fst st) b = true ->
      (WHILE b DO c1 END) / st ==> (c1;; (WHILE b DO c1 END)) / st
  | CS_WhileFalse : forall st b c1,
      beval (fst st) b = false ->
      (WHILE b DO c1 END) / st ==> SKIP / st

  where " t '/' st '==>' t' '/' st' " := (cstep (t,st) (t',st')).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Basic specifications : sets that may contain logical information *)

Set Implicit Arguments.

Require Import Notations.
Require Import Datatypes.
Require Import Logic.

(** Subsets and Sigma-types *)

(** [(sig A P)], or more suggestively [{x:A | P x}], denotes the subset
    of elements of the type [A] which satisfy the predicate [P].
    Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset
    of elements of the type [A] which satisfy both [P] and [Q]. *)

Inductive sig (A:Type) (P:A -> Prop) : Type :=
    exist : forall x:A, P x -> sig P.

Inductive sig2 (A:Type) (P Q:A -> Prop) : Type :=
    exist2 : forall x:A, P x -> Q x -> sig2 P Q.

(** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type.
    Similarly for [(sigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *)

Inductive sigT (A:Type) (P:A -> Type) : Type :=
    existT : forall x:A, P x -> sigT P.

Inductive sigT2 (A:Type) (P Q:A -> Type) : Type :=
    existT2 : forall x:A, P x -> Q x -> sigT2 P Q.

(* Notations *)

Arguments Scope sig [type_scope type_scope].
Arguments Scope sig2 [type_scope type_scope type_scope].
Arguments Scope sigT [type_scope type_scope].
Arguments Scope sigT2 [type_scope type_scope type_scope].

Notation "{ x  |  P }" := (sig (fun x => P)) : type_scope.
Notation "{ x  |  P  & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope.
Notation "{ x : A  |  P }" := (sig (fun x:A => P)) : type_scope.
Notation "{ x : A  |  P  & Q }" := (sig2 (fun x:A => P) (fun x:A => Q)) :
  type_scope.
Notation "{ x : A  & P }" := (sigT (fun x:A => P)) : type_scope.
Notation "{ x : A  & P  & Q }" := (sigT2 (fun x:A => P) (fun x:A => Q)) :
  type_scope.

Add Printing Let sig.
Add Printing Let sig2.
Add Printing Let sigT.
Add Printing Let sigT2.

(** Projections of [sig]

    An element [y] of a subset [{x:A & (P x)}] is the pair of an [a]
    of type [A] and of a proof [h] that [a] satisfies [P].  Then
    [(proj1_sig y)] is the witness [a] and [(proj2_sig y)] is the
    proof of [(P a)] *)

Section Subset_projections.

  Variable A : Type.
  Variable P : A -> Prop.

  Definition proj1_sig (e:sig P) := match e with
                                    | exist a b => a
                                    end.

  Definition proj2_sig (e:sig P) :=
    match e return P (proj1_sig e) with
    | exist a b => b
    end.

End Subset_projections.

(** Projections of [sigT]

    An element [x] of a sigma-type [{y:A & P y}] is a dependent pair
    made of an [a] of type [A] and an [h] of type [P a].  Then,
    [(projT1 x)] is the first projection and [(projT2 x)] is the
    second projection, the type of which depends on the [projT1]. *)

Section Projections.

  Variable A : Type.
  Variable P : A -> Type.

  Definition projT1 (x:sigT P) : A := match x with
                                      | existT a _ => a
                                      end.
  Definition projT2 (x:sigT P) : P (projT1 x) :=
    match x return P (projT1 x) with
    | existT _ h => h
    end.

End Projections.

(** [sigT] of a predicate is equivalent to [sig] *)

Lemma sig_of_sigT : forall (A:Type) (P:A->Prop), sigT P -> sig P.
Proof. destruct 1 as (x,H); exists x; trivial. Defined.

Lemma sigT_of_sig : forall (A:Type) (P:A->Prop), sig P -> sigT P.
Proof. destruct 1 as (x,H); exists x; trivial. Defined.

Coercion sigT_of_sig : sig >-> sigT.
Coercion sig_of_sigT : sigT >-> sig.

(** [sumbool] is a boolean type equipped with the justification of
    their value *)

Inductive sumbool (A B:Prop) : Set :=
  | left : A -> {A} + {B}
  | right : B -> {A} + {B}
 where "{ A } + { B }" := (sumbool A B) : type_scope.

Add Printing If sumbool.

Implicit Arguments left [[A] [B]] [A].
Implicit Arguments right [[A] [B]] [B].

(** [sumor] is an option type equipped with the justification of why
    it may not be a regular value *)

Inductive sumor (A:Type) (B:Prop) : Type :=
  | inleft : A -> A + {B}
  | inright : B -> A + {B}
 where "A + { B }" := (sumor A B) : type_scope.

Add Printing If sumor.

(** Various forms of the axiom of choice for specifications *)

Section Choice_lemmas.

  Variables S S' : Set.
  Variable R : S -> S' -> Prop.
  Variable R' : S -> S' -> Set.
  Variables R1 R2 : S -> Prop.

  Lemma Choice :
   (forall x:S, {y:S' | R x y}) -> {f:S -> S' | forall z:S, R z (f z)}.
  Proof.
   intro H.
   exists (fun z => proj1_sig (H z)).
   intro z; destruct (H z); assumption.
  Defined.

  Lemma Choice2 :
   (forall x:S, {y:S' & R' x y}) -> {f:S -> S' & forall z:S, R' z (f z)}.
  Proof.
    intro H.
    exists (fun z => projT1 (H z)).
    intro z; destruct (H z); assumption.
  Defined.

  Lemma bool_choice :
   (forall x:S, {R1 x} + {R2 x}) ->
     {f:S -> bool | forall x:S, f x = true /\ R1 x \/ f x = false /\ R2 x}.
  Proof.
    intro H.
    exists (fun z:S => if H z then true else false).
    intro z; destruct (H z); auto.
  Defined.

End Choice_lemmas.

Section Dependent_choice_lemmas.

  Variables X : Set.
  Variable R : X -> X -> Prop.

  Lemma dependent_choice :
    (forall x:X, {y | R x y}) ->
    forall x0, {f : nat -> X | f O = x0 /\ forall n, R (f n) (f (S n))}.
  Proof.
    intros H x0.
    set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end).
    exists f.
    split. reflexivity.
    induction n; simpl; apply proj2_sig.
  Defined.

End Dependent_choice_lemmas.

 (** A result of type [(Exc A)] is either a normal value of type [A] or
     an [error] :

     [Inductive Exc [A:Type] : Type := value : A->(Exc A) | error : (Exc A)].

     It is implemented using the option type. *)

Definition Exc := option.
Definition value := Some.
Definition error := @None.

Implicit Arguments error [A].

Definition except := False_rec. (* for compatibility with previous versions *)

Implicit Arguments except [P].

Theorem absurd_set : forall (A:Prop) (C:Set), A -> ~ A -> C.
Proof.
  intros A C h1 h2.
  apply False_rec.
  apply (h2 h1).
Defined.

Hint Resolve left right inleft inright: core v62.
Hint Resolve exist exist2 existT existT2: core.

(* Compatibility *)

Notation sigS := sigT (only parsing).
Notation existS := existT (only parsing).
Notation sigS_rect := sigT_rect (only parsing).
Notation sigS_rec := sigT_rec (only parsing).
Notation sigS_ind := sigT_ind (only parsing).
Notation projS1 := projT1 (only parsing).
Notation projS2 := projT2 (only parsing).

Notation sigS2 := sigT2 (only parsing).
Notation existS2 := existT2 (only parsing).
Notation sigS2_rect := sigT2_rect (only parsing).
Notation sigS2_rec := sigT2_rec (only parsing).
Notation sigS2_ind := sigT2_ind (only parsing).


Definition id {A : Type} (a : A) : A := a.

Definition compose {A B C : Type} (g : B -> C) (f : A -> B): A -> C :=
    fun a : A => g (f a).

Class Functor (functor: Type -> Type) := {
    fmap: forall {A B : Type}, (A -> B) -> functor A -> functor B;

    functors_preserve_composition
        : forall (A B C: Type)
        , forall (g : B -> C)
        , forall (f : A -> B)
        , forall (c : functor A)
        , (compose (fmap g) (fmap f)) c = fmap (compose g f) c;

    functor_id_law
        : forall (A : Type), forall (c : functor A), fmap id c = id c
}.

Class Applicative (F: Type -> Type) := {
    (* It must also be a functor *)
    is_functor :> Functor F;

    (* functions *)
    unit : forall {A : Type}, A -> F A;
    apply : forall {A B : Type}, F (A -> B) -> F A -> F B;

    (* laws *)
    unit_identity
        : forall (A : Type) (x : F A), apply (unit id) x = x;

    unit_compose
        : forall (A B C : Type) (u : F (B -> C)) (v : F (A -> B)) (w : F A)
        , apply (apply (apply (unit compose) u) v) w = apply u (apply v w);

    unit_homomorphism
        : forall (A B : Type) (f : A -> B) (x : A)
        , apply (unit f) (unit x) = unit (f x);

    unit_interchange
        : forall (A B : Type) (u : F (A -> B)) (x : A)
        , apply u (unit x) = apply (unit (fun (f : A -> B) => f x)) u;

    unit_fmap
        : forall (A B : Type) (f : A -> B) (x : F A)
        , fmap f x = apply (unit f) x
}.

Notation "v <*> w" := (apply v w) (at level 50).

Class Monad (M: Type -> Type) := {
    (* Must be an applicative functor *)
    monads_are_applicative :> Applicative M;

    (* functions *)
    join : forall {A : Type}, M (M A) -> M A;

    (* Monad Laws *)

    monad_unit_left_identity
        : forall (A B : Type) (f : A -> M B) (x : A)
        , f x = join (fmap f (unit x));

    monad_unit_right_identity
        : forall (A : Type) (m : M A)
        , id m = join (fmap unit m);

    (* monad_join_associative
        : forall (A : Type) (m : M (M (M A)))
        , join m = fmap join m *)

    monad_join_fmap_associative
        : forall (A B C : Type) (m : M A) (k : A -> M B) (h : B -> M C)
        , join (fmap (fun x : A => join (fmap h (k x))) m) = join (fmap h (join (fmap k m)))

}.

Definition bind {M : Type -> Type} {ismonad : Monad M} {A B : Type} (m : M A) (f : A -> M B) : M B :=
    join (fmap f m).

Notation "m >>= f" := (bind m f) (at level 50).

Theorem bind_associative
    : forall (A B C : Type) (M : Type -> Type) (monad_dict : Monad M) (m : M A) (k : A -> M B) (h : B -> M C)
    , m >>= (fun (x : A) => (k x >>= h)) = (m >>= k) >>= h.
Proof.
    intros.
    unfold bind.
    apply monad_join_fmap_associative.
Qed.

Inductive myMaybe (A : Type) : Type :=
    | empty : myMaybe A
    | just : A -> myMaybe A.

Definition maybeMap {A B : Type} (f : A -> B) (m : @myMaybe A) : @myMaybe B :=
    match m with
        | empty => empty B
        | just x => just B (f x)
    end.

Definition applyMaybe {A B : Type} (mf : @myMaybe (A -> B)) (m : @myMaybe A) : @myMaybe B :=
    match mf with
        | empty => empty B
        | just f => match m with
            | empty => empty B
            | just x => just B (f x)
        end
    end.

Definition joinMaybe {A : Type} (mm : @myMaybe (@myMaybe A)) : @myMaybe A :=
    match mm with
        | empty => empty A
        | just m => m
    end.

Instance maybe_functor : Functor myMaybe := {
    fmap := @maybeMap
}.
Proof.
    intros.
    unfold compose.
    unfold maybeMap.
    destruct c.
    reflexivity.
    reflexivity.
    intros.
    unfold maybeMap.
    destruct c.
    unfold id.
    reflexivity.
    unfold id.
    reflexivity.
Defined.

Instance maybe_applicative : Applicative myMaybe := {
    unit := @just;
    apply := @applyMaybe
}.
Proof.
    - intros. unfold applyMaybe. destruct x as [| x']. reflexivity. unfold id. reflexivity.
    - intros.
        unfold applyMaybe.
        destruct u as [| uf].
        reflexivity.
        destruct v as [| vf].
        reflexivity.
        destruct w as [| w'].
        reflexivity.
        unfold compose.
        reflexivity.
    - intros.
        unfold applyMaybe.
        reflexivity.
    -   intros.
        unfold applyMaybe.
        destruct u as [| uf].
        reflexivity.
        reflexivity.
    -   intros.
        simpl.
        destruct x as [| x'].
        unfold maybeMap.
        reflexivity.
        unfold maybeMap.
        reflexivity.
Defined.

Instance maybe_monad : Monad myMaybe := {
    join := @joinMaybe
}.
Proof.
    - intros.
        unfold joinMaybe.
        unfold fmap.
        unfold is_functor.
        unfold maybe_applicative.
        unfold maybe_functor.
        unfold maybeMap.
        unfold unit.
        reflexivity.
    - intros.
        unfold id.
        unfold joinMaybe.
        unfold fmap.
        unfold is_functor.
        unfold maybe_applicative.
        unfold maybe_functor.
        unfold maybeMap.
        destruct m as [| x].
        reflexivity.
        unfold unit.
        reflexivity.
    - intros.
        unfold fmap.
        unfold is_functor.
        unfold maybe_applicative.
        unfold maybe_functor.
        unfold maybeMap.
        destruct m as [| x].
        simpl.
        reflexivity.
        destruct (k x) as [| kx].
        simpl.
        reflexivity.
        simpl.
        reflexivity.
Defined.


(* -*- mode: coq; mode: visual-line -*-  *)
Require Import HoTT.Basics HoTT.Types.
Require Import HFiber Extensions Limits.Pullback.
Require Import Modality Accessible Localization.

Local Open Scope path_scope.
Local Open Scope subuniverse_scope.

(** * Descent between subuniverses *)

(** We study here a strengthening of the relation [O << O'] saying that [O]-modal type families descend along [O']-equivalences.  Pairs of reflective subuniverses with this relation share nearly all the properties of a reflective subuniverse [O] paired with its subuniverse [Sep O] of separated types (see [Separated.v]) and also many of those of a single left exact modality (see [Lex.v]).  Thus, many of the results herein generalize those of RSS for lex modalities and those of CORS for separated subuniverses.

Note that this kind of descent is not the same as the "modal descent" of Cherubini and Rijke.  When we get around to formalizing that, we may need to worry about disambiguating the names. *)

(** ** Definitions *)

(** This definition is an analogue of the statement of Lemma 2.19 of CORS, and of Theorem 3.1(xiii) of RSS.  Note that CORS Lemma 2.19 includes uniqueness of the extension, which we don't assert explicitly.  However, uniqueness follows from the [ReflectsD] parameter -- see [ooextendable_TypeO_lex_leq] below. *)
Class Descends@{i} (O' O : Subuniverse@{i}) (T : Type@{i})
      `{ReflectsD@{i} O' O T} :=
{
  OO_descend :
    forall (P : T -> Type@{i}) {P_inO : forall x, In O (P x)},
      O_reflector O' T -> Type@{i} ;
  OO_descend_inO :
    forall (P : T -> Type@{i}) {P_inO : forall x, In O (P x)} (x : O_reflector O' T),
      In O (OO_descend P x) ;
  OO_descend_beta :
    forall (P : T -> Type@{i}) {P_inO : forall x, In O (P x)} (x : T),
      OO_descend P (to O' T x) <~> P x ;
}.

Global Existing Instance OO_descend_inO.
Arguments OO_descend O' O {T _ _ _} P {P_inO} x.
Arguments OO_descend_inO O' O {T _ _ _} P {P_inO} x.
Arguments OO_descend_beta O' O {T _ _ _} P {P_inO} x.

Class O_lex_leq (O1 O2 : ReflectiveSubuniverse) `{O1 << O2} :=
  O_lex_leq_descends : forall A, Descends O2 O1 A.

Infix "<<<" := O_lex_leq : subuniverse_scope.
Global Existing Instance O_lex_leq_descends.

(** Unfortunately, it seems that generalizing binders don't work on notations: writing [`{O <<< O'}] doesn't automatically add the precondition [O << O'], although writing [`{O_lex_leq O O'}] does. *)

Definition O_lex_leq_eq {O1 O2 O3 : ReflectiveSubuniverse}
           `{O1 <=> O2} `{O2 << O3, O2 <<< O3}
           (Hstrong := O_strong_leq_trans_l O1 O2 O3)
  : O1 <<< O3.
Proof.
  intros A; unshelve econstructor; intros P P_inO1.
  all:pose (P_inO2 := fun x => inO_leq O1 O2 _ (P_inO1 x)).
  - apply (OO_descend O3 O2 P).
  - intros x; apply (inO_leq O2 O1), (OO_descend_inO O3 O2 P).
  - apply (OO_descend_beta O3 O2 P).
Defined.

(** ** Left exactness properties *)

(** We prove analogues of the properties in section 2.4 of CORS and Theorem 3.1 of RSS, but in a different order, with different proofs, to increase the generality.  The proofs in CORS use Proposition 2.26 for everything else, but it seems that most of the other results are true in the generality of two reflective subuniverses with [O <<< O'], so we give different proofs for some of them.  (To show that this generality is non-spurious, note that a lex modality [O] satisfies [O <<< O], but does not generally coincide with [Sep O].)

In the case of a single modality, most of these statements are equivalent to lex-ness (as stated in Theorem 3.1 of RSS).  We do not know if anything similar is true more generally. *)

Section LeftExactness.
Universe i.
Context (O' O : ReflectiveSubuniverse@{i}) `{O << O', O <<< O'}.

(** Proposition 2.30 of CORS and Theorem 3.1(xii) of RSS: any [O']-equivalence is [O]-connected.  The special case when [f = to O' A] requires only [O << O'], but the general case seems to require [O <<< O']. *)
Global Instance conn_map_OO_inverts
       {A B : Type} (f : A -> B) `{O_inverts O' f}
  : IsConnMap O f.
Proof.
  apply conn_map_from_extension_elim.
  intros P P_inO.
  assert (E : ExtendableAlong 1%nat f P); [ | exact (fst E) ].
  assert (Qp := OO_descend_beta O' O P).
  assert (Q_inO := OO_descend_inO O' O P).
  set (Q := OO_descend O' O P) in *.
  refine (extendable_postcompose' _ (Q o to O' B) P f Qp _).
  refine (cancelL_extendable _ Q f (to O' B) _ _).
  1:srapply (extendable_conn_map_inO O).
  refine (extendable_homotopic _ _ (O_functor O' f o to O' A) (to_O_natural O' f) _).
  srapply extendable_compose.
  1:srapply extendable_equiv.
  srapply (extendable_conn_map_inO O).
Defined.

(** A generalization of Lemma 2.27 of CORS: [functor_sigma] of a family of [O]-equivalences over an [O']-equivalence is an [O]-equivalence.  CORS Lemma 2.27 is the case when [f = to O' A] and [g] is a family of identities. *)
Definition OO_inverts_functor_sigma
       {A B : Type} {P : A -> Type} {Q : B -> Type}
       (f : A -> B) (g : forall a, P a -> Q (f a))
       `{O_inverts O' f} `{forall a, O_inverts O (g a)}
  : O_inverts O (functor_sigma f g).
Proof.
  srapply isequiv_homotopic'.
  - refine (equiv_O_sigma_O O _ oE _ oE (equiv_O_sigma_O O _)^-1).
    refine (Build_Equiv _ _ (O_functor O (functor_sigma f (fun x => O_functor O (g x)))) _).
  - apply O_indpaths. intros [x u]; cbn.
    rewrite !to_O_natural, O_rec_beta; cbn.
    rewrite !to_O_natural, O_rec_beta.
    reflexivity.
Defined.

(** Families of [O]-modal types descend along all [O']-equivalences (not just the [O']-units, as asserted in the definition of [<<<]. *)
Definition OO_descend_O_inverts
           {A B : Type} (f : A -> B) `{O_inverts O' f}
           (P : A -> Type) {P_inO : forall x, In O (P x)}
  : B -> Type.
Proof.
  intros b.
  pose (Q := OO_descend O' O P).
  exact (Q ((O_functor O' f)^-1 (to O' B b))).
Defined.

Global Instance OO_descend_O_inverts_inO
       {A B : Type} (f : A -> B) `{O_inverts O' f}
       (P : A -> Type) {P_inO : forall x, In O (P x)} (b : B)
  : In O (OO_descend_O_inverts f P b)
  := _.

Definition OO_descend_O_inverts_beta
           {A B : Type} (f : A -> B) `{O_inverts O' f}
           (P : A -> Type) {P_inO : forall x, In O (P x)} (a : A)
  : (OO_descend_O_inverts f P (f a)) <~> P a.
Proof.
  unfold OO_descend_O_inverts.
  refine (OO_descend_beta O' O P a oE _).
  assert (p := (to_O_natural O' f a)^).
  apply moveR_equiv_V in p.
  exact (equiv_transport _ p).
Defined.

(** Morally, an equivalent way of saying [O <<< O'] is that the universe of [O]-modal types is [O']-modal.  We can't say this directly since this type lives in a higher universe, but here is a rephrasing of it. *)
Definition ooextendable_TypeO_lex_leq `{Univalence}
           {A B : Type} (f : A -> B) `{O_inverts O' f}
  : ooExtendableAlong f (fun _ => Type_ O).
Proof.
  rapply ooextendable_TypeO_from_extension; intros P.
  exists (fun x => (OO_descend_O_inverts f P x ;
                    OO_descend_O_inverts_inO f P x)).
  intros x; apply path_TypeO, path_universe_uncurried; cbn.
  exact (OO_descend_O_inverts_beta f P x).
Defined.

(** We can also state it in terms of belonging to a subuniverse if we lift [O'] accessibly (an analogue of Theorem 3.11(iii) of RSS). *)
Global Instance inO_TypeO_lex_leq `{Univalence} `{IsAccRSU O'}
  : In (lift_accrsu O') (Type_ O)
  := fun i => ooextendable_TypeO_lex_leq (acc_lgen O' i).

(** If [f] is an [O']-equivalence, then [ap f] is an [O]-equivalence. *)
Global Instance OO_inverts_ap@{}
       {A B : Type@{i}} (f : A -> B) `{O_inverts O' f} (x y : A)
  : O_inverts O (@ap _ _ f x y).
Proof.
  assert (Pb := OO_descend_O_inverts_beta f (fun y:A => O (x = y))).
  assert (P_inO := OO_descend_O_inverts_inO f (fun y:A => O (x = y))).
  set (P := OO_descend_O_inverts f (fun y:A => O (x = y))) in *.
  clearbody P; cbn in *.
  srapply isequiv_adjointify.
  - intros q.
    pose (t := fun p => @transport B P (f x) (f y) p ((Pb x)^-1 (to O (x = x) 1))).
    exact (Pb y (O_rec t q)).
  - apply O_indpaths; intros p; cbn.
    rewrite O_rec_beta.
    assert (g := extension_conn_map_elim O (functor_sigma f (fun (a:A) (p:P (f a)) => p))
                                         (fun bp => O (f x = bp.1)) (fun u => O_functor O (ap f) (Pb u.1 u.2))).
    pose (g1 b p := g.1 (b;p)). cbn in g1.
    assert (e : (fun u => g1 u.1 u.2) == g.1).
    1:intros [a b]; reflexivity.
    assert (g2 := fun a p => e _ @ g.2 (a;p)); cbn in g2.
    refine ((g2 y _)^ @ _).
    rewrite (ap_transport p g1).
    rewrite (g2 x ((Pb x)^-1 (to O (x = x) 1))).
    rewrite eisretr, to_O_natural; cbn.
    rewrite <- (ap_transport p (fun b => to O (f x = b))).
    apply ap.
    rewrite transport_paths_r.
    apply concat_1p.
  - apply O_indpaths; intros p; cbn.
    rewrite to_O_natural, O_rec_beta.
    destruct p; cbn.
    srapply eisretr.
Defined.

Definition equiv_O_functor_ap_OO_inverts
       {A B : Type} (f : A -> B) `{O_inverts O' f} (x y : A)
  : O (x = y) <~> O (f x = f y)
  := Build_Equiv _ _ (O_functor O (ap f)) _.

(** Theorem 3.1(i) of RSS: path-spaces of [O']-connected types are [O]-connected. *)
Definition OO_isconnected_paths
           {A : Type} `{IsConnected O' A} (x y : A)
  : IsConnected O (x = y).
Proof.
  rapply (contr_equiv' _ (equiv_O_functor_ap_OO_inverts (const_tt _) x y)^-1).
Defined.

(** Proposition 2.26 of CORS and Theorem 3.1(ix) of RSS; also generalizes Theorem 7.3.12 of the book.  Here we need to add the extra assumption that [O' <= Sep O], which is satisfied when [O' = Sep O] but also when [O] is lex and [O' = O].  That some such extra hypothesis is necessary can be seen from the fact that [Tr (-2) <<< O'] for any [O'], whereas this statement is certainly not true in that generality. *)
Definition path_OO `{O' <= Sep O}
           {X : Type@{i}} (x y : X)
  : O (x = y) -> (to O' X x = to O' X y).
Proof.
  nrefine (O_rec (O := O) (@ap X (O' X) (to O' X) x y)).
  - rapply (@inO_leq O' (Sep O)).
  - exact _.
Defined.

Global Instance isequiv_path_OO `{O' <= Sep O}
       {X : Type@{i}} (x y : X)
  : IsEquiv (path_OO x y).
Proof.
  nrefine (isequiv_O_rec_O_inverts O _).
  (** Typeclass search can find this, but it's quicker (and may help the reader) to give it explicitly. *)
  apply (OO_inverts_ap (to O' X)).
Defined.

Definition equiv_path_OO `{O' <= Sep O}
           {X : Type@{i}} (x y : X)
  : O (x = y) <~> (to O' X x = to O' X y)
  := Build_Equiv _ _ (path_OO x y) _.

(** [functor_hfiber] on a pair of [O']-equivalences is an [O]-equivalence. *)
Global Instance OO_inverts_functor_hfiber
       {A B C D : Type} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D}
       (p : k o f == g o h) (b : B)
       `{O_inverts O' h, O_inverts O' k}
  : O_inverts O (functor_hfiber p b).
Proof.
  unfold functor_hfiber.
  simple notypeclasses refine (OO_inverts_functor_sigma _ _).
  1:exact _.
  intros a; cbn.
  refine (isequiv_homotopic (O_functor O (concat (p a)^) o O_functor O (@ap _ _ k (f a) b)) _).
  symmetry; apply O_functor_compose.
Defined.

(** Corollary 2.29 of CORS: [O'] preserves fibers up to [O]-equivalence. *)
Global Instance OO_inverts_functor_hfiber_to_O
       {Y X : Type} (f : Y -> X) (x : X)
  : O_inverts O (functor_hfiber (fun a => (to_O_natural O' f a)^) x).
Proof.
  (** Typeclass search can find this, but it's faster to give it explicitly. *)
  exact (OO_inverts_functor_hfiber _ _).
Defined.

Definition equiv_OO_functor_hfiber_to_O
           {Y X : Type@{i} } (f : Y -> X) (x : X)
  : O (hfiber f x) <~> O (hfiber (O_functor O' f) (to O' X x))
  := Build_Equiv _ _ _ (OO_inverts_functor_hfiber_to_O f x).

(** Theorem 3.1(iii) of RSS: any map between [O']-connected types is [O]-connected.  (Part (ii) is just the version for dependent projections.) *)
Definition OO_conn_map_isconnected
       {Y X : Type} `{IsConnected O' Y, IsConnected O' X} (f : Y -> X)
  : IsConnMap O f.
Proof.
  intros x; rapply (contr_equiv' _ (equiv_OO_functor_hfiber_to_O f x)^-1).
Defined.

Definition OO_isconnected_hfiber
       {Y X : Type} `{IsConnected O' Y, IsConnected O' X} (f : Y -> X) (x : X)
  : IsConnected O (hfiber f x)
  := OO_conn_map_isconnected f x.

(** Theorem 3.1(iv) of RSS: an [O]-modal map between [O']-connected types is an equivalence. *)
Global Instance OO_isequiv_mapino_isconnected
       {Y X : Type} `{IsConnected O' Y, IsConnected O' X} (f : Y -> X) `{MapIn O _ _ f}
  : IsEquiv f.
Proof.
  apply (isequiv_conn_ino_map O).
  - apply OO_conn_map_isconnected.
  - assumption.
Defined.

(** Theorem 3.1(vi) of RSS (and part (v) is just the analogue for dependent projections). *)
Definition OO_conn_map_functor_hfiber {A B C D : Type}
           {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D}
           `{IsConnMap O' _ _ h, IsConnMap O' _ _ k}
           (p : k o f == g o h) (b : B)
  : IsConnMap O (functor_hfiber p b).
Proof.
  intros [c q].
  nrefine (isconnected_equiv' O _ (hfiber_functor_hfiber p b c q)^-1 _).
  apply OO_isconnected_hfiber.
Defined.

(** An enhancement of Corollary 2.29 of CORS, corresponding to Theorem 3.1(viii) of RSS: when [O'] is a modality, the map between fibers is not just an O-equivalence but is O-connected. *)
Global Instance OO_conn_map_functor_hfiber_to_O `{IsModality O'}
       {Y X : Type} (f : Y -> X) (x : X)
  : IsConnMap O (functor_hfiber (fun y => (to_O_natural O' f y)^) x).
Proof.
  apply OO_conn_map_functor_hfiber.
Defined.

(** Theorem 3.1(vii) of RSS *)
Definition OO_ispullback_connmap_mapino
           {A B C D : Type} {f : A -> B} {g : C -> D} {h : A -> C} {k : B -> D}
           (p : k o f == g o h)
           `{O_inverts O' h, O_inverts O' k, MapIn O _ _ f, MapIn O _ _ g}
  : IsPullback p.
Proof.
  apply ispullback_isequiv_functor_hfiber; intros b.
  apply (isequiv_O_inverts O).
  apply OO_inverts_functor_hfiber; exact _.
Defined.

(** [functor_pullback] on a triple of [O']-equivalences is an [O]-equivalence. *)
Global Instance OO_inverts_functor_pullback
       {A1 B1 C1 A2 B2 C2 : Type}
       (f1 : B1 -> A1) (g1 : C1 -> A1)
       (f2 : B2 -> A2) (g2 : C2 -> A2)
       (h : A1 -> A2) (k : B1 -> B2) (l : C1 -> C2)
       (p : f2 o k == h o f1) (q : g2 o l == h o g1)
       `{O_inverts O' h, O_inverts O' k, O_inverts O' l}
  : O_inverts O (functor_pullback f1 g1 f2 g2 h k l p q).
Proof.
  unfold functor_pullback.
  simple notypeclasses refine (OO_inverts_functor_sigma _ _).
  1:exact _.
  intros b1; cbn.
  simple notypeclasses refine (OO_inverts_functor_sigma _ _).
  1:exact _.
  intros c1; cbn.
  pose @isequiv_compose. (* Speed up typeclass search. *)
  refine (isequiv_homotopic (O_functor O (fun r => r @ (q c1)^) o O_functor O (concat (p b1)) o O_functor O (@ap _ _ h (f1 b1) (g1 c1))) _).
  intros r; symmetry.
  refine (_ @ _).
  2:apply O_functor_compose.
  cbn; srapply O_functor_compose.
Defined.

(** Proposition 2.28 of CORS, and Theorem 3.1(x) of RSS: the functor [O'] preserves pullbacks up to [O]-equivalence. *)
Global Instance OO_inverts_functor_pullback_to_O
       {A B C : Type} (f : B -> A) (g : C -> A)
  : O_inverts O (functor_pullback f g (O_functor O' f) (O_functor O' g)
                                  (to O' A) (to O' B) (to O' C)
                                  (to_O_natural O' f) (to_O_natural O' g)).
Proof.
  apply OO_inverts_functor_pullback; exact _.
Defined.

Definition equiv_OO_pullback {A B C : Type} (f : B -> A) (g : C -> A)
  : O (Pullback f g) <~> O (Pullback (O_functor O' f) (O_functor O' g))
  := Build_Equiv _ _ _ (OO_inverts_functor_pullback_to_O f g).

(** The "if" direction of CORS Proposition 2.31, and the nontrivial part of Theorem 3.1(xi) of RSS.  Note that we could also deduce Theorem 3.1(iii) of RSS from this. *)
Definition OO_cancelL_conn_map
           {Y X Z : Type} (f : Y -> X) (g : X -> Z)
           `{IsConnMap O' _ _ (g o f)} `{IsConnMap O' _ _ g}
  : IsConnMap O f.
Proof.
  apply conn_map_OO_inverts.
  nrapply (cancelL_isequiv (O_functor O' g)).
  1:exact _.
  rapply (isequiv_homotopic _ (O_functor_compose O' f g)).
Defined.

End LeftExactness.

(** Here's the "only if" direction of CORS Proposition 2.31.  Note that the hypotheses are different from those of the "if" direction, and the proof is shorter than the one given in CORS. *)
Definition OO_cancelR_conn_map
       (O' O : ReflectiveSubuniverse@{u}) `{O_leq@{u u u} O O', O' <= Sep O}
       {Y X Z : Type} (f : Y -> X) (g : X -> Z)
       `{IsConnMap O' _ _ (g o f)} `{IsConnMap O _ _ f}
  : IsConnMap O' g.
Proof.
  apply conn_map_from_extension_elim.
  intros P P_inO h.
  exists (conn_map_elim O' (g o f) P (h o f)).
  nrefine (conn_map_elim O f _ _); [ exact _ | .. ].
  - intros x.
    pose proof (fun z => inO_leq O' (Sep O) (P z) (P_inO z)).
    exact _.
  - intros y.
    apply (conn_map_comp O' (g o f)).
Defined.

Definition OO_isconnected_from_conn_map
       (O' O : ReflectiveSubuniverse) `{O <= O', O' <= Sep O}
       {Y X : Type} (f : Y -> X)
       `{IsConnected O' Y} `{IsConnMap O _ _ f}
  : IsConnected O' X.
Proof.
  apply isconnected_conn_map_to_unit.
  apply (OO_cancelR_conn_map O' O f (const_tt _)).
Defined.

(** An interesting scholium to Proposition 2.31. *)
Definition OO_inverts_conn_map_factor_conn_map
       (O' O : ReflectiveSubuniverse) `{O << O', O <<< O', O' <= Sep O}
       {Y X Z : Type} (f : Y -> X) (g : X -> Z)
       `{IsConnMap O' _ _ (g o f)} `{IsConnMap O _ _ f}
  : O_inverts O' f.
Proof.
  nrapply (cancelL_isequiv (O_functor O' g)).
  - apply O_inverts_conn_map.
    apply (OO_cancelR_conn_map O' O f g).
  - rapply (isequiv_homotopic _ (O_functor_compose O' f g)).
Defined.

Definition OO_inverts_conn_map_isconnected_domain
       (O' O : ReflectiveSubuniverse) `{O << O', O <<< O', O' <= Sep O}
       {Y X : Type} (f : Y -> X)
       `{IsConnected O' Y} `{IsConnMap O _ _ f}
  : O_inverts O' f.
Proof.
  apply (OO_inverts_conn_map_factor_conn_map O' O f (const_tt _)).
Defined.

(** Here is the converse of [ooextendable_TypeO_lex_leq]. *)
Definition O_lex_leq_extendable_TypeO
           (O' O : ReflectiveSubuniverse) `{O << O'}
           (e : forall (A:Type) (g:A->Type_ O), ExtensionAlong (to O' A) (fun _ => Type_ O) g)
  : O <<< O'.
Proof.
  intros A; unshelve econstructor; intros P' P_inO; pose (P := fun x => (P' x ; P_inO x) : Type_ O).
  - exact (fun x => ((e A P).1 x).1).
  - exact (fun x => ((e A P).1 x).2).
  - intros x.
    apply equiv_path.
    exact (((e A P).2 x)..1).
Defined.

(** And a version for the accessible case. *)
Definition O_lex_leq_inO_TypeO
           (O' O : ReflectiveSubuniverse) `{O << O'}
           `{IsAccRSU O'} `{In (lift_accrsu O') (Type_ O)}
  : O <<< O'.
Proof.
  apply O_lex_leq_extendable_TypeO.
  intros A g.
  assert (O_inverts (lift_accrsu O') (to O' A)).
  - rapply (O_inverts_O_leq' (lift_accrsu O') O').
  - exact (fst (ooextendable_O_inverts (lift_accrsu O') (to O' A) (Type_ O) 1%nat) g).
Defined.


(*Robert Hughes
Comp 293 Hw 1
This is the document for the first homework for the software reliability class*)

(*Question #1*)
Theorem question_1: forall f:bool -> bool, forall x: bool,
  (f x) = x ->
  f(f x) = x.

Proof.
  intros.
  rewrite H.
  rewrite H.
  reflexivity.
Qed.

(*Question 2*)
Theorem question_2: forall b c : bool,
andb b c =  orb b c ->
b = c.

Proof.
  intros b c.
  destruct b. destruct c.
  reflexivity. simpl.
  intros H1. rewrite H1.
  reflexivity. simpl.
  destruct c. intros H2. rewrite H2. reflexivity. reflexivity.
Qed.

(*Question 3*)
Inductive bin: Type :=
| Zero: bin
| Two: bin -> bin
| Two_one: bin -> bin.

(*Question 4*)
Fixpoint bin_inc(b: bin): bin :=
  match b with
    | Zero => Two_one Zero
    | Two x => Two_one x
    | Two_one x => Two (bin_inc x)
  end.

(*Question 5*)
Fixpoint bin_to_nat (b: bin): nat :=
  match b with
    | Zero => O
    | Two x => (bin_to_nat x) + (bin_to_nat x)
    | Two_one x => S  ((bin_to_nat x) + (bin_to_nat x))
  end.

(*Question 6*)
Theorem bin_to_nat_pres_incr_original : forall b : bin,
  bin_to_nat (bin_inc b) = 1 + (bin_to_nat b).
Proof.
  intros b.
  induction b as [|b'|b2'].
  - reflexivity.
  - reflexivity.
  - simpl.
    rewrite -> IHb2'.
    rewrite -> plus_n_Sm.
    reflexivity.
Qed.

(*Question 7 -- from CA03 *)
Theorem question_7 : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros. induction n as [|n' IHn'].
  reflexivity.
  simpl. rewrite -> IHn'. reflexivity.  Qed.

(*Question 8*)

(*taken from class work*)
Lemma mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  intros. induction n as [|n' IHn'].
  - reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.  Qed.

Lemma plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
    intros. induction n as [|n' IHn'].
    reflexivity.
    simpl. rewrite -> IHn'. reflexivity.  Qed.

Lemma plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros. induction n as [|n' IHn'].
  reflexivity.
  simpl. rewrite -> IHn'. reflexivity.  Qed.

Lemma plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros. induction n as [|n' IHn'].
  - rewrite <- plus_n_O.
    + reflexivity.
  - simpl. rewrite -> IHn'. rewrite plus_n_Sm. reflexivity.  Qed.

(*This is needed for the communative multiply to work for the second half of the theorem*)
Lemma mult_n_Sm : forall n m:nat, n * m + n = n * S m.
Proof.
  intros. induction n as [| n'].
  reflexivity.
  simpl. rewrite <- IHn'.
  simpl. rewrite -> plus_n_Sm. rewrite -> plus_n_Sm.
  rewrite -> plus_assoc. reflexivity.
Qed.

Theorem question_8 : forall n m : nat,
  n * m = m * n.
Proof.
  intros n m. induction m as [|m' IHm'].
  simpl. rewrite mult_0_r. reflexivity.
  simpl. rewrite <- mult_n_Sm. rewrite <- plus_comm.
  rewrite -> IHm'. reflexivity. Qed.

(*Question 9*)
(*From class work*)
Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => leb n' m'
      end
  end.

Theorem question_9 : forall n : nat,
  leb n n = true.
Proof.
  intros. induction n as [| n'].
  simpl. reflexivity.
  simpl. rewrite IHn'. reflexivity.
Qed.

(*Question 10*)
Theorem question_10 : forall b : bool,
  andb b false = false.
Proof.
  intros. destruct b. simpl.
  reflexivity. simpl. reflexivity. Qed.

(*Question 11*)
Theorem question_11: forall n m p: nat,
leb n m = true ->
leb (p + n) (p + m) = true.
Proof.
  intros. induction p as [|p' IHp'].
  - simpl. rewrite H. reflexivity.
  - simpl. rewrite IHp'. reflexivity.
Qed.

(*Question 12*)
Lemma plus_n_O : forall n:nat, n = n + 0.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)    reflexivity.
  - (* n = S n' *) simpl. rewrite <- IHn'. reflexivity.  Qed.

Theorem question_12: forall n : nat,
  1 * n = n.
Proof.
  intros. induction n as [| n'].
  reflexivity.
  simpl. rewrite plus_n_O. reflexivity.  Qed.

(*Question 13*)
Theorem question_13: forall x y: bool,
orb (andb x y ) (orb (negb x) (negb y)) = true.
Proof.
 intros. destruct x.
  - destruct y.
    + reflexivity.
    + reflexivity.
  - reflexivity.
Qed.

(*Question 14*)

Theorem question_14 : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  intros. induction n as [| n'].
  reflexivity.
  simpl. rewrite IHn'. rewrite plus_assoc. reflexivity.  Qed.

(*Question 15*)

Theorem question_15 : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  intros. induction n as [| n'].
  reflexivity.
  simpl. rewrite IHn'. rewrite question_14. reflexivity.
Qed.

(*Question 16*)

Fixpoint double (n:nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

Fixpoint half (n : nat) : nat :=
    match n with
      | O => O
      | S O => O
      | S (S n) => S (half n)
    end.

Theorem question_16 : forall n : nat,
  half(double(n)) = n.
Proof.
  intros.
  induction n as [| n'].
  - reflexivity.
  - simpl. rewrite IHn'. reflexivity.
Qed.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import Psatz Poly_complements seq_base.

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

Import GRing.Theory.
Local Open Scope ring_scope.

Section Tcheby.
Variable R : ringType.
Implicit Types (l : seq R) (p: {poly R}) .

(* Chebyshev polynomials introduced via their recursion scheme *)

Fixpoint pT_expanded_def (n : nat) {struct n} : {poly R} :=
  if n is n1.+1 then
    if n1 is n2.+1 then 'X *+2 * pT_expanded_def n1 - pT_expanded_def n2
    else 'X
  else 1.

Fact pT_key : unit. Proof. by []. Qed.
Definition pT := locked_with pT_key pT_expanded_def.
Canonical pT_unlockable := [unlockable fun pT].

Notation "'T_ n" := (pT n)
  (at level 3, n at level 2, format "''T_' n ").

Lemma pT0 : 'T_0 = 1 :> {poly R}.
Proof. by rewrite unlock /pT_expanded_def. Qed.

Lemma pT1 : 'T_1 = 'X :> {poly R}.
Proof.
by rewrite unlock /pT_expanded_def.
Qed.

Lemma pTSS : forall n, 'T_n.+2 = 'X *+2 * 'T_n.+1 - 'T_n :> {poly R}.
Proof. by move => n; rewrite unlock. Qed.

Notation "'T_ n" := (pT n)
  (at level 3, n at level 2, format "''T_' n ").

Lemma horner1_pT n : ('T_n).[1: R] = 1.
Proof.
elim/ltn_ind: n => [] [|[|n]] IH; first by rewrite pT0 hornerC.
  by rewrite pT1 hornerX.
rewrite pTSS hornerD hornerN mulrnAl hornerMn.
by rewrite -commr_polyX hornerMX !IH // !mulr1 mulrS [1+ _]addrC addrK.
Qed.

Lemma hornerN1_pT n : ('T_n).[-1: R] = (-1) ^+ n.
Proof.
elim/ltn_ind : n => [] [|[|n]] IH; first by rewrite pT0 hornerC.
  by rewrite pT1 hornerX.
rewrite pTSS hornerD hornerN mulrnAl hornerMn.
rewrite -commr_polyX hornerMX !IH //.
by rewrite !exprS !(mulN1r, mulrN1, opprK) mulr2n addrK.
Qed.

Lemma commr_pT p n : GRing.comm p ('T_n).
Proof.
elim/ltn_ind : n => [] [|[|n]] IH; first by rewrite pT0; apply: commr1.
  by rewrite pT1; apply: commr_polyX.
rewrite pTSS; apply: commrD; last by apply: commrN; apply: IH.
by rewrite mulrnAl; apply: commrMn; apply: commrM;
 [exact: commr_polyX | apply: IH].
Qed.

Definition pU := fix pU_rec (n : nat) {struct n} : {poly R} :=
  if n is n1.+1 then
    if n1 is n2.+1 then 'X *+ 2 * pU_rec n1 - pU_rec n2
    else 'X *+ 2
  else 1.

Notation "'U_ n" := (pU n)
  (at level 3, n at level 2, format "''U_' n ").

Lemma pU0 : 'U_0 = 1.
Proof. by []. Qed.

Lemma pU1 : 'U_1 = 'X *+ 2.
Proof. by []. Qed.

Lemma pUSS n : 'U_n.+2 = 'X *+ 2 * 'U_n.+1 - 'U_n.
Proof. by []. Qed.

Lemma horner1_pU n : ('U_n).[1] = n.+1%:R.
Proof.
elim/ltn_ind : n => [] [|[|n]] IH; first by rewrite hornerC.
  by rewrite pU1 hornerMn hornerX.
rewrite pUSS hornerD hornerN mulrnAl hornerMn.
rewrite -commr_polyX hornerMX mulr1 !IH //.
rewrite -mulr_natl -natrM -natrB; last first.
  by rewrite mulSn !addSnnS addnS ltnS leq_addr.
by rewrite mul2n -addnn -addSnnS addnK.
Qed.

Lemma commr_pU p n : GRing.comm p ('U_n).
Proof.
elim/ltn_ind : n => [] [|[|n]] IH; first  by exact: commr1.
  by rewrite pU1; apply: commrMn; exact: commr_polyX.
rewrite pUSS; apply: commrD; last by apply: commrN; apply: IH.
by rewrite mulrnAl; apply: commrMn; apply: commrM;
   [exact: commr_polyX | apply: IH].
Qed.

Lemma pT_pU n : 'T_n.+1 = 'U_n.+1 - 'X * 'U_n.
Proof.
have F: pU 1 - 'X * pU 0 = 'X by rewrite pU1 pU0 mulr1 addrK.
elim/ltn_ind : n  => [] [|n] IH; first by rewrite pT1 F.
rewrite pTSS pUSS IH // mulrDr -!addrA; congr (_ + _).
case: n IH => [_|m IH].
  rewrite pT0 pU0 pU1 addrC mulrN; congr (_ - _).
  by rewrite mulr1 mulrnAl mulrnAr.
rewrite IH // pUSS addrC opprD -!addrA; congr (_ + _).
rewrite mulrDr !mulrN opprB opprK; congr (_ - _).
by rewrite !mulrA commr_polyX.
Qed.

Lemma deriv_pT n: ('T_n.+1)^`() = 'U_n *+ n.+1.
Proof.
elim/ltn_ind : n => [] [|n] IH; first by rewrite pT1 derivX.
rewrite pTSS derivD derivM derivMn derivX !IH // pT_pU.
case: n IH => [_|n IH].
  by rewrite pU0 pU1 pT0 derivN derivC subr0 mulr_natl mulrnBl !mulr1 addrK.
rewrite derivN IH // pUSS mulr_natl !(mulrnDl, mulrnBl).
rewrite !(mulrnAl, mulrnAr) -!mulrnA.
set x := 'X * _; set y := pU n.
rewrite -[x *+ _ + _ *+ _]addrC -3!addrA addrC.
rewrite addrA -[(2 * 2)%N]/(2 + 2)%N mulrnDr.
rewrite mulNrn addrK.
rewrite -mulrnDr mulnC; rewrite -addrA; congr (_ + _)=> //.
  congr (_ *+ _); rewrite !mul2n //.
by rewrite -mulNrn -mulrnDr addnC.
Qed.

Lemma coef_pU : forall n i,
  ('U_n)`_i =
    if (n < i)%N || odd (n + i) then 0 else
    let k := (n - i)./2 in ((-1)^+k * (2^i * 'C(n-k,k))%:R).
Proof.
elim/ltn_ind => [] [|[|n]] IH i.
- by case: i => [|i]; rewrite pU0 ?coefC //= mul1r.
  by rewrite coefMn coefX; case: i=> [|[|i]] //=;
     rewrite ?mul0rn //= -mulr_natl mulr1 mul1r.
rewrite pUSS coefB mulrnAl coefMn coefXM !IH //.
case: i=> [|i].
  rewrite !addn0 mul0rn sub0r subn0 /=; case O1: (odd _).
    by rewrite oppr0.
  rewrite !mul1n /= exprS !mulNr subSS mul1r.
  rewrite -{2 6}[n]odd_double_half O1 add0n subSn -addnn ?leq_addr //.
  by rewrite  addnK !binn.
rewrite !addSn !addnS /=; case O1: (odd _); last first.
   by rewrite !orbT mul0rn  subrr.
rewrite !orbF !subSS; case: leqP=> Hm; last first.
  rewrite ltnS (leq_trans _ Hm); last by  exact: (leq_addl 2 n).
  by rewrite mul0rn  sub0r oppr0.
rewrite ltnS.
move: Hm; rewrite leq_eqVlt; case/orP=> [/eqP->|].
  by rewrite subnn leqnSn !mul1r !bin0 !muln1 subr0 -mulr_natl -natrM.
rewrite ltnS leq_eqVlt; case/orP; [move/eqP->|move=>Him].
  by rewrite leqnn subSnn !subn0 expr0 !bin0
             subr0 !mul1r !muln1 -mulr_natl -natrM expnS.
rewrite leqNgt Him /= subSn; last by exact: ltnW.
have->: ((n - i).+1./2 = (n - i)./2.+1).
 rewrite -{1}[(n - i)%N]odd_double_half.
 rewrite (oddB (ltnW _)) // -oddD O1.
 by rewrite /= (half_bit_double _ false).
have->: ((n - i.+1)./2 = (n - i)./2).
 rewrite subnS -{1}[(n - i)%N]odd_double_half.
 rewrite (oddB (ltnW _)) // -oddD O1.
 by rewrite /= (half_bit_double _ false).
set u := (n - i)./2.
rewrite !subSS subSn.
  rewrite binS mulnDr mulrnDr mulrDr; congr (_ + _).
    by rewrite -mulrnAr -mulr_natl -natrM mulnA expnS.
  by rewrite -mulN1r mulrA exprS.
apply: (leq_trans (half_leq (leq_subr i n))).
by rewrite -{2}[n]odd_double_half -addnn addnA leq_addl.
Qed.

Lemma coef_pUn n : ('U_n)`_n = (2^n)%:R.
Proof.
by rewrite coef_pU ltnn addnn odd_double subnn /= bin0 mul1r muln1.
Qed.

Lemma size_pU_leq n : (size ('U_n) <= n.+1)%N.
Proof. by apply/leq_sizeP=> j Hj; rewrite coef_pU Hj. Qed.

Lemma coef_pT n i :
  ('T_n)`_i =
    if (n < i)%N || odd (n + i) then 0 : R else
    if n is 0 then 1 else
    let k := (n - i)./2 in
    (-1) ^+ k * ((2^i * n * 'C(n-k,k)) %/ (n-k).*2)%:R.
Proof.
case: n => [|n]; first by rewrite pT0 coefC; case: i.
rewrite pT_pU coefB coefXM !coef_pU.
case: leqP; last first.
  by case: i=> [|i] //; rewrite ltnS=> ->; exact: subrr.
case: i => [_|i Hi].
  rewrite addn0; case O1: (odd _); first by exact: subr0.
  rewrite !subr0 !subn0 !mul1n; congr (_ * _); congr (_%:R).
  have F: n.+1 = (n.+1)./2.*2 by rewrite-{1}[(n.+1)%N]odd_double_half O1.
  by rewrite {8}F -[_./2.*2]addnn addnK -F mulKn // mul1n.
rewrite subSS addnS /=; case O1: (odd _); first by rewrite orbT subr0.
rewrite orbF; move: (Hi); rewrite ltnS leqNgt; move/negPf->.
rewrite -mulrBr; congr (_ * _).
rewrite -natrB; last first.
  apply: leq_mul; first rewrite leq_exp2l //.
  by apply: leq_bin2l; apply: leq_sub2r.
congr (_%:R).
have F: (n-i = (n-i)./2.*2)%N
   by rewrite-{1}[(n-i)%N]odd_double_half oddB // -oddD O1.
set u := (n - i)./2.
have F1: (u <= n)%N.
  by apply: leq_trans (leq_subr i _); rewrite F -addnn leq_addl.
rewrite subSn //.
have->: (n - u = i + u)%N.
  rewrite ltnS in Hi; rewrite -{1}(subnK Hi) [(_ + i)%N]addnC.
  by rewrite -addnBA;
     [rewrite {1}F -addnn addnK | rewrite F -addnn leq_addr].
set v := (i + u)%N.
rewrite {2}expnS -!mulnA -mul2n divnMl //.
pose k := (u`! * (v.+1 - u)`!)%N.
have Fk: k != 0%N.
  apply/eqP=> Hk; move: (leqnn k); rewrite {2}Hk leqNgt.
  by rewrite /k !(muln_gt0,fact_gt0).
apply/eqP; rewrite -[_ == _]orFb -(negPf Fk).
have F2: (u <= v)%N by apply: leq_addl.
have F3 : (u <= v.+1)%N   by apply: (leq_trans F2).
have F4: (u + v = n)%N by rewrite addnC -addnA addnn -F addnC subnK.
rewrite -eqn_mul2r mulnBl -!mulnA bin_fact //.
rewrite expnSr -mulnA -mulnBr {1}/k subSn // [(_ - _).+1`!]factS.
rewrite [((_ - _).+1 * _)%N]mulnC 2!mulnA -[('C(_,_) * _ * _)%N]mulnA.
rewrite bin_fact ?leqDl // [(2 * _)%N]mulnC.
rewrite factS [(v.+1 * _)%N]mulnC -!mulnA -mulnBr.
rewrite -subSn // subnBA //.
rewrite [(_ + u)%N]addnC muln2 -addnn !addnA addnK.
rewrite divn_mulAC.
  rewrite -!mulnA bin_fact //.
  rewrite factS [(v.+1 * _)%N]mulnC !mulnA mulnK //.
  by apply/eqP; rewrite -!mulnA addnS F4 [(v`! * _)%N]mulnC.
rewrite dvdn_mull // -F4 -addnS mulnDl dvdn_add //; last first.
  by rewrite /dvdn; apply/eqP; exact: modnMr.
case: {1 2}u=> [|u1]; first by exact: dvdn0.
rewrite -mul_bin_diag.
by rewrite /dvdn; apply/eqP; exact: modnMr.
Qed.

Lemma coef_pTK  n i :
   ~~ odd (n + i) -> (i <= n)%N ->
  let k := (n - i)./2 in
  ('T_n)`_i *+ (n-k).*2 = (-1)^+k * (2^i * n * 'C(n-k,k))%:R :> R.
Proof.
move=> O1 L1; rewrite coef_pT; move/negPf: (O1)->.
move: (L1); rewrite leqNgt; move/negPf->.
case: n L1 O1 => [|n] L1  O1 /=; first by rewrite !muln0 mulr0.
rewrite -mulrnAr; congr (_ * _); rewrite -mulr_natl -natrM; congr (_%:R).
case: i L1 O1 => [|i L1 O1].
  rewrite addn0 subn0=> _ O1.
  have F: n.+1 = (n.+1)./2.*2
    by rewrite-{1}[n.+1]odd_double_half // (negPf O1).
  have ->: (n.+1 - (n.+1)./2 = (n.+1)./2)%N by rewrite {1}F -addnn addnK.
  by rewrite -F mul1n mulKn //.
set u := (n.+1 -i.+1)./2.
have F: (n.+1 - i.+1 = u.*2)%N.
  by rewrite-{1}[(n.+1 - i.+1)%N]odd_double_half
             /u oddB // -oddD (negPf O1).
have->: (n.+1 - u = i.+1 + u)%N.
  rewrite -{1}(subnK L1) [(_ + i.+1)%N]addnC.
  by rewrite -addnBA;
     [rewrite {1}F -addnn addnK | rewrite F -addnn leq_addr].
rewrite expnS -!mul2n -!mulnA divnMl //;  congr (_ * _)%N.
apply/eqP; rewrite mulnC -dvdn_eq.
have->: (n.+1 = u + (i.+1 + u))%N by rewrite addnC -addnA addnn -F addnC subnK.
apply: dvdn_mull.
case: {F}u=> [|u]; first by rewrite !muln1 !addn0 dvdnn.
by rewrite mulnDl dvdn_add //; first rewrite addnS -mul_bin_diag;
   apply: dvdn_mulr; exact: dvdnn.
Qed.

Lemma coef_pTn n : ('T_n)`_n = (2 ^ n.-1)%:R :> R.
Proof.
case: n => [|n]; rewrite coef_pT ltnn addnn odd_double //= subnn subn0.
rewrite mul1r expnS [(2 * _)%N]mulnC -!mulnA [(2 * _)%N]mulnA mul2n.
by rewrite mulnC -!mulnA mulKn // bin0 mul1n.
Qed.

Lemma size_pT_leq n : (size ('T_n) <= n.+1)%N.
Proof.
by apply/leq_sizeP => j Hj; rewrite coef_pT Hj.
Qed.

(* Pell equation *)

Lemma pell n : ('T_n.+1)^+2 - ('X^2 - 1) * ('U_n) ^+ 2 = 1.
Proof.
suff F: (pU n.+1)^+ 2 + (pU n)^+2 = 'X *+ 2 * pU n.+1 * pU n + 1.
  rewrite pT_pU exprS expr1 !mulrDl !mulrDr opprD !mulNr.
  rewrite !addrA addrC opprK mul1r !addrA [_^+2 + _]addrC F.
  apply: trans_equal (addr0 _); rewrite [_+1]addrC -!addrA; congr (_ + _).
  rewrite mulrN mulrA commr_polyX !addrA !mulrDl addrK.
  rewrite -mulrA -commr_pU mulrA addrN sub0r.
  by rewrite mulrN opprK -mulrA -commr_pU exprS expr1 exprS expr1 !mulrA addrN.
elim: n => [| n IH].
  by rewrite pU1 pU0 mulr1 expr1n exprS expr1.
rewrite pUSS exprS !mulrBr !mulrBl -!addrA; congr (_ + _).
  rewrite !(mulrnAl,mulrnAr); do 2 congr (_ *+ _).
  by rewrite -!mulrA; congr (_ * _); rewrite -commr_pU mulrA.
congr (_ + _); first by rewrite -commr_pU -!mulrA commr_pU.
by rewrite opprB addrC addrA IH [_+1]addrC addrK.
Qed.
End Tcheby.

Notation "'T_ n " := (pT _ n)
  (at level 3, n at level 2, format "''T_' n").

Lemma induc2 (P: nat -> Prop):
	P 0%nat -> P 1%nat ->
  (forall n, P n -> P (n.+1) -> P (n.+2)) -> forall n, P n.
Proof.
move=> HP0 HP1 HPn n.
elim/ltn_ind : n => [] [|[|n]] IH //.
by apply: HPn; apply: IH.
Qed.

Section LINEAR_INDEPENDENCE.
Variable R: unitRingType.

Lemma lreg_neq0 (l x: R): GRing.lreg l -> x != 0 -> l * x != 0.
Proof.
move => Hl;  apply: contra => /eqP H; apply/eqP.
by apply: Hl; rewrite H rm0.
Qed.

Hypothesis lr2 : GRing.lreg (2%:R : R).

Lemma rr2: GRing.rreg (2%:R :R).
Proof.
move => x y; rewrite mulr_natr [y*_]mulr_natr -mulr_natl -[y *+ _]mulr_natl => eq.
by apply lr2.
Qed.

Lemma size_pT n : size ('T_ n : {poly R}) = n.+1.
Proof.
elim/induc2: n => [ | | n ih1 ih2]; first by rewrite pT0 size_poly1.
	by rewrite pT1 size_polyX.
suff/leP leq: (n.+3 <= size ('T_n.+2: {poly R}))%nat by have/leP leq':= size_pT_leq R (n.+2); lia.
apply: gtn_size.
rewrite pTSS coefD coef_opp_poly -scaler_nat -scalerAl coefZ coef_mul_poly.
under eq_bigr do rewrite coefX.
rewrite big_ord_recl big_ord_recl big1; last by move => i _ /=; rewrite !rm0.
rewrite !lift0 -{2 }[ord0.+1]add1n !rm0 !rm1 coef_pTn (coef_pT R n) /=.
have ->: (n < n.+2)%N || odd (n + n.+2) by apply /orP; left.
rewrite rm0 natrX -exprS -[_ ^+ _]mulr1; apply: lreg_neq0; last by rewrite oner_eq0.
by apply GRing.lregX.
Qed.

Lemma pT_neq0 n: 'T_n != 0 :> {poly R}.
Proof. by rewrite -size_poly_eq0 size_pT. Qed.

Lemma coef_pTn_reg n: GRing.rreg ('T_n: {poly R})`_n.
Proof. by rewrite coef_pTn natrX; apply /GRing.rregX /rr2. Qed.

Lemma size_sum_pT (p: {poly R}):
	size (\sum_(i < size p) p`_i *: 'T_i) = size p.
Proof.
rewrite (@size_polybase _ (fun i => 'T_i)) => // [| n ]; first by apply size_pT.
by rewrite lead_coefE size_pT; apply: coef_pTn_reg.
Qed.

Lemma pT_eq (p q : {poly R}):
	p = q <->
	\sum_(i < size p) p`_i *: 'T_ i = \sum_(i < size q) q`_i *: 'T_ i.
Proof.
split=> [->//|/eqP].
rewrite -(@polybase_widen _ (fun i => 'T_i) _ _ (leq_maxl (size p) (size q))).
rewrite -(@polybase_widen _ (fun i => 'T_i) _ _ (leq_maxr (size p) (size q))).
rewrite -subr_eq0 -sumrB.
under eq_bigr do rewrite -scalerBl -coefB; move => /eqP eq.
apply: subr0_eq; rewrite -polyP => i; rewrite coef0.
have [ineq|ineq]:= (ltnP i (maxn (size p) (size q))).
	apply: seqbase_coef_eq0; [exact: size_pT | | exact: eq | exact ineq].
	move => n; rewrite lead_coefE size_pT.
	exact: coef_pTn_reg.
apply/ leq_sizeP; last apply ineq.
by rewrite -[size q]size_opp size_add.
Qed.

Lemma pT_eq0 (p: {poly R}):
	p = 0 <-> \sum_(i < size p) p`_i *: 'T_i = 0.
Proof. by rewrite pT_eq size_poly0 big_ord0. Qed.
End LINEAR_INDEPENDENCE.

Section Multiplication.

Variable (R: unitRingType).

Definition absn m n := (m - n + (n - m))%nat.

Lemma subn_leq m n : (n <= m -> n - m = 0)%nat.
Proof. by move => ineq; apply /eqP; rewrite subn_eq0. Qed.

Lemma absnE m n : absn m n = (if m <= n then n - m else m - n)%nat.
Proof.
rewrite /absn; case: leqP => H; first by rewrite subn_leq.
by rewrite [(n - m)%nat]subn_leq ?addn0 // ltnW.
Qed.

Lemma absnC : commutative absn.
Proof. by move => m n; rewrite /absn addnC. Qed.

Lemma absnn n : absn n n = 0%nat.
Proof. by rewrite /absn !subnn addn0. Qed.

Lemma absn_eq0 m n : (absn m n = 0 -> m = n)%nat.
Proof.
move=>/eqP; rewrite addn_eq0 => H; apply/eqP.
by rewrite eqn_leq.
Qed.

Lemma absnSS n m : absn m.+1 n.+1 = absn m n.
Proof. by rewrite /absn !subSS. Qed.

Lemma abs0n n :	absn 0 n = n.
Proof. by rewrite /absn sub0n subn0 add0n. Qed.

Lemma absn0 n : absn n 0 = n.
Proof. by rewrite absnC abs0n. Qed.

Lemma absn1S n : absn 1 n.+1 = n%nat.
Proof. by rewrite absnSS abs0n. Qed.

Lemma absnS1 n : absn n.+1 1 = n%nat.
Proof. by rewrite absnC absn1S. Qed.

Lemma absn_max_min m n : (absn m n = maxn m n - minn m n)%nat.
Proof.
rewrite /absn maxnE minnE.
case: (leqP n m) => H.
  by rewrite subKn // (subn_leq H) !addn0.
by rewrite (subn_leq) 1?ltnW // subn0 addKn.
Qed.

Lemma subn_eq m n p: (p > 0 -> m - n = p -> m = p + n)%nat.
Proof.
move => pgt E; rewrite -E subnK //.
by apply: ltnW; rewrite -subn_gt0 E.
Qed.

Lemma absnnD n m : absn n (n + m) = m.
Proof.
rewrite /absn (subn_leq); last by rewrite leq_addr.
by rewrite add0n addnC -addnBA// subnn addn0.
Qed.

Lemma subnSn n : (n - n.+1 = 0)%nat.
Proof. by elim: n. Qed.

Lemma absnif n m:
	(absn m n.+1 = if m <= n then (absn m n).+1 else (absn m n).-1)%nat.
Proof.
rewrite absnC !absnE leqNgt ltnS.
case: leqP => //=; first exact: subSn.
by rewrite subnS.
Qed.

Lemma absn_pT n m:
	'X *+2 * 'T_(absn m n.+1) - 'T_(absn m n) = 'T_(absn m n.+2) :> {poly R}.
Proof.
rewrite !absnif; case: leqP => [H|]; first by rewrite ltnW // -pTSS.
rewrite leq_eqVlt => /orP[/eqP<-|ineq].
  rewrite leqnn absnC -[n.+1]addn1 absnnD.
	by rewrite pT0 pT1 mulr1 -addrA subrr addr0.
rewrite leqNgt ineq /= -(subnK ineq) -!addSnnS addnC absnC absnnD /=.
by rewrite pTSS subKr.
Qed.

Lemma mul_pT n m :
	2%:R *: 'T_n * 'T_m = 'T_(n + m) + 'T_(absn m n) :> {poly R}.
Proof.
elim/ltn_ind : n m => // [] [|[|n]] IH m.
- by rewrite pT0 absn0 mulr2n scalerDl scale1r mulrDl mul1r.
- rewrite pT1 scaler_nat add1n.
	case: m => [|m]; first by rewrite pT0 pT1 /absn rm1 mulr2n.
	by rewrite absnS1 pTSS -addrA [-'T_m + 'T_m]addrC subrr rm0.
rewrite pTSS scalerDr mulrDl -!scalerAl mulNr.
rewrite scalerN !scalerAl IH; last by rewrite -ltnS ltnW.
rewrite -scaler_nat -!scalerAl -mulrA -commr_polyX.
rewrite  scalerAl scalerAl scalerAl IH //.
rewrite !addSn pTSS scalerDr mulrDl -scalerAl commr_polyX.
rewrite scalerAl scaler_nat -!addrA.
congr (_ + _).
rewrite opprD addrA [_ - 'T_(n+m)]addrC -addrA.
congr (_ + _).
rewrite -scalerAl commr_polyX scalerAl scaler_nat.
exact: absn_pT.
Qed.

Lemma pT_mulX_weak n :  'X *+ 2 * 'T_n.+1 = 'T_n + 'T_n.+2 :> {poly R}.
Proof. by rewrite pTSS addrCA subrr rm0. Qed.

Lemma pT_mulX n :
  (2%:R : R) \is a GRing.unit -> 'X * 'T_n.+1 = 2%:R ^-1 *: 'T_n + 2%:R ^-1 *: 'T_n.+2 :> {poly R}.
Proof.
move => I2; rewrite pTSS scalerDr addrCA scalerN subrr addr0.
by rewrite -scaler_nat -scalerAl scalerA mulVr // scale1r.
Qed.
End Multiplication.

Section pTab.

Variable R: fieldType.

Definition Tab (a b: R) := 	(1 + 1)/(b - a) *: 'X + (- (a + b) / (b - a))%:P.

Lemma Taba a b: b != a -> (Tab a b).[a] = -1.
Proof.
move =>neq; rewrite /Tab !hornerE.
rewrite opprD !mulrDl mul1r mulrC addrA -[a / (b - a) + _ + _]addrA.
rewrite mulNr subrr rm0 -mulrDl -[a-b]opprB mulNr divrr //.
by rewrite unitfE; apply: contra neq => eq; rewrite -subr_eq0.
Qed.

Lemma Tabb a b: b != a -> (Tab a b).[b] = 1.
Proof.
move => neq; rewrite /Tab !hornerE.
rewrite opprD !mulrDl mul1r mulrC addrC addrA -[- a / (b - a) + _ + _]addrA.
rewrite [- b / (b- a) + _]addrC [- b / _]mulNr subrr rm0 addrC -mulrDl divrr //.
by rewrite unitfE; apply: contra neq => eq; rewrite -subr_eq0.
Qed.

Definition pTab a b n := 'T_n \Po (Tab a b).

Notation "''T^(' a ',' b ')_' n" := (pTab a b n)
  (at level 3, n at level 2, format "''T^(' a ',' b ')_' n").

Lemma size_pTab n a b :
   2%:R != 0 :> R -> a != b -> size ('T^(a,b)_n) = n.+1.
Proof.
move=> H aDb.
have D :  b + - a != 0 by rewrite subr_eq0 eq_sym.
have E : GRing.lreg ((1 + 1) / (b - a)).
  by apply/GRing.lregM; apply/lregP => //; apply: invr_neq0.
rewrite size_comp_poly2 ?size_pT //; first by apply/lregP.
rewrite /Tab size_addl lreg_size ?size_polyX //.
by rewrite size_polyC; case: (_ == _).
Qed.

(* The condition GRing.lreg (2%:R : R) is unnecessary but makes live easier *)
Lemma coef_pTab n a b :
  2%:R != 0 :> R -> 'T^(a, b)_n`_n = (2^n.*2.-1)%:R /(b - a)^+n.
Proof.
move=> H.
rewrite ['T^(a, b)_n]comp_polyE coef_sum.
have rTA k : k%:R = (k%:R)%:A :> {poly R}.
    elim: k => /= [|k IH]; first by rewrite !rm0.
    by rewrite -addn1 !natrD IH scalerDl !rm1 /= scale1r.
have F : (n < size ('T_n : {poly R}))%nat by rewrite size_pT //; apply/lregP.
rewrite (bigD1 (Ordinal F)) //= big1 => [|i /eqP/val_eqP /= H1]; last first.
  rewrite coefZ exprDn coef_sum big1 => [|j _]; first by rewrite rm0.
  rewrite -mulr_natl -polyC_exp mulrCA mulrC.
  rewrite rTA alg_polyC -polyCM coefCM exprZn coefZ.
  rewrite coefXn.
  have : (i < n.+1)%nat.
    by rewrite -[n.+1](@size_pT R) //; apply/lregP.
  rewrite ltnS leq_eqVlt (negPf H1) /= => HH.
  have : (i - j < n)%nat.
    by apply: leq_ltn_trans (leq_subr _ _) HH.
  rewrite ltn_neqAle eq_sym => /andP[/negPf-> _].
  by rewrite !rm0.
rewrite coefZ addr0 exprDn coef_sum.
rewrite big_ord_recl /= big1 => [|i _].
  rewrite !rm0 bin0 !rm1 subn0 exprZn coef_pTn.
  rewrite coefZ coefXn eqxx rm1 -[1 + 1]/(2%:R).
  rewrite expr_div_n mulrA -natrX -natrM -expnD.
  by congr ((_ ^ _)%:R / _); rewrite -addnn; case: (n).
rewrite [bump _ _]add1n.
rewrite -mulr_natl -polyC_exp mulrCA mulrC.
rewrite rTA alg_polyC -polyCM coefCM exprZn coefZ coefXn.
case: i => ii /= _; case: (n) => [|nn].
  by rewrite bin0n !rm0.
have : (nn.+1 - ii.+1 < nn.+1)%nat.
  by apply: leq_ltn_trans (leq_subr _ _) (ltnSn _).
rewrite ltn_neqAle eq_sym => /andP[/negPf-> _].
by rewrite !rm0.
Qed.

Lemma horner_pTab a b n (x: R) :
  ('T^(a,b)_n).[x] = ('T_n).[(x*+2 - a - b) / (b - a)].
Proof.
rewrite /pTab horner_comp /Tab.
rewrite hornerD hornerZ hornerX hornerC.
congr (_.[_]).
rewrite mulr2n -{2 3}[x]mul1r -[1 * x + 1 * x]mulrDl -addrA [RHS]mulrDl.
by rewrite -[-a-b]opprD -{3}[b-a]mulr1 -mulf_div divr1.
Qed.

Lemma horner_pTab_a a b n :
	b != a -> 	('T^(a,b)_n).[a] = ('T_n).[-1].
Proof. by move => ineq; rewrite /pTab horner_comp Taba. Qed.

Lemma horner_pTab_b a b n :
	b != a -> ('T^(a,b)_n).[b] = ('T_n).[1].
Proof. by move => ineq; rewrite /pTab horner_comp Tabb. Qed.

Definition CPolyab a b l : {poly R} := \sum_(i < (size l)) l`_i *: 'T^(a,b)_i.

Lemma CPolyabN a b p :
  (CPolyab a b [seq - i | i <- p] = - (CPolyab a b p)).
Proof.
rewrite /CPolyab size_map -sumrN.
apply: eq_bigr => i _.
by rewrite (nth_map 0) // scaleNr.
Qed.

Lemma CPolyabD a b p q :
  size p = size q ->
  (CPolyab a b [seq i.1 + i.2 | i <- (zip p q)] =
     CPolyab a b p + CPolyab a b q).
Proof.
move=> Hs.
rewrite /CPolyab size_map size1_zip // Hs ?leqnn // -big_split.
apply: eq_bigr => i _.
by rewrite (nth_map 0) ?size2_zip ?Hs // scalerDl nth_zip.
Qed.

Lemma CPolyabB a b p q :
  size p = size q ->
  (CPolyab a b [seq i.1 - i.2 | i <- (zip p q)] =
     CPolyab a b p - CPolyab a b q).
Proof.
move=> Hs.
rewrite /CPolyab size_map size1_zip // Hs ?leqnn // -sumrB.
apply: eq_bigr => i _.
by rewrite (nth_map 0) ?size2_zip ?Hs // scalerBl nth_zip.
Qed.

End pTab.

Notation "''T^(' a ',' b ')_' n" := (pTab a b n)
  (at level 3, n at level 2, format "''T^(' a ',' b ')_' n").

Require Import Rstruct.

Section Int.

Variable R: fieldType.

Lemma deriv_pT0 : ('T_1)^`() = 'T_0 :> {poly R}.
Proof. by rewrite pT1 pT0 derivX. Qed.

Lemma deriv_pT1 : [char R]%RR =i pred0 ->
  (4%:R^-1 *: 'T_2)^`() = 'T_1 :> {poly R}.
Proof.
move=> /GRing.charf0P Hf.
rewrite derivZ pTSS pT1 pT0 mulrnAl derivB derivMn -expr2 derivXn derivC.
by rewrite subr0 -mulrnA -scaler_nat scalerA mulVf ?Hf ?scale1r.
Qed.

Lemma deriv_pTSS n: (1 < n)%nat -> [char R]%RR =i pred0 ->
  (n.+1.*2%:R^-1 *: 'T_n.+1 - n.-1.*2%:R^-1 *: 'T_n.-1)^`() =
    'T_n :> {poly R}.
Proof.
case: n => [] // [] // n _ /GRing.charf0P Hf.
rewrite !(derivB, derivZ, deriv_pT) -!scaler_nat !scalerA.
do 2 rewrite -muln2 natrM invfM mulrC mulrA mulfV ?Hf // mul1r.
rewrite -scalerBr pT_pU pUSS -addrA -opprD -mulr2n mulrnAl -mulrnBl.
rewrite -[(_ + _) *+ _]scaler_nat scalerA mulVf ?Hf // scale1r.
by rewrite addrAC mulr2n addrK.
Qed.

Variables a b : R.

Lemma deriv_Tab : (Tab  a b )^`() = ((1 + 1) / (b - a))%:P.
Proof. by rewrite !derivE addr0 alg_polyC. Qed.

Lemma deriv_pTabn n :
  ('T^(a,b)_n)^`() = 2%:R / (b - a) *: (('T_n)^`() \Po Tab a b).
Proof. by rewrite deriv_comp deriv_Tab [_ * _%:P]mulrC mul_polyC. Qed.

Lemma deriv_pTab0 : a != b -> 2%:R != 0 :> R ->
 ((b - a) / 2%:R *: 'T^(a,b)_1)^`() = 'T^(a,b)_0 :> {poly R}.
Proof.
move=> aDb twoNZ.
rewrite !derivE deriv_pTabn deriv_pT0 scalerA.
by rewrite mulrA divfK // mulfV ?scale1r // subr_eq0 eq_sym.
Qed.

Lemma deriv_pTab1 : a != b -> [char R]%RR =i pred0 ->
  (((b - a)/ 8%:R) *: 'T^(a,b)_2)^`() = 'T^(a,b)_1 :> {poly R}.
Proof.
rewrite eq_sym -subr_eq0 => bDaNeq0 Hc.
have /GRing.charf0P Hf := Hc.
rewrite !derivE deriv_pTabn scalerA mulrAC !mulrA [_ * 2%:R]mulrC mulfK //.
rewrite -[8%:R]/((2 * 4)%:R) natrM invfM mulrA mulfV ?Hf // mul1r.
by rewrite -comp_polyZ -derivZ deriv_pT1.
Qed.

Lemma deriv_pTabSS n: (1 < n)%nat -> a != b -> [char R]%RR =i pred0 ->
  ((b - a) / 2%:R *: (n.+1.*2%:R^-1 *:
    'T^(a,b)_n.+1 - n.-1.*2%:R^-1 *: 'T^(a,b)_n.-1))^`() =
    'T^(a,b)_n :> {poly R}.
Proof.
rewrite eq_sym -subr_eq0 => n_gt1 bDaNeq0 Hc.
have /GRing.charf0P Hf := Hc.
rewrite !derivE !deriv_pTabn.
rewrite !scalerA ![_ * (_ / _)]mulrC -!scalerA -!scalerBr !scalerA.
rewrite !divfK ?Hf // mulfV // scale1r.
by rewrite -!comp_polyZ -comp_polyB -!derivE deriv_pTSS.
Qed.

Variable f : nat -> R.

Variable k : nat.
Hypothesis fk1 : f (k.+1) = 0.
Hypothesis fk2 : f (k.+2) = 0.

Lemma deriv_sum_pT : (0 < k)%N -> [char R]%RR =i pred0 ->
  ((f 0 / 2%:R) *: 'T_1 +
    \sum_(1 <= i < k.+2) ((f i.-1 - f i.+1) / (i.*2%:R)) *: 'T_i)^`() =
    \sum_(0 <= i < k.+1) f i *: 'T_i.
Proof.
move=> k_gt0 Hc.
have /GRing.charf0P Hf := Hc.
under eq_bigr do rewrite mulrBl scalerBl.
rewrite sumrB.
rewrite big_add1.
have <-/= := @big_add1 _ _ _ 1 k.+4.-1 xpredT (fun i => (f i / i.-1.*2%:R) *: 'T_i.-1).
rewrite big_ltn // big_ltn //.
rewrite [\sum_(_ <= _ < _.+3) _]big_nat_recr //= fk2 mul0r scale0r addr0.
rewrite [\sum_(_ <= _ < _.+2) _]big_nat_recr //= fk1 mul0r scale0r addr0.
rewrite -!addrA -sumrB.
under eq_bigr do rewrite -!scalerA -scalerBr.
rewrite !derivE !deriv_pT0 -[_ *: _^`()]scalerA -derivE deriv_pT1 //.
rewrite addrA -scalerDl -mulrDr -mulr2n -mulr_natl mulfV ?Hf // mulr1.
rewrite (big_morph _ (@derivD R) (@deriv0 R)).
rewrite [RHS]big_ltn //; congr (_ + _).
rewrite [RHS]big_ltn //; congr (_ + _).
rewrite [RHS]big_nat_cond [LHS]big_nat_cond.
apply: eq_bigr => i /andP[/andP[i_gt1 iLk _]].
by rewrite derivE deriv_pTSS.
Qed.

Lemma deriv_sum_pTab : (0 < k)%N -> a != b -> [char R]%RR =i pred0 ->
  (((b - a) / 2%:R * (f 0 / 2%:R)) *: 'T^(a,b)_1 +
    \sum_(1 <= i < k.+2)
       ((b - a) / 2%:R * (f i.-1 - f i.+1) / (i.*2%:R)) *: 'T^(a,b)_i)^`() =
    \sum_(0 <= i < k.+1) f i *: 'T^(a,b)_i.
Proof.
move => k_gt0 aDb Hc.
have /GRing.charf0P Hf := Hc.
under eq_bigr do rewrite mulrBr mulrBl scalerBl.
rewrite sumrB.
rewrite big_add1.
have <-/= := @big_add1 _ _ _ 1 k.+4.-1 xpredT
             (fun i => ((b - a) / 2%:R  * f i / i.-1.*2%:R) *: 'T^(a,b)_i.-1).
rewrite big_ltn // big_ltn //.
rewrite [\sum_(_ <= _ < _.+3) _]big_nat_recr //= fk2 mulr0 mul0r scale0r addr0.
rewrite [\sum_(_ <= _ < _.+2) _]big_nat_recr //= fk1 mulr0 mul0r scale0r addr0.
rewrite -!addrA -sumrB.
under eq_bigr do rewrite -!scalerA -scalerBr.
rewrite !derivE.
rewrite addrA -scalerDl mulrA -mulrDr -mulrA mulrC.
rewrite -[_ *:  'T^(a,b)_1^`()]scalerA.
rewrite -[_ *: 'T^(a,b)_1^`()]derivE deriv_pTab0 ?Hf //.
rewrite -mulr2n -mulr_natl mulfV ?Hf // mulr1.
rewrite [RHS]big_ltn //; congr (_ _ _).
rewrite [_ * f 1]mulrC -2!mulrA -invfM ?Hf // -natrM -scalerA.
rewrite -derivE deriv_pTab1 //.
rewrite [RHS]big_ltn //; congr (_ _ _).
rewrite (big_morph _ (@derivD R) (@deriv0 R)).
rewrite [RHS]big_nat_cond [LHS]big_nat_cond.
apply: eq_bigr => i /andP[/andP[i_gt1 iLk _]].
by rewrite -!scalerBr !scalerA mulrC -scalerA derivE deriv_pTabSS.
Qed.

End Int.


Require Import Arith.
Require Import Omega.
Require Import Psatz.

Require Import kernel_numeric.

Notation "'all' i : V , P" := (forall i : nat, i < V -> P) (at level 20, i at level 99).
Notation "'some' i : V , P" := (exists i : nat, i < V /\ P) (at level 20, i at level 99).

Structure Graph := {
  V :> nat ; (* The number of vertices. So the vertices are numbers 0, 1, ..., V-1. *)
  E :> nat -> nat -> Prop ; (* The edge relation *)
  E_decidable : forall x y : nat, ({E x y} + {~ E x y}) ;
  E_irreflexive : all x : V, ~ E x x ;
  E_symmetric : all x : V, all y : V, (E x y -> E y x)
}.

Theorem simetricnost_povezav (G : Graph):
  (all x : V G , all y : V G,
  ((if E_decidable G x y then 1 else 0) =
  (if E_decidable G y x then 1 else 0))).
Proof.
  intros x p y q.
  destruct (E_decidable G x y); destruct (E_decidable G y x).
  - auto.
  - firstorder using E_symmetric.
  - firstorder using E_symmetric.
  - auto.
Qed.

(** Given a decidable predicate [P] on [nat], we can count how many numbers up to [n] satisfy [P]. *)
Definition count (n : nat) {P : nat -> Prop} (decP : forall x, {P x} + {~ P x})  :=
  sum' n (fun x => if decP x then 1 else 0).

(** The number of edges in a graph. *)
Definition edges (G : Graph) : nat :=
  sum' (V G) (fun x => count x (E_decidable G x)).

(** The degree of a vertex. We define it so that it
    return 0 if we give it a number which is not
    a vertex. *)
Definition degree (G : Graph) (x : nat) :=
  count (V G) (E_decidable G x).

(*
Theorem hand_shake (G : Graph) :
  2 * edges G = sum' (V G) (degree G).
*)


(* Exercise 3 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_003 :
  (forall x y : D, R x y -> ~ R y x)
->
  forall x : D, ~ R x x.
Proof.
imp_i a1.
all_i a.
neg_i (R a a) a2.
imp_e (R a a).
all_e (forall y:D, R a y -> ~R y a) a.
all_e (forall x:D, forall y:D, (R x y -> ~R y x)) a.
hyp a1.
hyp a2.
hyp a2.
Qed.