(* * Peano Arithmetic *)
(* ** Axioms of PA, excluding induction *)
Require Export Undecidability.FOL.Syntax.Core.
Require Export Undecidability.FOL.Arithmetics.Signature.
Require Import Undecidability.FOL.Syntax.Facts.
Import Vector.VectorNotations.
Require Import List.
Import FullSyntax.
Export FullSyntax.

#[global] Existing Instance falsity_on.

Definition ax_add_zero :=  ∀  (zero ⊕ $0 == $0).
Definition ax_add_rec :=   ∀∀ ((σ $0) ⊕ $1 == σ ($0 ⊕ $1)).
Definition ax_mult_zero := ∀  (zero ⊗ $0 == zero).
Definition ax_mult_rec :=  ∀∀ (σ $1 ⊗ $0 == $0 ⊕ $1 ⊗ $0).

(* Fragment only containing the defining equations for addition and multiplication. *)
Definition FA := ax_add_zero :: ax_add_rec :: ax_mult_zero :: ax_mult_rec :: nil.

(* Equality axioms for the PA signature *)

Definition ax_refl :=  ∀   $0 == $0.
Definition ax_sym :=   ∀∀  $1 == $0 → $0 == $1.
Definition ax_trans := ∀∀∀ $2 == $1 → $1 == $0 → $2 == $0.

Definition ax_succ_congr := ∀∀ $0 == $1 → σ $0 == σ $1.
Definition ax_add_congr := ∀∀∀∀ $0 == $1 → $2 == $3 → $0 ⊕ $2 == $1 ⊕ $3.
Definition ax_mult_congr := ∀∀∀∀ $0 == $1 → $2 == $3 → $0 ⊗ $2 == $1 ⊗ $3.

Definition EQ :=
  ax_refl :: ax_sym :: ax_trans :: ax_succ_congr :: ax_add_congr :: ax_mult_congr :: nil.

Definition FAeq :=
  EQ ++ FA.

(* Defines numerals i.e. a corresponding term for every natural number *)
Fixpoint μ n :=  match n with
                   O => zero
                 | S x => σ (μ x)
                 end.
Definition num := μ.

