From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype tuple.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Prop and Type *)

Lemma sig_exists A (P : A -> Prop) :
  {x : A | P x} -> exists x : A, P x.
Proof.
case=> x px.
by exists x.
Undo.
exists x.
exact: px.
Qed.

Definition exists_sig A (P : A -> Prop) :
  (exists x : A, P x) ->
  {x : A | P x}.
Proof.
Fail case=> x px.
(**
Error: ...
Case analysis on sort [Type] is not allowed
for inductive definition [ex].
*)
Abort.
(** Recall that [exists x : A, P x] is a notation
    for [ex P] *)
Check ex :  forall A : Type, (A -> Prop) -> Prop.
Check sig : forall A : Type, (A -> Prop) -> Type.

(** This happens because [ex] lives in [Prop] --
    the universe of logical proposititons and
    [sig] belongs to [Type] -- the universe of
    computations.
    If Coq wants to stay compatible with classical
    logic it needs to prohibit information flow
    from [Prop] to [Type].
    In other words, one can _only_ use proofs to
    build other proofs.
*)

(** ** But why exactly this restriction? *)

(** First of all, we should mention that [Prop]
    is _impredicative_, meaning the following
    typechecks just fine:
 *)
Section Impredicativity.

Check (forall P : Prop, P) : Prop.

(**
This formula quantifies over all formulas,
including itself:
 *)

Variable p : (forall P : Prop, P).
Check p (forall P : Prop, P).

End Impredicativity.

Section TypeInType.
(** But what about [Type]? Doesn't it have
    the same property?  *)

Check (forall P : Type, P) : Type.

(** Well, no. [Type] is not a primitive universe,
    in fact, it's a family of indexed universes
    but the indices are hidden by default.
    We can recover those like so: *)

Set Printing Universes.
Check (forall P : Type, P) : Type.
(**
(forall P : Type@{Top.246}, P) : Type@{Top.245}
     : Type@{Top.245}
(* {Top.246 Top.245} |= Top.246 < Top.245 *)
*)

(** To make this more readable we can declare
    explicit universe levels: *)
Universe i j.
Check (forall P : Type@{i}, P) : ( Type@{j} ).
(** Coq infers [i < j] in this case, so following
    predictably fails: *)
Fail Check (forall P : Type@{i}, P) : ( Type@{i} ).
(**
universe inconsistency:
Cannot enforce i < i because i = i.
*)

(** This restriction prevents us from getting
    the so-called "type-in-type" paradox --
    had we not introduced this hierarchy of
    universes we would get
    [Type : Type] which leads to inconsistency
    as famously shown by Girard.
 *)

Check Type@{i}.
(** Type@{i} : Type@{i+1} *)

(** Some more examples: *)

Check nat.
(** nat : Set *)

Check Set.
(** Set : Type@{Set+1} *)

Check Prop.
(** Prop : Type@{Set+1} *)

Unset Printing Universes.
End TypeInType.

(** * Large elimination *)

(**
Next, let's look at _large elimination
Large elimination is the ability to build values
of type [Type] by eliminating an inductive value.

We used it to prove the disjointness of constructors
in Lecture 03:
*)

Definition false_implies_False_term :
  false = true -> False
:=
  fun     eq :  false = true =>
    match eq in (_    = b)
             return (if b then False else True)
                    (* ^^^^^^^^^^^^^^^^^^^^^^^ *)
                    (* large elimination       *)
    with
    | erefl => I
    end.

(** Now, Coq is known to be consistent with the
    Law of Excluded Middle, i.e. the following
    axiom can be safely added
 *)

Axiom LEM : forall P : Prop, P \/ ~ P.

(** But, as shown by Berardi in the 1990s,
  impredicativity + excluded middle
  => proof irrelevance

See the paper "Proof-irrelevance out of
Excluded-middle and Choice in the Calculus of
Constructions" - F. Barbanera, S. Berardi(1996)
 *)

(** Had we not prohibited large elimination for
    the impredicative universe [Prop],
    we would get a means to proving disjointness
    of constructors, i.e. that proofs can differ
    from each other. *)
Inductive Bool : Prop := T : Bool | F : Bool.

Fail Definition prf_rel_Bool (Eq : T = F) : False :=
  match Eq in (_ = y)
        return (match y with
                | T => True
                | F => False
                end)
  with
  | eq_refl => I
  end.

(** no large elimination for [Prop] *)
Fail Check match F with T => True | F => False end.

(** no such restriction for [Type] *)
Check
  match false with true => True | false => False end.

(**
  Upshot:
  proof irrelevance + large elimination
  => False

  Hence
  impredicative [Prop] + large elimination + excluded middle
  => False

  Overall, this lets [Prop] be impredicative
  and Coq compatible with the law of excluded
  middle, which is commonly used in mathematics.

  See also https://github.com/FStarLang/FStar/issues/360

*)

(** It's now easy to see that some exceptions
    that won't result in proof _relevance_
    are fine:
 *)
Definition False_to_nat (prf : False) : nat :=
  match prf with end.

Definition true_to_nat (prf : True) : nat :=
  match prf with | I => 0 end.

(** The above examples work because
    the corresponding inductive types have only
    zero or one constructors, i.e. not enough
    to prove the disjointness *)

Fail Definition or_to_nat (prf : True \/ True) : nat :=
  match prf with
  | or_introl _ => 0
  | or_intror _ => 1
  end.
(**
Incorrect elimination of "prf" in the inductive type "or":
the return type has sort "Set" while it should be "Prop".
Elimination of an inductive object of sort Prop
is not allowed on a predicate in sort Set
because proofs can be eliminated only to build proofs.
*)

(** * Totality and termination *)

(** There is a plugin to control
    - the guardedness check,
    - strict positivity rule, and
    - universe inconsistency check
    It's not needed with the current development
    version of Coq (8.11+alpha).
    For Coq versions 8.7 - 8.9 it can be installed
    with opam package manager:
      opam install coq-typing-flags
    or compiled manually using instructions from
    the plugin's homepage:
    https://github.com/SimonBoulier/TypingFlags
    To start using the plugin in a Coq file:
      From TypingFlags Require Import Loader.
    This adds
    Set Type In Type / Unset Type In Type
    and
    Set Guard Checking / Unset Guard Checking.
    vernacular commands.
 *)

From TypingFlags Require Import Loader.

(** We already mentioned earlier that
    Coq is a total language.
    This ensures its consistency as a logic
    because it rules out things like the following:
 *)

(** Disable termination checker *)
Unset Guard Checking.

Fixpoint proof_of_False (n : nat) : False :=
  proof_of_False n.

Check proof_of_False 0 : False.

(** The following vernacular reveals that
    the proof of falsehood was obtained due to
    bypassing of one of the checkers *)
Print Assumptions proof_of_False.
(** Axioms:
    proof_of_False is positive. *)

(** Remark: Coq's implementation does not enforce
    _strong_ normalization, only weak one *)

(** Enable termination checker again *)
Set Guard Checking.

Fixpoint weak_normalization (n : nat) : nat :=
  let bar := weak_normalization n in
  0.

Print Assumptions weak_normalization.
(** [Closed under the global context]
    This means neither axioms were used nor any checker was disabled *)

(** * Intermezzo: [interleave] function *)

(** ** Elegant, but non-structural recursive [interleave] function *)

Unset Guard Checking.
Fixpoint interleave_ns {T} (xs ys : seq T)
           {struct xs} : seq T :=
  if xs is (x :: xs') then x :: interleave_ns ys xs'
  else ys.

(** A simple unit test. *)
Check erefl :
interleave_ns [:: 1; 3] [:: 2; 4] = [:: 1; 2; 3; 4].
(** As you can see the evaluator does not care
    if the function passes the guardedness check
    or not *)

Print Assumptions interleave_ns.
(**
  Axioms:
  interleave_ns is positive.
*)

(** Here is how [interleave] can be actually defined in Coq: *)
Set Guard Checking.
Fixpoint interleave {T} (xs ys : seq T) : seq T :=
  match xs, ys with
  | (x :: xs'), (y :: ys') =>
       x :: y :: interleave xs' ys'
  | [::], _ => ys
  | _, [::] => xs
  end.

(** We can even prove the two implementations
    are "the same" *)
Lemma interleave_ns_eq_interleave {T} :
  (@interleave_ns T) =2 (@interleave T).
Proof.
by elim=> // x xs IHxs [|y ys] //=; rewrite IHxs.
Qed.

(** Coq offers more ways of defining [interleave]
    function *)

(** ** 1. Using the builtin [Function] plugin *)

(** To activate [Function] plugin,
    this makes available a new piece of vernacular:
    [Function] *)
From Coq Require Import Recdef.

Definition sum_len {T} (xs_ys : seq T * seq T) : nat :=
  length xs_ys.1 + length xs_ys.2.

Function interleave_f' {T} (xs_ys : (seq T * seq T))
         {measure sum_len xs_ys} : seq T :=
  if xs_ys is (x :: xs', ys) then
    x :: interleave_f' (ys, xs')
  else [::].
Proof.
move=> X xs_ys xs ys x xs' _ _.
by rewrite /sum_len /= addnC.
Qed.
(**
Notice a bunch of autogenerated definitions:

interleave_f'_tcc is defined
interleave_f'_terminate is defined
interleave_f'_ind is defined
interleave_f'_rec is defined
interleave_f'_rect is defined
R_interleave_f'_correct is defined
R_interleave_f'_complete is defined
 *)

Fail Check erefl :
  interleave_f' ([:: 1; 3], [:: 2; 4]) =
  [:: 1; 2; 3; 4].
Eval hnf in interleave_f' ([:: 1; 3], [:: 2; 4]).
(**
The above gets stuck on:
  = let (v, _) :=
      interleave_f'_terminate ([:: 1; 3], [:: 2; 4])
    in v
  : seq nat
*)
About interleave_f'_terminate.
(**
...
interleave_f'_terminate is opaque
...
 *)

(** First, we are going to fix evaluation
    by making [interleave_f_terminate]
    transparent: *)
Function interleave_f {T} (xs_ys : (seq T * seq T))
         {measure sum_len xs_ys} : seq T :=
  if xs_ys is (x :: xs', ys) then
    x :: interleave_f (ys, xs')
  else [::].
Proof.
move=> X xs_ys xs ys x xs' _ _.
by rewrite /sum_len /= addnC.
(** [Defined] makes [interleave_f_terminate]
    transparent *)
Defined.

(** Now evaluation works: *)
Check erefl :
  interleave_f ([:: 1; 3], [:: 2; 4]) =
  [:: 1; 2; 3; 4].
About interleave_f_terminate.
(**
...
interleave_f_terminate is transparent
...
*)

(** Now let us see how [interleave_f] is built *)
Print interleave_f.
(**
interleave_f =
fun (x : Type) (x0 : seq x * seq x) =>
  let (v, _) := interleave_f_terminate x0 in v
     : forall x : Type, seq x * seq x -> seq x
*)
About interleave_f_terminate.
(**
interleave_f_terminate :
forall (T : Type) (xs_ys : seq T * seq T),
{v : seq T |
exists p : nat,
  forall k : nat,
  (p < k)%coq_nat ->
  forall def : forall T0 : Type,
                 seq T0 * seq T0 -> seq T0,
  iter (forall T0 : Type, seq T0 * seq T0 -> seq T0)
       k
       interleave_f_F
       def
       T
       xs_ys
  = v}
*)

(** Under the hood [interleave_f_terminate]
    is (of course) a structural recursive function.
    To understand what type we do recursion over,
    let's print the definition of the function and
    search for [fix] *)
Print interleave_f_terminate.
(**
...
fix hrec (T0 : Type) (xs_ys0 : seq T0 * seq T0)
         (Acc_xs_ys0 : Acc (Wf_nat.ltof
                              (seq T0 * seq T0)
                              [eta sum_len])
                           xs_ys0)
         {struct Acc_xs_ys0} :
...
*)

(** Here we meet the accessibility predicate [Acc]
    which can be used to define well-founded
    induction principles *)
Print Acc.
(**
Inductive Acc (A : Type)
              (R : A -> A -> Prop)
              (x : A) : Prop :=
  | Acc_intro :
      (forall y : A, R y x -> Acc R y) -> Acc R x

[Acc R x] can be read as "x is accessible under
relation R if all elements staying in relation R
with it are also accessible"
*)

(** Notice that Coq allows us do structural
    recursion on a term of type [Acc]
    which lives in [Prop] while building
    a term of a type living in [Type].
    (structural recursion involves pattern-matching).
    But the accessibility predicate is defined
    to be non-informative (one constructor!).
 *)

(** ** More on choice operator *)
Section Find.

(** Getting a concrete value from
    an abstract existence proof. *)

Variable (P : pred nat).

(** This construction lets us count up *)
Inductive acc_nat i : Prop :=
| AccNat0 of P i
| AccNatS of acc_nat i.+1.

Lemma find_ex :
  (exists n, P n) -> {m | P m}.
Proof.
move=> exP.

have: acc_nat 0.
  case exP => n; rewrite -(addn0 n); elim: n 0 => [|n IHn] j; first by left.
  by rewrite addSnnS; right; apply: IHn.

move: 0.
fix find_ex 2 => m IHm.
case Pm: (P m).
- by exists m.
apply: find_ex m.+1 _.
case: IHm.
- by rewrite Pm.
by [].
Defined.

End Find.

(** ** 2. Using the builtin [Program] mechanism *)

From Coq Require Import Program.

Program Fixpoint interleave_p {A} (xs ys : seq A)
  {measure (length xs + length ys)} : list A :=
  if xs is (x :: xs') then
    x :: interleave_p ys xs'
  else ys.
Next Obligation. by rewrite addnC. Qed.

Check erefl :
  interleave_p [:: 1; 3] [:: 2; 4] =
  [:: 1; 2; 3; 4].

(** [Program] also relies on [Acc] predicate *)

Print Assumptions interleave_p.
(** [Closed under the global context]

    But sometimes [Program] relies on
    [JMeq_eq] axiom to do dependent pattern
    matching.
 *)
Check JMeq_eq.
(**
JMeq_eq : forall (A : Type) (x y : A),
            x ~= y -> x = y
*)
Print JMeq.
(**
"JMeq" means "John Major equality", a.k.a.
heterogenous equality.

Inductive JMeq (A : Type) (x : A) :
  forall B : Type, B -> Prop :=
| JMeq_refl : x ~= x

[~=] is a notation for [JMeq]
*)

(** ** 3. Using the [Equations] plugin *)

(** The plugin can be installed via opam:
      opam install coq-equations *)

From Equations Require Import Equations.

Equations interleave_e {T} (xs ys : seq T) : seq T
  by wf (length xs + length ys) lt :=
interleave_e (x :: xs) ys :=
  x :: (interleave_e ys xs);
interleave_e [::] ys :=
  ys.
Next Obligation. by rewrite addnC. Qed.

Check erefl :
  interleave_e [:: 1; 3] [:: 2; 4] =
  [:: 1; 2; 3; 4].

(** One more trick to teach Coq termination:
    nested [fix] *)

(** Ackermann's function *)

Fixpoint ack (n m : nat) : nat :=
  if n is n'.+1 then
    let fix ackn (m : nat) :=
        if m is m'.+1 then ack n' (ackn m')
        else ack n' 1
    in ackn m
  else m.+1.

(** * Strict positivity rule *)

Print Typing Flags.

Fail Inductive prop :=
  RemoveNegation of (prop -> False).
(**
Non strictly positive occurrence of "prop" in
"(prop -> False) -> prop".
*)

Unset Guard Checking.
Print Typing Flags.

Inductive prop :=
  RemoveNegation of (prop -> False).
Print Assumptions prop.
(**
Axioms:
prop is positive.
*)

Definition not_prop (p : prop) : False :=
  let '(RemoveNegation not_p) := p in not_p p.
Check not_prop : prop -> False.

Check RemoveNegation not_prop : prop.

Definition yet_another_proof_of_False : False :=
  not_prop (RemoveNegation not_prop).

Print Assumptions yet_another_proof_of_False.
(**
Axioms:
yet_another_proof_of_False is positive.
not_prop is positive.
prop is positive.
*)
Set Guard Checking.

(**
Roughly, the positivity condition says that
constructors for an inductive data type can
only depend on maps to the data type but not on
maps from it.
*)

(** * Bonus: Universe polymorphism *)

Definition idf {A} : A -> A := fun x => x.
Fail Definition selfidfun := idf (@idf).
(**
The term "@idf" has type "forall A : Type, A -> A"
while it is expected to have type "?A"
(unable to find a well-typed instantiation for "?A": cannot ensure that
"Type@{Top.1849+1}" is a subtype of "Type@{Top.1849}").
*)

Set Universe Polymorphism.

Definition idf' {A} : A -> A := fun x => x.
Definition selfidfun' := idf' (@idf').
Print selfidfun'.

(** See more examples in the Coq Reference Manual *)


Require Export RTopology.
Require Export ProductTopology.

Local Unset Standard Proposition Elimination Names.

Lemma Rplus_continuous: continuous_2arg Rplus (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
apply pointwise_continuity_2arg.
intros.
red.
pose proof (RTop_metrization (x+y)).
apply continuous_at_neighborhood_basis with
  (metric_topology_neighborhood_basis R_metric (x+y)).
apply open_neighborhood_basis_is_neighborhood_basis.
apply RTop_metrization.

intros.
destruct H0.
exists ([ p:point_set RTop * point_set RTop | let (x',y'):=p in
  In (open_ball _ R_metric x (r/2)) x' /\
  In (open_ball _ R_metric y (r/2)) y' ]).
repeat split.
apply ProductTopology2_basis_is_basis.
constructor.
pose proof (RTop_metrization x).
destruct H1.
apply (open_neighborhood_basis_elements
  (open_ball _ R_metric x (r/2))).
constructor.
Require Import Fourier.
fourier.
destruct (RTop_metrization y).
apply (open_neighborhood_basis_elements
  (open_ball _ R_metric y (r/2))).
constructor.
fourier.
rewrite metric_zero.
fourier.
apply R_metric_is_metric.
rewrite metric_zero.
fourier.
apply R_metric_is_metric.
destruct x0 as [x' y'].
destruct H1 as [[[] []]].
unfold R_metric.
replace (x'+y' - (x+y)) with ((x'-x) + (y'-y)) by ring.
apply Rle_lt_trans with (Rabs (x'-x) + Rabs(y'-y)).
apply Rabs_triang.
replace r with (r/2+r/2) by field; apply Rplus_lt_compat; trivial.
Qed.

Corollary sum_continuous: forall (X:TopologicalSpace)
  (f g:point_set X -> point_set RTop) (x:point_set X),
  continuous_at f x -> continuous_at g x ->
  continuous_at (fun x:point_set X => f x + g x) x (Y:=RTop).
Proof.
intros.
apply continuous_composition_at_2arg; trivial.
apply continuous_func_continuous_everywhere.
apply Rplus_continuous.
Qed.

(* Ropp_continuous was already proved in RTopology *)

Lemma Rminus_continuous: continuous_2arg Rminus
  (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
unfold Rminus.
apply pointwise_continuity_2arg; intros.
red.
pose proof (sum_continuous _
  (fun p:point_set (ProductTopology2 RTop RTop) => fst p)
  (fun p:point_set (ProductTopology2 RTop RTop) => -snd p) (x,y)).
simpl in H.
match goal with |- continuous_at ?f ?q =>
  replace f with (fun p:R*R => fst p + - snd p) end.
apply sum_continuous.
apply continuous_func_continuous_everywhere.
apply product2_fst_continuous.
apply (continuous_composition_at (Y:=RTop)).
apply continuous_func_continuous_everywhere.
apply Ropp_continuous.
apply continuous_func_continuous_everywhere.
apply product2_snd_continuous.

Require Import FunctionalExtensionality.
extensionality p.
destruct p as [x' y'].
trivial.
Qed.

Corollary diff_continuous: forall (X:TopologicalSpace)
  (f g:point_set X -> point_set RTop) (x:point_set X),
  continuous_at f x -> continuous_at g x ->
  continuous_at (fun x:point_set X => f x - g x) x (Y:=RTop).
Proof.
intros.
apply continuous_composition_at_2arg; trivial.
apply continuous_func_continuous_everywhere.
exact Rminus_continuous.
Qed.

Lemma const_multiple_func_continuous: forall c:R,
  continuous (fun x:R => c*x) (X:=RTop) (Y:=RTop).
Proof.
intros.
apply pointwise_continuity; intros.
apply metric_space_fun_continuity with R_metric R_metric;
  try apply RTop_metrization.
destruct (classic (c=0)).
exists 1.
split.
red; auto with real.
intros.
rewrite H.
unfold R_metric.
replace (0*x'-0*x) with 0 by ring.
rewrite Rabs_R0.
trivial.

intros.
exists (eps / Rabs c).
split.
apply Rmult_gt_0_compat; trivial.
apply Rinv_0_lt_compat.
apply Rabs_pos_lt; trivial.
intros.
unfold R_metric.
replace (c*x' - c*x) with (c*(x'-x)) by ring.
rewrite Rabs_mult.
replace eps with (Rabs c * (eps / Rabs c)); try field.
apply Rmult_lt_compat_l.
apply Rabs_pos_lt; trivial.
trivial.
apply Rabs_no_R0; trivial.
Qed.

Corollary const_multiple_continuous: forall (X:TopologicalSpace)
  (f:point_set X -> point_set RTop) (c:R) (x:point_set X),
  continuous_at f x -> continuous_at (fun x:point_set X => c * f x) x
                       (Y:=RTop).
Proof.
intros.
apply continuous_composition_at; trivial.
apply continuous_func_continuous_everywhere.
apply const_multiple_func_continuous with (c:=c).
Qed.

Lemma Rmult_continuous_at_origin: continuous_at_2arg Rmult 0 0
                                  (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
red.
pose proof (RTop_metrization 0).
apply continuous_at_neighborhood_basis with
  (metric_topology_neighborhood_basis R_metric 0).
apply open_neighborhood_basis_is_neighborhood_basis.
replace (0*0) with 0 by auto with real.
apply H.

intros.
destruct H0.
exists (characteristic_function_to_ensemble
  (fun p:point_set RTop * point_set RTop => let (x',y'):=p in
  In (open_ball _ R_metric 0 r) x' /\
  In (open_ball _ R_metric 0 1) y' )).
repeat split.
apply ProductTopology2_basis_is_basis.
constructor.
destruct H.
apply (open_neighborhood_basis_elements (open_ball _ R_metric 0 r)).
constructor; trivial.
destruct H.
apply (open_neighborhood_basis_elements (open_ball _ R_metric 0 1)).
constructor; red; auto with real.
rewrite metric_zero; trivial.
apply R_metric_is_metric.
rewrite metric_zero; auto with real.
apply R_metric_is_metric.

destruct H1.
destruct x as [x y].
destruct H1 as [[] []].
unfold R_metric in H1, H2.
unfold R_metric.
replace (x*y-0) with (x*y) by auto with real.
replace (x-0) with x in H1 by auto with real.
replace (y-0) with y in H2 by auto with real.
rewrite Rabs_mult.
replace r with (r*1) by auto with real.
apply Rmult_le_0_lt_compat; trivial.
apply Rabs_pos.
apply Rabs_pos.
Qed.

Lemma Rmult_continuous: continuous_2arg Rmult (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
apply pointwise_continuity_2arg.
intros x0 y0.
red.
match goal with |- continuous_at ?f ?q => replace f with
  (fun p:point_set RTop*point_set RTop =>
   (fst p - x0) * (snd p - y0) + y0 * fst p + x0 * snd p - x0 * y0) end.
apply diff_continuous.
apply sum_continuous.
apply sum_continuous.
apply continuous_composition_at_2arg with RTop RTop.
simpl.
replace (x0-x0) with 0 by ring.
replace (y0-y0) with 0 by ring.
apply Rmult_continuous_at_origin.
apply diff_continuous.
apply continuous_func_continuous_everywhere; apply product2_fst_continuous.
apply continuous_func_continuous_everywhere; apply continuous_constant.
apply diff_continuous.
apply continuous_func_continuous_everywhere; apply product2_snd_continuous.
apply continuous_func_continuous_everywhere; apply continuous_constant.
apply const_multiple_continuous.
apply continuous_func_continuous_everywhere; apply product2_fst_continuous.
apply const_multiple_continuous.
apply continuous_func_continuous_everywhere; apply product2_snd_continuous.
apply continuous_func_continuous_everywhere; apply continuous_constant.

extensionality p.
destruct p as [x y].
simpl.
ring.
Qed.

Corollary product_continuous: forall (X:TopologicalSpace)
  (f g:point_set X -> point_set RTop) (x:point_set X),
  continuous_at f x -> continuous_at g x ->
  continuous_at (fun x:point_set X => f x * g x) x (Y:=RTop).
Proof.
intros.
apply continuous_composition_at_2arg; trivial.
apply continuous_func_continuous_everywhere.
exact Rmult_continuous.
Qed.

Lemma Rinv_continuous_at_1: continuous_at Rinv 1 (X:=RTop) (Y:=RTop).
Proof.
apply metric_space_fun_continuity with R_metric R_metric;
  try apply RTop_metrization.
intros.
exists (Rmin (1/2) (eps/2)).
split; intros.
apply Rmin_Rgt_r; split; fourier.
assert (x' > 1/2).
assert (Rabs (x'-1) < 1/2).
apply Rlt_le_trans with (1 := H0).
apply Rmin_l.
destruct (Rabs_def2 _ _ H1).
fourier.
assert (/ x' < 2).
rewrite <- Rinv_involutive.
apply Rinv_lt_contravar.
apply Rmult_lt_0_compat; fourier.
unfold Rdiv in H1.
replace (1 * / 2) with (/ 2) in H1 by auto with real.
exact H1.
intro.
fourier.

unfold R_metric.
replace (/ x' - / 1) with ((1 - x') * / x'); try field.
rewrite Rabs_mult.
rewrite (Rabs_right (/ x')).
rewrite Rabs_minus_sym.
assert (Rabs (x' - 1) < eps/2).
apply Rlt_le_trans with (1:=H0).
apply Rmin_r.
replace eps with ((eps/2) * 2) by field.
apply Rmult_gt_0_lt_compat; trivial.
apply Rinv_0_lt_compat.
fourier.
fourier.
left.
apply Rinv_0_lt_compat.
fourier.
intro.
fourier.
Qed.

Require Import Ensembles.
Require Import SeparatednessAxioms.

Lemma Rinv_continuous: forall x0:R, x0<>0 -> continuous_at Rinv x0 (X:=RTop) (Y:=RTop).
Proof.
  intros.
  apply continuous_at_is_local with
    (f:=fun x:R => /x0 * Rinv (/x0 * x))
    (N:=Complement (Singleton 0)).
  apply open_neighborhood_is_neighborhood.
  split.
  apply Hausdorff_impl_T1_sep.
  apply T3_sep_impl_Hausdorff.
  apply normal_sep_impl_T3_sep.
  apply metrizable_impl_normal_sep.
  exists R_metric.
  apply R_metric_is_metric.
  apply RTop_metrization.
  intro.
  destruct H0.
  contradiction H.
  reflexivity.
  intros.
  assert (x<>0).
  intro.
  contradiction H0.
  rewrite H1; constructor.
  simpl.
  field; split; trivial.

  apply const_multiple_continuous.
  apply (continuous_composition_at (Y:=RTop)).
  replace (/x0 * x0) with 1.
  apply Rinv_continuous_at_1.
  field; trivial.
  apply continuous_func_continuous_everywhere.
  apply const_multiple_func_continuous with (c:=/ x0).
Qed.

Lemma Rdiv_continuous: forall x y:R, y <> 0 ->
  continuous_at_2arg Rdiv x y (X:=RTop) (Y:=RTop) (Z:=RTop).
Proof.
intros.
red.
match goal with |- continuous_at ?f ?q => replace f with
  (fun p:point_set RTop * point_set RTop => fst p * / snd p) end.
apply product_continuous.
apply continuous_func_continuous_everywhere; apply product2_fst_continuous.
apply continuous_composition_at.
simpl.
apply Rinv_continuous; trivial.
apply continuous_func_continuous_everywhere; apply product2_snd_continuous.

extensionality p.
destruct p as [x' y'].
trivial.
Qed.

Corollary quotient_continuous: forall (X:TopologicalSpace)
  (f g:point_set X -> point_set RTop) (x0:point_set X),
  continuous_at f x0 -> continuous_at g x0 -> g x0 <> 0 ->
  continuous_at (fun x:point_set X => f x / g x) x0 (Y:=RTop).
Proof.
intros.
apply continuous_composition_at_2arg; trivial.
apply Rdiv_continuous; trivial.
Qed.

Lemma Rabs_continuous: continuous Rabs (X:=RTop) (Y:=RTop).
Proof.
apply pointwise_continuity; intros.
apply metric_space_fun_continuity with R_metric R_metric;
  try apply RTop_metrization.
intros.
exists eps; split; trivial.
intros.
apply Rle_lt_trans with (2 := H0).
apply Rabs_triang_inv2.
Qed.

(* a miscellaneous example which is used in the proof of the
   Tietze extension theorem *)
Require Import Homeomorphisms.

Lemma open_interval_homeomorphic_to_real_line:
  let U:=characteristic_function_to_ensemble
      (fun x:point_set RTop => -1 < x < 1) in
  homeomorphic RTop (SubspaceTopology U).
Proof.
intros.
assert (forall x:R, -1 < x / (1 + Rabs x) < 1).
intros.
assert (0 < 1 + Rabs x).
apply Rlt_le_trans with 1; auto with real.
pattern 1 at 1; replace 1 with (1+0) by auto with real.
apply Rplus_le_compat_l.
apply Rabs_pos.
apply and_comm; apply Rabs_def2.
unfold Rdiv; rewrite Rabs_mult.
rewrite Rabs_Rinv.
rewrite (Rabs_right (1 + Rabs x)); try (left; trivial).
pattern 1 at 2; replace 1 with ((1 + Rabs x) * / (1 + Rabs x)).
apply Rmult_lt_compat_r.
apply Rinv_0_lt_compat; trivial.
pattern (Rabs x) at 1; replace (Rabs x) with (0 + Rabs x); auto with real.
field.
apply Rgt_not_eq; trivial.
apply Rgt_not_eq; trivial.

assert (forall x:point_set RTop, In U (x / (1 + Rabs x))).
intros; constructor; apply H.
Require Import ContinuousFactorization.
exists (continuous_factorization _ _ H0).
exists (fun x:point_set (SubspaceTopology U) =>
  (subspace_inc U x) / (1 - Rabs (subspace_inc U x))).
apply factorization_is_continuous.
apply pointwise_continuity; intros.
apply quotient_continuous.
apply continuous_func_continuous_everywhere; apply continuous_identity.
apply sum_continuous.
apply continuous_func_continuous_everywhere; apply continuous_constant.
apply continuous_func_continuous_everywhere; apply Rabs_continuous.
apply Rgt_not_eq.
apply Rlt_le_trans with 1; auto with real.
pattern 1 at 1; replace 1 with (1+0) by auto with real.
apply Rplus_le_compat_l.
apply Rabs_pos.

apply pointwise_continuity; intros.
apply quotient_continuous.
apply continuous_func_continuous_everywhere; apply subspace_inc_continuous.
apply diff_continuous.
apply continuous_func_continuous_everywhere; apply continuous_constant.
apply continuous_composition_at.
apply continuous_func_continuous_everywhere; apply Rabs_continuous.
apply continuous_func_continuous_everywhere; apply subspace_inc_continuous.
apply Rgt_not_eq.
apply Rgt_minus.
red.
destruct x as [x [[]]]; simpl.
apply Rabs_def1; trivial.

simpl.
intros.
unfold Rabs at 1 3; destruct Rcase_abs.
rewrite Rabs_left.
field.
split; intro; fourier.
assert (/ (1 + -x) > 0).
apply Rinv_0_lt_compat.
fourier.
replace 0 with (x*0) by auto with real.
apply Rmult_lt_gt_compat_neg_l; trivial.

rewrite Rabs_right.
field.
split; intro; fourier.
assert (/ (1+x) > 0).
apply Rinv_0_lt_compat.
fourier.
apply Rle_ge.
apply Rge_le in r.
red in H1.
unfold Rdiv.
replace 0 with (0 * / (1+x)); auto with real.

intros.
destruct y as [x].
simpl.
Require Import Proj1SigInjective.
apply subset_eq_compatT.
destruct i.
destruct H1.
assert (Rabs x < 1).
apply Rabs_def1; trivial.

unfold Rabs at 1 3; destruct Rcase_abs.
rewrite Rabs_left.
field.
split; intro; fourier.
replace (1 - -x) with (1+x) by ring.
assert (/ (1+x) > 0).
apply Rinv_0_lt_compat.
fourier.
unfold Rdiv.
replace 0 with (x*0) by auto with real.
apply Rmult_lt_gt_compat_neg_l; trivial.

rewrite Rabs_right.
field.
split; intro; fourier.
assert (/ (1-x) > 0).
apply Rinv_0_lt_compat.
apply Rgt_minus; trivial.
unfold Rdiv.
red in H4.
apply Rge_le in r.
apply Rle_ge.
replace 0 with (0 * / (1-x)); auto with real.
Qed.


(* week-06_miscellany.v *)
(* FPP 2020 - YSC3236 2020-2021, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 20 Sep 2020 *)
(* was: *)
(* Version of 19 Sep 2020 *)

(* ********** *)

Require Import Arith Bool.

(* ********** *)

Lemma about_decomposing_a_pair_using_the_injection_tactic :
  forall i j : nat,
    (i, j) = (0, 1) ->
    i = 0 /\ j = 1.
Proof.
  intros i j H_ij.
  injection H_ij.

  Restart.

  intros i j H_ij.
  injection H_ij as H_i H_j.
  exact (conj H_i H_j).
Qed.

Lemma about_decomposing_a_pair_using_the_injection_tactic' :
  forall i j : nat,
    (i, 1) = (0, j) ->
    i = 0 /\ j = 1.
Proof.
  intros i j H_ij.
  injection H_ij as H_i H_j.
  symmetry in H_j.
  exact (conj H_i H_j).
Qed.

Lemma about_decomposing_a_pair_of_pairs_using_the_injection_tactic :
  forall a b c d: nat,
    ((a, 1), (2, d)) = ((0, b), (c, 3)) ->
    a = 0 /\ b = 1 /\ c = 2 /\ d = 3.
Proof.
  intros a b c d H_abcd.
  injection H_abcd as H_a H_b H_c H_d.
  symmetry in H_b.
  symmetry in H_c.
  exact (conj H_a (conj H_b (conj H_c H_d))).
Qed.

(* ********** *)

Lemma truism :
  forall P : nat -> Prop,
    (exists n : nat,
        P n) ->
    exists n : nat,
      P n.
Proof.
  intros P H_P.
  exact H_P.

  Restart.

  intros P H_P.
  destruct H_P as [n H_Pn].
  exists n.
  exact H_Pn.

  Restart.

  intros P [n H_Pn].
  exists n.
  exact H_Pn.
Qed.

(* ***** *)

Lemma other_truism :
  forall P Q : nat -> Prop,
    (exists n : nat,
        P n /\ Q n) ->
    exists m : nat,
      P m \/ Q m.
Proof.
  intros P Q [n [H_Pn H_Qn]].
  exists n.
  left.
  exact H_Pn.

  Restart.

  intros P Q [n [H_Pn H_Qn]].
  exists n.
  right.
  exact H_Qn.
Qed.

(* ********** *)

Lemma about_the_existential_quantifier_and_disjunction :
  forall P Q : nat -> Prop,
    (exists n : nat, P n \/ Q n)
    <->
    ((exists n : nat, P n)
     \/
     (exists n : nat, Q n)).
Proof.
  intros P Q.
  split.
  - intros [n [H_P | H_Q]].
    + left.
      exists n.
      exact H_P.
    + right.
      exists n.
      exact H_Q.
  - intros [[n H_P] | [n H_Q]].
    + exists n.
      left.
      exact H_P.
    + exists n.
      right.
      exact H_Q.
Qed.

(* ********** *)

Lemma about_the_universal_quantifier_and_conjunction :
  forall P Q : nat -> Prop,
    (forall n : nat, P n /\ Q n)
    <->
    ((forall n : nat, P n)
     /\
     (forall n : nat, Q n)).
Proof.
  intros P Q.
  split.
  - intro H_PQ.
    split.
    + intro n.
      destruct (H_PQ n) as [H_Pn _].
      exact H_Pn.
    + intro n.
      destruct (H_PQ n) as [_ H_Qn].
      exact H_Qn.
  - intros [H_P H_Q] n.
    exact (conj (H_P n) (H_Q n)).
Qed.

(* ********** *)

Definition specification_of_addition (add : nat -> nat -> nat) :=
  (forall m : nat,
      add O m = m)
  /\
  (forall n' m : nat,
      add (S n') m = S (add n' m)).

Definition specification_of_addition' (add : nat -> nat -> nat) :=
  forall n' m : nat,
    add O m = m
    /\
    add (S n') m = S (add n' m).

Lemma about_two_universal_quantifiers_and_conjunction :
  forall (P : nat -> Prop)
         (Q : nat -> nat -> Prop),
    ((forall j : nat, P j)
     /\
     (forall i j : nat, Q i j))
    <->
    (forall i j : nat, P j /\ Q i j).
Proof.
  intros P Q.
  split.
  - intros [H_P H_Q] i j.
    split.
    + exact (H_P j).
    + exact (H_Q i j).
  - intro H_PQ.
    split.
    + intro j.
      destruct (H_PQ 0 j) as [H_Pj _].
      exact H_Pj.
    + intros i j.
      destruct (H_PQ i j) as [_ H_Qij].
      exact H_Qij.
Qed.

Proposition the_two_specifications_of_addition_are_equivalent :
  forall add : nat -> nat -> nat,
    specification_of_addition add <-> specification_of_addition' add.
Proof.
  intro add.
  unfold specification_of_addition, specification_of_addition'.
  Check (about_two_universal_quantifiers_and_conjunction
           (fun m : nat => add 0 m = m)
           (fun n' m : nat => add (S n') m = S (add n' m))).
  exact (about_two_universal_quantifiers_and_conjunction
           (fun m : nat => add 0 m = m)
           (fun n' m : nat => add (S n') m = S (add n' m))).
Qed.

(* ********** *)

Lemma even_or_odd_dropped :
  forall n : nat,
    (exists q : nat,
        n = 2 * q)
    \/
    (exists q : nat,
        n = S (2 * q)).
Proof.
Admitted.

Lemma even_or_odd_lifted :
  forall n : nat,
  exists q : nat,
    n = 2 * q
    \/
    n = S (2 * q).
Proof.
Admitted.

Proposition the_two_specifications_of_even_or_odd_are_equivalent :
  forall n : nat,
    (exists q : nat,
        n = 2 * q
        \/
        n = S (2 * q))
    <->
    ((exists q : nat,
         n = 2 * q)
     \/
     (exists q : nat,
         n = S (2 * q))).
Proof.
  intro n.
  Check (about_the_existential_quantifier_and_disjunction
           (fun q : nat => n = 2 * q)
           (fun q : nat => n = S (2 * q))).
  exact (about_the_existential_quantifier_and_disjunction
           (fun q : nat => n = 2 * q)
           (fun q : nat => n = S (2 * q))).
Qed.

(* ********** *)

Lemma O_or_S :
  forall n : nat,
    n = 0 \/ (exists n' : nat,
                 n = S n').
Proof.
  intro n.
  destruct n as [ | n'] eqn:H_n.

  - left.
    reflexivity.

  - right.
    exists n'.
    reflexivity.
Qed.

(* ********** *)

Proposition now_what :
  (forall n : nat, n = S n) <-> 0 = 1.
Proof.
  split.

  - intro H_n_Sn.
    Check (H_n_Sn 0).
    exact (H_n_Sn 0).

  - intro H_absurd.
    discriminate H_absurd.

  Restart.

  split.

  - intro H_n_Sn.
    Check (H_n_Sn 42).
    discriminate (H_n_Sn 42).

  - intro H_absurd.
    discriminate H_absurd.
Qed.

Proposition what_now :
  forall n : nat,
    n = S n <-> 0 = 1.
Proof.
  intro n.
  split.

  - intro H_n.
    Search (_ <> S _).
    Check (n_Sn n).
    assert (H_tmp := n_Sn n).
    unfold not in H_tmp.
    Check (H_tmp H_n).
    contradiction (H_tmp H_n).

  - intro H_absurd.
    discriminate H_absurd.
Qed.

(* ********** *)

Proposition factoring_and_distributing_a_forall_in_a_conclusion :
  forall (P : nat -> Prop)
         (Q : Prop),
    (Q -> forall n : nat, P n)
    <->
    (forall n : nat,
        Q -> P n).
Proof.
  intros P Q.
  split.
  - intros H_QP n H_Q.
    exact (H_QP H_Q n).
  - intros H_QP H_Q n.
    exact (H_QP n H_Q).
Qed.

(* ********** *)

Proposition interplay_between_quantifiers_and_implication :
  forall (P : nat -> Prop)
         (Q : Prop),
    (exists n : nat, P n -> Q) ->
    (forall n : nat, P n) -> Q.
Proof.
  intros P Q [n H_PnQ] H_P.
  Check (H_PnQ (H_P n)).
  exact (H_PnQ (H_P n)).
Qed.

(* ********** *)

Proposition interplay_between_implication_and_quantifiers :
  forall (P : nat -> Prop)
         (Q : Prop),
    ((exists n : nat, P n) -> Q) ->
    forall n : nat, P n -> Q.
Proof.
  intros P Q H_PQ n H_Pn.
  apply H_PQ.
  exists n.
  exact H_Pn.
Qed.

(* ********** *)

Proposition strengthening_X_in_the_conclusion :
  forall A B C D X Y : Prop,
    (A -> X) -> (B -> Y) -> (X -> C) -> (Y -> D) -> (X -> Y) -> A -> Y.
Proof.
  intros A B C D X Y H_AX H_BY H_XC H_YD H_XY.
Abort.

Proposition weakening_X_in_the_conclusion :
  forall A B C D X Y : Prop,
    (A -> X) -> (B -> Y) -> (X -> C) -> (Y -> D) -> (X -> Y) -> C -> Y.
Proof.
  intros A B C D X Y H_AX H_BY H_XC H_YD H_XY.
Abort.

Proposition strengthening_Y_in_the_conclusion :
  forall A B C D X Y : Prop,
    (A -> X) -> (B -> Y) -> (X -> C) -> (Y -> D) -> (X -> Y) -> X -> B.
Proof.
  intros A B C D X Y H_AX H_BY H_XC H_YD H_XY.
Abort.

Proposition weakening_Y_in_the_conclusion :
  forall A B C D X Y : Prop,
    (A -> X) -> (B -> Y) -> (X -> C) -> (Y -> D) -> (X -> Y) -> X -> D.
Proof.
  intros A B C D X Y H_AX H_BY H_XC H_YD H_XY.
Abort.

Proposition strengthening_X_in_a_premise :
  forall A B C D X Y : Prop,
    (A -> X) -> (B -> Y) -> (X -> C) -> (Y -> D) -> (A -> Y) -> X -> Y.
Proof.
  intros A B C D X Y H_AX H_BY H_XC H_YD.
Abort.

Proposition weakening_X_in_a_premise :
  forall A B C D X Y : Prop,
    (A -> X) -> (B -> Y) -> (X -> C) -> (Y -> D) -> (C -> Y) -> X -> Y.
Proof.
  intros A B C D X Y H_AX H_BY H_XC H_YD.
Abort.

Proposition strengthening_Y_in_a_premise :
  forall A B C D X Y : Prop,
    (A -> X) -> (B -> Y) -> (X -> C) -> (Y -> D) -> (X -> B) -> X -> Y.
Proof.
  intros A B C D X Y H_AX H_BY H_XC H_YD.
Abort.

Proposition weakening_Y_in_a_premise :
  forall A B C D X Y : Prop,
    (A -> X) -> (B -> Y) -> (X -> C) -> (Y -> D) -> (X -> D) -> X -> Y.
Proof.
  intros A B C D X Y H_AX H_BY H_XC H_YD.
Abort.

(* ********** *)

(* end of week-06_miscellany.v *)


Require Import Bool Psatz Arith.PeanoNat.
Require Import FunInd.
Require Import vsequent.

Function measure_p (p : prop) : nat :=
  match p with
  | p_sym _ => O
  | p_neg p0 => S (measure_p p0)
  | p_and p0 p1
  | p_or p0 p1
  | p_impl p0 p1 => S (measure_p p0 + measure_p p1)
  end.

Function measure_l (s : seq_l) : nat :=
  match s with
  | seq_l_nil => O
  | seq_l_cons p s0 => measure_p p + measure_l s0
  end.

Function measure_r (s : seq_r) : nat :=
  match s with
  | seq_r_nil => O
  | seq_r_cons p s0 => measure_p p + measure_r s0
  end.

Function measure (s : seq_t) : nat :=
  match s with
  | seq l r => measure_l l + measure_r r
  end.

Lemma measure_break : forall l r n,
  measure (seq l r) = n -> exists n0 n1,
  measure_l l = n0 /\ measure_r r = n1 /\ n = n0 + n1.
Proof.
  intros l r n.
  unfold measure. destruct (measure_l l); destruct (measure_r r).
  - intros H. exists O. exists O. auto.
  - intros H. exists O. exists (S n0). auto.
  - intros H. exists (S n0). exists O. auto.
  - intros H. exists (S n0). exists (S n1). auto.
Qed.

Lemma eval_unary_decreases : forall s0 s1 n0 n1,
  eval_unary s0 s1 -> measure s0 = n0 ->
  measure s1 = n1 -> n1 < n0.
Proof.
  intros s0 s1 n0 n1 Heval. induction Heval.
  - unfold measure. rewrite measure_l_equation.
    rewrite (measure_r_equation (seq_r_cons p r)).
    intros Heq0 Heq1. subst. simpl. lia.
  - unfold measure. rewrite measure_r_equation.
    rewrite (measure_l_equation (seq_l_cons p l)).
    intros Heq0 Heq1. subst. simpl. lia.
  - unfold measure. rewrite measure_r_equation.
    rewrite (measure_r_equation (seq_r_cons p0 (seq_r_cons p1 r))).
    rewrite (measure_r_equation (seq_r_cons p1 r)).
    intros Heq0 Heq1. subst. simpl. lia.
    - unfold measure. rewrite measure_r_equation.
    rewrite (measure_l_equation (seq_l_cons p0 l)).
    rewrite (measure_r_equation (seq_r_cons p1 r)).
    intros Heq0 Heq1. subst. simpl. lia.
Qed.

Lemma eval_binary_decreases : forall s0 s1 s2 n0 n1 n2,
  eval_binary s0 s1 s2 -> measure s0 = n0 ->
  measure s1 = n1 -> measure s2 = n2 -> n1 < n0 /\ n2 < n0.
Proof.
  intros s0 s1 s2 n0 n1 n2 Heval. induction Heval.
  - unfold measure. rewrite measure_l_equation.
    rewrite (measure_l_equation (seq_l_cons p0 l)).
    rewrite (measure_l_equation (seq_l_cons p1 l)).
    intros Heq0 Heq1 Heq2. subst. simpl. lia.
Qed.

Definition normal_form_unary (s : seq_t) : Prop :=
  ~ exists s', eval_unary s s'.

Definition normal_form_binary (s : seq_t) : Prop :=
  ~ exists s' s'', eval_binary s s' s''.

Definition normal_form (s : seq_t) : Prop :=
  normal_form_unary s /\ normal_form_binary s.

Lemma prop_zero_measure : forall p,
  measure_p p = O -> exists n, p = p_sym n.
Proof.
  intros p Hm. rewrite measure_p_equation in Hm. induction p.
  - exists n. reflexivity.
  - discriminate.
  - discriminate.
  - discriminate.
  - discriminate.
Qed.

Lemma seq_l_zero_measure : forall p l,
  measure_l (seq_l_cons p l) = O -> exists n, p = p_sym n.
Proof.
  intros p l. rewrite measure_l_equation. induction l.
  - unfold measure_l. rewrite Plus.plus_0_r.
    apply prop_zero_measure.
  - rewrite measure_l_equation.
    rewrite (Plus.plus_comm (measure_p p0) (measure_l l)).
    rewrite (Plus.plus_assoc). intros Hm.
    apply (Plus.plus_is_O (measure_p p + measure_l l) (measure_p p0)) in Hm as [ Hm Hp ].
    apply IHl in Hm. assumption.
Qed.

Lemma seq_r_zero_measure : forall p r,
  measure_r (seq_r_cons p r) = O -> exists n, p = p_sym n.
Proof.
  intros p r. rewrite measure_r_equation. induction r.
  - unfold measure_r. rewrite Plus.plus_0_r.
    apply prop_zero_measure.
  - rewrite measure_r_equation.
    rewrite (Plus.plus_comm (measure_p p0) (measure_r r)).
    rewrite (Plus.plus_assoc). intros Hm.
    apply (Plus.plus_is_O (measure_p p + measure_r r) (measure_p p0)) in Hm as [ Hm Hp ].
    apply IHr in Hm. assumption.
Qed.

Lemma plus_to_O : forall n0 n1,
  n0 = O -> n1 = O -> n0 + n1 = O.
Proof.
  lia.
Qed.

Lemma measure_zero_iff_normal_form : forall s,
  measure s = O -> normal_form s.
Proof.
  intros s.
  unfold measure. destruct s as [ l r ]. induction l; induction r; intros Heq.
  - split.
    + unfold normal_form_unary, not. intros [ s Hex ]. inversion Hex.
    + unfold normal_form_binary, not. intros [ s [ s' Hex ] ]. inversion Hex.
  - split.
    + unfold normal_form_unary, not. intros [s Hex].
      apply Plus.plus_is_O in Heq as [ Hnil Hr ].
      rewrite measure_r_equation in Hr.
      apply Plus.plus_is_O in Hr as [ Hp Hr ].
      apply (plus_to_O (measure_l seq_l_nil)) in Hr.
      apply IHr in Hr.
      clear IHr Hnil.
      revert Hr.
      intros [ H _ ]. unfold normal_form_unary, not in H. apply H. clear H.
      apply prop_zero_measure in Hp as [ n Hp ]. subst. exists s.


Require Export XR_Rlt_trans.
Require Export XR_Rplus_lt_compat_r.
Require Export XR_Rplus_lt_compat_l.

Local Open Scope R_scope.

Lemma Rplus_lt_compat : forall r1 r2 r3 r4,
  r1 < r2 ->
  r3 < r4 ->
  r1 + r3 < r2 + r4.
Proof.
  intros u v w x.
  intros huv hwx.
  apply Rlt_trans with (u+x).
  {
    apply Rplus_lt_compat_l.
    exact hwx.
  }
  {
    apply Rplus_lt_compat_r.
    exact huv.
  }
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Permutation Relations Bool Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_nat.

Set Implicit Arguments.

(* Every class of X/~ is enumerated ie there is a surjective partial map
    from nat to representatives of class *)

Definition nat_enum_cls X (R : X -> X -> Prop) :=
  { f : nat -> option X | forall x, exists y n, f n = Some y /\ R y x }.

Notation dec := ((fun X Y (R : X -> Y -> Prop) => forall x y, { R x y } + { R x y -> False }) _ _).

(* A class function and its inverse, a function that computes representatives
    with two equations characterizing the quotient *)

Definition quotient X (R : X -> X -> Prop) Y :=
  { cls : X -> Y &
  { rpr : Y -> X |
         (forall y, cls (rpr y) = y)
      /\ (forall x1 x2, R x1 x2 <-> cls x1 = cls x2) } }.

Section ep_quotient.

  Variable (X : Type) (R : X -> X -> Prop) (f : nat -> option X)
           (Hf : forall x, exists y n, f n = Some y /\ R y x).

  Hypothesis HR1 : equiv _ R.
  Hypothesis HR2 : dec R.

  Let T n m :=
    match f n, f m with
      | Some x, Some y => R x y
      | None  , None   => True
      | _     , _      => False
    end.

  Let HT1 : equiv _ T.
  Proof.
    msplit 2.
    + intros x; red; destruct (f x); auto; apply (proj1 HR1).
    + intros x y z; unfold T.
      destruct (f x); destruct (f y); destruct (f z); try tauto; apply HR1.
    + intros x y; unfold T.
      destruct (f x); destruct (f y); try tauto; apply HR1.
  Qed.

  Infix "≈" := T (at level 70, no associativity).

  Let is_repr x n :=
    match f n with
      | Some r => R r x
      | None   => False
    end.

  Let is_repr_trans x1 x2 n : R x1 x2 -> is_repr x1 n -> is_repr x2 n.
  Proof.
    intros H1 H2; revert H2 H1.
    unfold is_repr; destruct (f n); auto.
    apply HR1.
  Qed.

  Let is_repr_dec : dec is_repr.
  Proof.
    intros x n.
    unfold is_repr.
    destruct (f n).
    + apply HR2.
    + tauto.
  Qed.

  Let is_repr_exists x : ex (is_repr x).
  Proof.
    destruct (Hf x) as (y & n & H1 & H2).
    exists n; red; rewrite H1; auto.
  Qed.

  Let is_min_repr x n :=
    is_repr x n /\ forall m, is_repr x m -> n <= m.

  Let is_min_repr_inj x n1 n2 : is_min_repr x n1 -> is_min_repr x n2 -> n1 = n2.
  Proof.
    intros (H1 & H2) (H3 & H4).
    apply Nat.le_antisymm; auto.
  Qed.

  Let is_min_repr_involutive x n : is_min_repr x n ->
     match f n with
       | Some y => is_min_repr y n
       | None   => False
     end.
  Proof.
    intros (H1 & H2); unfold is_min_repr, is_repr in *.
    destruct (f n) as [ y | ]; try tauto.
    split.
    + apply (proj1 HR1).
    + intros m; specialize (H2 m).
      destruct (f m) as [ k | ]; try tauto.
      intros H3; apply H2, (proj1 (proj2 HR1)) with (1 := H3); auto.
  Qed.

  Let find_min_repr x : sig (is_min_repr x).
  Proof.
    destruct min_dec with (P := is_repr x)
      as (r & H1 & H2).
    + intro; apply is_repr_dec.
    + apply is_repr_exists.
    + exists r; split; auto.
  Qed.

  Let is_min_repr_dec : dec is_min_repr.
  Proof.
    unfold is_min_repr, is_repr.
    intros x n.
    destruct (f n) as [ y | ].
    2: right; tauto.
    destruct (HR2 y x) as [ H1 | H1 ].
    2: right; tauto.
    destruct bounded_search with (m := n) (P := fun m => match f m with Some r => R r x | None => False end)
      as [ (p & H2 & H3) | H ].
    + intros m _; destruct (is_repr_dec x m); auto.
    + case_eq (f p).
      * intros r Hr.
        right; intros (G1 & G2).
        specialize (G2 p).
        rewrite Hr in G2, H3.
        specialize (G2 H3); lia.
      * intros Hr; rewrite Hr in H3; tauto.
    + left; split; auto.
      intros m Hm.
      destruct (le_lt_dec n m) as [ | C ]; auto.
      exfalso; specialize (H _ C).
      destruct (f m) as [ z | ]; tauto.
  Qed.

  Let P n :=
    match f n with
      | Some x => if is_min_repr_dec x n then true else false
      | None   => false
    end.

  Let P_spec n : P n = true <-> exists x, f n = Some x /\ is_min_repr x n.
  Proof.
    unfold P.
    destruct (f n) as [ x | ].
    + destruct (is_min_repr_dec x n) as [ | C ]; split; try tauto.
      * exists x; auto.
      * discriminate.
      * intros (y & Hy & ?).
        destruct C; inversion Hy; auto.
    + split; try discriminate.
      intros (? & ? & _); discriminate.
  Qed.

  Let Y := sig (fun x => P x = true).

  Let pi1_inj : forall x y : Y, proj1_sig x = proj1_sig y -> x = y.
  Proof.
    intros (x & H1) (y & H2); simpl; intros; subst; f_equal.
    apply UIP_dec, bool_dec.
  Qed.

  Let Y_discrete : dec (@eq Y).
  Proof.
    intros (x & Hx) (y & Hy).
    destruct (eq_nat_dec x y) as [ | H ].
    + left; apply pi1_inj; simpl; auto.
    + right; contradict H; inversion H; auto.
  Qed.

  Let is_min_repr_P n x : is_min_repr x n -> P n = true.
  Proof.
    intros H1.
    apply P_spec; revert H1.
    unfold is_min_repr, is_repr.
    case_eq (f n).
    + intros y Hy (H1 & H2).
      exists y; msplit 2; auto.
      * apply (proj1 HR1).
      * intros m; specialize (H2 m).
        destruct (f m) as [ z | ]; auto.
        intros H; apply H2, (proj1 (proj2 HR1) _ y); auto.
    + intros _ ([] & _).
  Qed.

  Let cls (x : X) : Y.
  Proof.
    destruct (find_min_repr x) as (n & Hn).
    exists n; apply is_min_repr_P with x; auto.
  Defined.

  Let P_to_X n : P n = true -> { k | f n = Some k }.
  Proof.
    intros H; rewrite P_spec in H.
    case_eq (f n).
    + intros k _; exists k; auto.
    + intros Hn; exfalso; revert Hn.
      destruct H as (x & -> & _); discriminate.
  Qed.

  Let rpr (y : Y) := proj1_sig (P_to_X _ (proj2_sig y)).

  Let Hrpr y : f (proj1_sig y) = Some (rpr y).
  Proof. apply (proj2_sig (P_to_X _ (proj2_sig y))). Qed.

  Let Hcr : forall y, cls (rpr y) = y.
  Proof.
    intros (n & Hn); simpl.
    unfold rpr; simpl.
    apply pi1_inj; simpl; unfold cls.
    case (find_min_repr (proj1_sig (P_to_X n Hn))).
    intros m Hm; simpl.
    generalize Hn; rewrite P_spec; intros (y & G1 & G2).
    destruct (P_to_X n Hn) as (z & Hz); simpl in Hm.
    rewrite Hz in G1; inversion G1; subst z.
    revert Hm G2; apply is_min_repr_inj.
  Qed.

  Let Hrc x1 x2 : R x1 x2 <-> cls x1 = cls x2.
  Proof.
    split.
    + intros H; apply pi1_inj.
      unfold cls.
      case (find_min_repr x1); intros y1 (G1 & G2); simpl.
      case (find_min_repr x2); intros y2 (G3 & G4); simpl.
      apply Nat.le_antisymm.
      * apply G2; revert G3.
        apply is_repr_trans, (proj2 (proj2 HR1)); auto.
      * apply G4; revert G1.
        apply is_repr_trans; auto.
    + unfold cls.
      case (find_min_repr x1); intros y1 G1; simpl.
      case (find_min_repr x2); intros y2 G2; simpl.
      intros H; inversion H; subst y2; clear H.
      apply proj1 in G1; apply proj1 in G2.
      revert G1 G2; unfold is_repr.
      destruct (f y1); try tauto; intros H.
      apply HR1; revert H; apply HR1.
  Qed.

  Local Fact enum_quotient_rec :
        { Y : Type & { _ : dec (@eq Y) & quotient R Y } }.
  Proof using HR1 HR2 Hf.
    exists Y, Y_discrete, cls, rpr; split; auto.
  Qed.

End ep_quotient.

(* Given type X with a decidable equivalence ~ over X
    such that the classes of X/~ can be enumerated then
    one can build the quotient X/~ into a discrete type Y
    and Y is necessarily enumerated, see below
*)

Theorem enum_quotient X R :
          nat_enum_cls R
       -> equiv X R
       -> dec R
       -> { Y : Type & { _ : dec (@eq Y) & quotient R Y } }.
Proof.
  intros (f & Hf) H1 H2.
  apply enum_quotient_rec with (1 := Hf) (R := R); auto.
Qed.

(* A quotient of enumerated classes is automatically enumerated (for equality *)

Fact quotient_is_enum X R Y : nat_enum_cls R -> @quotient X R Y -> nat_enum_cls (@eq Y).
Proof.
  intros (f & Hf) (c & r & H1 & H2).
  exists (fun n => match f n with Some x => Some (c x) | None => None end).
  intros y.
  destruct (Hf (r y)) as (z & n & H3 & H4).
  exists (c z), n; rewrite H3; split; auto.
  rewrite <- (H1 y); apply H2; auto.
Qed.

(*
Print nat_enum_cls.
Print quotient.

Check enum_quotient.
Check quotient_is_enum.
*)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf3 : natural) (z : natural) : natural := plus lf3 z.


(**
総和（Σ）の補題 整数版

2020_8_22 @suharahiromichi 自然数
2022_6_12 @suharahiromichi 整数
 *)
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.
From common Require Import ssromega. (* ssromega *)

Import GRing.Theory.         (* mulrA などを使えるようにする。 *)
Import Num.Theory.           (* unitf_gt0 などを使えるようにする。 *)
Import intZmod.              (* addz など *)
Import intRing.              (* mulz など *)
Open Scope ring_scope.       (* 環の四則演算を使えるようにする。 *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Summation1.
(**
## 総和の結合と分配

高校で習う、総和についての公式です。

総和の範囲は、$m \lt n$ としてmからnとします。
$m \ge n$ の場合は、Σの中身が単位元となり成立しません。

```math

\sum_{i=m}^{n-1}a_i + \sum_{i=m}^{n-1}b_i = \sum_{i=m}^{n-1}(a_i + b_i) \\

\sum_{i=m}^{n-1}c a_i = c \sum_{i=m}^{n-1}a_i \\

\sum_{i=m}^{n-1}(a_i c) = (\sum_{i=m}^{n-1}a_i) c \\

\sum_{i=m}^{n-1} c = (n - m) c \\

```
*)
  Lemma sum_split (m n : nat) (a b : nat -> int) :
    (m < n)%N ->
    \sum_(m <= i < n)(a i) + \sum_(m <= i < n)(b i) = \sum_(m <= i < n)(a i + b i).
  Proof. by rewrite big_split. Qed.

  Lemma sum_distrr (m n : nat) (c : int) (a : nat -> int) :
    (m < n)%N ->
    \sum_(m <= i < n)(c * (a i)) = c * (\sum_(m <= i < n)(a i)).
  Proof. by rewrite big_distrr. Qed.

  Lemma sum_distrl (m n : nat) (a : nat -> int) (c : nat) :
    (m < n)%N ->
    \sum_(m <= i < n)((a i) * c) = (\sum_(m <= i < n)(a i)) * c.
  Proof. by rewrite big_distrl. Qed.

  Lemma sum_nat_const_int (m n : nat) (c : int) :
    (m < n)%N ->
    \sum_(m <= i < n) c = (n - m)%:Z * c.
  Proof.
    move=> H.
    rewrite big_const_nat.
    rewrite iter_addr_0.
    rewrite mulrC.
    rewrite -mulr_natr natz.
    done.
  Qed.

(**
# Σの中身の書き換え

Σの中の i は、ローカルに束縛されている（ラムダ変数である）ので、
直接書き換えることはできません。一旦、取り出して書き換えることになります。
 *)
  Lemma eq_sum (m n : nat) (a b : nat -> int) : a =1 b ->
                         \sum_(m <= i < n)(a i) = \sum_(m <= j < n)(b j).
  Proof.
    move=> Hab.                             (* =1 は第1階の=です。 *)
    apply: eq_big_nat => i Hmn.
      by rewrite Hab.
  Qed.

(**
# 入れ子（ネスト）
 *)
(**
## ネストの入れ替え（総和どうしの場合）

$$ \sum_{i=0}^{m-1}(\sum_{j=0}^{n-1)} a_{i j} =
   \sum_{j=0}^{n-1}(\sum_{i=0}^{m-1)} a_{i j} $$
*)
  Lemma exchamge_sum (m n : nat) (a : nat -> nat -> int) :
    \sum_(0 <= i < m) (\sum_(0 <= j < n) (a i j)) =
    \sum_(0 <= j < n) (\sum_(0 <= i < m) (a i j)).
  Proof. by rewrite exchange_big. Qed.

(**
# Σを消す
 *)
(**
## 0を取り出す。

$$ \sum_{i \in \emptyset}a_i = 0 $$

総和をとる範囲が無い場合（0以上0未満）は、単位元``0``になります。
 *)
  Lemma sum_nil' (a : nat -> int) : \sum_(0 <= i < 0)(a i) = 0.
  Proof.
    by rewrite big_nil.
  Qed.

(**
上記の補題は、1以上1未満などの場合にも適用できてしまいますが、任意のmとnで証明しておきます。
*)
  Lemma sum_nil (m n : nat) (a : nat -> int) :
    (n <= m)%N -> \sum_(m <= i < n)(a i) = 0.
  Proof.
    move=> Hmn.
    have H : \sum_(m <= i < n)(a i) = \sum_(i <- [::])(a i).
    - apply: congr_big => //=.
      rewrite /index_iota.
      have -> : (n - m = 0)%N by ssromega. (* apply/eqP; rewrite subn_eq0. *)
      done.
    - rewrite H.
      by rewrite big_nil.
  Qed.

(**
## ``a_n``項を取り出す。

$$ \sum_{i=n}^{n}a_i = a_n $$

総和をとる範囲がひとつの項の場合（n以上n以下）は、``a n`` となります。
 *)
  Lemma sum_nat1 (n : nat) (a : nat -> int) :
    \sum_(n <= i < n.+1)(a i) = a n.
  Proof. by rewrite big_nat1. Qed.

(**
# インデックスを調整する補題
*)
(**
## 総和の範囲を0起源に振りなおす。

項のインデックスを調整して（ずらして）、mからn+mまでの総和の範囲を0からnまでにします。

$$ \sum_{i=m}^{n+m-1}a_i = \sum_{i=0}^{n-1}a_{i+m} $$
 *)
  Lemma sum_addn (m n : nat) (a : nat -> int) :
    \sum_(m <= i < n + m)(a i) = \sum_(0 <= i < n)(a (i + m)%N).
  Proof.
    rewrite -{1}[m]add0n.
    rewrite big_addn.
    have -> : (n + m - m = n)%N by ssromega.
    done.
  Qed.

(**
これは、任意のmで成り立ちますが、``Σ``の中の項のインデックスの``i.+1``を
``i + 1`` に書き換えられないため、``i.+1`` と ``i.+2`` の場合については、
個別に用意する必要があります。実際はこちらの方を使います。
*)
  Lemma sum_add1 (n : nat) (a : nat -> int) :
    \sum_(1 <= i < n.+1)(a i) = \sum_(0 <= i < n)(a i.+1).
  Proof. by rewrite big_add1 succnK. Qed.

  Lemma sum_add2 (n : nat) (a : nat -> int) :
    \sum_(2 <= i < n.+2)(a i) = \sum_(0 <= i < n)(a i.+2).
  Proof. by rewrite 2!big_add1 2!succnK. Qed.

(**
# 最初の項、または、最後の項をΣの外に出す。
 *)
(**
## 最初の項をΣの外に出す。

$$ \sum_{i=m}^{n-1}a_i = a_m + \sum_{i=m+1}^{n-1}a_i $$
 *)
  Lemma sum_first (m n : nat) (a : nat -> int) :
    (m < n)%N ->
    \sum_(m <= i < n)(a i) = a m + \sum_(m.+1 <= i < n)(a i).
  Proof.
    move=> Hn.
    by rewrite big_ltn.
  Qed.

(**
総和の範囲の起点を変えずに、インデックスをずらす補題もあります。

$$ \sum_{i=m}^{n}a_i = a_m + \sum_{i=m}^{n-1}a_{i + 1} $$
*)
  Lemma sum_first' (m n : nat) (a : nat -> int) :
    (m <= n)%N ->
    \sum_(m <= i < n.+1)(a i) = a m + \sum_(m <= i < n)(a i.+1).
  Proof.
    move=> Hn.
    by rewrite big_nat_recl.
  Qed.

(**
## 最後の項をΣの外に出す。

n(インデックスの上限)についての帰納法と組み合わせて使います。

$$ \sum_{i=m}^{n}a_i = \sum_{i=m}^{n-1}a_i + a_n $$
 *)
  Lemma sum_last (m n : nat) (a : nat -> int) :
    (m <= n)%N ->
    \sum_(m <= i < n.+1)(a i) = \sum_(m <= i < n)(a i) + a n.
  Proof.
    move=> Hmn.
    by rewrite big_nat_recr.
  Qed.

(**
## 数列の分割と結合

$$ \sum_{i=m}^{p}a_i = \sum_{i=m}^{n}a_i + \sum_{i=n}^{p}a_i $$
 *)
  Lemma sum_cat' (m n1 n2 n : nat) (a : nat -> int) :
    \sum_(m <= i < m + n1 + n2) a i =
    \sum_(m <= i < m + n1) a i + \sum_(m + n1 <= i < m + n1 + n2) a i.
  Proof.
    rewrite -big_cat.
    f_equal.                       (* iインデックス部分を取り出す。 *)
    rewrite /index_iota.
    Check iota_add
      : forall m n1 n2 : nat, iota m (n1 + n2) = iota m n1 ++ iota (m + n1) n2.
    have -> : (m + n1 + n2 - m = n1 + n2)%N by ssromega.
    have -> : (m + n1 - m = n1)%N by ssromega.
    have -> : (m + n1 + n2 - (m + n1) = n2)%N by ssromega.
    rewrite -iota_add.
    done.
  Qed.

  (* big_cat_nat を使えば、直接証明できる。 *)
  Lemma sum_cat (m n p : nat) (a : nat -> int) :
    (m <= n)%N -> (n <= p)%N ->
    \sum_(m <= i < p) a i = \sum_(m <= i < n) a i + \sum_(n <= i < p) a i.
  Proof.
    move=> Hmn Hnp.
    by rewrite -big_cat_nat.

    Restart.
    move=> Hmn Hnp.                         (* omega が使う。 *)
    pose n1 := (n - m)%N.
    pose n2 := (p - n)%N.
    have -> : (p = m + n1 + n2)%N by rewrite /n1 /n2; ssromega.
    have -> : (n = m + n1)%N by rewrite /n1; ssromega.
    by apply: sum_cat'.
  Qed.

End Summation1.

(* END *)


Inductive Rotation : Type :=
| R0 : Rotation
| R120 : Rotation
| R240 : Rotation.

Definition RaR (r2 r1 : Rotation) : Rotation:=
  match r1 with
  |R0 =>
     (match r2 with
     |R0 => R0
     |R120 => R120
     |R240 => R240
      end)
  |R120 =>
     (match r2 with
     |R0 => R120
     |R120 => R240
     |R240 => R0
      end)
  |R240 =>
     (match r2 with
     |R0 => R240
     |R120 => R0
     |R240 => R120
      end)
  end.

Proposition R0_is_neutral_for_RaR_on_the_left:
  forall (r : Rotation),
    RaR R0 r = r.
Proof.
  intro r.
  induction r.
  unfold RaR.
  reflexivity.

  unfold RaR.
  reflexivity.

  unfold RaR.
  reflexivity.

  Restart.
  intro r.
  case r as [ | | ] eqn: H_r.

  unfold RaR; reflexivity.

  unfold RaR; reflexivity.

  unfold RaR; reflexivity.

  Restart.
  intro r; case r as [ | | ] eqn: H_r; unfold RaR; reflexivity.

  Restart.
  intros [ | | ]; unfold RaR; reflexivity.

  Restart.
  intros [ | | ]; reflexivity.
  (*
We can unfold without writing unfold lemmas because RaR is not recursive.
   *)
Qed.

Proposition R0_is_neutral_for_RaR_on_the_right:
  forall (r : Rotation),
    RaR R0 r = r.
Proof.
  intros [ | | ]; reflexivity.
Qed.

Proposition RaR_is_commutative:
  forall r1 r2: Rotation,
    RaR r2 r1 = RaR r1 r2.
Proof.
  intros r1 r2.
  case r1 as [ | | ] eqn: H_r1.
  case r2 as [ | | ] eqn: H_r2.
  reflexivity.

  unfold RaR.
  reflexivity.

  unfold RaR.
  reflexivity.

  unfold RaR.
  reflexivity.

  unfold RaR.
  reflexivity.

  Restart.
  intros [ | | ] [ | | ]; reflexivity.

Qed.

Proposition RaR_is_associative:
  forall r1 r2 r3: Rotation,
    RaR (RaR r3 r2) r1 = RaR r3 (RaR r2 r1).
Proof.
  intros [ | | ] [ | | ] [ | | ]; reflexivity.
Qed.

Proposition RaR_is_nilpotent_with_order_3:
  forall r : Rotation,
    RaR (RaR r r) r = R0.
Proof.
  intros [ | | ]; reflexivity.
Qed.

Inductive Reflection: Type :=
| S_N : Reflection
| S_SW : Reflection
| S_SE : Reflection.

Definition SaS (s2 s1: Reflection) :=
   match s1 with
  |S_N =>
     (match s2 with
     |S_N => R0
     |S_SW => R120
     |S_SE => R240
      end)
  |S_SW =>
     (match s2 with
     |S_N => R240
     |S_SW => R0
     |S_SE => R120
      end)
  |S_SE =>
     (match s2 with
     |S_N => R120
     |S_SW => R240
     |S_SE => R0
      end)
  end.

Proposition SaS_is_commutative:
  forall s1 s2 : Reflection,
  SaS s1 s2 = SaS s2 s1.
Proof.
  (*
  intros [ | | ] [ | | ]; reflexivity.
   *)
  intros s1 s2.
  case s1 as [ | | ] eqn: H_s1.
  case s2 as [ | | ] eqn: H_s2.

  reflexivity.
  unfold SaS.
Abort.

Proposition SaS_is_not_commutative:
  exists s1 s2 : Reflection,
    (SaS s1 s2 <> SaS s2 s1).
Proof.
  exists S_SW, S_SE.
  unfold SaS.
  intro H_absurd.
  discriminate.
Qed.
(*
Proposition SaS_is_associative:
  forall s1 s2 : Reflection,
  SaS (SaS s3 s2) s1 = SaS s3 (SaS s2 s1).
  Proof.
This is type incorrect, as the codomain of SaS is a Rotation, and not a Reflection.
 *)

Proposition SaS_is_nilpotent_with_order_2:
  forall s : Reflection,
    SaS s s = R0.
Proof.
  intros [ | | ]; reflexivity.
Qed.

Definition SaR (s : Reflection) (r : Rotation): Reflection :=
   match r with
  |R0 =>
     (match s with
     |S_N => S_N
     |S_SW => S_SW
     |S_SE => S_SE
      end)
  |R120 =>
     (match s with
     |S_N => S_SE
     |S_SW => S_N
     |S_SE => S_SW
      end)
  |R240 =>
     (match s with
     |S_N => S_SW
     |S_SW => S_SE
     |S_SE => S_N
      end)
  end.

Definition RaS (r : Rotation) (s : Reflection): Reflection :=
   match s with
  |S_N =>
     (match r with
     |R0 => S_N
     |R120 => S_SE
     |R240 => S_SW
      end)
  |S_SW =>
     (match r with
     |R0 => S_SW
     |R120 => S_N
     |R240 => S_SE
      end)
  |S_SE =>
     (match r with
     |R0 => S_SE
     |R120 => S_SW
     |R240 => S_N
      end)
  end.

Inductive Isomorphism : Type :=
| IR : Rotation -> Isomorphism
| IS : Reflection -> Isomorphism.

Definition Id : Isomorphism := IR R0.

Definition C (i2 i1 : Isomorphism) : Isomorphism :=
  match i1 with
  | IR r1 => match i2 with
             | IR r2 => IR (RaR r2 r1)
             | IS s2 => IS (SaR s2 r1)
             end
  | IS s1 => match i2 with
             | IR r2 => IS (RaS r2 s1)
             | IS s2 => IR (SaS s2 s1)
             end
  end.

Proposition Id_is_neutral_for_C_on_the_left :
  forall i : Isomorphism,
    C Id i = i.
Proof.
  intros [ [ | | ] | [ | | ] ].
  unfold C.
  unfold Id.
  unfold RaR.
  reflexivity.
  Restart.

  intro i.
  unfold Id.
  unfold C.
  case i as [r| s] eqn: H_i.

  case r as [ | | ] eqn: H_r.
  unfold RaR.
  reflexivity.
  unfold RaR.
  reflexivity.
  unfold RaR.
  reflexivity.
  unfold RaR.
  Restart.

  intros [ [ | | ] | [ | | ] ]; reflexivity.
Qed.

Proposition Id_is_neutral_for_C_on_the_right :
  forall i : Isomorphism,
    C i Id = i.
Proof.
   intros [ [ | | ] | [ | | ] ]; reflexivity.
Qed.

Proposition C_is_associative:
  forall i1 i2 i3 : Isomorphism,
    C (C i3 i2) i1 = C i3 (C i2 i1).
Proof.
  intros i1 i2 i3.
  case i1 as [ [ | | ] | [ | | ] ] eqn:H_1.
  case i2 as [ [ | | ] | [ | | ] ] eqn:H_2.
  case i3 as [ [ | | ] | [ | | ] ] eqn:H_3.

  unfold C, SaS, SaR, RaS, RaR; reflexivity.
  unfold C, SaS, SaR, RaS, RaR; reflexivity.
  unfold C, SaS, SaR, RaS, RaR; reflexivity.
  unfold C, SaS, SaR, RaS, RaR; reflexivity.

Abort.

(* injective on the right, injective on the left *)


Require Import Unicode.Utf8.

Inductive mynat : Set :=
| zero : mynat
| succ : mynat → mynat.

Definition one : mynat := succ zero.
Definition two : mynat := succ one.

Notation "0" := zero.
Notation "1" := one.
Notation "2" := two.

Theorem one_eq_succ_zero : 1 = succ 0.
Proof.
  reflexivity.
Qed.

Theorem two_eq_succ_one : 2 = succ 1.
Proof.
  reflexivity.
Qed.

(* `discriminate`: Prove structural inequality *)
(* Goal of the form `C1 = C2` where C1 and C2 are different constructors of the same injective type *)

Lemma zero_ne_succ (a : mynat) : (0 : mynat) ≠ succ a.
Proof.
  discriminate.
Qed.

(* `injection`: Remove the same constructor from both sides of an equality *)
(* Goal of the form `C a = C b` *)

Lemma succ_inj {a b : mynat} (h : succ a = succ b) : a = b.
Proof.
  injection h.
  intro f.
  exact f.
Qed.


From mathcomp Require Import all_ssreflect.
From GraphTheory Require Import preliminaries bij digraph.
From GraphTheory Require Import sgraph dom partition.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Clique Number, Stable Set Number and Chromatic Number *)

(** In this file, we define the graph parameters α,ω, and χ. As much
of the reasoning about these parameters is concerned with the values
for the parameters on induced subgraphs, we define the parameters as
functions of type [mem_pred G \to nat] and introduce a notation that
insertes the required [mem] cast. For [G : sgraph] and [A : {set G}],
we can therefore write both both χ(G) and χ(A). This (drastically)
reduces the amount of (induced) subgraphs that need to be constructed,
significantly simplifying the proofs. *)

(** ** Clique number *)

Section Cliques.
Variables (G : sgraph).
Implicit Types (H K : {set G}).

Definition cliques H := [set K : {set G} | (K \subset H) && cliqueb K].

Lemma cliques_gt0 A : 0 < #|cliques A|.
Proof.
apply/card_gt0P; exists set0; rewrite inE sub0set; apply/cliqueP.
by apply: small_clique; rewrite cards0.
Qed.

Lemma cliquesW (A B K : {set G}) : A \subset B -> K \in cliques A -> K \in cliques B.
Proof.
by move=> subAB; rewrite !inE => /andP[subKA ->]; rewrite (subset_trans subKA).
Qed.

Lemma cliques_subset (A K : {set G}) : K \in cliques A -> K \subset A.
Proof. by rewrite !inE => /andP[-> _]. Qed.

Lemma cliqueU1 x K : K \subset N(x) -> clique K -> clique (x |: K).
Proof.
move => /subsetP subKNx clK u v /setU1P[-> {u}|uK] /setU1P[-> {v}|vK].
- by rewrite eqxx.
- by move/subKNx : vK; rewrite inE.
- by move/subKNx : uK; rewrite inE sgP.
- exact: clK.
Qed.

Lemma sub_clique K K' : K' \subset K -> clique K -> clique K'.
Proof. by move=> /subsetP subK clK x y /subK xK /subK yK; exact: clK. Qed.

Lemma cliqueD K H : clique K -> clique (K :\: H).
Proof. by move => clK x y /setDP[xK _] /setDP[yK _]; exact: clK. Qed.

Lemma cliquesD K H S : K \in cliques (H :\: S) -> K \in cliques H.
Proof. by rewrite !inE subsetD -andbA => /and3P[-> _ ->]. Qed.

Definition omega_mem (A : mem_pred G) :=
  \max_(B in cliques [set x in A]) #|B|.

End Cliques.

Notation "ω( A )" := (omega_mem (mem A)) (format "ω( A )").

Definition maxcliques (G : sgraph) (H : {set G}) :=
  [set K in cliques H | ω(H) <= #|K|].

Section OmegaBasics.
Variables (G : sgraph).
Implicit Types (A B K H : {set G}).

Lemma maxclique_clique K H : K \in maxcliques H -> clique K.
Proof. by rewrite !inE -andbA => /and3P[_ /cliqueP ? _]. Qed.

Lemma maxcliquesW S H : S \in maxcliques H -> S \in cliques H.
Proof. by rewrite !inE -andbA => /and3P[-> -> _]. Qed.

Variant omega_spec A : nat -> Prop :=
  OmegaSpec K of K \in maxcliques A : omega_spec A #|K|.

Lemma omegaP A : omega_spec A ω(A).
Proof.
rewrite /omega_mem setE.
have [/= K clK maxK] := eq_bigmax_cond (fun A => #|A|) (cliques_gt0 A).
by rewrite maxK; apply: OmegaSpec; rewrite inE clK -maxK -{2}[A]setE leqnn.
Qed.

Lemma clique_bound K A : K \in cliques A -> #|K| <= ω(A).
Proof. by move => clK; apply: bigmax_sup (leqnn _); rewrite setE. Qed.

Lemma card_maxclique K H : K \in maxcliques H -> #|K| = ω(H).
Proof.
rewrite inE => /andP[clK ltK]; apply/eqP; rewrite eqn_leq ltK andbT.
exact: clique_bound.
Qed.

Lemma sub_omega A B : A \subset B -> ω(A) <= ω(B).
Proof.
move=> subAB; have [K] := omegaP A; rewrite inE => /andP[clA _].
exact/clique_bound/(cliquesW subAB).
Qed.

Lemma maxclique_disjoint K H A :
  K \in maxcliques H -> [disjoint K & A] -> K \in maxcliques (H :\: A).
Proof.
rewrite !inE -!andbA subsetD => /and3P[-> -> maxK] -> /=.
apply: leq_trans (sub_omega _) maxK. exact: subsetDl.
Qed.

Lemma maxclique_opn H K v :
  v \in H -> K \in maxcliques H -> K \subset N(v) -> v \in K.
Proof.
rewrite !inE -andbA => vH /and3P[subKH /cliqueP clK maxK] subNvK.
have/cliqueP clvK : clique (v |: K) by apply: cliqueU1.
apply: contraTT maxK => vNK ; rewrite -ltnNge.
rewrite -add1n -[1 + _]/(true + #|K|) -vNK -cardsU1; apply: clique_bound.
by rewrite !inE clvK subUset sub1set vH subKH.
Qed.

Lemma omega0 : ω(@set0 G) = 0.
Proof.
by case: omegaP => K; rewrite !inE subset0 -andbA => /andP[/eqP-> _]; rewrite cards0.
Qed.

Lemma omega_eq0 A : (ω(A) == 0) = (A == set0).
Proof.
apply/idP/idP => [|/eqP->]; last by rewrite omega0.
apply: contraTT => /set0Pn[x xH]; rewrite -lt0n -(cards1 x).
apply: clique_bound. rewrite inE sub1set xH. exact/cliqueP/clique1.
Qed.

(** TODO: if [stable S], the difference is exactly 1 *)
Lemma omega_cut H S :
  {in maxcliques H, forall K, S :&: K != set0} -> ω(H :\: S) < ω(H).
Proof.
move/forall_inP; rewrite ltnNge; apply: contraTN; rewrite negb_forall_in.
have [/= K maxK geH] := omegaP (H :\: S).
move: maxK; rewrite inE => /andP[clK cardK].
apply/exists_inP; exists K; first by rewrite inE geH (cliquesD clK).
by move: clK; rewrite !inE subsetD negbK setI_eq0 disjoint_sym -andbA => /and3P[_ -> _].
Qed.

End OmegaBasics.

(** ** Stable Set Number *)

Section StableSets.
Variable (G : sgraph).
Implicit Types (H A S : {set G}).

Definition stabsets H := [set S : {set G} | S \subset H & stable S].

(* mostly useful in the right to left region to reestablish [stabsets] *)
Lemma in_stabsets B H : B \in stabsets H = (B \subset H) && @stable G B.
Proof. by rewrite !inE. Qed.

Lemma stabsetsP H S : reflect (S \subset H /\ stable S) (S \in stabsets H).
Proof. by rewrite in_stabsets; exact: andP. Qed.

Lemma stabsets_gt0 A : 0 < #|stabsets A|.
Proof.
apply/card_gt0P; exists set0; rewrite inE sub0set; apply/stableP.
by move => u v; rewrite inE.
Qed.

Definition alpha_mem (A : mem_pred G) :=
  \max_(S in stabsets [set x in A]) #|S|.

Lemma stable_compl A : stable (A : {set compl G}) = cliqueb A.
Proof.
apply/stableP/cliqueP => [stabA|clA] x y xA yA; first move=> xDy.
  by move: (stabA _ _ xA yA); rewrite {1}/edge_rel/= xDy negbK.
have [<-|xDy] := eqVneq x y; by [rewrite sgP|rewrite /edge_rel/= xDy clA].
Qed.

(** alternative proof, using duality, likely not worth it *)
Lemma clique_compl A : cliqueb (A : {set compl G}) = stable A.
Proof.
apply/cliqueP/stableP => [clA|stabA] x y xA yA; last move=> xDy.
  have [<-|xDy] := eqVneq x y; first by rewrite sgP.
  by move:(clA _ _ xA yA xDy); rewrite {1}/edge_rel/= xDy.
by move: (stabA _ _ xA yA); rewrite {2}/edge_rel/= xDy.
Qed.

End StableSets.

Notation "α( A )" := (alpha_mem (mem A)) (format "α( A )").

Definition maxstabsets (G : sgraph) (H : {set G}) :=
  [set S in stabsets H | α(H) <= #|S|].

Section AlphaBasics.
Variables (G : sgraph).
Implicit Types (A B K S H : {set G}).

Variant alpha_spec A : nat -> Prop :=
  AlphaSpec S of S \in maxstabsets A : alpha_spec A #|S|.

Lemma maxstabset_stable S H : S \in maxstabsets H -> stable S.
Proof. by rewrite !inE -andbA => /and3P[_ -> _]. Qed.

Lemma maxstabsetW S H : S \in maxstabsets H -> S \in stabsets H.
Proof. by rewrite !inE -andbA => /and3P[-> -> _]. Qed.

Lemma maxstabsetS S H : S \in maxstabsets H -> S \subset H.
Proof. by rewrite !inE -andbA => /and3P[-> _ _]. Qed.

Lemma alphaP A : alpha_spec A α(A).
Proof.
rewrite /alpha_mem setE.
have [/= S stabS maxS] := eq_bigmax_cond (fun A => #|A|) (stabsets_gt0 A).
by rewrite maxS; apply: AlphaSpec; rewrite inE stabS -maxS -{2}[A]setE leqnn.
Qed.

Lemma stabset_bound S A : S \in stabsets A -> #|S| <= α(A).
Proof. by move => stabS; apply: bigmax_sup (leqnn _); rewrite setE. Qed.

Lemma card_maxstabset K H : K \in maxstabsets H -> #|K| = α(H).
Proof.
rewrite inE => /andP[stabS ltS]; apply/eqP; rewrite eqn_leq ltS andbT.
exact: stabset_bound.
Qed.

Lemma alpha0 : α(set0 : {set G}) = 0.
Proof.
by case: alphaP => S; rewrite !inE subset0 -!andbA => /and3P[/eqP ->]; rewrite cards0.
Qed.

Lemma alpha_eq0 H : (α(H) == 0) = (H == set0).
Proof.
apply/idP/idP => [|/eqP->]; last by rewrite alpha0.
apply: contraTT => /set0Pn[x xH]; rewrite -lt0n -(cards1 x).
by apply: stabset_bound; rewrite !inE stable1 sub1set xH.
Qed.

End AlphaBasics.

(** ** chromatic number *)

Definition coloring (G : sgraph) (P : {set {set G}}) (D : {set G}) :=
  partition P D && [forall S in P, stable S].

Definition trivial_coloring (G : sgraph) (A : {set G}) :=
  [set [set x] | x in A].

Lemma trivial_coloringP (G : sgraph) (A : {set G}) :
  coloring (trivial_coloring A) A.
Proof.
apply/andP; split; last by apply/forall_inP=> ? /imsetP[x xA ->]; exact: stable1.
suff -> : trivial_coloring A = preim_partition id A by apply: preim_partitionP.
have E x : x \in A -> [set x] = [set y in A | x == y].
  by move=> xA; apply/setP => y; rewrite !inE eq_sym andb_idl // => /eqP<-.
by apply/setP => P; apply/imsetP/imsetP => -[x xA ->]; exists x => //; rewrite E.
Qed.
Arguments trivial_coloringP {G A}.

Definition chi_mem (G : sgraph) (A : mem_pred G) :=
  #|[arg min_(P < trivial_coloring [set x in A] | coloring P [set x in A]) #|P|]|.

Notation "χ( A )" := (chi_mem (mem A)) (format "χ( A )").

Section Basics.
Variable (G : sgraph).
Implicit Types (P : {set {set G}}) (A B C D H : {set G}).

(** the [sub_partition] is actually a sub_coloring *)
Lemma sub_coloring P D A :
  coloring P D -> A \subset D -> coloring (sub_partition P A) A.
Proof.
case/andP => partP /forall_inP/= stabP subAD; apply/andP;split.
  exact: sub_partitionP.
have/subsetP sub := sub_partition_sub partP subAD.
apply/forall_inP => S {}/sub /imsetP [B BP ->].
by apply: sub_stable (stabP _ BP); apply: subsetIl.
Qed.

Lemma empty_coloring : coloring set0 (@set0 G).
Proof.
by rewrite /coloring partition_set0 eqxx; apply/forall_inP => S; rewrite inE.
Qed.

Lemma coloringD1 P S H : coloring P H -> S \in P -> coloring (P :\ S) (H :\: S).
Proof.
move=> /andP[partP stabP] SP; apply/andP; split; first exact: partitionD1.
by apply/forall_inP => A /setD1P[_ /(forall_inP stabP)].
Qed.

Lemma coloringU1 P S H :
  stable S -> S != set0 -> coloring P H -> [disjoint S & H] -> coloring (S |: P) (S :|: H).
Proof.
move=> stS SD0 /andP[partP stabP] disHS; apply/andP; split; first exact: partitionU1.
by apply/forall_inP => A /setU1P[-> //|/(forall_inP stabP)].
Qed.

Variant chi_spec A : nat -> Prop :=
  ChiSpec P of coloring P A & (forall P', coloring P' A -> #|P| <= #|P'|)
  : chi_spec A #|P|.

(** We can always replace [χ(A)] with [#|P|] for some optimal coloring [P]. *)
Lemma chiP A : chi_spec A χ(A).
Proof.
rewrite /chi_mem; case: arg_minnP; first exact: trivial_coloringP.
by move=> P; rewrite setE => ? ?; apply: ChiSpec.
Qed.

Lemma color_bound P A : coloring P A -> χ(A) <= #|P|.
Proof. by move => col_P; case: chiP => P' _ /(_ _ col_P). Qed.

Lemma coloring_stabsetP P D :
  reflect (partition P D /\ {in P, forall B, B \in stabsets D}) (coloring P D).
Proof.
apply: (iffP andP) => -[partP stabP]; split => //; [|apply/forall_inP] => B BP.
  by rewrite inE (partitionS partP) ?(forall_inP stabP).
by move/stabP : BP; rewrite !inE => /andP[_ ->].
Qed.

Lemma chi0 : χ(@set0 G) = 0.
Proof.
apply/eqP; rewrite -leqn0; apply: leq_trans (color_bound empty_coloring) _.
by rewrite cards0.
Qed.

Lemma leq_chi A : χ(A) <= #|A|.
Proof.
case: chiP => C col_C /(_ _ (@trivial_coloringP _ A)).
rewrite /trivial_coloring card_imset //. exact: set1_inj.
Qed.

Lemma sub_chi A B : A \subset B -> χ(A) <= χ(B).
Proof.
move=> subAB; case: (chiP B) => P col_P opt_P.
have col_S := sub_coloring col_P subAB.
apply: leq_trans (color_bound col_S) (card_sub_partition _ subAB).
by case/andP : col_P.
Qed.

Lemma cliqueIstable A C : clique C -> stable A -> #|C :&: A| <= 1.
Proof.
move => clique_C; apply: contraTT; rewrite -ltnNge.
case/card_gt1P => x [y] [/setIP[xA xC] /setIP[yA yC] xDy].
apply/stablePn; exists x, y; split => //. exact: clique_C.
Qed.

Lemma chi_clique C : clique C -> χ(C) = #|C|.
Proof.
move=> clique_C; apply/eqP; rewrite eqn_leq leq_chi /=.
have [P /andP[partP /forall_inP /= stabP] opt_P] := chiP.
suff S A : A \in P -> #|A| = 1.
{ rewrite (card_partition partP); under eq_bigr => A ? do rewrite S //.
  by rewrite sum_nat_const muln1. }
move=> AP; apply/eqP; rewrite eqn_leq card_gt0 (partition_neq0 partP) //.
rewrite andbT -(@setIidPl _ A C _) ?(partitionS partP) // setIC.
exact : cliqueIstable (stabP _ _).
Qed.

Lemma omega_leq_chi A : ω(A) <= χ(A).
Proof.
case: omegaP => C; rewrite !inE -andbA => /and3P[subCA /cliqueP clique_C _].
by apply: leq_trans (sub_chi subCA); rewrite chi_clique.
Qed.

Lemma chiD1 H S : stable S -> χ(H) <= χ(H :\: S).+1.
Proof.
move=> stabS; wlog subSH : S stabS / S \subset H.
  move => /(_ (S :&: H)); rewrite setDIr setDv setU0 subsetIr; apply => //.
  by apply: sub_stable stabS; rewrite subsetIl.
have [->|SD0] := eqVneq S set0; first by rewrite setD0.
case: (chiP (H :\: S)) => P colP _; have := coloringU1 stabS SD0 colP.
rewrite disjoint_sym disjoints_subset subsetDr [S :|: _]setUC setDK // => /(_ isT) => colP'.
by apply: leq_trans (color_bound colP') _; rewrite cardsU1; case (_ \in _).
Qed.

Let setG : [set x in mem [set: G]] = [set x in mem G].
Proof. by apply/setP => x; rewrite !inE. Qed.

Lemma alphaT : α([set: G]) = α(G).
Proof. by rewrite /alpha_mem setG. Qed.

Lemma omegaT : ω([set: G]) = ω(G).
Proof. by rewrite /omega_mem setG. Qed.

Lemma chiT : χ([set: G]) = χ(G).
Proof. by rewrite /chi_mem setG. Qed.

End Basics.

Notation sval := (@sval _ _).

Section ISubgraph.
Variables (F G : sgraph) (i : F ⇀ G).
Let i_inj := isubgraph_inj i.

Lemma cliqueb_isubgraph (K : {set F}) : cliqueb K = cliqueb (i @: K).
Proof.
rewrite /cliqueb (@forall2_imset _ _ i i).
apply: eq_forall_in => x xK; apply: eq_forall_in => y yK.
by rewrite (inj_eq (isubgraph_inj i)) isubgraph_mono.
Qed.

Lemma stable_isubgraph (S  : {set F}) : stable S = stable (i @: S).
Proof.
rewrite !stableEedge (@forall2_imset _ _ i i).
apply: eq_forall_in => x xS; apply: eq_forall_in => y yS.
by rewrite isubgraph_mono.
Qed.

Lemma coloring_isubgraph (P : {set {set F}}) (D : {set F}) :
  coloring P D = @coloring G [set i @: (S : {set F}) | S in P] (i @: D).
Proof.
rewrite /coloring -imset_partition; last exact: isubgraph_inj.
by rewrite forall_imset; under [in RHS]eq_forallb => S do rewrite -stable_isubgraph.
Qed.

Lemma preim_coloring (P : {set {set G}}) (D : {set F}) :
  coloring P (i @: D) -> coloring [set i @^-1: (B : {set G}) | B in P] D.
Proof.
move => colP; rewrite coloring_isubgraph -imset_comp /comp /=.
have coB B : B \in P -> B \subset codom i.
{ case/andP: colP => partP _; move/(partitionS partP) => sub.
  apply: subset_trans sub _. exact: imset_codom. }
under [X in coloring X _]eq_in_imset => B BP.
  rewrite (can_preimset i) ?coB //; over.
by rewrite imset_id.
Qed.

Lemma chi_isubgraph (A : {set F}) : χ(A) = χ(i @: A).
Proof.
apply/eqP; rewrite eqn_leq; apply/andP; split.
- case: (chiP (i @: A)) => P /preim_coloring colP minP.
  exact: leq_trans (color_bound colP) (leq_imset_card _ _).
- case: (chiP A) => P colP minP.
  rewrite coloring_isubgraph in colP; apply: leq_trans (color_bound colP) _.
  by rewrite card_imset //; apply/imset_inj/isubgraph_inj.
Qed.

Lemma isubgraph_cliques (B K : {set F}) :
  (K \in cliques B) = (i @: K \in cliques (i @: B)).
Proof. by rewrite !inE inj_imsetS // -cliqueb_isubgraph. Qed.

Lemma clique_to_isubgraph (K A : {set G}) :
  K \in cliques A -> i @^-1: K \in cliques (i @^-1: A).
Proof.
rewrite !inE => /andP[subKA /cliqueP clK].
rewrite preimsetS //= cliqueb_isubgraph; apply/cliqueP.
by apply: sub_clique clK; rewrite sub_imset_pre preimsetS.
Qed.

Lemma can_inj_imset (A : {set F}) : i @^-1: (i @: A) = A.
Proof. by apply/setP => x; rewrite !inE (mem_imset). Qed.

Lemma omega_isubgraph (B : {set F}) : ω(B) = ω(i @: B).
Proof.
apply/eqP; rewrite eqn_leq; apply/andP; split.
- have [K] := omegaP B.
  rewrite inE isubgraph_cliques => /andP[ckK _]; rewrite -(card_imset _ i_inj).
  exact: clique_bound.
- have [K] := omegaP; rewrite inE => /andP[clK].
  move/clique_to_isubgraph : (clK). rewrite can_inj_imset => clK' _.
  apply: leq_trans (clique_bound clK'). rewrite inj_card_preimset //.
  exact: subset_trans (cliques_subset clK) (imset_codom _ _).
Qed.

End ISubgraph.

(** We have proper duality reasoning at this point *)
Lemma maxcliques_compl (G : sgraph) (H : {set G}) :
  maxcliques (H : {set compl G}) = maxstabsets H.
Proof.
apply/setP => A. rewrite !inE clique_compl; apply: andb_id2l => /andP[subAH stabA].
rewrite /omega_mem /alpha_mem setE /=.
by under eq_bigl => B do rewrite inE clique_compl -(@in_stabsets G).
Qed.

Lemma omega_compl (G : sgraph) (A : {set G}) : ω(A : {set compl G}) = α(A).
Proof.
case: omegaP => K. rewrite maxcliques_compl. exact: (@card_maxstabset G).
Qed.

Lemma alpha_isubgraph (F G : sgraph) (i : F ⇀ G) (A : {set F}) : α(A) = α(i @: A).
Proof.
by rewrite -omega_compl (omega_isubgraph (isubgraph_compl i)) omega_compl.
Qed.

Lemma maxstabsets_compl (G : sgraph) (H : {set G}) :
  maxstabsets (H : {set compl G}) = maxcliques H.
Abort.

Lemma alpha_compl (G : sgraph) (A : {set G}) : α(A : {set compl G}) = ω(A).
Abort.

Section Induced.
Variables (G : sgraph) (H : {set G}).
Let i := induced_isubgraph H.

Lemma alpha_induced : α(induced H) = α(H).
Proof. by rewrite -alphaT (alpha_isubgraph i) imset_valT setE. Qed.

Lemma omega_induced : ω(induced H) = ω(H).
Proof. by rewrite -omegaT (omega_isubgraph i) imset_valT setE. Qed.

Lemma chi_induced : χ(induced H) = χ(H).
Proof. by rewrite -chiT (chi_isubgraph i) imset_valT setE. Qed.

Lemma cliqueb_induced (K : {set induced H}) : cliqueb K = cliqueb (val @: K).
Proof. exact: (cliqueb_isubgraph i). Qed.

Lemma stable_induced (K : {set induced H}) : stable K = stable (val @: K).
Proof. exact: (stable_isubgraph i). Qed.

End Induced.

Lemma maxstabset_to_induced (G : sgraph) (H : {set G}) (S : {set G}) :
  S \in maxstabsets H -> val @^-1: S \in maxstabsets [set: induced H].
Proof.
pose i := induced_isubgraph H.
rewrite !inE subsetT (stable_isubgraph i) -andbA /= => /and3P[S1 S2 S3].
have subSi : S \subset codom i.
{ apply: subset_trans S1 _; apply/subsetP => x xH. by apply/codomP; exists (Sub x xH). }
rewrite (@can_preimset _ _ i) ?S2 //= (@inj_card_preimset _ _ i) //=.
rewrite alphaT alpha_induced //. exact: val_inj.
Qed.

(** A coloring consisting of maximal stable sets is optimal *)
Lemma maxstabset_coloring (G : sgraph) (P : {set {set G}}) (D : {set G}) :
  partition P D -> {in P, forall S, S \in maxstabsets D} -> χ(D) = #|P|.
Proof.
move=> partP maxP; have [D0|[x xD]] := set_0Vmem D.
  by subst D; apply/esym/eqP; rewrite chi0 cards_eq0 -partition_set0.
have colP : coloring P D.
  by apply/coloring_stabsetP; split => // B /maxP/maxstabsetW.
apply/eqP; rewrite eqn_leq (color_bound colP) /=.
have [P' /coloring_stabsetP[partP' stabP'] _] := chiP.
have [trivP trivP'] : trivIset P /\ trivIset P'.
  by case/and3P : partP; case/and3P : partP'.
apply: contraTT (leqnn #|D|); rewrite -!ltnNge => lt_P'_P.
rewrite -{1}(cover_partition partP') -(cover_partition partP).
rewrite -(eqP trivP) -(eqP trivP').
under [X in _ < X]eq_bigr => B BP do rewrite (card_maxstabset (maxP _ BP)).
apply: (@leq_ltn_trans (#|P'| * α(D))).
  by rewrite -sum_nat_const; apply: leq_sum => B /stabP'; apply: stabset_bound.
rewrite sum_nat_const ltn_mul2r lt0n alpha_eq0 lt_P'_P andbT.
by apply/set0Pn; exists x.
Qed.

Section Iso.
Variables (F G : sgraph) (i : diso F G).
Implicit Types (A : {set F}).

Let i_mono : {mono i : x y / x -- y}.
Proof. by move => x y; rewrite edge_diso. Qed.

Let i_inj : injective i.
Proof. by apply: (can_inj (g := i^-1)) => x; rewrite bijK. Qed.

Definition i' : F ⇀ G := ISubgraph i_inj i_mono.

(* TODO *)

Lemma diso_stable A : stable A = stable (i @: A).
Abort.

Lemma diso_clique A : cliqueb A = cliqueb (i @: A).
Abort.

Lemma diso_omega A : ω(A) = ω(i @: A).
Abort.

Lemma diso_chi A : χ(A) = χ(i @: A).
Abort.

End Iso.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) : natural := plus y (Succ Zero).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf4 : natural) (lf1 : natural) : natural := plus lf4 lf1.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf1 : natural) : natural := mult y lf1.


Require Import Arith.
Lemma plus1: forall x:nat,x+2=x+1+1.
Proof.
  intros.
  SearchRewrite((_ + _)).
  rewrite plus_assoc_reverse.
  simpl.
  reflexivity.
Qed.

Lemma ord: forall x:nat, x+1<x+1+1->x+1<x+2.
Proof.
  intros.
  SearchRewrite(_+_).
  rewrite BinInt.ZL0.
  rewrite Nat.add_assoc.
  apply H.
Qed.

Theorem plus2: (forall x:nat, x<x+1)->(forall x y z:nat, (x<y) -> (y<z)->x<z)->(forall x:nat, x<(x+1)+1).
Proof.
  intros.
  apply (H0 x (x+1) (x+1+1)).
  apply (H x).
  apply (H (x+1)).
Qed.

Theorem ordlaw: forall x y z:nat, x<y->y<z->x<y<z.
Proof.
  auto.
Qed.

Theorem plus2': (forall x:nat, x<x+1)->(forall x y z:nat, x<y<z->x<z)->(forall x:nat, x<(x+1)+1).
Proof.
  intros.
  apply plus2.
  apply H.
  intros.
  apply (H0 x0 y z).
  apply (ordlaw x0 y z).
  apply H1.
  apply H2.
Qed.