Lemma num_subst k ρ : (num k)`[ρ] = num k.
Proof.
  induction k; cbn; congruence.
Qed.

Lemma num_bound n k : bounded_t k (num n).
Proof.
  induction n; cbn; constructor.
  - intros t []%Vectors.In_nil.
  - now intros t [-> | []%Vectors.In_nil]%vec_cons_inv.
Qed.


Require Export ZArith.
Require Export Arith.

Fixpoint check_range (v:Z)(r:nat)(sr:Z){struct r} : bool :=
  match r with
    O => true
  | S r' =>
    match (v mod sr)%Z with
      Z0 => false
    | _ => check_range v r' (Zpred sr)
    end
  end.

Definition check_primality (n:nat) :=
  check_range (Z_of_nat n)(pred (pred n))(Z_of_nat (pred n)).

Theorem verif_divide :
    forall m p:nat, 0 < m -> 0 < p ->
    (exists q:nat, m = q*p) -> (Z_of_nat m mod Z_of_nat p = 0)%Z.
Proof.
 intros m p Hltm Hltp (q, Heq); rewrite Heq.
 rewrite inj_mult.
 replace (Z_of_nat q * Z_of_nat p)%Z with (0 + Z_of_nat q * Z_of_nat p)%Z;
    try ring.
 rewrite Z_mod_plus; auto.
 omega.
Qed.

Theorem divisor_smaller :
    forall m p:nat, 0 < m -> forall q:nat, m = q*p -> q <= m.
Proof.
 intros m p Hlt; case p.
 -  intros q Heq; rewrite Heq in Hlt; rewrite mult_comm in Hlt.
     elim (lt_irrefl 0);exact Hlt.
 -  intros p' q; case q.
    +  intros Heq; rewrite Heq in Hlt.
       elim (lt_irrefl _ Hlt).
    + intros q' Heq; rewrite Heq.
      rewrite mult_comm; simpl; auto with arith.
Qed.

Theorem Zabs_nat_0 : forall x:Z, Zabs_nat x = 0 -> (x = 0)%Z.
Proof.
 intros x; case x.
 -  simpl; auto.
 -  intros p Heq; elim (lt_irrefl 0).
    pattern 0 at 2; rewrite <- Heq.
    simpl; apply lt_O_nat_of_P.
 -  intros p Heq; elim (lt_irrefl 0).
    pattern 0 at 2; rewrite <- Heq.
    simpl; apply lt_O_nat_of_P.
Qed.

Theorem Z_to_nat_and_back :
 forall x:Z, (0 <= x)%Z -> (Z_of_nat (Zabs_nat x))=x.
Proof.
 intros x; case x.
 - reflexivity.
 -  intros p Hd; elim p.
   +  unfold Zabs_nat; intros p' Hrec; rewrite nat_of_P_xI.
      rewrite inj_S,  inj_mult,  Zpos_xI.
      unfold Zsucc; rewrite Hrec;  simpl; auto.
   +  unfold Zabs_nat; intros p' Hrec; rewrite nat_of_P_xO.
      rewrite inj_mult,  Zpos_xO.
      unfold Zsucc; rewrite Hrec; simpl; auto.
   +  simpl; auto.

 -  intros p' Hd; elim Hd;auto.
Qed.

Theorem  check_range_correct :
  forall (v:Z)(r:nat)(rz:Z),
  (0 < v)%Z -> Z_of_nat (S r) = rz -> check_range v r rz = true ->
  ~(exists k:nat, k <= S r /\ k <> 1 /\
                       (exists q:nat, Zabs_nat v = q*k)).
Proof.
 intros v r; elim r.
 -  intros rz Hlt H1 H2 Hex; case Hex; intros k; case k.
   +  intros (Hle, (Hne1, (q, Heq))).
      rewrite mult_comm in Heq; simpl in Heq.
      rewrite (Zabs_nat_0 _ Heq) in Hlt.
      elim (Zlt_irrefl 0); assumption.

   + intros k' (Hle, (Hne1, (q, Heq))).
     inversion Hle.
     *  assert (H':k'=0) by  assumption.
        rewrite H' in Hne1; elim Hne1;auto.
     *  assert (H': S k' <= 0) by  assumption.
        inversion H'.

 -  intros r' Hrec rz Hlt H1 H2 Hex; case Hex; intros k; case k.
    intros (Hle, (Hne1, (q, Heq))).
    rewrite mult_comm in Heq; simpl in Heq.
    rewrite (Zabs_nat_0 _ Heq) in Hlt.
    elim (Zlt_irrefl 0); assumption.
    intros k' (Hle, (Hne1, (q, Heq))).
    inversion Hle.
    rewrite <- H1 in H2.
    rewrite <- (Z_to_nat_and_back v) in H2.
    assert (Hmod:(Z_of_nat (Zabs_nat v) mod Z_of_nat (S (S r')) = 0)%Z).
    +  apply verif_divide.
       replace 0 with (Zabs_nat 0%Z).
       apply Zabs_nat_lt.
       omega.
       simpl; auto.
       auto with arith.
       exists q.
       assert (H': k' = S r') by  assumption.
       rewrite <- H'.
       assumption.
    +  unfold check_range in H2.
       rewrite Hmod in H2.
       discriminate H2.
      + omega.
      + unfold check_range in H2; fold check_range in H2.
        case_eq ((v mod rz)%Z).
        *  intros Heqmod; rewrite Heqmod in H2; discriminate H2.
        *  intros pmod Heqmod; rewrite Heqmod in H2;  elim (Hrec (Zpred rz) Hlt).
           rewrite <- H1; repeat rewrite inj_S;  rewrite <- Zpred_succ; auto.
          assumption.
          exists (S k'); repeat split;auto.
          exists q; assumption.

        * intros p Hmod; elim (Z_mod_lt v rz).
          rewrite Hmod; unfold Zle; simpl; intros Hle'; elim Hle';auto.
          rewrite <- H1; rewrite inj_S; unfold Zsucc; generalize (Zle_0_nat (S r')).
          intros; omega.
Qed.

Theorem nat_of_P_Psucc :
 forall p:positive, nat_of_P (Psucc p) = S (nat_of_P p).
Proof.
 intros p; elim p.
 - simpl; intros p'; rewrite nat_of_P_xO.
   intros Heq; rewrite Heq.
   rewrite nat_of_P_xI; ring.
- intros p' Heq; simpl; rewrite nat_of_P_xI; rewrite nat_of_P_xO;auto.
-  auto.
Qed.

Theorem nat_to_Z_and_back:
 forall n:nat, Zabs_nat (Z_of_nat n) = n.
Proof.
 intros n; elim n.
 -  auto.
 - intros n'; simpl; case n'.
  +  simpl; auto.
  +  intros n''; simpl; rewrite nat_of_P_Psucc; intros Heq; rewrite Heq; auto.
Qed.

Theorem check_correct :
  forall p:nat, 0 < p -> check_primality p = true ->
  ~(exists k:nat, k <> 1 /\ k <> p /\ (exists q:nat, p = q*k)).
Proof.
 unfold lt; intros p Hle; elim Hle.
 -  intros Hcp (k, (Hne1, (Hne1bis, (q, Heq)))); rewrite mult_comm in Heq.
    assert (Hle' : k < 1).
    +  elim (le_lt_or_eq k 1); try(intuition; fail).
       apply divisor_smaller with (2:= Heq); auto.
    +  case_eq k.
       *  intros Heq'; rewrite Heq' in Heq; simpl in Heq; discriminate Heq.
       *  intros; omega.
 -  intros p' Hlep' Hrec; unfold check_primality.
    assert (H':(exists p'':nat, p' = (S p''))).
   +  inversion Hlep'.
      *     exists 0; auto.
      *  eapply ex_intro;eauto.
   +  elim H'; intros p'' Hp''; rewrite Hp''.
      repeat rewrite <- pred_Sn.
      intros Hcr Hex;  elim check_range_correct with (3:= Hcr).
     *  rewrite inj_S; generalize (Zle_0_nat (S p'')).
        intros; omega.
     *  auto.
     *  elim Hex; intros k (Hne1, (HneSSp'', (q, Heq))); exists k.
       split.
       assert (HkleSSp'': k <= S (S p'')).
       apply (divisor_smaller (S (S p'')) q); auto with arith.
       rewrite mult_comm; assumption.
       omega.
       split.
       assumption.
       exists q; now  rewrite nat_to_Z_and_back.
Qed.


Require Import Coq.Program.Equality.

Inductive List (A: Type) : nat -> Type :=
  | Nil : List A 0
  | Cons : forall n: nat,  A -> List A n -> List A (S n).

Arguments Nil {A}.
Arguments Cons {A n}.

Definition len {A: Type} {n: nat} (l: List A n) : nat := n.

Theorem len_ok : forall A: Type, forall n : nat, forall l : List A n, forall a : A, S (len l) = len (Cons a l).
Proof.
  intros. cbv. trivial.
Qed.

Theorem o_means_empty : forall A: Type, forall l: List A O, l = Nil.
Proof.
  intros A l. dependent destruction l. trivial.
Qed.

Inductive UList (A: Type) : Type :=
  | UNil : UList A
  | UCons : forall l : UList, forall a : A, Unique a l -> UList A
with Unique {A : Type} (a: A) (l : UList A) : Prop :=
  | UniqNil : Unique l a
  | UniqCons : forall h : A, forall l : UList A, Unique l -> h <> a -> Unique a (UCons l h).

Inductive SEvenList (A: Type) (ord : A -> A -> bool) :=
  | SEvenNil : SEvenList A ord
  | SEvenCons : forall a: A, forall l : SOddList A ord,
       l = SOddCons h t -> ord a h = true -> SEvenList A ord
with SOddList (A: Type) (ord : A -> A -> bool) :Type :=
  | SOddCons : forall a : A, forall l : SEvenList A ord,
      (l = SEvenNil A ord \/ (l = SEvenCons h t /\ ord a h = true)) -> SOddList A ord.


From mathcomp Require Import ssreflect seq ssrfun ssrbool ssrnat.
From mf Require Import all_mf.
Require Import pointwise reals pseudo_metrics.
Require Import Reals Psatz Classical ChoiceFacts Morphisms ProofIrrelevance ProofIrrelevanceFacts.

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

Local Open Scope pseudometric_scope.
Local Open Scope R_scope.

Section PseudoMetricSpaces.
  Class PseudoMetricSpace :=
    {carrier:> Type;
     distance: carrier * carrier -> R;
     pseudo_metric: distance \is_pseudometric_on carrier}.

  Coercion carrier: PseudoMetricSpace >-> Sortclass.

  Global Instance pm (M: PseudoMetricSpace): distance \is_pseudometric.
  Proof. exact/pseudo_metric. Qed.
  Notation d := distance.

  Context (M: PseudoMetricSpace).
  Implicit Types (x y z: M).

  Lemma dst_le x y z r r' q: d(x,z) <= r -> d(z,y) <= r' -> r + r' <= q -> d(x,y) <= q.
  Proof. by apply dst_le. Qed.

  Lemma le_dst x y z r r' q: r + r' <= q -> d(x,z) <= r -> d(z,y) <= r' -> d(x,y) <= q.
  Proof. by apply le_dst. Qed.

  Lemma dst_lt x y z r r' q: d(x,z) <= r -> d(z,y) <= r' -> r + r' < q -> d(x,y) < q.
  Proof. by apply dst_lt. Qed.
End PseudoMetricSpaces.
Notation d := distance.

Notation limit := (limit d).
Notation "xn ~> x" := (limit xn x) (at level 23): pseudometric_scope.
Notation "x \limit_of xn" := (xn ~> x) (at level 23): pseudometric_scope.
Notation "x \is_limit_of xn" := (xn ~> x) (at level 23): pseudometric_scope.
Section limits.
  Context (M: PseudoMetricSpace).
  Implicit Types (x y z: M).

  Lemma lim_dst xn x y: x \limit_of xn -> y \limit_of xn  -> d(x,y) = 0.
  Proof. by apply lim_dst. Qed.

  Lemma lim_cnst x: x \limit_of (cnst x).
  Proof. by apply lim_cnst. Qed.

  Lemma lim_tpmn xn x: x \limit_of xn <->
    (forall n, exists N, forall m, (N <= m)%nat -> d(x,xn m) <= /2 ^ n).
  Proof. by apply lim_tpmn. Qed.

  Lemma dst0_tpmn x y: d(x,y) = 0 <-> (forall n, d(x,y) <= / 2 ^ n).
  Proof. by apply dst0_tpmn. Qed.
End limits.

Notation "A \dense_subset" := (A \dense_subset_wrt d) (at level 35): pseudometric_scope.
Notation "A \is_dense_subset":= (A \dense_subset) (at level 35): pseudometric_scope.
Notation "xn \dense" := (xn \dense_wrt d) (at level 35): pseudometric_scope.
Notation "xn \is_dense" := (xn \dense) (at level 35): pseudometric_scope.
Notation "xn \dense_sequence" := (xn \dense) (at level 35): pseudometric_scope.
Notation "xn \is_dense_sequence" := (xn \dense) (at level 35): pseudometric_scope.
Notation closure A := (closure d A).
Section density.
  Context (M: PseudoMetricSpace).

  Lemma dns_tpmn (A: subset M):
    A \is_dense_subset <-> forall x n, exists y, y \from A /\ d(x,y) <= /2^n.
  Proof. exact/dns_tpmn. Qed.

  Lemma dseq_dns (xn: sequence_in M):
    xn \is_dense <-> (codom (F2MF xn)) \is_dense_subset.
  Proof. exact/dseq_dns. Qed.

  Lemma dseq_tpmn (xn: sequence_in M):
    xn \is_dense <-> forall x n, exists k, d(x,xn k) <= /2^n.
  Proof. exact/dseq_tpmn. Qed.

  Lemma subs_clos A: A \is_subset_of closure A.
  Proof. by apply subs_clos. Qed.

  Lemma dns_clos A: A \is_dense_subset <-> closure A === All.
  Proof. exact/dns_clos. Qed.
End density.

Notation Cauchy_sequences:= (Cauchy_sequences d).
Notation "xn \Cauchy" := (xn \Cauchy_wrt d) (at level 45): pseudometric_scope.
Notation "xn \Cauchy_sequence" := (xn \Cauchy) (at level 45): pseudometric_scope.
Notation "xn \is_Cauchy" := (xn \Cauchy) (at level 45): pseudometric_scope.
Notation "xn \is_Cauchy_sequence" := (xn \Cauchy) (at level 45): pseudometric_scope.
Notation complete M := (@complete M d).
Notation "M \is_complete" := (complete M) (at level 45): metric_scope.
Section Cauchy_sequences.
  Context (M: PseudoMetricSpace).
  Implicit Types (x y z: M) (xn yn: sequence_in M).

  Lemma lim_cchy: dom limit \is_subset_of Cauchy_sequences.
  Proof. by apply lim_cchy. Qed.

  Lemma cchy_tpmn xn: xn \Cauchy <->
    (forall k, exists N, forall n m,
            (N <= n <= m)%nat -> d (xn n, xn m) <= /2^k).
  Proof. by apply cchy_tpmn. Qed.

  Lemma lim_evb xn mu (x: M): x \limit_of xn -> eventually_big mu -> limit (xn \o_f mu) x.
  Proof. exact/lim_evb. Qed.

  Lemma cchy_evb xn mu: xn \Cauchy -> eventually_big mu -> (xn \o_f mu) \Cauchy.
  Proof. exact/cchy_evb. Qed.
End Cauchy_sequences.

Section efficient_convergence.
  Context (M: PseudoMetricSpace).
  Local Notation fast_Cauchy_sequences := (fast_Cauchy_sequences d).
  Local Notation "xn \fast_Cauchy" := (xn \is_fast_Cauchy_sequence_wrt d) (at level 35).
  Local Notation efficient_limit := (efficient_limit d).

  Lemma fchy_cchy: fast_Cauchy_sequences \is_subset_of Cauchy_sequences.
  Proof. exact/fchy_cchy. Qed.

  Lemma lim_eff_spec: efficient_limit =~= limit|_(fast_Cauchy_sequences).
  Proof. exact lim_eff_spec. Qed.

  Lemma lim_eff_lim : limit \extends efficient_limit.
  Proof. exact lim_eff_lim. Qed.

  Lemma fchy_lim_eff: complete M ->
    fast_Cauchy_sequences === dom efficient_limit.
  Proof. exact fchy_lim_eff. Qed.

  Lemma lim_eff_dst xn x y: efficient_limit xn x -> efficient_limit xn y -> d(x, y) = 0.
  Proof. by apply lim_eff_dst. Qed.

  Lemma lim_tight_lim_eff: limit \tightens efficient_limit.
  Proof. exact lim_tight_lim_eff. Qed.

  Lemma cchy_eff_suff xn:
    (forall n m, (n <= m)%nat -> d (xn n, xn m) <= /2^n + /2^m) -> xn \fast_Cauchy.
  Proof. by apply cchy_eff_suff. Qed.
End efficient_convergence.
Notation fast_Cauchy_sequences := (fast_Cauchy_sequences d).
Notation "xn \fast_Cauchy" := (xn \fast_Cauchy_wrt d) (at level 45): pseudometric_scope.
Notation "xn \fast_Cauchy_sequence" := (xn \fast_Cauchy) (at level 45): pseudometric_scope.
Notation "xn \is_fast_Cauchy_sequence" := (xn \fast_Cauchy) (at level 45): pseudometric_scope.
Notation efficient_limit:= (efficient_limit d).
Notation "x \efficient_limit_of xn" := (efficient_limit xn x) (at level 45): pseudometric_scope.

Section continuity.
  Context (M M': PseudoMetricSpace).
  Context (f: M -> M').
  Implicit Types (x y: M) (xn yn: sequence_in M).
  Local Notation continuous_in x := (continuity_point d d f x).
  Local Notation continuous := (f \continuous_wrt d \and d).
  Local Notation continuity_points := (continuity_points d d f).
  Local Notation sequential_continuity_points := (sequential_continuity_points d d f).
  Local Notation sequentially_continuous := (f \sequentially_continuous_wrt d \and d).

  Lemma cntp_tpmn x:
    continuous_in x <-> forall n, exists m, forall x', d (x, x') <= /2^m -> d (f x, f x') <= /2^n.
  Proof. exact/cntp_tpmn. Qed.

  Lemma cont_tpmn:
    continuous <-> forall x n, exists m, forall x', d (x, x') <= /2^m -> d (f x, f x') <= /2^n.
  Proof. exact/cont_tpmn. Qed.

  Lemma cntp_all: continuous <-> continuity_points === All.
  Proof. exact/cntp_all. Qed.

  Lemma scntp_all: sequentially_continuous <-> sequential_continuity_points === All.
  Proof. exact/scntp_all. Qed.

  Lemma cntp_scntp: continuity_points \is_subset_of sequential_continuity_points.
  Proof. exact/cntp_scntp. Qed.

  Lemma cont_scnt: continuous -> sequentially_continuous.
  Proof. exact/cont_scnt. Qed.
End continuity.
Notation "f \continuous_in x" :=
  (continuity_point d d  f x) (at level 35): pseudo_metric_scope.
Notation continuity_points:= (continuity_points d d).
Notation "f \continuous" := (continuous d d f) (at level 2): pseudo_metric_scope.
Notation "f \is_continuous" := (f \continuous_wrt d \and d) (at level 2): pseudo_metric_scope.
Notation sequential_continuity_points := (sequential_continuity_points d d).
Notation "f \sequentially_continuous_in x" :=
  (sequential_continuity_point d d f x) (at level 40): pseudo_metric_scope.
Notation "f \sequentially_continuous" :=
  (f \sequentially_continuous_wrt d \and d) (at level 40): pseudo_metric_scope.
Notation "f \is_sequentially_continuous" :=
  (f \sequentially_continuous_wrt d \and d) (at level 40): pseudo_metric_scope.

Delimit Scope pseudo_metric_scope with pmetric.
Section subspaces.
  Context (M: PseudoMetricSpace).

  Global Instance subspace (A: subset M): PseudoMetricSpace.
    exists {x | x \from A} (fun xy => d (sval xy.1, sval xy.2)).
    split; first by move => x y; apply dst_pos.
    - by move => x y; apply dst_sym.
    - by move => x; apply dstxx.
    by move => x y z; apply dst_trngl.
  Defined.
End subspaces.


(** 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 (lf1 : natural) (y : natural) (x : natural) (lf2 : natural)
  : natural := plus Zero lf1.


Require Import OrderedType.
Require Import OrderedTypeEx.

Module Type PairOrderedType_Type (O1 O2:OrderedType).

 Module MO1:=OrderedTypeFacts(O1).
 Module MO2:=OrderedTypeFacts(O2).

 Definition t := prod O1.t O2.t.

 Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y).

 Definition lt x y :=
    O1.lt (fst x) (fst y) \/
    (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)).

 Parameter eq_refl : forall x : t, eq x x.

 Parameter eq_sym : forall x y : t, eq x y -> eq y x.

 Parameter eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.

 Parameter lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.

 Parameter lt_not_eq : forall x y : t, lt x y -> ~ eq x y.

 Parameter compare : forall x y : t, Compare lt eq x y.

 Parameter eq_dec : forall x y : t, {eq x y} + {~ eq x y}.

End PairOrderedType_Type.


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinear4.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_rayimpliescollinear :
   forall A B C,
   Out A B C ->
   Col A B C.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists J, (BetS J A C /\ BetS J A B)) by (conclude_def Out );destruct Tf as [J];spliter.
assert (neq J A) by (forward_using lemma_betweennotequal).
assert (Col J A B) by (conclude_def Col ).
assert (Col J A C) by (conclude_def Col ).
assert (Col A B C) by (conclude lemma_collinear4).
close.
Qed.

End Euclid.


(*
   雪江明彦「代数学1群論入門」日本評論社
   本文に沿って、coqにて展開する。

   2011_03_19 Sectionを使い、群に共通の定義をまとめて定義した。
   2011_03_20 Ltac でtacticsをまとめた。
   *)

Require Import Setoid.                      (* rewrite at *)

Section Group.
  Variable G : Set.
  (* 演算子 *)
  Variable App : G -> G -> G.
  Infix "**" := App (at level 61, left associativity).
  (* 定義 2.1.1 (1) *) (* 単位元 *)
  Variable E : G.
  (* 定義 2.1.1 (2) *) (* 逆元 *)
  Variable Inv : G -> G.

  (* 定義 2.1.1 (1) *) (* 単位元 *)
  Axiom identity_r :
    forall x, x ** E = x.
  Axiom identity_l :
    forall x, E ** x = x.

  (* 定義 2.1.1 (2) *) (* 逆元 *)
  Axiom inverse_r :
    forall x, x ** (Inv x) = E.
  Axiom inverse_l :
    forall x, (Inv x) ** x = E.

  (* 定義 2.1.1 (3) *) (* 結合則 *)
  Axiom associative_law :
    forall x y z, x ** (y ** z) = (x ** y) ** z.

  Theorem right_law :
    forall a b x, a = b -> a ** x = b ** x.
  Proof.
    intros a b x H.
    rewrite H.
    reflexivity.
  Qed.
  Theorem left_law :
    forall a b x, a = b -> x ** a = x ** b.
  Proof.
    intros a b x H.
    rewrite H.
    reflexivity.
  Qed.
  (* 暗黙の裏公理。両辺にxを掛ける *)
  (*Axiom right_law :
    forall a b x, a = b -> a ** x = b ** x.
  Axiom left_law :
    forall a b x, a = b -> x ** a = x ** b.
  *)

  (* 例題 2.1.7 *)
  Goal forall x y z w : G,
    x ** ((y ** z) ** w) = (x ** y) ** (z ** w).
  Proof.
    intros.
    rewrite <- associative_law.
    rewrite associative_law.
    reflexivity.
  Qed.

  Ltac insert_inv_l B A :=                  (* B の左に (Inv A) ** A を掛ける *)
    rewrite <- (identity_l B);
      rewrite <- (inverse_l A).

  Ltac insert_inv_r B A :=                  (* B の右に A ** (Inv A) を掛ける *)
    rewrite <- (identity_r B);
      rewrite <- (inverse_r A).

  (* 命題 2.1.8 (1) *) (* 簡約法則 *)
  Theorem reduce_law_l :
    forall a b c : G, a ** b = a ** c -> b = c.
  Proof.
    intros.
    insert_inv_l b a.
    insert_inv_l c a.
    rewrite <- associative_law.
    rewrite <- associative_law.
    eapply (left_law _ _ (Inv a)).
    apply H.
  Qed.

  Theorem reduce_law_r :
    forall b c a : G, b ** a = c ** a -> b = c.
  Proof.
    intros.
    insert_inv_r b a.
    insert_inv_r c a.
    rewrite associative_law.
    rewrite associative_law.
    eapply (right_law _ _ (Inv a)).
    apply H.
  Qed.

  (*
     b = Inv a ** c
     --------------
     a ** b = c
     *)
  Ltac r_to_l A :=
    eapply (reduce_law_l A _ _);
      repeat (rewrite associative_law);
        try (rewrite inverse_r);            (* rewrite (inverse_r a). *)
          try (rewrite inverse_l);          (* 実行されないかも *)
            try (rewrite identity_l).       (* rewrite (identity_l c). *)

  (*
     a = c ** Inv b
     --------------
     a ** b = c
     *)
  Ltac l_to_r B :=
    eapply (reduce_law_r _ _ B);
      repeat (rewrite <- associative_law);
        try (rewrite inverse_l);            (* rewrite (inverse_l b). *)
          try (rewrite inverse_r);          (* 実行されないかも *)
            try (rewrite identity_r).       (* rewrite (identity_r c). *)

  (* 命題 2.1.8 (2) *)
  Goal forall a b c,
    a ** b = c -> b = (Inv a) ** c.
  Proof.
    intros.
    r_to_l a.
    apply H.
  Qed.

  Goal forall a b c,
    a ** b = c -> a = c ** (Inv b).
  Proof.
    intros.
    l_to_r b.
    apply H.
  Qed.

  (* 例題 2.1.9 *)
  Goal forall x y z,
    x ** (Inv y) ** z ** x ** y ** x = E ->
    z = y ** (Inv x) ** (Inv x) ** (Inv y) ** (Inv x).
  Proof.
    intros.
    r_to_l (Inv y).
    (*
       eapply (reduce_law_l (Inv y) _ _).
       repeat rewrite associative_law.
       rewrite inverse_l.
       rewrite identity_l.
       *)
    r_to_l x.
    (*
       eapply (reduce_law_l x _ _).
       repeat rewrite associative_law.
       rewrite inverse_r.
       rewrite identity_l.
       *)
    l_to_r x.
    (*
       eapply (reduce_law_r _ _ x).
       repeat rewrite <- associative_law.
       rewrite inverse_l.
       rewrite identity_r.
       *)
    l_to_r y.
    (*
       eapply (reduce_law_r _ _ y).
       repeat rewrite <- associative_law.
       rewrite inverse_l.
       rewrite identity_r.
       *)
    l_to_r x.
    (*
       eapply (reduce_law_r _ _ x).
       repeat rewrite <- associative_law.
       rewrite inverse_l.
       *)
    repeat rewrite associative_law.
    apply H.
  Qed.

  (* 命題 2.1.10 (1) *) (* 単位元の唯一性 *)
  Theorem identity_uniqueness :
    forall x E',
      E' ** x = x -> E' = E.
  Proof.
    intros.
    eapply (reduce_law_r _ _ x).
    rewrite (identity_l x).
    apply H.
  Qed.

  (* 命題 2.1.10 (2) *) (* 逆元の一意性 *)
  Goal forall b b',
    b ** b' = E -> b' = Inv b.
  Proof.
    intros.
    eapply (reduce_law_l b _ _).
    rewrite inverse_r.
    apply H.
  Qed.

  (* 命題 2.1.10 (3) *)
  Theorem inv_inv:
    forall a b,
      (Inv b) ** (Inv a) = Inv (a ** b).
  Proof.
    assert (forall a b, (Inv b) ** (Inv a) ** a ** b = E).
    intros.
    r_to_l b.
    (*
       apply (reduce_law_l b _ _).
       repeat rewrite associative_law.
       rewrite inverse_r.
       rewrite identity_l.
       *)
    rewrite identity_r.
    r_to_l a.
    (*
       apply (reduce_law_l a _ _).
       repeat rewrite associative_law.
       rewrite inverse_r.
       rewrite identity_l.
       *)
    reflexivity.
    (* END assert *)

    intros.
    apply (reduce_law_r _ _ (a ** b)).
    rewrite (inverse_l (a ** b)).
    repeat rewrite associative_law.
    eapply H.
  Qed.

  (* 命題 2.1.10 (4) *)
  Axiom inverse_inverse :
    forall x, Inv (Inv x) = x.
End Group.

(* 群 G *)
Variable G : Set.
(* 演算子 *)
Variable AppG : G -> G -> G.
Infix "**" := AppG (at level 61, left associativity).
(* 定義 2.1.1 (1) *) (* 単位元 *)
Variable EG : G.
(* 定義 2.1.1 (2) *) (* 逆元 *)
Variable InvG : G -> G.
(* 公理や定理 *)
Let identity_g_r := identity_r G AppG EG.
Let identity_g_l := identity_l G AppG EG.
Check identity_g_l.
Let inverse_g_r := inverse_r G AppG EG InvG.
Let inverse_g_l := inverse_l G AppG EG InvG.
Check inverse_g_l.
Let associative_g_law := associative_law G AppG.
Let right_law_g := right_law G AppG.
Let left_law_g := left_law G AppG.
Let reduce_law_g_r :=  reduce_law_r G AppG EG InvG.
Let reduce_law_g_l :=  reduce_law_l G AppG EG InvG.
Check reduce_law_g_l.
Let inv_inv_g := inv_inv G AppG EG InvG.

(* 群 H *)
Variable H : Set.
Variable AppH : H -> H -> H.
Infix "++" := AppH (at level 61, left associativity).
Variable EH : H.
Variable InvH : H -> H.
Let identity_h_r := identity_r H AppH EH.
Let identity_h_l := identity_l H AppH EH.
Check identity_h_l.
Let inverse_h_r := inverse_r H AppH EH InvH.
Let inverse_h_l := inverse_l H AppH EH InvH.
Check inverse_h_l.
Let associative_h_law := associative_law H AppH.
Let right_law_h := right_law H AppH.
Let left_law_h := left_law H AppH.
Let reduce_law_h_r :=  reduce_law_r H AppH EH InvH.
Let reduce_law_h_l :=  reduce_law_l H AppH EH InvH.

(* phi : G -> H が群の準同型写像 *)
Variable phi : G -> H.

Axiom homomorphism_phi :
  forall a b : G, phi (a ** b) = (phi a) ++ (phi b).

(* 命題 2.5.2 *)
(* 全単射写像 phi : G -> H が群の準同型写像なら、GとHは同型である *)

(* phi が全単射なら、phi は単射である。 *)
Axiom injective_phi :
  forall a b, (phi a) = (phi b) -> a = b.

(* phi が全単射なら、逆写像 psi が存在する *)
Variable psi : H -> G.
Axiom inverse_phi :
  forall x, phi (psi x) = x.

(* 逆写像 psi は準同型写像である。 *)
Lemma t_2_5_2 :
  forall x y,
    (psi x) ** (psi y) = psi (x ++ y).
Proof.
  intros.
  apply injective_phi.
  rewrite inverse_phi.
  rewrite homomorphism_phi.
  rewrite inverse_phi.
  rewrite inverse_phi.
  reflexivity.
Qed.
(*
   題意から、phi : G -> H は準同型写像である。
   Lemma t_2_5_2から、phiの逆写像 psi : H -> G は準同型写像である。
   写像とその逆写像の両方が準同型写像であるので、G と H は同型である。
   *)

Theorem homomorphism_phi_identity :
  phi EG = EH.
Proof.
  eapply (reduce_law_h_r _ _ (phi EG)).
  rewrite identity_h_l.
  rewrite <- homomorphism_phi.
  rewrite identity_g_l.
  reflexivity.
Qed.

(* 命題 2.5.3 (2) *)
Theorem homomorphism_phi_inverse :
  forall x, phi (InvG x) = InvH (phi x).
Proof.
  intros.
  eapply (reduce_law_h_r _ _ (phi x)).
  rewrite inverse_h_l.
  rewrite <- homomorphism_phi.
  rewrite inverse_g_l.
  apply homomorphism_phi_identity.
Qed.

(* Img(phi) = {(phi x) | x : G} は、Hの(部分)群である *)
Goal forall x y, exists z,
  (phi x) ++ (phi y) = phi z.
Proof.
  intros.
  exists (x ** y).
  rewrite <- homomorphism_phi.
  reflexivity.
Qed.

Goal forall x, exists y,
  InvH (phi x) = phi y.
Proof.
  intros.
  exists (InvG x).
  rewrite <- homomorphism_phi_inverse.
  reflexivity.
Qed.

(* 恒等写像は、準同型写像である *)
Variable IdG : G -> G.
Axiom Identity_function : forall a, a = IdG a.

Goal forall x y : G, (IdG x) ** (IdG y) = IdG (x ** y).
Proof.
  intros.
  repeat (rewrite <- Identity_function).
  reflexivity.
Qed.

(* 群GからGへの同型写像をGの自己同型写像とよぶ。その集合をAut(G)で表す。
   恒等写像は同型写像であるから、自己同型写像である。IdG∈Aut(G)。
   同型写像と同型写像の合成の演算を @@ とおく。
   自己同型写像は @@ に対して閉じている（同型でなくても閉じているから）。
   自己同型写像の集合 Aut(G) は、IdG を単位元とした群である。
*)

(* 命題 2.5.17 *)
(* Tht : G -> Aut(G) を下記のとおり定義する。
   （g∈Gに対して、(Tht g)∈Aut(G)である）
   任意のgが固定されたとき、(Tht g)は、群Gの自己同型写像であることを示す。
   *)

Variable Tht : G -> (G -> G).               (* G -> Aut(G) *)
Axiom define_tht :
  forall g h : G, Tht g h = g ** h ** (InvG g).

Lemma p2_5_17 : forall g h1 h2 : G,
  Tht g (h1 ** h2) = (Tht g h1) ** (Tht g h2).
Proof.
  intros.
  repeat (rewrite define_tht).
  repeat (rewrite associative_g_law).
  rewrite <- associative_g_law at 1.
  (* rewriteはできるところはすべてrewriteするので、最初のところだけに限定する。 *)
  rewrite <- (identity_g_l (h2 ** InvG g)).
  rewrite <- (inverse_g_l g).
  repeat (rewrite associative_g_law).
  reflexivity.
Qed.

(* 命題 2.5.22 *)
(* Tht : G -> Aut(G) を上記のとおり定義する。
   （g∈Gに対して、(Tht g)∈Aut(G)である）
   Thtは、群Gから群Aut(G)への準同型写像であることを示す。
   ただし、群Aut(G)の積は、写像の合成（以下のDot）で定義する。
*)

Variable Dot : (G -> G) -> (G -> G) -> (G -> G).
Infix "@@" := Dot (at level 51, right associativity).
Axiom define_dot :
  forall f g : G -> G,
    forall x : G, (f @@ g) x = f (g x).

Lemma p2_5_22 : forall g1 g2 h : G,
  ((Tht g1) @@ (Tht g2)) h = Tht (g1 ** g2) h.
Proof.
  intros.
  rewrite define_dot.
  repeat (rewrite define_tht).
  rewrite <- inv_inv_g.
  repeat (rewrite associative_g_law).
  reflexivity.
Qed.

(* END *)


Section Ejercicio3.
Variable A B C: Set.

End Ejercicio3.

Section Ejercicio4.
Variable A: Set.

Definition id := ....

Theorem e4 : forall x:A, ...
Proof.

Qed.

End Ejercicio4.

Section Ejercicio5.

(* 5.1 *)
Definition opI (A : Set) (x : A) := x.

Definition opK ...

Definition opS ...

(* 5.2 *)
(* Para formalizar el siguiente lema, determine los tipos ?1 ... ?8 adecuados *)
Lemma e52 : forall A B : Set, opS ?1 ?2 ?3 (opK ?4 ?5) (opK ?6 ?7) = opI ?8.
Proof.

Qed.

End Ejercicio5.

Section Ejercicio6.
Definition N := forall X : Set, X -> (X -> X) -> X.
Definition Zero (X : Set) (o : X) (f : X -> X) := o.
Definition Uno  (X : Set) (o : X) (f : X -> X) := f (Zero X o f).

(* 6.1 *)
Definition Dos  ...

(* 6.2 *)
Definition Succ ...

Lemma succUno : Succ Uno = Dos.
Proof.

Qed.

(* 6.3 *)
Definition Plus (n m : N) : N
                := fun (X : Set) (o : X) (f : X -> X) => n X (m X o f) f.

Infix "++" := Plus (left associativity, at level 94).

Lemma suma1: (Uno ++ Zero) = Uno.
Proof.

Qed.

Lemma suma2: (Uno ++ Uno) = Dos.
Proof.

Qed.

(* 6.4 *)
Definition Prod (n m : N) : N
                := fun (X:Set) (o:X) (f:X->X) => m X o (fun y:X => n X y f).

Infix "**" := ...

(* 6.5 *)
Lemma prod1 : (Uno ** Zero) = Zero.
Proof.

Qed.

Lemma prod2: (Uno ** Dos) = Dos.
Proof.

Qed.

End Ejercicio6.

Section Ejercicio7.
(* 7.1 *)
Definition Bool := ...
Definition t    := ...
Definition f    := ...

(* 7.2 *)
Definition If ...

(* 7.3 *)
Definition Not ...

Lemma CorrecNot : (Not t) = f /\ (Not f) = t.
Proof.

Qed.

(* 7.4 *)
Definition And ...

Definition And' ...

(* 7.5 *)
Infix "&" := ...

Lemma CorrecAnd : (t & t) = t /\ (f & t) = f /\ (t & f) = f.
Proof.

Qed.

End Ejercicio7.

(* Ejercicio8 *)

Section ArrayNat.
Parameter ArrayNat : forall n:nat, Set.
Parameter empty    : ArrayNat 0.
Parameter add      : forall n:nat, nat -> ArrayNat n -> ArrayNat (n + 1).

(* 8.1 *)

(* 8.2 *)

(* 8.3 *)
Parameter Concat : ...

(* 8.4 *)
Parameter Zip : ...

(* 8.5 *)

(* 8.6 *)
Parameter Array' : ...
Parameter empty' : ...
Parameter add'   : ...
Parameter Zip'   : ...

(* 8.7 *)
Parameter ArrayBool : ...

End ArrayNat.

Section Ejercicio9.
...
End Ejercicio9.

Section Ejercicio10.

Parameter Array : Set -> nat -> Set.
Parameter emptyA : forall X : Set, Array X 0.
Parameter addA : forall (X : Set) (n : nat), X -> Array X n -> Array X (S n).

Parameter Matrix : Set -> nat -> Set.
Parameter emptyM : ...
Parameter addM : ...

Definition M1 := ... (* matriz de una columna *)
Definition M2 := ... (* matriz de dos columnas *)
Definition M3 := ... (* matriz de tres columnas *)

Check M3.

End Ejercicio10.

Section Ejercicio11.
...
End Ejercicio11.

Section Ejercicio12.
...
End Ejercicio12.

Section Ejercicio13.
Variable A B C: Set.

Lemma e13_1 : (A -> B -> C) -> B -> A -> C.
Proof.

Qed.

Lemma e13_2 : (A -> B) -> (B -> C) -> A -> C.
Proof.

Qed.

Lemma e13_3 : (A -> B -> C) -> (B -> A) -> B -> C.
Proof.

Qed.

End Ejercicio13.

Section Ejercicio14.
Variable A B C: Prop.

Lemma Ej314_1 : (A -> B -> C) -> A -> (A -> C) -> B -> C.
Proof.
  intros f a g b.
        ...
Qed.

Lemma Ej314_2 : A -> ~ ~ A.
Proof.
  unfold not.
  intros.
     ...
Qed.

Lemma Ej314_3 : (A -> B -> C) -> A -> B -> C.
Proof.
     ...
Qed.

Lemma Ej314_4 : (A -> B) -> ~ (A /\ ~ B).
Proof.
  unfold not.
  intros.
  elim H0; intros.
     ...
Qed.

End Ejercicio14.

Section Ejercicio15.

Variable U : Set.
Variable e : U.
Variable A B : U -> Prop.
Variable P : Prop.
Variable R : U -> U -> Prop.

Lemma Ej315_1 : (forall x : U, A x -> B x) -> (forall x : U, A x) ->
forall x : U, B x.
Proof.
  intros.
   ...
Qed.

Lemma Ej315_2 : forall x : U, A x -> ~ (forall x : U, ~ A x).
Proof.
  unfold not.
  intros.
  ...
Qed.

Lemma Ej315_3 : (forall x : U, P -> A x) -> P -> forall x : U, A x.
Proof.
    ...
Qed.

Lemma Ej315_4 : (forall x y : U, R x y) -> forall x : U, R x x.
Proof.
     ...
Qed.

Lemma Ej315_5 : (forall x y: U, R x y -> R y x) ->
                 forall z : U, R e z -> R z e.
Proof.
     ...
Qed.

End Ejercicio15.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path fintype.

(******************************************************************************)
(* This file develops the theory of finite graphs represented by an "edge"    *)
(* relation over a finType T; this mainly amounts to the theory of the        *)
(* transitive closure of such relations.                                      *)
(*   For g : T -> seq T, e : rel T and f : T -> T we define:                  *)
(*         grel g == the adjacency relation y \in g x of the graph g.         *)
(*       rgraph e == the graph (x |-> enum (e x)) of the relation e.          *)
(*    dfs g n v x == the list of points traversed by a depth-first search of  *)
(*                   the g, at depth n, starting from x, and avoiding v.      *)
(* dfs_path g v x y <-> there is a path from x to y in g \ v.                 *)
(*      connect e == the transitive closure of e (computed by dfs).           *)
(*  connect_sym e <-> connect e is symmetric, hence an equivalence relation.  *)
(*       root e x == a representative of connect e x, which is the component  *)
(*                   of x in the transitive closure of e.                     *)
(*        roots e == the codomain predicate of root e.                        *)
(*     n_comp e a == the number of e-connected components of a, when a is     *)
(*                   e-closed and connect e is symmetric.                     *)
(*                   equivalence classes of connect e if connect_sym e holds. *)
(*     closed e a == the collective predicate a is e-invariant.               *)
(*    closure e a == the e-closure of a (the image of a under connect e).     *)
(* rel_adjunction h e e' a <-> in the e-closed domain a, h is the left part   *)
(*                   of an adjunction from e to another relation e'.          *)
(*     fconnect f == connect (frel f), i.e., "connected under f iteration".   *)
(*      froot f x == root (frel f) x, the root of the orbit of x under f.     *)
(*       froots f == roots (frel f) == orbit representatives for f.           *)
(*      orbit f x == lists the f-orbit of x.                                  *)
(*   findex f x y == index of y in the f-orbit of x.                          *)
(*      order f x == size (cardinal) of the f-orbit of x.                     *)
(*  order_set f n == elements of f-order n.                                   *)
(*         finv f == the inverse of f, if f is injective.                     *)
(*                := finv f x := iter (order x).-1 f x.                       *)
(*      fcard f a == number of orbits of f in a, provided a is f-invariant    *)
(*                   f is one-to-one.                                         *)
(*    fclosed f a == the collective predicate a is f-invariant.               *)
(*   fclosure f a == the closure of a under f iteration.                      *)
(* fun_adjunction == rel_adjunction (frel f).                                 *)
(******************************************************************************)

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

Definition grel (T : eqType) (g : T -> seq T) := [rel x y | y \in g x].

(* Decidable connectivity in finite types.                                  *)
Section Connect.

Variable T : finType.

Section Dfs.

Variable g : T -> seq T.
Implicit Type v w a : seq T.

Fixpoint dfs n v x :=
  if x \in v then v else
  if n is n'.+1 then foldl (dfs n') (x :: v) (g x) else v.

Lemma subset_dfs n v a : v \subset foldl (dfs n) v a.
Proof.
elim: n a v => [|n IHn]; first by elim=> //= *; rewrite if_same.
elim=> //= x a IHa v; apply: subset_trans {IHa}(IHa _); case: ifP => // _.
by apply: subset_trans (IHn _ _); apply/subsetP=> y; exact: predU1r.
Qed.

Inductive dfs_path v x y : Prop :=
  DfsPath p of path (grel g) x p & y = last x p & [disjoint x :: p & v].

Lemma dfs_pathP n x y v :
  #|T| <= #|v| + n -> y \notin v -> reflect (dfs_path v x y) (y \in dfs n v x).
Proof.
have dfs_id w z: z \notin w -> dfs_path w z z.
  by exists [::]; rewrite ?disjoint_has //= orbF.
elim: n => [|n IHn] /= in x y v * => le_v'_n not_vy.
  rewrite addn0 (geq_leqif (subset_leqif_card (subset_predT _))) in le_v'_n.
  by rewrite predT_subset in not_vy.
have [v_x | not_vx] := ifPn.
  by rewrite (negPf not_vy); right=> [] [p _ _]; rewrite disjoint_has /= v_x.
set v1 := x :: v; set a := g x; have sub_dfs := subsetP (subset_dfs n _ _).
have [-> | neq_yx] := eqVneq y x.
  by rewrite sub_dfs ?mem_head //; left; exact: dfs_id.
apply: (@equivP (exists2 x1, x1 \in a & dfs_path v1 x1 y)); last first.
  split=> {IHn} [[x1 a_x1 [p g_p p_y]] | [p /shortenP[]]].
    rewrite disjoint_has has_sym /= has_sym /= => /norP[_ not_pv].
    by exists (x1 :: p); rewrite /= ?a_x1 // disjoint_has negb_or not_vx.
  case=> [_ _ _ eq_yx | x1 p1 /=]; first by case/eqP: neq_yx.
  case/andP=> a_x1 g_p1 /andP[not_p1x _] /subsetP p_p1 p1y not_pv.
  exists x1 => //; exists p1 => //.
  rewrite disjoint_sym disjoint_cons not_p1x disjoint_sym.
  by move: not_pv; rewrite disjoint_cons => /andP[_ /disjoint_trans->].
have{neq_yx not_vy}: y \notin v1 by exact/norP.
have{le_v'_n not_vx}: #|T| <= #|v1| + n by rewrite cardU1 not_vx addSnnS.
elim: {x v}a v1 => [|x a IHa] v /= le_v'_n not_vy.
  by rewrite (negPf not_vy); right=> [] [].
set v2 := dfs n v x; have v2v: v \subset v2 := subset_dfs n v [:: x].
have [v2y | not_v2y] := boolP (y \in v2).
  by rewrite sub_dfs //; left; exists x; [exact: mem_head | exact: IHn].
apply: {IHa}(equivP (IHa _ _ not_v2y)).
  by rewrite (leq_trans le_v'_n) // leq_add2r subset_leq_card.
split=> [] [x1 a_x1 [p g_p p_y not_pv]].
  exists x1; [exact: predU1r | exists p => //].
  by rewrite disjoint_sym (disjoint_trans v2v) // disjoint_sym.
suffices not_p1v2: [disjoint x1 :: p & v2].
  case/predU1P: a_x1 => [def_x1 | ]; last by exists x1; last exists p.
  case/pred0Pn: not_p1v2; exists x; rewrite /= def_x1 mem_head /=.
  suffices not_vx: x \notin v by apply/IHn; last exact: dfs_id.
  by move: not_pv; rewrite disjoint_cons def_x1 => /andP[].
apply: contraR not_v2y => /pred0Pn[x2 /andP[/= p_x2 v2x2]].
case/splitPl: p_x2 p_y g_p not_pv => p0 p2 p0x2.
rewrite last_cat cat_path -cat_cons lastI cat_rcons {}p0x2 => p2y /andP[_ g_p2].
rewrite disjoint_cat disjoint_cons => /and3P[{p0}_ not_vx2 not_p2v].
have{not_vx2 v2x2} [p1 g_p1 p1_x2 not_p1v] := IHn _ _ v le_v'_n not_vx2 v2x2.
apply/IHn=> //; exists (p1 ++ p2); rewrite ?cat_path ?last_cat -?p1_x2 ?g_p1 //.
by rewrite -cat_cons disjoint_cat not_p1v.
Qed.

Lemma dfsP x y :
  reflect (exists2 p, path (grel g) x p & y = last x p) (y \in dfs #|T| [::] x).
Proof.
apply: (iffP (dfs_pathP _ _ _)); rewrite ?card0 // => [] [p]; exists p => //.
by rewrite disjoint_sym disjoint0.
Qed.

End Dfs.

Variable e : rel T.

Definition rgraph x := enum (e x).

Lemma rgraphK : grel rgraph =2 e.
Proof. by move=> x y; rewrite /= mem_enum. Qed.

Definition connect : rel T := fun x y => y \in dfs rgraph #|T| [::] x.
Canonical connect_app_pred x := ApplicativePred (connect x).

Lemma connectP x y :
  reflect (exists2 p, path e x p & y = last x p) (connect x y).
Proof.
apply: (equivP (dfsP _ x y)).
by split=> [] [p e_p ->]; exists p => //; rewrite (eq_path rgraphK) in e_p *.
Qed.

Lemma connect_trans : transitive connect.
Proof.
move=> x y z /connectP[p e_p ->] /connectP[q e_q ->]; apply/connectP.
by exists (p ++ q); rewrite ?cat_path ?e_p ?last_cat.
Qed.

Lemma connect0 x : connect x x.
Proof. by apply/connectP; exists [::]. Qed.

Lemma eq_connect0 x y : x = y -> connect x y.
Proof. move->; exact: connect0. Qed.

Lemma connect1 x y : e x y -> connect x y.
Proof. by move=> e_xy; apply/connectP; exists [:: y]; rewrite /= ?e_xy. Qed.

Lemma path_connect x p : path e x p -> subpred (mem (x :: p)) (connect x).
Proof.
move=> e_p y p_y; case/splitPl: p / p_y e_p => p q <-.
by rewrite cat_path => /andP[e_p _]; apply/connectP; exists p.
Qed.

Definition root x := odflt x (pick (connect x)).

Definition roots : pred T := fun x => root x == x.
Canonical roots_pred := ApplicativePred roots.

Definition n_comp_mem (m_a : mem_pred T) := #|predI roots m_a|.

Lemma connect_root x : connect x (root x).
Proof. by rewrite /root; case: pickP; rewrite ?connect0. Qed.

Definition connect_sym := symmetric connect.

Hypothesis sym_e : connect_sym.

Lemma same_connect : left_transitive connect.
Proof. exact: sym_left_transitive connect_trans. Qed.

Lemma same_connect_r : right_transitive connect.
Proof. exact: sym_right_transitive connect_trans. Qed.

Lemma same_connect1 x y : e x y -> connect x =1 connect y.
Proof. by move/connect1; exact: same_connect. Qed.

Lemma same_connect1r x y : e x y -> connect^~ x =1 connect^~ y.
Proof. by move/connect1; exact: same_connect_r. Qed.

Lemma rootP x y : reflect (root x = root y) (connect x y).
Proof.
apply: (iffP idP) => e_xy.
  by rewrite /root -(eq_pick (same_connect e_xy)); case: pickP e_xy => // ->.
by apply: (connect_trans (connect_root x)); rewrite e_xy sym_e connect_root.
Qed.

Lemma root_root x : root (root x) = root x.
Proof. exact/esym/rootP/connect_root. Qed.

Lemma roots_root x : roots (root x).
Proof. exact/eqP/root_root. Qed.

Lemma root_connect x y : (root x == root y) = connect x y.
Proof. exact: sameP eqP (rootP x y). Qed.

Definition closed_mem m_a := forall x y, e x y -> in_mem x m_a = in_mem y m_a.

Definition closure_mem m_a : pred T :=
  fun x => ~~ disjoint (mem (connect x)) m_a.

End Connect.

Hint Resolve connect0.

Notation n_comp e a := (n_comp_mem e (mem a)).
Notation closed e a := (closed_mem e (mem a)).
Notation closure e a := (closure_mem e (mem a)).

Prenex Implicits connect root roots.

Implicit Arguments dfsP [T g x y].
Implicit Arguments connectP [T e x y].
Implicit Arguments rootP [T e x y].

Notation fconnect f := (connect (coerced_frel f)).
Notation froot f := (root (coerced_frel f)).
Notation froots f := (roots (coerced_frel f)).
Notation fcard_mem f := (n_comp_mem (coerced_frel f)).
Notation fcard f a := (fcard_mem f (mem a)).
Notation fclosed f a := (closed (coerced_frel f) a).
Notation fclosure f a := (closure (coerced_frel f) a).

Section EqConnect.

Variable T : finType.
Implicit Types (e : rel T) (a : pred T).

Lemma connect_sub e e' :
  subrel e (connect e') -> subrel (connect e) (connect e').
Proof.
move=> e'e x _ /connectP[p e_p ->]; elim: p x e_p => //= y p IHp x /andP[exy].
by move/IHp; apply: connect_trans; exact: e'e.
Qed.

Lemma relU_sym e e' :
  connect_sym e -> connect_sym e' -> connect_sym (relU e e').
Proof.
move=> sym_e sym_e'; apply: symmetric_from_pre => x _ /connectP[p e_p ->].
elim: p x e_p => //= y p IHp x /andP[e_xy /IHp{IHp}/connect_trans]; apply.
case/orP: e_xy => /connect1; rewrite (sym_e, sym_e');
  by apply: connect_sub y x => x y e_xy; rewrite connect1 //= e_xy ?orbT.
Qed.

Lemma eq_connect e e' : e =2 e' -> connect e =2 connect e'.
Proof.
move=> eq_e x y; apply/connectP/connectP=> [] [p e_p ->];
  by exists p; rewrite // (eq_path eq_e) in e_p *.
Qed.

Lemma eq_n_comp e e' : connect e =2 connect e' -> n_comp_mem e =1 n_comp_mem e'.
Proof.
move=> eq_e [a]; apply: eq_card => x /=.
by rewrite !inE /= /roots /root /= (eq_pick (eq_e x)).
Qed.

Lemma eq_n_comp_r {e} a a' : a =i a' -> n_comp e a = n_comp e a'.
Proof. by move=> eq_a; apply: eq_card => x; rewrite inE /= eq_a. Qed.

Lemma n_compC a e : n_comp e T = n_comp e a + n_comp e [predC a].
Proof.
rewrite /n_comp_mem (eq_card (fun _ => andbT _)) -(cardID a); congr (_ + _).
by apply: eq_card => x; rewrite !inE andbC.
Qed.

Lemma eq_root e e' : e =2 e' -> root e =1 root e'.
Proof. by move=> eq_e x; rewrite /root (eq_pick (eq_connect eq_e x)). Qed.

Lemma eq_roots e e' : e =2 e' -> roots e =1 roots e'.
Proof. by move=> eq_e x; rewrite /roots (eq_root eq_e). Qed.

End EqConnect.

Section Closure.

Variables (T : finType) (e : rel T).
Hypothesis sym_e : connect_sym e.
Implicit Type a : pred T.

Lemma same_connect_rev : connect e =2 connect (fun x y => e y x).
Proof.
suff crev e': subrel (connect (fun x : T => e'^~ x)) (fun x => (connect e')^~x).
  by move=> x y; rewrite sym_e; apply/idP/idP; exact: crev.
move=> x y /connectP[p e_p p_y]; apply/connectP.
exists (rev (belast x p)); first by rewrite p_y rev_path.
by rewrite -(last_cons x) -rev_rcons p_y -lastI rev_cons last_rcons.
Qed.

Lemma intro_closed a : (forall x y, e x y -> x \in a -> y \in a) -> closed e a.
Proof.
move=> cl_a x y e_xy; apply/idP/idP=> [|a_y]; first exact: cl_a.
have{x e_xy} /connectP[p e_p ->]: connect e y x by rewrite sym_e connect1.
by elim: p y a_y e_p => //= y p IHp x a_x /andP[/cl_a/(_ a_x)]; exact: IHp.
Qed.

Lemma closed_connect a :
  closed e a -> forall x y, connect e x y -> (x \in a) = (y \in a).
Proof.
move=> cl_a x _ /connectP[p e_p ->].
by elim: p x e_p => //= y p IHp x /andP[/cl_a->]; exact: IHp.
Qed.

Lemma connect_closed x : closed e (connect e x).
Proof. by move=> y z /connect1/same_connect_r; exact. Qed.

Lemma predC_closed a : closed e a -> closed e [predC a].
Proof. by move=> cl_a x y /cl_a; rewrite !inE => ->. Qed.

Lemma closure_closed a : closed e (closure e a).
Proof.
apply: intro_closed => x y /connect1 e_xy; congr (~~ _).
by apply: eq_disjoint; exact: same_connect.
Qed.

Lemma mem_closure a : {subset a <= closure e a}.
Proof. by move=> x a_x; apply/existsP; exists x; rewrite !inE connect0. Qed.

Lemma subset_closure a : a \subset closure e a.
Proof. by apply/subsetP; exact: mem_closure. Qed.

Lemma n_comp_closure2 x y :
  n_comp e (closure e (pred2 x y)) = (~~ connect e x y).+1.
Proof.
rewrite -(root_connect sym_e) -card2; apply: eq_card => z.
apply/idP/idP=> [/andP[/eqP {2}<- /pred0Pn[t /andP[/= ezt exyt]]] |].
  by case/pred2P: exyt => <-; rewrite (rootP sym_e ezt) !inE eqxx ?orbT.
by case/pred2P=> ->; rewrite !inE roots_root //; apply/existsP;
  [exists x | exists y]; rewrite !inE eqxx ?orbT sym_e connect_root.
Qed.

Lemma n_comp_connect x : n_comp e (connect e x) = 1.
Proof.
rewrite -(card1 (root e x)); apply: eq_card => y.
apply/andP/eqP => [[/eqP r_y /rootP-> //] | ->] /=.
by rewrite inE connect_root roots_root.
Qed.

End Closure.

Section Orbit.

Variables (T : finType) (f : T -> T).

Definition order x := #|fconnect f x|.

Definition orbit x := traject f x (order x).

Definition findex x y := index y (orbit x).

Definition finv x := iter (order x).-1 f x.

Lemma fconnect_iter n x : fconnect f x (iter n f x).
Proof.
apply/connectP.
by exists (traject f (f x) n); [ exact: fpath_traject | rewrite last_traject ].
Qed.

Lemma fconnect1 x : fconnect f x (f x).
Proof. exact: (fconnect_iter 1). Qed.

Lemma fconnect_finv x : fconnect f x (finv x).
Proof. exact: fconnect_iter. Qed.

Lemma orderSpred x : (order x).-1.+1 = order x.
Proof. by rewrite /order (cardD1 x) [_ x _]connect0. Qed.

Lemma size_orbit x : size (orbit x) = order x.
Proof. exact: size_traject. Qed.

Lemma looping_order x : looping f x (order x).
Proof.
apply: contraFT (ltnn (order x)); rewrite -looping_uniq => /card_uniqP.
rewrite size_traject => <-; apply: subset_leq_card.
by apply/subsetP=> _ /trajectP[i _ ->]; exact: fconnect_iter.
Qed.

Lemma fconnect_orbit x y : fconnect f x y = (y \in orbit x).
Proof.
apply/idP/idP=> [/connectP[_ /fpathP[m ->] ->] | /trajectP[i _ ->]].
  by rewrite last_traject; exact/loopingP/looping_order.
exact: fconnect_iter.
Qed.

Lemma orbit_uniq x : uniq (orbit x).
Proof.
rewrite /orbit -orderSpred looping_uniq; set n := (order x).-1.
apply: contraFN (ltnn n) => /trajectP[i lt_i_n eq_fnx_fix].
rewrite {1}/n orderSpred /order -(size_traject f x n).
apply: (leq_trans (subset_leq_card _) (card_size _)); apply/subsetP=> z.
rewrite inE fconnect_orbit => /trajectP[j le_jn ->{z}].
rewrite -orderSpred -/n ltnS leq_eqVlt in le_jn.
by apply/trajectP; case/predU1P: le_jn => [->|]; [exists i | exists j].
Qed.

Lemma findex_max x y : fconnect f x y -> findex x y < order x.
Proof. by rewrite [_ y]fconnect_orbit -index_mem size_orbit. Qed.

Lemma findex_iter x i : i < order x -> findex x (iter i f x) = i.
Proof.
move=> lt_ix; rewrite -(nth_traject f lt_ix) /findex index_uniq ?orbit_uniq //.
by rewrite size_orbit.
Qed.

Lemma iter_findex x y : fconnect f x y -> iter (findex x y) f x = y.
Proof.
rewrite [_ y]fconnect_orbit => fxy; pose i := index y (orbit x).
have lt_ix: i < order x by rewrite -size_orbit index_mem.
by rewrite -(nth_traject f lt_ix) nth_index.
Qed.

Lemma findex0 x : findex x x = 0.
Proof. by rewrite /findex /orbit -orderSpred /= eqxx. Qed.

Lemma fconnect_invariant (T' : eqType) (k : T -> T') :
  invariant f k =1 xpredT -> forall x y, fconnect f x y -> k x = k y.
Proof.
move=> eq_k_f x y /iter_findex <-; elim: {y}(findex x y) => //= n ->.
by rewrite (eqP (eq_k_f _)).
Qed.

Section Loop.

Variable p : seq T.
Hypotheses (f_p : fcycle f p) (Up : uniq p).
Variable x : T.
Hypothesis p_x : x \in p.

(* This lemma does not depend on Up : (uniq p) *)
Lemma fconnect_cycle y : fconnect f x y = (y \in p).
Proof.
have [i q def_p] := rot_to p_x; rewrite -(mem_rot i p) def_p.
have{i def_p} /andP[/eqP q_x f_q]: (f (last x q) == x) && fpath f x q.
  by have:= f_p; rewrite -(rot_cycle i) def_p (cycle_path x).
apply/idP/idP=> [/connectP[_ /fpathP[j ->] ->] | ]; last exact: path_connect.
case/fpathP: f_q q_x => n ->; rewrite !last_traject -iterS => def_x.
by apply: (@loopingP _ f x n.+1); rewrite /looping def_x /= mem_head.
Qed.

Lemma order_cycle : order x = size p.
Proof. by rewrite -(card_uniqP Up); exact (eq_card fconnect_cycle). Qed.

Lemma orbit_rot_cycle : {i : nat | orbit x = rot i p}.
Proof.
have [i q def_p] := rot_to p_x; exists i.
rewrite /orbit order_cycle -(size_rot i) def_p.
suffices /fpathP[j ->]: fpath f x q by rewrite /= size_traject.
by move: f_p; rewrite -(rot_cycle i) def_p (cycle_path x); case/andP.
Qed.

End Loop.

Hypothesis injf : injective f.

Lemma f_finv : cancel finv f.
Proof.
move=> x; move: (looping_order x) (orbit_uniq x).
rewrite /looping /orbit -orderSpred looping_uniq /= /looping; set n := _.-1.
case/predU1P=> // /trajectP[i lt_i_n]; rewrite -iterSr => /= /injf ->.
by case/trajectP; exists i.
Qed.

Lemma finv_f : cancel f finv.
Proof. exact (inj_can_sym f_finv injf). Qed.

Lemma fin_inj_bij : bijective f.
Proof. exists finv; [ exact finv_f | exact f_finv ]. Qed.

Lemma finv_bij : bijective finv.
Proof. exists f; [ exact f_finv | exact finv_f ]. Qed.

Lemma finv_inj : injective finv.
Proof. exact (can_inj f_finv). Qed.

Lemma fconnect_sym x y : fconnect f x y = fconnect f y x.
Proof.
suff{x y} Sf x y: fconnect f x y -> fconnect f y x by apply/idP/idP; auto.
case/connectP=> p f_p -> {y}; elim: p x f_p => //= y p IHp x.
rewrite -{2}(finv_f x) => /andP[/eqP-> /IHp/connect_trans-> //].
exact: fconnect_finv.
Qed.
Let symf := fconnect_sym.

Lemma iter_order x : iter (order x) f x = x.
Proof. by rewrite -orderSpred iterS; exact (f_finv x). Qed.

Lemma iter_finv n x : n <= order x -> iter n finv x = iter (order x - n) f x.
Proof.
rewrite -{2}[x]iter_order => /subnKC {1}<-; move: (_ - n) => m.
by rewrite iter_add; elim: n => // n {2}<-; rewrite iterSr /= finv_f.
Qed.

Lemma cycle_orbit x : fcycle f (orbit x).
Proof.
rewrite /orbit -orderSpred (cycle_path x) /= last_traject -/(finv x).
by rewrite fpath_traject f_finv andbT /=.
Qed.

Lemma fpath_finv x p : fpath finv x p = fpath f (last x p) (rev (belast x p)).
Proof.
elim: p x => //= y p IHp x; rewrite rev_cons rcons_path -{}IHp andbC /=.
rewrite (canF_eq finv_f) eq_sym; congr (_ && (_ == _)).
by case: p => //= z p; rewrite rev_cons last_rcons.
Qed.

Lemma same_fconnect_finv : fconnect finv =2 fconnect f.
Proof.
move=> x y; rewrite (same_connect_rev symf); apply: {x y}eq_connect => x y /=.
by rewrite (canF_eq finv_f) eq_sym.
Qed.

Lemma fcard_finv : fcard_mem finv =1 fcard_mem f.
Proof. exact: eq_n_comp same_fconnect_finv. Qed.

Definition order_set n : pred T := [pred x | order x == n].

Lemma fcard_order_set n (a : pred T) :
  a \subset order_set n -> fclosed f a -> fcard f a * n = #|a|.
Proof.
move=> a_n cl_a; rewrite /n_comp_mem; set b := [predI froots f & a].
symmetry; transitivity #|preim (froot f) b|.
  apply: eq_card => x; rewrite !inE (roots_root fconnect_sym).
  by rewrite -(closed_connect cl_a (connect_root _ x)).
have{cl_a a_n} (x): b x -> froot f x = x /\ order x = n.
  by case/andP=> /eqP-> /(subsetP a_n)/eqnP->.
elim: {a b}#|b| {1 3 4}b (eqxx #|b|) => [|m IHm] b def_m f_b.
  by rewrite eq_card0 // => x; exact: (pred0P def_m).
have [x b_x | b0] := pickP b; last by rewrite (eq_card0 b0) in def_m.
have [r_x ox_n] := f_b x b_x; rewrite (cardD1 x) [x \in b]b_x eqSS in def_m.
rewrite mulSn -{1}ox_n -(IHm _ def_m) => [|_ /andP[_ /f_b //]].
rewrite -(cardID (fconnect f x)); congr (_ + _); apply: eq_card => y.
  by apply: andb_idl => /= fxy; rewrite !inE -(rootP symf fxy) r_x.
by congr (~~ _ && _); rewrite /= /in_mem /= symf -(root_connect symf) r_x.
Qed.

Lemma fclosed1 (a : pred T) : fclosed f a -> forall x, (x \in a) = (f x \in a).
Proof. by move=> cl_a x; exact: cl_a (eqxx _). Qed.

Lemma same_fconnect1 x : fconnect f x =1 fconnect f (f x).
Proof. by apply: same_connect1 => /=. Qed.

Lemma same_fconnect1_r x y : fconnect f x y = fconnect f x (f y).
Proof. by apply: same_connect1r x => /=. Qed.

End Orbit.

Prenex Implicits order orbit findex finv order_set.

Section FconnectId.

Variable T : finType.

Lemma fconnect_id (x : T) : fconnect id x =1 xpred1 x.
Proof. by move=> y; rewrite (@fconnect_cycle _ _ [:: x]) //= ?inE ?eqxx. Qed.

Lemma order_id (x : T) : order id x = 1.
Proof. by rewrite /order (eq_card (fconnect_id x)) card1. Qed.

Lemma orbit_id (x : T) : orbit id x = [:: x].
Proof. by rewrite /orbit order_id. Qed.

Lemma froots_id (x : T) : froots id x.
Proof. by rewrite /roots -fconnect_id connect_root. Qed.

Lemma froot_id (x : T) : froot id x = x.
Proof. by apply/eqP; exact: froots_id. Qed.

Lemma fcard_id (a : pred T) : fcard id a = #|a|.
Proof. by apply: eq_card => x; rewrite inE froots_id. Qed.

End FconnectId.

Section FconnectEq.

Variables (T : finType) (f f' : T -> T).

Lemma finv_eq_can : cancel f f' -> finv f =1 f'.
Proof.
move=> fK; exact: (bij_can_eq (fin_inj_bij (can_inj fK)) (finv_f (can_inj fK))).
Qed.

Hypothesis eq_f : f =1 f'.
Let eq_rf := eq_frel eq_f.

Lemma eq_fconnect : fconnect f =2 fconnect f'.
Proof. exact: eq_connect eq_rf. Qed.

Lemma eq_fcard : fcard_mem f =1 fcard_mem f'.
Proof. exact: eq_n_comp eq_fconnect. Qed.

Lemma eq_finv : finv f =1 finv f'.
Proof.
by move=> x; rewrite /finv /order (eq_card (eq_fconnect x)) (eq_iter eq_f).
Qed.

Lemma eq_froot : froot f =1 froot f'.
Proof. exact: eq_root eq_rf. Qed.

Lemma eq_froots : froots f =1 froots f'.
Proof. exact: eq_roots eq_rf. Qed.

End FconnectEq.

Section FinvEq.

Variables (T : finType) (f : T -> T).
Hypothesis injf : injective f.

Lemma finv_inv : finv (finv f) =1 f.
Proof. exact: (finv_eq_can (f_finv injf)). Qed.

Lemma order_finv : order (finv f) =1 order f.
Proof. by move=> x; exact: eq_card (same_fconnect_finv injf x). Qed.

Lemma order_set_finv n : order_set (finv f) n =i order_set f n.
Proof. by move=> x; rewrite !inE order_finv. Qed.

End FinvEq.

Section RelAdjunction.

Variables (T T' : finType) (h : T' -> T) (e : rel T) (e' : rel T').
Hypotheses (sym_e : connect_sym e) (sym_e' : connect_sym e').

Record rel_adjunction_mem m_a := RelAdjunction {
  rel_unit x : in_mem x m_a -> {x' : T' | connect e x (h x')};
  rel_functor x' y' :
    in_mem (h x') m_a -> connect e' x' y' = connect e (h x') (h y')
}.

Variable a : pred T.
Hypothesis cl_a : closed e a.

Local Notation rel_adjunction := (rel_adjunction_mem (mem a)).

Lemma intro_adjunction (h' : forall x, x \in a -> T') :
   (forall x a_x,
      [/\ connect e x (h (h' x a_x))
        & forall y a_y, e x y -> connect e' (h' x a_x) (h' y a_y)]) ->
   (forall x' a_x,
      [/\ connect e' x' (h' (h x') a_x)
        & forall y', e' x' y' -> connect e (h x') (h y')]) ->
  rel_adjunction.
Proof.
move=> Aee' Ae'e; split=> [y a_y | x' z' a_x].
  by exists (h' y a_y); case/Aee': (a_y).
apply/idP/idP=> [/connectP[p e'p ->{z'}] | /connectP[p e_p p_z']].
  elim: p x' a_x e'p => //= y' p IHp x' a_x.
  case: (Ae'e x' a_x) => _ Ae'x /andP[/Ae'x e_xy /IHp e_yz] {Ae'x}.
  by apply: connect_trans (e_yz _); rewrite // -(closed_connect cl_a e_xy).
case: (Ae'e x' a_x) => /connect_trans-> //.
elim: p {x'}(h x') p_z' a_x e_p => /= [|y p IHp] x p_z' a_x.
  by rewrite -p_z' in a_x *; case: (Ae'e _ a_x); rewrite sym_e'.
case/andP=> e_xy /(IHp _ p_z') e'yz; have a_y: y \in a by rewrite -(cl_a e_xy).
by apply: connect_trans (e'yz a_y); case: (Aee' _ a_x) => _ ->.
Qed.

Lemma strict_adjunction :
    injective h -> a \subset codom h -> rel_base h e e' [predC a] ->
  rel_adjunction.
Proof.
move=> /= injh h_a a_ee'; pose h' x Hx := iinv (subsetP h_a x Hx).
apply: (@intro_adjunction h') => [x a_x | x' a_x].
  rewrite f_iinv connect0; split=> // y a_y e_xy.
  by rewrite connect1 // -a_ee' !f_iinv ?negbK.
rewrite [h' _ _]iinv_f //; split=> // y' e'xy.
by rewrite connect1 // a_ee' ?negbK.
Qed.

Let ccl_a := closed_connect cl_a.

Lemma adjunction_closed : rel_adjunction -> closed e' [preim h of a].
Proof.
case=> _ Ae'e; apply: intro_closed => // x' y' /connect1 e'xy a_x.
by rewrite Ae'e // in e'xy; rewrite !inE -(ccl_a e'xy).
Qed.

Lemma adjunction_n_comp :
  rel_adjunction -> n_comp e a = n_comp e' [preim h of a].
Proof.
case=> Aee' Ae'e.
have inj_h: {in predI (roots e') [preim h of a] &, injective (root e \o h)}.
  move=> x' y' /andP[/eqP r_x' /= a_x'] /andP[/eqP r_y' _] /(rootP sym_e).
  by rewrite -Ae'e // => /(rootP sym_e'); rewrite r_x' r_y'.
rewrite /n_comp_mem -(card_in_image inj_h); apply: eq_card => x.
apply/andP/imageP=> [[/eqP rx a_x] | [x' /andP[/eqP r_x' a_x'] ->]]; last first.
  by rewrite /= -(ccl_a (connect_root _ _)) roots_root.
have [y' e_xy]:= Aee' x a_x; pose x' := root e' y'.
have ay': h y' \in a by rewrite -(ccl_a e_xy).
have e_yx: connect e (h y') (h x') by rewrite -Ae'e ?connect_root.
exists x'; first by rewrite inE /= -(ccl_a e_yx) ?roots_root.
by rewrite /= -(rootP sym_e e_yx) -(rootP sym_e e_xy).
Qed.

End RelAdjunction.

Notation rel_adjunction h e e' a := (rel_adjunction_mem h e e' (mem a)).
Notation "@ 'rel_adjunction' T T' h e e' a" :=
  (@rel_adjunction_mem T T' h e e' (mem a))
  (at level 10, T, T', h, e, e', a at level 8, only parsing) : type_scope.
Notation fun_adjunction h f f' a := (rel_adjunction h (frel f) (frel f') a).
Notation "@ 'fun_adjunction' T T' h f f' a" :=
  (@rel_adjunction T T' h (frel f) (frel f') a)
  (at level 10, T, T', h, f, f', a at level 8, only parsing) : type_scope.

Implicit Arguments intro_adjunction [T T' h e e' a].
Implicit Arguments adjunction_n_comp [T T' e e' a].

Unset Implicit Arguments.


(**
「Coq/SSReflect/MathCompによる定理証明」第5章で導入された公理について
========================

@suharahiromichi

2020/12/26
 *)

(**
# はじめに

文献 [1.] （以下、テキストと呼びます）の第5章では集合形式化について説明されています。
そこでは、ふたつの公理が導入されています。

5章の冒頭に記載されているとおり、形式化の方法は一通りではないため、
別な公理や公理を導入しないで済ますことができないか、考えてたいと思います。
*)

From mathcomp Require Import all_ssreflect.

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

(**
# 集合の形式化（復習）

型 M の要素である元 x が、型Mの要素全体を母集合とする集合 A に属することを、
M型を引数とする命題型P （すなわち M -> Prop) の型をもつ命題によってあらわす
（テキストのことばでいうと「形式化」することにします。

なお、型Mは任意な型とします。あとで制限することになるので、注意しておいてください。
*)

Definition mySet (M : Type) := M -> Prop.
Definition belong {M : Type} (A : mySet M) (x : M) : Prop := A x.
Notation "x ∈ A" := (belong A x) (at level 11).

Definition myEmptySet {M : Type} : mySet M := fun (_ : M) => False.
Definition myMotherSet {M : Type} : mySet M := fun (_ : M) => True.

Definition mySub {M : Type} := fun (A B : mySet M) => forall (x : M), x ∈ A -> x ∈ B.
Notation "A ⊂ B" := (mySub A B) (at level 11).
Definition eqmySet {M : Type} (A B : mySet M) := (A ⊂ B) /\ (B ⊂ A).

Definition myComplement {M : Type} (A : mySet M) : mySet M := fun (x : M) => ~(A x).
Notation "A ^c" := (myComplement A) (at level 11).

Definition myCup {M : Type} (A B : mySet M) : mySet M := fun (x : M) => x ∈ A \/ x ∈ B.
Notation "A ∪ B" := (myCup A B) (at level 11).

(**
# CSMの第5章の公理

上記の集合の形式化の定義には問題がふたつあります。（要補足）

- 元xが集合Aに含まれることは言えても、含まれないと言えるとは限らない。

これは、Coqが採用する直観主義論理の立場から、命題が証明できればそれが真だといえます。
しかし、命題が証明できないと言い切ることができない（場合がある）ため、
偽であるとの証明ができない（できるとは限らない）からです。

- 集合AがBに含まれ、かつ、BがAに含まれることから、集合AとBが等しいことを証明できない。

これは、Coqの等号``=``は、ライプニッツの等式といって、
その型の(Inductiveな)定義に遡って「同じに見える」場合に限り成立します。

例 ``1 + 1 = 2`` は、``S (S O) = S (S O)``

この場合、集合AとBが等しいこと ``(A ⊂ B) /\ (B ⊂ A)``
は集合の帰納的な定義に基づくものでないため ``A = B`` というこができません。

結果として、テキストの本文にあるように、
「補集合の補集合がもとの集合になること」の証明ができません。
テキストではふたつの公理を導入することで解決しています。
ここでは、それぞれを「公理 1」「公理 2」と呼ぶことにします。
*)

(**
## (公理 1.) axiom_mySet

テキストの第5章に沿って、
「元xが集合Aに含まれるか、含まれないかのどちらかである」を公理として導入します。
 *)

Axiom axiom_mySet : forall (M : Type) (A : mySet M), forall (x : M), x ∈ A \/ ~(x ∈ A).

(**
## (公理 2.) axiom_ExteqmySet

テキストの第5章に沿って、集合AとBが等しいことを、
集合AがBに含まれ、かつ、BがAに含まれることとして定義します。
 *)

Axiom axiom_ExteqmySet : forall {M : Type} (A B : mySet M), eqmySet A B -> A = B.

(**
## 補集合の補集合の証明
*)
Section Test1.
  Variable M : Type.                        (* 注意してください。 *)

  Lemma cc_cancel (A : mySet M) : (A^c)^c = A.
  Proof.
    apply: axiom_ExteqmySet.
    split; rewrite /myComplement => x H;
      by case: (axiom_mySet A x) => HxA.
  Qed.

  Lemma myUnionCompMother (A : mySet M) : A ∪ (A^c) = myMotherSet.
  Proof.
    apply: axiom_ExteqmySet.
    split=> [x | x H] //=.
    case: (axiom_mySet A x); by [left | right].
  Qed.
End Test1.

(**
# (公理 1.)について

## 排中律

(公理 1.)は排中律を使えば証明できます。
*)
Section ExMid.
  Variable M : Type.                        (* 注意してください。 *)

  Axiom ExMid : forall (P : Prop), P \/ ~ P. (* 排中律 *)

  Lemma axiom_mySet'' : forall (A : mySet M),
      forall (x : M), x ∈ A \/ ~(x ∈ A).
  Proof.
    move=> A x.
      by apply: ExMid.
  Qed.
End ExMid.

(*
## morita_hmさんの公理 ``refl_mySet``

ProofCafe において @morita_hm さんから別の公理が提案されました。より単純な、

``reflect (A x) true``

から、(公理 1.)を導くものです。
*)

Section Morita.
  Variable M : Type.                        (* 注意してください。 *)

  Axiom refl_mySet : forall (A : mySet M) (x : M), reflect (A x) true.

  Lemma axiom_mySet' : forall (A : mySet M),
      forall (x : M), x ∈ A \/ ~(x ∈ A).
  Proof.
    rewrite /belong => A x.
      by case: (refl_mySet A x); [left | right].
    Undo.
    move: (@refl_mySet A x) => Hr. (* ここで refl_mySet に M A x を与えている。 *)
    case: Hr.
    - by left.
    - by right.
  Qed.

(**
ここで実際に証明しているのは、次の命題であることが解ります。
*)
  Goal forall (A : mySet M) (x : M),
      reflect (A x) true -> x ∈ A \/ ~(x ∈ A).
  Proof.
    move=> A x.
    by case; [left | right].
  Qed.
End Morita.

(**
## 別の説明

公理 ``refl_mySet`` は、かたちを変えた排中律であり、
排中律を経由して(公理 1.)を証明していることになります。これを以下で説明します。
*)

(**
文献[2.] p.101 にあるとおり、``reflect P b`` は、

- 命題(Prop型の) P がTrueであると証明できるとき、 bool型の命題が真(true)である。

- 命題(Prop型の) P がFalseであると証明できるとき、bool型の命題が偽(false)である。

と場合分けできることを示します。
*)
Section Test2.

  Lemma A_ref (P : Prop) : P -> reflect P true.
  Proof.
    move=> H.
      by apply: ReflectT.
  Qed.

  Lemma notA_ref (P : Prop) : ~ P -> reflect P false.
  Proof.
    move=> H.
      by apply: ReflectF.
  Qed.

(**
場合分けができ、また、bool型の命題 true が false であるとは、false のことですから、
``reflect P true`` から排中律を導くことができます。
*)
  Lemma refl_exmid (P : Prop): reflect P true -> P \/ ~ P.
  Proof.
    case=> Hr.
    - by left.
    - by right.
  Qed.
End Test2.

(**
## 依存和の使用

かたちを変えた排中律としては、依存和があります。
命題 P が P または ~ P のどちらかに決定可能である、
ということから排中律が求められます。
*)

Section Depend.

  Lemma dec_exmid (P : Prop) : {P} + {~ P} -> P \/ ~ P.
  Proof.
    case=> Hd.
    - by left.
    - by right.
  Qed.

End Depend.

(**
## finType の場合

テキストの 5.5節にあるように、
母集合にあたる型 M を任意の型から、有限型 (finType) に制限することでも、
(公理 1.)を不要にすることもできます。
 *)

Section FinType.
  Variable M : finType.             (* これまでは ``M : Type`` だった。 *)

(**
なぜなら、有限型（母集合が有限）ならば、元が集合に含まれるかどうかを決定する命題を
定義することができるからです。

このような命題はbool型の値をとるようにすると扱いやすいので、pA であらわします。
そして、bool述語 pA が x で成り立つときことを
MathCompの演算子 \in を使って ``x \in pA`` とあらわします。

- pA は ``pred M`` 型となっていますが、これは ``M -> bool`` のことです（深い意味は無い）。

- ``x \in pA`` を ``pA x`` に置き換えても（ここでは）同じです。
ただし、単純な構文糖衣ではないので、つねに同じであるわけではありません。
以下の説明も参照してください。

https://github.com/suharahiromichi/coq/blob/master/csm/csm_4_1_ssrbool.v
*)

(**
``pA : pred M`` が ``P : mySet M`` で形式化された集合の定で使えるように、
変換する関数 p2S を定義します。
なお、テキストで定義されている構文糖衣 ``\{ x 'in' pA \}`` は使わないことにしました。
すなわち `` \{ x in M \}`` は ``p2S M`` のことで x に意味はありません。
*)
  Definition p2S (pA : pred M) : mySet M :=
    fun (x : M) => if x \in pA then True else False.

  Lemma Mother_predT : myMotherSet = p2S M.
  Proof. by []. Qed.

  Lemma myFinBelongP (x : M) (pA : pred M) : reflect (x ∈ p2S pA) (x \in pA).
  Proof.
    rewrite /belong /p2S.
    apply/(iffP idP) => H1.
    - by rewrite H1.
    - by case H : (x \in pA); last rewrite H in H1.
  Qed.

(**
「元xが集合Aに含まれるか、含まれないかのどちらかである」ことを(公理 1.)を使わずに、
定理として導くことができます。
*)

  Lemma fin_mySet (pA : pred M) (x : M) : x \in pA \/ ~(x \in pA).
  Proof.
    case: (myFinBelongP x pA); by [left | right].
  Qed.

(**
実際の集合の証明では、``M : Type, P : mySet M``
を ``M : finType, pA : pred M`` に変更する必要があります。
*)
  Lemma Mother_Sub (pA : pred M) :
    myMotherSet ⊂ p2S pA -> forall x, x ∈ p2S pA.
  Proof.
    rewrite Mother_predT.                   (* 省略可能 *)
    move=> H x.
    Check H x : x ∈ p2S M -> x ∈ p2S pA.
    apply: (H x).
    done.
  Qed.

  Lemma transitive_Sub (pA pB pC : pred M) :
    pA ⊂ pB -> pB ⊂ pC -> pA ⊂ pC.
  Proof.
    move=> HAB HBC t HtA.
      by auto.
  Qed.

(**
axiom_mySet ではなく、fin_mySet を使って証明することができます。
すなわち(公理 1.)を使用せずに証明できたことになります。
*)
  Lemma cc_cancel' (pA : pred M) : (pA^c)^c = pA.
  Proof.
    apply: axiom_ExteqmySet.
    split; rewrite /myComplement => x H;
      by case: (fin_mySet pA x) => HxA.
  Qed.

  Lemma myUnionCompMother' (pA : pred M) : pA ∪ (pA^c) = myMotherSet.
  Proof.
    apply: axiom_ExteqmySet.
    split=> [x | x H] //=.
    case: (fin_mySet pA x); by [left | right].
  Qed.
End FinType.

Section 具体的なfinType.

  Definition p0 := @Ordinal 5 0 is_true_true.
  Check p2S 'I_5 : mySet 'I_5.

  Goal p0 ∈ p2S 'I_5.
  Proof. by []. Qed.

End 具体的なfinType.

(**
## mySet を bool型であらわす場合

そもそも ``mySet M`` を bool型の ``pred M`` であらわすことで、(公理 1.)は不要になります。
belongがbool述語となるので、公理なしで決定性が保証されるからです。以下を参照してください。

https://github.com/suharahiromichi/coq/blob/master/csm/csm_5_set_theory_class.v

（ご注意。ファイル名に意味はありません）
 *)

(**
# 公理 2. について

これは、外延性の公理です。
*)

Section Test3.
  Variable M : finType.                     (* 注意してください。 *)

  Definition myMotherSet' : mySet M := fun (_ : M) => true.

  Lemma cc_cancel'' (pA : pred M) : (pA^c)^c =1 pA.
  Proof.
    move=> x.
    rewrite /myComplement.
    (* Goal : (~ ~ pA x) = pA x *)
  Admitted.

  Lemma myUnionCompMother'' (pA : pred M) : (pA ∪ (pA^c)) =1 myMotherSet'.
  Proof.
    move=> x.
    case: (fin_mySet pA x).
    move/myFinBelongP=> H.
    rewrite /myCup /myComplement /myMotherSet'.
  Admitted.

End Test3.

(**
# 文献

[1.] 萩原学 アフェルト・レナルド、「Coq/SSReflect/MathCompによる定理証明」、森北出版

[2.] Mathematical Components (MathComp Book) https://math-comp.github.io
 *)

(* END *)


Require Import Toy.FP.usl.interface.
Require Import Toy.FP.usl.implementation.
Require Import ZArith.
Require Import QArith.
Import T.
Open Scope Z.

Definition mapsto (p : addr) (z : Z) : Assertion := fun st => exists q, snd st p = Some (q, z).
Definition mapsto' (p : addr) (q : Q) (z : Z) : Assertion := fun st => snd st p = Some (q, z).
Definition exp {A : Type} (P : A -> Assertion) : Assertion := fun st => exists a, P a st.
Definition NULL : addr := -1.

Fixpoint listrep (p : Z) (l : list Z) (q1 q2 : Q) : Assertion :=
  match l with
	  | nil => fun _ => p = NULL
	  | cons x l' => sepcon (mapsto' p q1 x) (exp (fun t => sepcon (mapsto' (p + 1) q2 t) (listrep t l' q1 q2)))
  end.


Require Import Basis .

(** 戦術を使う。 *)
Declare ML Module "ltac_plugin" .
Set Default Proof Mode "Classic" .

Arguments paths : clear implicits .
Arguments idpath : clear implicits .
Arguments paths_elim : clear implicits .
Arguments paths_elim_nop : clear implicits .

Definition book_1_12_2_a
  {A : Type} {P : forall a a', paths A a a' -> Type}
  (case_idpath : forall a, P a a (idpath A a))
  (a a' : A) (x : paths A a a') : P a a' x .
Proof.
 revert a' x .
 refine (paths_elim A a (P a) _) .
 exact (case_idpath a) .
Defined.

Definition book_1_12_2_b
  (A : Type) (a : A) (P : forall a', paths A a a' -> Type)
  (case_idpath : P a (idpath A a))
  (a' : A) (x : paths A a a') : P a' x .
Proof.
 revert a a' x P case_idpath .
 refine (paths_elim_nop A ?[ex_P] _) .
 refine (fun a P h => _) .
 exact h .
Defined.

(* transport *)
Definition exerise_1_8_lemma_1
  (A : Type) (P : A -> Type)
  (x y : A) (p : paths A x y)
  (u : P x) : P y .
Proof.
 revert x y p u .
 refine (paths_elim_nop A (fun x y _ => P x -> P y) _) .
 exact (fun z v => v) .
Defined.

(* path_based_paths *)
Definition exerise_1_8_lemma_2
  (X : Type) (x : X) (p : dsum (paths X x))
  : paths (dsum (paths X x)) (dpair x (idpath X x)) p .
Proof.
 revert p .
 refine (dsum_elim _) .
 revert x .
 refine (paths_elim_nop X ?[ex_P] _) .
 exact (fun z => idpath (dsum (paths X z)) (dpair z (idpath X z))) .
Defined.

Definition exerise_1_8
  (A : Type) (a : A) (P : forall a', paths A a a' -> Type)
  (case_idpath : P a (idpath A a))
  (a' : A) (x : paths A a a') : P a' x .
Proof.
 pose (Q := fun h => P (dfst h) (dsnd h)) .
 pose (h := dpair a (idpath A a)) .
 pose (h' := dpair a' x) .
 change (Q h) in case_idpath .
 change (Q h') .
 refine (exerise_1_8_lemma_1 (dsum (paths A a)) Q h h' _ case_idpath) .
 change (paths (dsum (paths A a)) (dpair a (idpath A a)) h') .
 exact (exerise_1_8_lemma_2 A a h') .
Defined.


Require Import Arith List ZArith.

Inductive season : Set := Spring | Summer | Fall | Winter.

Theorem bool_equal : forall (b:bool), b=true\/b=false.
  apply bool_ind;
  [apply or_introl|apply or_intror];
  apply refl_equal.
Qed.

Inductive month : Set :=
  January|
  February|
  March|
  April|
  May|
  June|
  July|
  August|
  September|
  October|
  November|
  December.

Definition season_of_month m :=
  (month_rec
    (fun _:month => season)
    Winter
    Winter
    Winter
    Spring
    Spring
    Spring
    Summer
    Summer
    Summer
    Fall
    Fall
    Fall) m.

Definition season_of_month' m :=
  match m with
  | January => Winter
  | February => Winter
  | March => Winter
  | April => Spring
  | May => Spring
  | June => Spring
  | July => Summer
  | August => Summer
  | September => Summer
  | October => Winter
  | November => Winter
  | December => Winter
  end.

Definition bool_not( b : bool ) := if b then false else true.
Definition bool_or( l r : bool ) := if l then true else r.
Definition bool_and( l r : bool ) := if l then r else false.
Definition bool_eq( l r : bool ) := if l then r else bool_not r.
Definition bool_xor( l r : bool ) := bool_not (bool_eq l r).

Theorem bool_xor_not_eq :
  forall b1 b2 : bool, (bool_xor b1 b2) = (bool_not (bool_eq b1 b2)).
  trivial.
Qed.

Theorem bool_not_and :
  forall b1 b2 : bool,
    (bool_not (bool_and b1 b2)) =
    (bool_or (bool_not b1) (bool_not b2)).
  case b1, b2;auto.
Qed.

Theorem bool_not_not : forall b : bool, (bool_not (bool_not b))=b.
  intros.
  case b;auto.
Qed.

Theorem bool_tex : forall b : bool, (bool_or b (bool_not b))=true.
  intros.
  case b;auto.
Qed.

Theorem bool_eq_reflect : forall b1 b2 : bool, (bool_eq b1 b2)=true -> b1=b2.
  intros.
  case b1, b2;auto.
Qed.

Theorem bool_eq_reflect2 : forall b1 b2 : bool,
  b1 = b2 ->
    (bool_eq b1 b2) = true.
  intros.
  case b1, b2;auto.
Qed.

Theorem bool_not_or : forall b1 b2 : bool,
  (bool_not (bool_or b1 b2)) = (bool_and (bool_not b1) (bool_not b2)).
  intros.
  case b1, b2;auto.
Qed.

Theorem bool_distr:  forall b1 b2 b3:bool,
  (bool_or (bool_and b1 b3) (bool_and b2 b3)) = (bool_and (bool_or b1 b2) b3).
  intros.
  case b1, b2, b3;auto.
Qed.

Record plane : Set := point {abscissa : Z; ordinate : Z}.

Definition absolute p :=
  match p with
  | Z0 => Z0
  | Zneg x => Zpos x
  | Zpos x => Zneg x
  end.

Open Scope Z_scope.

Definition manhatten l r :=
  absolute ((abscissa l) - (abscissa r)) +
  absolute ((ordinate l) - (ordinate r)).

Close Scope Z_scope.

Inductive vehicle : Set :=
  bicycle : nat -> vehicle|
  motorized : nat -> nat -> vehicle.

Definition number_of_seats v : nat :=
  vehicle_rec (fun _ => nat) (fun x => x) (fun x _ => x) v.

Definition is_January v : bool :=
  month_rec
    (fun _ => bool)
    true
    false
    false
    false
    false
    false
    false
    false
    false
    false
    false
    false
    v.

Goal true <> false.
  unfold not.
  intros.
  change((fun b : bool => if b then False else True)true).
  rewrite H.
  trivial.
Qed.

Record RatPlus : Set := mkRat
  {top : nat; bottom : nat; bottom_condition : bottom <> 0}.

Definition r0 : RatPlus.
  apply (mkRat 1 2).
  auto.
Defined.

Definition r1 : RatPlus.
  apply (mkRat 2 4).
  auto.
Defined.

Definition eq_RatPlus : Prop := forall r r':RatPlus,
  top r * bottom r' = top r' * bottom r -> r = r'.

Goal eq_RatPlus -> False.
  unfold eq_RatPlus.
  intros.
  assert(r0=r1).
  apply H.
  simpl.
  reflexivity.
  discriminate H0.
Qed.

Section partial_functions.
  Variable P : nat -> Prop.
  Variable f : nat -> option nat.

  Hypothesis f_domain : forall n, P n <-> f n <> None.

  Definition g n : option nat :=
    match f (n+2) with None => None
    | Some y => Some (y + 2)
    end.

  Lemma g_domain : forall n, P (n+2) <-> g n <> None.
    intros;
    case(f_domain (n + 2));
    intros H1 H2;
    unfold g;
    split;
    [
      remember (f (n + 2)) as o;
      destruct o;
      intros;
      [
        discriminate |

        apply H1;
        assumption
      ]|

      remember (f (n + 2)) as o;
      destruct o;
      intros;
      apply H2;
      discriminate||assumption
    ].
  Qed.

End partial_functions.

Definition lt3 n :=
  match n with
  | O => true
  | S O => true
  | _ => false
  end.

Fixpoint plus' l r {struct r}:=
  match r with
  | O => l
  | S x => S (plus' l x)
  end.

Goal forall x y, plus' x y = x + y.
  induction y.
  auto with arith.
  simpl.
  rewrite IHy.
  auto with arith.
Qed.

Open Scope Z_scope.

Fixpoint accumulate( begin time : nat )( f : nat -> Z ) : Z :=
  match time with
  | O => 0
  | S x => (f begin) + accumulate (S begin) x f
  end.

Eval compute in accumulate 0 10 (fun x => Z_of_nat (x * x)).

Fixpoint two_power x := match x with |O => 1 |S x => 2 * (two_power x) end.

Close Scope Z_scope.

Definition _1000 := xO (xO (xO (xI (xO (xI (xI (xI (xI (xH))))))))).

Definition _1024 := xO (xO (xO (xO (xO (xO (xO (xO (xO (xO xH))))))))).

Definition _25 := xI (xO (xO (xI xH))).

Definition _512 := xO (xO (xO (xO (xO (xO (xO (xO (xO xH)))))))).

Definition is_even n := match n with | xO _ => true | _ => false end.

Definition div_2 n :=
  match n with
  | xO x => Zpos x
  | xI x => Zpos x
  | xH => Z0 end.

Definition div_4 n :=
  match div_2 n with
  | Z0 => Z0
  | Zpos x => div_2 x
  | Zneg x => div_2 x
  end.

Inductive bool' : Set :=
  true'|
  false'|
  and' : bool' -> bool' -> bool'|
  or' : bool' -> bool' -> bool'|
  not : bool' -> bool'.

Fixpoint bool'_denote b :=
  match b with
  | true' => true
  | false' => false
  | and' l r => bool_and (bool'_denote l) (bool'_denote r)
  | or' l r => bool_or (bool'_denote l) (bool'_denote r)
  | not x => bool_not (bool'_denote x)
  end.

Inductive F := one | N : F -> F | D : F -> F.

Fixpoint fraction f :=
  match f with
  | one => (1,1)
  | N x => let (a,b) := fraction x in (a+b,b)
  | D x => let (a,b) := fraction x in (a,a+b)
  end.

Inductive Z_btree : Set :=
| Z_leaf : Z_btree
| Z_bnode : Z->Z_btree->Z_btree->Z_btree.

Fixpoint has_occurence find t :=
  match t with
  | Z_leaf => false
  | Z_bnode num l r =>
      bool_or
        (Zeq_bool num find)
        (bool_or
          (has_occurence find l)
          (has_occurence find r))
  end.

Open Scope Z_scope.

Fixpoint power( x : Z )( y : nat ):=
  match y with
  | O => 1
  | S y' => x * (power x y')
  end.

Close Scope Z_scope.

Fixpoint discrete_log p : nat :=
  match p with
  | xH => 0
  | xI p' => S (discrete_log p')
  | xO p' => S (discrete_log p')
end.

Inductive Z_fbtree : Set :=
| Z_fleaf : Z_fbtree
| Z_fnode : Z  -> (bool -> Z_fbtree) -> Z_fbtree.

Fixpoint fzero_present t :=
  match t with
  | Z_fleaf => false
  | Z_fnode num f =>
      bool_or (Zeq_bool num 0)
        (bool_or (fzero_present (f true)) (fzero_present (f false)))
  end.

Inductive Z_inf_branch_tree : Set :=
| Z_inf_leaf : Z_inf_branch_tree
| Z_inf_node : Z->(nat->Z_inf_branch_tree)->Z_inf_branch_tree.

Fixpoint zero_reachable t i :=
  match t with
  | Z_inf_leaf => false
  | Z_inf_node num func =>
      bool_or
        (Zeq_bool num 0)
        ((fix reachable (z : nat) :=
          bool_or
            (zero_reachable (func z) i)
            match z with
            | O => false
            | S x => (reachable x)
            end) i)
  end.

Theorem plus_n_O : forall n, n+0 =n.
  intros.
  elim n.
  reflexivity.
  intros.
  simpl.
  rewrite H.
  reflexivity.
Qed.

Fixpoint f1 (t : Z_btree) : Z_fbtree :=
  match t with
  | Z_leaf => Z_fleaf
  | Z_bnode num l r => Z_fnode num (fun b => if b then f1 l else f1 r)
  end.

Fixpoint f2 (t : Z_fbtree) : Z_btree :=
  match t with
  | Z_fleaf => Z_leaf
  | Z_fnode num func => Z_bnode num (f2 (func true)) (f2 (func false))
  end.

Theorem f2_f1 : forall t: Z_btree, f2 (f1 t) = t.
  induction t.
  reflexivity.
  simpl.
  rewrite IHt1.
  rewrite IHt2.
  reflexivity.
Qed.

Theorem f1_f2 :
  (forall (A B:Set) (f g: A -> B),
    (forall a, f a = g a) -> f = g )->
      (forall t: Z_fbtree, f1 (f2 t) = t).
  induction t.
  reflexivity.
  simpl.
  f_equal.
  apply H.
  destruct a;
  apply H0.
Qed.

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

Goal forall n, n + n = mult2 n.
  induction n.
  reflexivity.
  rewrite <- plus_Snm_nSm.
  simpl.
  rewrite IHn.
  reflexivity.
Qed.

Fixpoint sum_n (n:nat) : nat :=
  match n with
  | O => O
  | (S p) => (plus (S p) (sum_n p))
  end.

Goal forall n, 2*(sum_n n) = n * (n+1).
  induction n.
  reflexivity.
  unfold sum_n.
  fold sum_n.
  rewrite mult_plus_distr_l.
  rewrite IHn.
  simpl.
  f_equal.
  rewrite plus_n_O.
  rewrite mult_succ_r.
  rewrite mult_plus_distr_l.
  rewrite plus_assoc_reverse.
  rewrite plus_assoc_reverse.
  f_equal.
  simpl.
  f_equal.
  rewrite plus_comm.
  reflexivity.
Qed.

Goal forall n, n <= sum_n n.
  induction n.
  reflexivity.
  simpl.
  apply le_n_S.
  apply le_plus_l.
Qed.

Fixpoint first_n(A : Type)(n : nat)(l : list A) :=
  match n with
  | O => nil
  | S x =>
      match l with
      | nil => nil
      | e :: next => e :: first_n A x next
      end
  end.

Fixpoint generate begin time : list nat :=
  match time with
  | O => nil
  | S x => begin :: generate (S begin) x
  end.

Fixpoint nth_option (A:Set)(n:nat)(l:list A) {struct l}
  : option A :=
  match n, l with
  | O, cons a tl => Some a
  | S p, cons a tl => nth_option A p tl
  | n, nil => None
  end.

Lemma nth_length :
  forall (A:Set)(n:nat)(l:list A),
    nth_option _ n l = None <-> length l <= n.
  induction n;
  [
    destruct l;
    simpl;
    split;
    discriminate 1||auto;
    inversion 1|
    intros;
    destruct l;
    [
      split;
      auto with arith|

      simpl;
      split;
      case (IHn l);
      auto with arith
    ]
  ].
Qed.

Fixpoint split (A B : Set)(l : list(A * B)) : (list A) * (list B) :=
  match l with
  | nil => (nil, nil)
  | (a, b) :: l' => let (ll, lr) := split A B l' in (a :: ll, b :: lr)
  end.

Fixpoint combine (A B : Set)(ll : list A)(lr : list B) : list (A * B) :=
  match (ll, lr) with
  | (l :: ll', r :: lr') => (l, r) :: (combine A B ll' lr')
  | (_, _) => nil
  end.

Goal forall (A B : Set)(l : list (A * B)),
  let ( l1,l2) :=  (split _ _ l) in combine _ _ l1 l2 = l.
  induction l.
  reflexivity.
  simpl.
  destruct (split A B l).
  destruct a.
  destruct IHl.
  reflexivity.
Qed.

Inductive btree(T : Set) : Set :=
  leaf : btree T | bnode : T->btree T->btree T->btree T.

Fixpoint to_b_tree_Z(t : Z_btree) : btree Z :=
  match t with
  | Z_leaf => leaf Z
  | Z_bnode z l r => bnode Z z (to_b_tree_Z l) (to_b_tree_Z r)
  end.

Fixpoint to_Z_btree(t : btree Z) : Z_btree :=
  match t with
  | leaf => Z_leaf
  | bnode z l r => Z_bnode z (to_Z_btree l) (to_Z_btree r)
  end.

Goal forall t, to_Z_btree (to_b_tree_Z t) = t.
  induction t.
  reflexivity.
  simpl.
  rewrite IHt1.
  rewrite IHt2.
  reflexivity.
Qed.

Goal forall t, to_b_tree_Z (to_Z_btree t) = t.
  induction t.
  reflexivity.
  simpl.
  rewrite IHt1.
  rewrite IHt2.
  reflexivity.
Qed.

Inductive htree (A:Set) : nat -> Set :=
  hleaf : A -> (htree A O)
| hnode : forall n:nat, A -> htree A n -> htree A n -> htree A (S n).

Definition first_of_htree
  (A : Set) (n : nat) (v : htree A n) (t : htree A (S n)) : htree A n :=
    match t in (htree _ n0) return (htree A (pred n0) -> htree A (pred n0)) with
    | hleaf _ => fun v' : htree A 0 => v'
    | hnode p _ t1 _ => fun _ : htree A p => t1
    end v.

Theorem injection_first_htree:
  forall (n : nat) (t1 t2 t3 t4 : htree nat n),
    hnode nat n O t1 t2 = hnode nat n O t3 t4 ->  t1 = t3.
  intros n t1 t2 t3 t4 h.
  change
  (first_of_htree nat n t1 (hnode nat n 0 t1 t2) =
  first_of_htree nat n t1 (hnode nat n 0 t3 t4)).
  rewrite h.
  reflexivity.
Qed.

Fixpoint make_htree (n:nat): htree Z n :=
  match n return htree Z n with
    0 => hleaf Z 0%Z
  | S p => hnode Z p 0%Z (make_htree p) (make_htree p)
  end.

Inductive binary_word : nat -> Set :=
  tail : binary_word 0
| push : forall n : nat, bool -> binary_word n -> binary_word (S n).

Fixpoint word_con (nl nr : nat) (wl : binary_word nl) (wr : binary_word nr) : binary_word (nl + nr) :=
  match wl in binary_word ln return binary_word (ln + nr) with
  | tail => wr
  | push l b w => push (l + nr) b (word_con l nr w wr)
  end.

Fixpoint binary_word_or (l : nat) (wl wr : binary_word l) : binary_word l.
  refine(
    match wl in binary_word n return binary_word n -> binary_word n with
    | tail => (fun x => x)
    | push ll lb lw =>
        (fun wr' : binary_word (S ll) => match wr' with
        | tail => (fun p : False => wr')
        | push rl rb rw =>
            (fun p : ll = rl =>
              push
              rl
              (bool_or lb rb)
              (binary_word_or rl (eq_rec ll binary_word lw rl p) rw))
        end _)
    end wr).
    reflexivity.
Defined.

Theorem all_equal : forall x y : Empty_set, x = y.
  destruct x.
Qed.

Theorem all_diff : forall x y : Empty_set, x <> y.
  destruct x.
Qed.


From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype order seq path.
From favssr Require Import bintree bst.

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

Import Order.POrderTheory.
Import Order.TotalTheory.
Open Scope order_scope.

Module ASetM.
Structure ASetM (T : eqType): Type :=
  make {tp :> Type;
        empty : tp;
        insert : T -> tp -> tp;
        delete : T -> tp -> tp;
        isin : tp -> T -> bool;

        abs : tp -> pred T;
        invar : tp -> bool;

        _ : invar empty;
        _ : abs empty =i pred0;

        _ : forall x s, invar s -> invar (insert x s);
        _ : forall x s, invar s ->
              abs (insert x s) =i [predU1 x & abs s];

        _ : forall x s, invar s -> invar (delete x s);
        _ : forall x s, invar s ->
              abs (delete x s) =i [predD1 abs s & x];

        _ : forall s, invar s -> isin s =i abs s
        }.
End ASetM.

Section Specification.
Context {disp : unit} {T : orderType disp}.

Corollary inorder_empty_pred : inorder (@Leaf T) =i pred0.
Proof. by []. Qed.

Corollary inorder_insert_pred x (t : tree T) :
  bst t ->
  inorder (insert x t) =i [predU1 x & inorder t].
Proof.
move=>H z; move/perm_mem: (inorder_insert x H)=>/(_ z)->.
rewrite inE; case: ifP=>//=.
by case: eqP=>//->->.
Qed.

Corollary inorder_delete_pred x (t : tree T) :
  bst t ->
  inorder (delete x t) =i [predD1 inorder t & x].
Proof.
move=>H z; move/perm_mem: (inorder_delete x H)=>/(_ z)->.
by rewrite mem_filter; rewrite !inE /=.
Qed.

(* direct proofs for unbalanced trees work *)
Definition UASetM :=
  @ASetM.make _ (tree T)
    leaf insert delete isin
    (pred_of_seq \o inorder) bst
    bst_empty inorder_empty_pred
    bst_insert inorder_insert_pred
    bst_delete inorder_delete_pred
    inorder_isin.

Corollary emp_pred0 : (@nil T) =i pred0.
Proof. by []. Qed.

Corollary inorder_ins_list_pred (x : T) xs :
  sorted <%O xs ->
  ins_list x xs =i [predU1 x & xs].
Proof.
move=>H z; move/perm_mem: (inorder_ins_list x H)=>/(_ z)->.
rewrite !inE /=; case: ifP=>//=.
by case: eqP=>//->->.
Qed.

Corollary inorder_del_list_pred (x : T) xs :
  sorted <%O xs ->
  del_list x xs =i [predD1 xs & x].
Proof.
move=>H z; move/perm_mem: (inorder_del_list x H)=>/(_ z)->.
by rewrite mem_filter; rewrite !inE /=.
Qed.

(* sorted lists implement sets *)
Definition LASetM :=
  @ASetM.make _ (seq T)
    [::] ins_list del_list (fun xs s => s \in xs)
    (pred_of_seq \o id) (sorted <%O)
    erefl emp_pred0
    ins_list_sorted inorder_ins_list_pred
    del_list_sorted inorder_del_list_pred
    (fun _ _ _ => erefl).

Corollary bst_list_empty : bst_list (@Leaf T).
Proof. by []. Qed.

Corollary bst_list_insert x (t : tree T) :
  bst_list t -> bst_list (insert x t).
Proof.
move=>H; rewrite /bst_list inorder_insert_list //.
by apply: ins_list_sorted.
Qed.

Corollary inorder_insert_list_set x (t : tree T) :
  bst_list t ->
  inorder (insert x t) =i [predU1 x & inorder t].
Proof.
rewrite /bst_list => Hn.
rewrite inorder_insert_list //.
by apply: inorder_ins_list_pred.
Qed.

Corollary bst_list_delete x (t : tree T) :
  bst_list t -> bst_list (delete x t).
Proof.
move=>H; rewrite /bst_list inorder_delete_list //.
by apply: del_list_sorted.
Qed.

Corollary inorder_delete_list_set x (t : tree T) :
  bst_list t ->
  inorder (delete x t) =i [predD1 inorder t & x].
Proof.
rewrite /bst_list => Hn.
rewrite inorder_delete_list //.
by apply: inorder_del_list_pred.
Qed.

(* unbalanced trees via sorted lists implement sets *)
Definition ULASetM :=
  @ASetM.make _ (tree T)
    leaf insert delete isin
    (pred_of_seq \o inorder) bst_list
    bst_list_empty inorder_empty_pred
    bst_list_insert inorder_insert_list_set
    bst_list_delete inorder_delete_list_set
    inorder_isin_list.

End Specification.

Module Map.
Structure Map (K : eqType) (V : Type) : Type :=
  make {tp :> Type;
        empty : tp;
        update : K -> V -> tp -> tp;
        delete : K -> tp -> tp;
        lookup : tp -> K -> option V;

        invar : tp -> bool;

        _ : invar empty;
        _ : lookup empty =1 fun => None;

        _ : forall k v s, invar s -> invar (update k v s);
        _ : forall k v s, invar s ->
            lookup (update k v s) =1 [eta (lookup s) with k |-> Some v];

        _ : forall k s, invar s -> invar (delete k s);
        _ : forall k s, invar s ->
            lookup (delete k s) =1 [eta (lookup s) with k |-> None]
        }.
End Map.

(* Exercise 6.1 *)

Module ASetI.
Structure ASetI (T : eqType): Type :=
  make {tp :> Type;
        empty : tp;
        insert : T -> tp -> tp;
        delete : T -> tp -> tp;
        isin : tp -> T -> bool;

        (* FIXME *)

        }.
End ASetI.

(* Exercise 6.3 *)

Section MapUnbalanced.
Context {disp : unit} {K : orderType disp} {V : Type}.

Notation kvtree := (tree (K*V)).

(* FIXME *)

End MapUnbalanced.


Require Import Problem PeanoNat.

Theorem solution : task.
Proof.
  unfold task.
  intros.
  rewrite Nat.mul_comm.
  simpl.
  rewrite Nat.mul_comm.
  auto.
Qed.


Require BigO.Util.Admitted.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.interfaces.orders.
Require Import MathClasses.orders.dec_fields.
Require Import MathClasses.orders.semirings.

Section NoOrder.
  Context `{DecField K}.
  Context `{!FullPseudoSemiRingOrder Kle Klt}.
  Lemma plus_le : forall x y z : K, 0 < x -> 0 < y -> x + y ≤ z -> x ≤ z.
    intros x y z zero_lt_x zero_lt_y x_plus_y.
    destruct (decompose_le x_plus_y) as [a Hyp].
    destruct Hyp as [zero_le_a z_eq].

    apply (compose_le x z (y + a)).
    {
      setoid_replace 0 with (0 + 0) by (now rewrite left_identity).
      apply (plus_le_compat 0 _ 0 _); try assumption.
      now apply lt_le.
    }
    {
      now rewrite associativity.
    }
  Qed.
End NoOrder.

Section DecFieldLemmas.
  Context `{DecField K}.
  Context `{!FullPseudoSemiRingOrder Kle Klt}.
  Context `{!TotalOrder Kle}.

  Lemma zero_ne_one : (0 : K) ≠ (1 : K).
    unfold not.
    intros zero_eq_1.

    assert (Hyp : PropHolds (strong_setoids.default_apart 1 0)) by
      (exact (@decfield_nontrivial K Ae Aplus Amult Azero Aone Anegate Adec_recip H)).
    unfold PropHolds in Hyp.
    assert (Hyp' : PropHolds (1 ≠ 0)).
    {
      unfold PropHolds.
      apply trivial_apart.
      exact Hyp.
    }
    unfold PropHolds in Hyp'.
    unfold not in Hyp'.
    apply Hyp'.
    now symmetry.
  Qed.

  Lemma zero_lt_one_dec : (0 : K) < (1 : K).
    assert (one_is_less_than_the_other : 0 < 1 \/ 1 < 0) by
      (apply apart_total_lt; apply zero_ne_one).
    assert (one_not_lt_zero : ¬ 1 < 0).
    {
      apply le_not_lt_flip.
      exact Admitted.zero_le_one_dec.
    }
    unfold not in one_not_lt_zero.
    case one_is_less_than_the_other.
    {
      trivial.
    }
    {
      intros Hyp.
      apply one_not_lt_zero in Hyp.
      inversion Hyp.
    }
  Qed.

  Lemma dec_recip_inverse_reverse : forall x : K, x ≠ 0 -> (/ x) * x = 1.
    intros x.
    rewrite commutativity.
    apply dec_recip_inverse.
  Qed.

  Lemma dec_recip_inverse_ge_0 : forall x : K, 0 < x -> (/ x) * x = 1.
    intros x x_gt_0.
    apply dec_recip_inverse_reverse.
    now apply lt_ne_flip.
  Qed.

  Lemma order_preserving_mult_le : forall a b c : K, 0 < c -> a ≤ b -> c * a ≤ c * b.
    intros a b c c_ge_0 a_le_b.
    now apply (order_preserving ((.*.) c) a b).
  Qed.

  Lemma order_preserving_mult : forall x : K, 0 < x -> OrderPreserving (mult x).
    intros x x_ge_0.
    repeat (split; try apply _).
    intros a b.
    intros a_leq_b.
    now apply order_preserving_mult_le.
  Qed.

  Lemma order_preserving_mult_lt : forall a b c : K, 0 < c -> a < b -> c * a < c * b.
    intros a b c c_gt_0 a_lt_b.
    now apply (strictly_order_preserving ((.*.) c) a b).
  Qed.

  Require Import Coq.setoid_ring.Ring.
  (* this is definitely in math-classes *)
  Add Ring R: (MathClasses.theory.rings.stdlib_ring_theory K).
  Lemma mult_pos_gt_0 : forall x y : K, 0 < x -> 0 < y -> 0 < x * y.
    intros x y x_ge_0 y_ge_0.
    assert (Hyp : x * 0 = 0) by ring.
    rewrite <- Hyp.
    apply order_preserving_mult_lt; assumption.
  Qed.
End DecFieldLemmas.


Require Import rt.util.all.
Require Import rt.model.basic.task rt.model.basic.job rt.model.basic.task_arrival
               rt.model.basic.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(* Definition of response-time bound and some simple lemmas. *)
Module ResponseTime.

  Import Schedule SporadicTaskset SporadicTaskArrival.

  Section ResponseTimeBound.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Context {arr_seq: arrival_sequence Job}.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Given a task ...*)
    Variable tsk: sporadic_task.

    (* ... and a particular schedule, ...*)
    Context {num_cpus : nat}.
    Variable sched: schedule num_cpus arr_seq.

    (* ... R is a response-time bound of tsk in this schedule ... *)
    Variable R: time.

    Let job_has_completed_by := completed job_cost sched.

    (* ... iff any job j of tsk in this arrival sequence has
       completed by (job_arrival j + R). *)
    Definition is_response_time_bound_of_task :=
      forall (j: JobIn arr_seq),
        job_task j = tsk ->
        job_has_completed_by j (job_arrival j + R).

  End ResponseTimeBound.

  Section BasicLemmas.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.

    Context {arr_seq: arrival_sequence Job}.

    (* Consider any valid schedule... *)
    Context {num_cpus : nat}.
    Variable sched: schedule num_cpus arr_seq.

    Let job_has_completed_by := completed job_cost sched.

    (* ... where jobs dont execute after completion. *)
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    Section SpecificJob.

      (* Then, for any job j ...*)
      Variable j: JobIn arr_seq.

      (* ...with response-time bound R in this schedule, ... *)
      Variable R: time.
      Hypothesis response_time_bound:
        job_has_completed_by j (job_arrival j + R).

      (* the service received by j at any time t' after its response time is 0. *)
      Lemma service_after_job_rt_zero :
        forall t',
          t' >= job_arrival j + R ->
          service_at sched j t' = 0.
      Proof.
        rename response_time_bound into RT,
               H_completed_jobs_dont_execute into EXEC; ins.
        unfold is_response_time_bound_of_task, completed,
               completed_jobs_dont_execute in *.
        apply/eqP; rewrite -leqn0.
        rewrite <- leq_add2l with (p := job_cost j).
        move: RT => /eqP RT; rewrite -{1}RT addn0.
        apply leq_trans with (n := service sched j t'.+1);
          last by apply EXEC.
        unfold service; rewrite -> big_cat_nat with
                                   (p := t'.+1) (n := job_arrival j + R);
            [rewrite leq_add2l /= | by ins | by apply ltnW].
          by rewrite big_nat_recr // /=; apply leq_addl.
      Qed.

      (* The same applies for the cumulative service of job j. *)
      Lemma cumulative_service_after_job_rt_zero :
        forall t' t'',
          t' >= job_arrival j + R ->
          \sum_(t' <= t < t'') service_at sched j t = 0.
      Proof.
        ins; apply/eqP; rewrite -leqn0.
        rewrite big_nat_cond; rewrite -> eq_bigr with (F2 := fun i => 0);
          first by rewrite big_const_seq iter_addn mul0n addn0 leqnn.
        intro i; rewrite andbT; move => /andP [LE _].
        by rewrite service_after_job_rt_zero;
          [by ins | by apply leq_trans with (n := t')].
      Qed.

    End SpecificJob.

    Section AllJobs.

      (* Consider any task tsk ...*)
      Variable tsk: sporadic_task.

      (* ... for which a response-time bound R is known. *)
      Variable R: time.
      Hypothesis response_time_bound:
        is_response_time_bound_of_task job_cost job_task tsk sched R.

      (* Then, for any job j of this task, ...*)
      Variable j: JobIn arr_seq.
      Hypothesis H_job_of_task: job_task j = tsk.

      (* the service received by job j at any time t' after the response time is 0. *)
      Lemma service_after_task_rt_zero :
        forall t',
          t' >= job_arrival j + R ->
          service_at sched j t' = 0.
      Proof.
        by ins; apply service_after_job_rt_zero with (R := R); [apply response_time_bound |].
      Qed.

      (* The same applies for the cumulative service of job j. *)
      Lemma cumulative_service_after_task_rt_zero :
        forall t' t'',
          t' >= job_arrival j + R ->
          \sum_(t' <= t < t'') service_at sched j t = 0.
      Proof.
        by ins; apply cumulative_service_after_job_rt_zero with (R := R);
          first by apply response_time_bound.
      Qed.

    End AllJobs.

  End BasicLemmas.

End ResponseTime.


(**
  Ciro Iván García López
  Tesis de Maestría
  Session Type Systems Verification
  Unam - 2021
*)
From Tmcod Require Import Defs_Proposition.
From Tmcod Require Import Defs_Tactics.

(**
  The dual operation is idempotent.
*)
Proposition Doble_Duality_ULLT  :
forall A : Proposition ,
(A^⊥)^⊥ = A.
Proof.
  StructuralInduction A.

Qed.
#[global]
Hint Resolve Doble_Duality_ULLT : Piull.

(**
  The definition of the linear implication is well defined.
*)
Proposition Dual_Implication_Tensor :
forall A B : Proposition ,
((A −∘ B)^⊥) = (A ⊗ (B^⊥)).
Proof.
  intros.
  unfold ULLT_IMP.
  simpl.
  rewrite -> (Doble_Duality_ULLT A).
  reflexivity.
Qed.
#[global]
Hint Resolve Dual_Implication_Tensor : Piull.

(**
  Relation between duals, tensor and linear implication.
  The proof follows fron the definitions.
*)
Proposition Dual_Tensor_Implication :
forall A B : Proposition,
((A ⊗ B )^⊥) = (A −∘ (B^⊥)).
Proof.
  auto with Piull.
Qed.
#[global]
Hint Resolve Dual_Implication_Tensor : Piull.

(**
  The linar implication respect the idempotent property of the tensor.
  The proof follows from the definitions.
*)
Proposition Doble_Dual_Implication :
forall A B : Proposition,
(((A −∘ B)^⊥)^⊥) = (A −∘ B).
Proof.
  auto with Piull.
Qed.
#[global]
Hint Resolve Dual_Implication_Tensor : Piull.

(**
*)
Theorem Decid_Propositions :
forall (A B : Proposition),
A = B \/ A <> B.
Proof.
  intro.
  induction A.
  + destruct B; OrSearch.
  + destruct B; OrSearch.
  + destruct B; try OrSearch.
    specialize (IHA1 B1).
    specialize (IHA2 B2).
    destruct IHA1.
    - destruct IHA2.
      * subst. Piauto.
      * right.
        unfold not.
        intros.
        apply H0.
        inversions H1.
        Piauto.
    - right.
      unfold not.
      intros.
      apply H.
      inversions H0.
      Piauto.
  + destruct B; try OrSearch.
    specialize (IHA1 B1).
    specialize (IHA2 B2).
    destruct IHA1.
    - destruct IHA2.
      * subst. Piauto.
      * right.
        unfold not.
        intros.
        apply H0.
        inversions H1.
        Piauto.
    - right.
      unfold not.
      intros.
      apply H.
      inversions H0.
      Piauto.
  + destruct B; try OrSearch.
    specialize (IHA B).
    destruct IHA.
    - rewrite H.
      OrSearch.
    - right.
      unfold not.
      intros.
      apply H.
      inversions H0.
      Piauto.
  + destruct B; try OrSearch.
    specialize (IHA B).
    destruct IHA.
    - rewrite H.
      OrSearch.
    - right.
      unfold not.
      intros.
      apply H.
      inversions H0.
      Piauto.
Qed.
#[global]
Hint Resolve Decid_Propositions : Piull.

(**
*)
Proposition Dual_inv :
forall A B : Proposition ,
(A^⊥)= (B^⊥) -> A = B.
Proof.
  intros.
  assert ( Ha : (A ^⊥)^⊥ = A); Piauto.
  rewrite H in Ha.
  rewrite Doble_Duality_ULLT in Ha.
  Piauto.
Qed.
#[global]
Hint Resolve Dual_inv : Piull.