Require Import Coq.Classes.SetoidClass.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Peano_dec.
Require Import NatList.
Require Import MyInductions.

Module PartialMap.

Fixpoint myeq_nat n m  :=
  match n, m with
    | O, O => true
    | O, S _ => false
    | S _, O => false
    | S n1, S m1 => myeq_nat n1 m1
  end.

Theorem myeq_nat_eq : forall n, (myeq_nat n n) = true.
Proof.
induction n.
simpl.
reflexivity.
simpl.
assumption.
Qed.

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id x1 x2 :=
  match x1, x2 with
    | Id n1, Id n2 => myeq_nat n1 n2
  end.

Check beq_id.

Theorem beq_id_refl : forall x, true = beq_id x x.
Proof.
  intros.
  induction x.
  simpl.
  induction n.
  simpl.
  reflexivity.
  simpl.
  assumption.
Qed.

Inductive partial_map : Type :=
 | empty : partial_map
| record : id -> nat -> partial_map -> partial_map.

Definition update(d : partial_map) (key : id) (value : nat) : partial_map :=
  record key value d.

Fixpoint find (key : id) (d : partial_map) : NatList.natoption :=
  match d with
    |empty => NatList.None
    |record k v d' => if beq_id key k then NatList.Some v else find key d'
  end.

Theorem update_eq :
  forall (d : partial_map) (k : id) (v : nat),
    find k (update d k v) = NatList.Some v.
  Proof.
    intros.
    induction d.
    simpl.
    rewrite <- beq_id_refl.
    reflexivity.
    simpl.
    rewrite <- beq_id_refl.
    reflexivity.
  Qed.

Theorem update_neq :
  forall (d : partial_map) (m n : id) (o : nat), beq_id m n = false -> find m (update d n o) = find m d.
Proof.
  intros.
  simpl.
  rewrite ->H.
  reflexivity.
Qed.

Inductive list (X : Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Print nat.
Check list.

Check nil.

Check (cons nat 2 (cons nat 1 (nil nat))).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
| 0 => nil X
| S count' => cons X x (repeat X x count')
  end.

Example test_repeat1 : repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof.
  reflexivity.
Qed.

Example test_repeat2 : repeat bool false 1 = cons bool false (nil bool).
Proof.
  reflexivity.
Qed.

Module MumbleGrumble.

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

Definition toto := (d mumble (b a 5)).

Check toto.

End MumbleGrumble.

Fixpoint repeat' X x count : list X :=
  match count with
| 0 => nil X
| S count' => cons X x (repeat' X x count')
  end.

Check repeat'.

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Inductive list' {X:Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.

Fixpoint app {X: Type} (l1 l2 : list X) : (list X) :=
  match l1 with
    | nil => l2
    | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X: Type} (l : list X) : list X :=
  match l with
      | nil => nil
      | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
    | nil => 0
    | cons _ l' => S (length l')
  end.

Fail Definition mynil := nil.

Check @nil.
Definition mynil' := @nil nat.

Notation "x :: y" := (cons x y) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation " x ++ y" := (app x y) (at level 60, right associativity).

Definition list123''' := [1;2;3].
Example test_rev1 : rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

Check @doit3times.

Theorem app_nil_r : forall (X:Type), forall l : list X, l ++ [] = l.
Proof.
  intros.
  induction l.
  intros.
  simpl.
  reflexivity.
  simpl.
  rewrite ->IHl.
  reflexivity.
Qed.

Theorem app_assoc : forall A (l m n : list A), l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros.
  induction l.
  simpl.
  reflexivity.
  simpl.
  rewrite ->IHl.
  reflexivity.
Qed.

Lemma app_length : forall (X : Type) (l1 l2 : list X), length(l1 ++ l2) = length l1 + length l2.
Proof.
  intros.
  induction l1.
  simpl.
  reflexivity.
  simpl.
  rewrite ->IHl1.
  reflexivity.
Qed.

Theorem rev_app_distr : forall (X : Type) (l1 l2 : list X), rev(l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros.
  induction l1.
  simpl.
  rewrite -> app_nil_r.
  reflexivity.
  simpl.
  rewrite -> IHl1.
  rewrite <- app_assoc.
  reflexivity.
Qed.

Theorem rev_involutive : forall (X : Type) (l : list X), rev (rev l) = l.
Proof.
  intros.
  induction l.
  simpl.
  reflexivity.
  simpl.
  replace ([x]) with (rev [x]).
  set (rev l).
  set (rev [x]).
  rewrite ->rev_app_distr.
  unfold l1.
  unfold l0.
  simpl.
  rewrite ->IHl.
  reflexivity.
  simpl.
  reflexivity.
Qed.

(* Polymorphic Pairs *)

Inductive prod (X Y : Type) : Type :=
| pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
    | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
    | (x, y) => y
  end.

Fixpoint combine { X Y : Type } (lx : list X) (ly : list Y) : list (X * Y) :=
  match lx, ly with
| [], _ => []
| _, [] => []
| x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Check @combine.

Compute (combine [1;2] [false;false;true;true]).

Fixpoint first_on_list { X Y : Type } (lx : list ( X * Y )) : list (X) :=
  match lx with
    | [] => []
    | x::t => (fst x)::(first_on_list t)
  end.

Fixpoint snd_on_list { X Y : Type } (lx : list ( X * Y )) : list (Y) :=
  match lx with
    | [] => []
    | x::t => (snd x)::(snd_on_list t)
  end.

Fixpoint split {X Y : Type} (l : list (X * Y)) : (list X) * (list Y) :=
  (first_on_list l, snd_on_list l).

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
  reflexivity.
Qed.

Check @split.

(* Polymorphic Options *)

Inductive option2 ( X : Type ) : Type :=
  | Some2 : X -> option2 X
  | None2 : option2 X.

Arguments Some2 {X} _.
Arguments None2 {X}.

Fixpoint nth_error2 {X : Type } (l : list X) (n : nat) : option2 X :=
  match l with
    | [] => None2
    | a :: l2 => if myeq_nat n 0 then Some2 a else nth_error2 l2 (n-1)
  end.

Example test_nth_error1 : nth_error2 [4;5;6;7] 0 = Some2 4.
Proof.
  reflexivity.
Qed.

Example test_nth_error2 : nth_error2 [[1];[2]] 1 = Some2 [2].
Proof.
  simpl.
  reflexivity.
Qed.

Fixpoint evenb (n:nat) : bool :=
  match n with
      | O => true
      | S O => false
      | S (S n') => evenb n'
  end.

Definition oddb (n:nat) := negb (evenb (n)).

Fixpoint filter { X : Type} (test : X -> bool) (l:list X) : (list X) :=
  match l with
    | [] => []
    | h::t => if test h then h :: (filter test t) else filter test t
  end.

Example test_filter1 : filter evenb [1;2;3;4] = [2;4].
Proof.
  reflexivity.
Qed.

Definition length_is_1 { X : Type } (l : list X) : bool :=
  myeq_nat (length l) 1.

Example test_filter2 : filter length_is_1 [ [1;2];[3];[4];[5;6;7];[];[8]] = [[3];[4];[8]].
Proof.
  reflexivity.
Qed.

Definition countoddmembers' (l : list nat) : nat := length (filter oddb l).

Example test_countoddmembers'1 : countoddmembers' [1;0;3;1;4;5] = 4.
Proof.
  reflexivity.
Qed.

Example test_countoddmembers'2: countoddmembers' [0;2;4] = 0.
Proof.
  reflexivity.
Qed.

Example test_countoddmembers'3: countoddmembers' nil = 0.
Proof.
  reflexivity.
Qed.

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof.
  reflexivity.
Qed.

Example test_filter2' : filter (fun l => NatList.myeq_nat (length l) 1) [[1;2];[3];[4];[5;6;7];[];[8]] = [[3];[4];[8]].
Proof.
  reflexivity.
Qed.

Definition filter_event_gt7 ( l : list nat) : list nat :=
  filter (fun h
          =>
             if ( (oddb h) ) then true else false

         ) l.

Definition partition { X : Type } (test : X -> bool) (l : list X) : list X * list X :=
  ((filter (fun h => (test h)) l), (filter (fun h => (negb (test h))) l)).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof.
  reflexivity.
Qed.

Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof.
  reflexivity.
Qed.

Fixpoint map {X Y : Type} (f: X -> Y) (l:list X) : (list Y) :=
  match l with
    | [] => []
    | h :: t => (f h) :: (map f t)
  end.

Theorem map_app_distr :  forall (X Y : Type) (f : X -> Y) (l1 l2 : list X), map f (l1 ++ l2) = map f l1 ++ map f l2.
Proof.
  intros.
  induction l1.
  simpl.
  reflexivity.
  replace (x::l1) with ([x]++l1).
  rewrite <- app_assoc.
  simpl.
  rewrite <- IHl1.
  reflexivity.
  simpl.
  reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X), map f (rev l) = rev (map f l).
Proof.
  intros.
  induction l.
  simpl.
  reflexivity.
  replace ( x :: l) with ([x]++l).
  rewrite -> rev_app_distr.
  rewrite -> map_app_distr.
  simpl.
  rewrite <-IHl.
  reflexivity.
  simpl.
  reflexivity.
Qed.

Fixpoint flat_map {X Y : Type} (f: X -> list Y) (l : list X) : (list Y) :=
  match l with
    | [] => []
    | h::t => (let r := (f h) in
              (r ++ (flat_map f t)))
  end.

Example test_flat_map1 : flat_map (fun n => [n;n;n]) [1;5;4] = [1;1;1;5;5;5;4;4;4].
Proof.
  reflexivity.
Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X) : option Y :=
  match xo with
      | None => None
      | Some x => Some (f x)
  end.

Fixpoint fold {X Y : Type} (f : X -> Y -> Y) (l : list X) (b : Y) : Y :=
  match l with
    | nil => b
    | h :: t => f h (fold f t b)
  end.

Compute fold plus [1;2;3;4] 0.

Example fold_example1 : fold mult [1;2;3;4] 1 = 24.
Proof.
  reflexivity.
Qed.

Definition constfun {X : Type} (x : X) : nat -> X := fun (k : nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof.
  reflexivity.
Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof.
  reflexivity.
Qed.

Check plus.

Definition fold_length { X : Type } (l : list X) : nat := fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof.
  reflexivity.
Qed.

Theorem fold_length_app : forall X (l1 l2 : list X),
                             fold_length (l1++l2) = fold_length (l1) + fold_length (l2).
Proof.
  intros.
  induction l1.
  simpl.
  reflexivity.
  replace (x::l1) with ([x]++l1).
  rewrite <- app_assoc.
  unfold fold_length in IHl1.
  unfold fold_length.
  simpl.
  rewrite <-IHl1.
  reflexivity.
  simpl.
  reflexivity.
Qed.

Theorem fold_length_correct : forall X (l : list X), fold_length l = length l.
Proof.
  intros.
  induction l.
  simpl.
  unfold fold_length.
  simpl.
  reflexivity.
  replace (x::l) with ([x]++l).
  rewrite -> app_length.
  rewrite -> fold_length_app.
  rewrite -> IHl.
  replace (length [x]) with 1.
  replace (fold_length [x]) with 1.
  reflexivity.
  unfold fold_length.
  unfold fold.
  reflexivity.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
Qed.

Definition toto := [1;2;3].

(*Definition fold_map {X Y : Type} (f : X -> Y) (l : list X) : list Y := *)
Theorem silly1 : forall (n m o p : nat), (n = m) -> ([n;o] = [n;p]) -> ([n;o] = [m;p]).
Proof.
  intros.
  rewrite <- H.
  apply H0.
Qed.

Theorem silly2 : forall (n m o p : nat), n = m -> (forall ( q r : nat), q = r -> [q;o] = [r;p]) -> [n;o] = [m;p].
Proof.
  intros.
  apply H0.
  apply H.
Qed.

Theorem silly2a : forall (n m : nat), (n,n) = (m,m) -> (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) -> [n] = [m].
Proof.
  intros n m eq1 eq2.
  apply eq2.
  apply eq1.
Qed.

(* Logical Connectives *)

Example and_example : 3 + 4 = 7 /\ 2 * 2 =4.
Proof.
  split.
  reflexivity.
  reflexivity.
Qed.

Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof.
  intros A B HA HB. split.
  - apply HA.
  - apply HB.
Qed.

Theorem plus_0_n2 : forall n : nat, n + 0 = n.
Proof.
  intros.
  induction n.
  simpl.
  reflexivity.
  simpl.
  rewrite ->IHn.
  reflexivity.
Qed.

Theorem a_n_0 : forall a : nat, S a <> 0.
Proof.
  auto.
Qed.

Theorem a_p_b : forall a b : nat, a + S b <> 0.
Proof.
  intros.
  induction a.
  simpl.
  auto.
  simpl.
  set (a + S b).
  apply a_n_0.
Qed.

Theorem and_exercise : forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros.
  split.
  destruct m.
  rewrite <-H.
  replace (n + 0) with n.
  reflexivity.
  rewrite -> plus_0_n2.
  reflexivity.
  absurd (n + S m = 0).
  apply a_p_b.
  assumption.
  destruct n.
  rewrite <- H.
  simpl.
  reflexivity.
  absurd (S n + m = 0).
  set (S n).
  rewrite <- MyInductions.plus_comm.
  unfold n0.
  apply a_p_b.
  assumption.
Qed.

Lemma proj2 : forall P Q : Prop, P /\ Q -> P.
Proof.
  intros P Q [HP HQ].
  apply HP.
Qed.

Theorem and_commut : forall P Q : Prop, P /\ Q -> Q /\ P.
Proof.
  intros P Q [HP HQ].
  split.
  apply HQ.
  apply HP.
Qed.

Theorem  and_assoc : forall P Q R : Prop, P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R [HP [HQ HR]].
  split.
  split.
  assumption.
  assumption.
  assumption.
Qed.

Theorem mult_0_r : forall n : nat, n * 0 = 0.
Proof.
  intros n. induction n as [|n' IHn'].
  reflexivity.
  simpl.
  assumption.
Qed.

Theorem mult_0_elm : forall n : nat, n * 0 = 0.
Proof.
  auto.
Qed.

Lemma or_example : forall n m : nat, n = 0 \/ m = 0 -> n*m = 0.
Proof.
  intros n m [Hn | Hm].
  rewrite Hn.
  reflexivity.
  rewrite Hm.
  rewrite mult_0_elm.
  reflexivity.
Qed.

Lemma or_intro : forall A B : Prop, A -> A \/ B.
Proof.
  intros A B HA.
  left.
  apply HA.
Qed.

Lemma zero_or_succ : forall n : nat, n = 0 \/ n = S (pred n).
Proof.
  intros [|n].
  - left. reflexivity.
  - right. reflexivity.
Qed.

Lemma toto100 : forall n, ((0 = (S n)) <-> False).
Proof.
  intros.
  split.
  intro.
  inversion H.
  intro.
  contradiction.
Qed.

Lemma mult_eq_0 : forall n m, n *m = 0 -> n = 0 \/ m = 0.
Proof.
  intros.
  induction n.
  left.
  reflexivity.
  right.
  admit.
Qed.

Theorem or_commut : forall P Q : Prop, P \/ Q -> Q \/ P.
Proof.
  intros.
  destruct H as [H1 | H2].
  right.
  assumption.
  left.
  assumption.
Qed.

Fact not_implies_out_not : forall (P:Prop), ~P -> (forall (Q:Prop), P -> Q).
Proof.
  intros.
  elim H.
  assumption.
Qed.

Theorem zeo_not_one : ~(0 = 1).
Proof.
  intros contra.
  inversion contra.
Qed.

Check (0 <> 1).

Theorem zero_not_one : 0 <> 1.
Proof.
  intros H.
  inversion H.
Qed.

Theorem not_False :
  not False.
Proof.
  unfold not.
  intros H.
  destruct H.
Qed.

Theorem contradiction_implies_anything : forall P Q : Prop, (P /\ ~P) -> Q.
Proof.
  intros P Q [HP HNA].
  unfold not in HNA.
  apply HNA in HP.
  destruct HP.
Qed.

Theorem double_neg : forall P : Prop,
    P -> ~~P.
Proof.
  intros P H.
  unfold not.
  intros G.
  apply G.
  apply H.
Qed.

Theorem contrapositive : forall (P Q : Prop), (P -> Q) -> (~Q -> ~P).
Proof.
  intros A B C.
  unfold not.
  intro D.
  intro E.
  apply D.
  apply C.
  apply E.
Qed.

Theorem not_both_true_and_false : forall P : Prop, ~( P /\ ~P).
Proof.
  unfold not.
  intro H.
  intro G.
  apply G.
  apply G.
Qed.

Theorem ex_falso_quodlibet : forall (P:Prop), False -> P.
Proof.
  intros P contra.
  destruct contra.
Qed.

Lemma True_is_true : True.
  Proof.
    apply I.
  Qed.

Theorem iff_sym : forall P Q : Prop,
      (P <-> Q) -> (Q <-> P).
Proof.
  intros P Q [HAB HBA].
  split.
  apply HBA.
  apply HAB.
Qed.

Lemma not_true_iff_false : forall b, b<> true <-> b = false.
Proof.
  intros b. split.
  apply not_true_is_false.
  intros H.  rewrite H. intros H'. inversion H'.
Qed.

Theorem iff_refl : forall P : Prop, P <-> P.
Proof.
  intro P.
  split.
  intros.
  apply H.
  intros.
  apply H.
Qed.

Theorem iff_trans : forall P Q R : Prop, (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros.
  split.
  intros.
  apply H0.
  apply H.
  assumption.
  intros.
  apply H.
  apply H0.
  apply H1.
Qed.

Theorem or_distributes_over_and : forall P Q R : Prop, P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros.
  split.
  intro.
  elim H.
  intro.
  split.
  left.
  apply H0.
  left.
  apply H0.
  elim H.
  intro.
  intro.
  split.
  left.
  apply H0.
  left.
  apply H0.
  intro.
  intro.
  split.
  right.
  elim H1.
  intros.
  apply H2.
  right.
  elim H1.
  intros.
  apply H3.
  intros.
  destruct H as [H1 H2].
  elim H1.
  elim H2.
  intros.
  left.
  apply H0.
  intros.
  left.
  apply H0.
  intros.
  destruct H2 as [H3 | H4].
  left.
  apply H3.
  right.
  split.
  apply H.
  apply H4.
Qed.

Lemma four_is_even : exists n : nat, 4 = n + n.
Proof.
  exists 2.
  reflexivity.
Qed.

Theorem exists_example_2 : forall n, (exists m, n = 4 +m) -> (exists o, n = 2 + o).
Proof.
  intros n [m Hm].
  exists (2 + m).
  apply Hm.
Qed.

Theorem dist_not_exists :
  forall (X : Type) (P : X -> Prop), (forall x, P x) -> ~ (exists x, ~P x).
  intros.
  unfold not.
  intros.
  destruct H0 as [x G].
  apply G.
  apply H.
Qed.

Theorem dist_exists_or :
  forall (X : Type) (P Q : X -> Prop), (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
  intros.
  split.
  intros.
  left.

End PartialMap.

(* MAP *)


Require Import WildCat.
Require Import Spaces.Nat.
Require Export Classes.interfaces.abstract_algebra.
Require Import Algebra.AbGroups.
Require Export Classes.theory.rings.
Require Import Modalities.ReflectiveSubuniverse.

(** Theory of commutative rings *)

(** TODO: We should really develop the theory of non-commutative rings seperately, and have commutative rings as a special case of that theory. Similar to how we have Group and AbGroup. But since we are only interested in commutative rings for the time being, it makes sense to only consider them. *)

Declare Scope ring_scope.

Local Open Scope ring_scope.
(** We want to print equivalences as [≅]. *)
Local Open Scope wc_iso_scope.

(** A commutative ring consists of the following data *)
Record CRing := {
  cring_type : Type;
  cring_plus : Plus cring_type;
  cring_mult : Mult cring_type;
  cring_zero : Zero cring_type;
  cring_one  : One  cring_type;
  cring_negate : Negate cring_type;
  cring_isring : IsRing cring_type;
}.

Arguments cring_plus {_}.
Arguments cring_mult {_}.
Arguments cring_zero {_}.
Arguments cring_one {_}.
Arguments cring_negate {_}.
Arguments cring_isring {_}.

Definition issig_CRing : _ <~> CRing := ltac:(issig).

(** We coerce rings to their underlying type. *)
Coercion cring_type : CRing >-> Sortclass.
(** All fields which are typeclasses are global instances *)
Global Existing Instances cring_plus cring_mult cring_zero cring_one cring_negate cring_isring.

(** A ring homomorphism between commutative rings is a map of the underlying type and a proof that this map is a ring homomorphism. *)
Record CRingHomomorphism (A B : CRing) := {
  rng_homo_map : A -> B;
  rng_homo_ishomo : IsSemiRingPreserving rng_homo_map;
}.

Arguments Build_CRingHomomorphism {_ _} _ _.

Definition issig_CRingHomomorphism (A B : CRing)
  : _ <~> CRingHomomorphism A B
  := ltac:(issig).

(** We coerce ring homomorphisms to their underlying maps *)
Coercion rng_homo_map : CRingHomomorphism >-> Funclass.
Global Existing Instance rng_homo_ishomo.

Definition equiv_path_cringhomomorphism `{Funext} {A B : CRing}
  {f g : CRingHomomorphism A B} : f == g <~> f = g.
Proof.
  refine ((equiv_ap (issig_CRingHomomorphism A B)^-1 _ _)^-1 oE _).
  refine (equiv_path_sigma_hprop _ _ oE _).
  apply equiv_path_forall.
Defined.

Definition rng_homo_id (A : CRing) : CRingHomomorphism A A
  := Build_CRingHomomorphism idmap _.

Definition rng_homo_compose {A B C : CRing}
  (f : CRingHomomorphism B C) (g : CRingHomomorphism A B)
  : CRingHomomorphism A C.
Proof.
  snrapply Build_CRingHomomorphism.
  1: exact (f o g).
  rapply compose_sr_morphism.
Defined.

(** ** Ring laws *)

Section RingLaws.

  (** Many of these ring laws have already been proven. But we give them names here so that they are easy to find and use. *)

  Context {A B : CRing} (f : CRingHomomorphism A B) (x y z : A).

  Definition rng_dist_l : x * (y + z) = x * y + x * z := simple_distribute_l _ _ _.
  Definition rng_dist_r : (x + y) * z = x * z + y * z := simple_distribute_r _ _ _.
  Definition rng_plus_zero_l : 0 + x = x := left_identity _.
  Definition rng_plus_zero_r : x + 0 = x := right_identity _.
  Definition rng_plus_negate_l : (- x) + x = 0 := left_inverse _.
  Definition rng_plus_negate_r : x + (- x) = 0 := right_inverse _.

  Definition rng_plus_comm : x + y = y + x := commutativity x y.
  Definition rng_plus_assoc : x + (y + z) = (x + y) + z := simple_associativity x y z.
  Definition rng_mult_comm : x * y = y * x := commutativity x y.
  Definition rng_mult_assoc : x * (y * z) = (x * y) * z := simple_associativity x y z.

  Definition rng_negate_negate : - (- x) = x := negate_involutive _.

  Definition rng_mult_one_l : 1 * x = x := left_identity _.
  Definition rng_mult_one_r : x * 1 = x := right_identity _.
  Definition rng_mult_zero_l : 0 * x = 0 := left_absorb _.
  Definition rng_mult_zero_r : x * 0 = 0 := right_absorb _.
  Definition rng_mult_negate : -1 * x = - x := (negate_mult _)^.
  Definition rng_mult_negate_negate : -x * -y = x * y := negate_mult_negate _ _.
  Definition rng_mult_negate_l : -x * y = -(x * y) := inverse (negate_mult_distr_l _ _).
  Definition rng_mult_negate_r : x * -y = -(x * y) := inverse (negate_mult_distr_r _ _).

  Definition rng_homo_plus : f (x + y) = f x + f y := preserves_plus x y.
  Definition rng_homo_mult : f (x * y) = f x * f y := preserves_mult x y.
  Definition rng_homo_zero : f 0 = 0 := preserves_0.
  Definition rng_homo_one  : f 1 = 1 := preserves_1.
  Definition rng_homo_negate : f (-x) = -(f x) := preserves_negate x.

  Definition rng_homo_minus_one : f (-1) = -1
    := preserves_negate 1%mc @ ap negate preserves_1.

End RingLaws.

(** Isomorphisms of commutative rings *)
Record CRingIsomorphism (A B : CRing) := {
  rng_iso_homo : CRingHomomorphism A B ;
  isequiv_rng_iso_homo : IsEquiv rng_iso_homo ;
}.

Arguments rng_iso_homo {_ _ }.
Coercion rng_iso_homo : CRingIsomorphism >-> CRingHomomorphism.
Global Existing Instance isequiv_rng_iso_homo.

Definition issig_CRingIsomorphism {A B : CRing}
  : _ <~> CRingIsomorphism A B := ltac:(issig).

(** We can construct a ring isomorphism from an equivalence that preserves addition and multiplication. *)
Definition Build_CRingIsomorphism' (A B : CRing) (e : A <~> B)
  `{!IsSemiRingPreserving e}
  : CRingIsomorphism A B
  := Build_CRingIsomorphism A B (Build_CRingHomomorphism e _) _.

(** The inverse of a CRing isomorphism *)
Definition rng_iso_inverse {A B : CRing}
  : CRingIsomorphism A B -> CRingIsomorphism B A.
Proof.
  intros [f e].
  snrapply Build_CRingIsomorphism.
  { snrapply Build_CRingHomomorphism.
    1: exact f^-1.
    exact _. }
  exact _.
Defined.

(** CRing isomorphisms are a reflexive relation *)
Global Instance reflexive_cringisomorphism : Reflexive CRingIsomorphism
  := fun x => Build_CRingIsomorphism _ _ (rng_homo_id x) _.

(** CRing isomorphisms are a symmetric relation *)
Global Instance symmetry_cringisomorphism : Symmetric CRingIsomorphism
  := fun x y => rng_iso_inverse.

(** CRing isomorphisms are a transitive relation *)
Global Instance transitive_cringisomorphism : Transitive CRingIsomorphism
  := fun x y z f g => Build_CRingIsomorphism _ _ (rng_homo_compose g f) _.

(** Underlying abelian groups of rings *)
Definition abgroup_cring : CRing -> AbGroup.
Proof.
  intro A.
  snrapply Build_AbGroup.
  - srapply (Build_Group (cring_type A)).
  - exact _.
Defined.

Coercion abgroup_cring : CRing >-> AbGroup.

(** Underlying group homomorphism of a ring homomorphism *)
Definition grp_homo_rng_homo {R S : CRing}
  : CRingHomomorphism R S -> GroupHomomorphism R S
  := fun f => @Build_GroupHomomorphism R S f _.

Coercion grp_homo_rng_homo : CRingHomomorphism >-> GroupHomomorphism.

(** We can construct a ring homomorphism from a group homomorphism that preserves multiplication *)
Definition Build_CRingHomomorphism' (A B : CRing) (map : GroupHomomorphism A B)
  {H : IsMonoidPreserving (Aop:=cring_mult) (Bop:=cring_mult)
    (Aunit:=one) (Bunit:=one) map}
  : CRingHomomorphism A B
  := Build_CRingHomomorphism map
      (Build_IsSemiRingPreserving _ (grp_homo_ishomo _ _ map) H).

(** We can construct a ring isomorphism from a group isomorphism that preserves multiplication *)
Definition Build_CRingIsomorphism'' (A B : CRing) (e : GroupIsomorphism A B)
  {H : IsMonoidPreserving (Aop:=cring_mult) (Bop:=cring_mult) (Aunit:=one) (Bunit:=one) e}
  : CRingIsomorphism A B
  := @Build_CRingIsomorphism' A B e (Build_IsSemiRingPreserving e _ H).

(** Here is an alternative way to build a commutative ring using the underlying abelian group. *)
Definition Build_CRing' (R : AbGroup)
  `(Mult R, One R, LeftDistribute R mult (@group_sgop R))
  (iscomm : @IsCommutativeMonoid R mult one)
  : CRing
  := Build_CRing R (@group_sgop R) _ (@group_unit R) _
       (@group_inverse R) (Build_IsRing _ _ _ _).

(** ** Ring movement lemmas *)

Section RingMovement.

  (** We adopt a similar naming convention to the [moveR_equiv] style lemmas that can be found in Types.Paths. *)

  Context {R : CRing} {x y z : R}.

  Definition rng_moveL_Mr : - y + x = z <~> x = y + z := @grp_moveL_Mg R x y z.
  Definition rng_moveL_rM : x + - z = y <~> x = y + z := @grp_moveL_gM R x y z.
  Definition rng_moveR_Mr : y = - x + z <~> x + y = z := @grp_moveR_Mg R x y z.
  Definition rng_moveR_rM : x = z + - y <~> x + y = z := @grp_moveR_gM R x y z.

  Definition rng_moveL_Vr : x + y = z <~> y = - x + z := @grp_moveL_Vg R x y z.
  Definition rng_moveL_rV : x + y = z <~> x = z + - y := @grp_moveL_gV R x y z.
  Definition rng_moveR_Vr : x = y + z <~> - y + x = z := @grp_moveR_Vg R x y z.
  Definition rng_moveR_rV : x = y + z <~> x + - z = y := @grp_moveR_gV R x y z.

  Definition rng_moveL_M0 : - y + x = 0 <~> x = y := @grp_moveL_M1 R x y.
  Definition rng_moveL_0M :	x + - y = 0 <~> x = y := @grp_moveL_1M R x y.
  Definition rng_moveR_M0 : 0 = - x + y <~> x = y := @grp_moveR_M1 R x y.
  Definition rng_moveR_0M : 0 = y + - x <~> x = y := @grp_moveR_1M R x y.

  (** TODO: Movement laws about mult *)

End RingMovement.

(** ** Wild category of commutative rings *)

Global Instance isgraph_cring : IsGraph CRing
  := Build_IsGraph _ CRingHomomorphism.

Global Instance is01cat_cring : Is01Cat CRing
  := Build_Is01Cat _ _ rng_homo_id (@rng_homo_compose).

Global Instance is2graph_cring : Is2Graph CRing
  := fun A B => isgraph_induced (@rng_homo_map A B).

Global Instance is01cat_cringhomomorphism {A B : CRing} : Is01Cat (A $-> B)
  := is01cat_induced (@rng_homo_map A B).

Global Instance is0gpd_cringhomomorphism {A B : CRing} : Is0Gpd (A $-> B)
  := is0gpd_induced (@rng_homo_map A B).

Global Instance is0functor_postcomp_cringhomomorphism {A B C : CRing} (h : B $-> C)
  : Is0Functor (@cat_postcomp CRing _ _ A B C h).
Proof.
  apply Build_Is0Functor.
  intros [f ?] [g ?] p a ; exact (ap h (p a)).
Defined.

Global Instance is0functor_precomp_cringhomomorphism
       {A B C : CRing} (h : A $-> B)
  : Is0Functor (@cat_precomp CRing _ _ A B C h).
Proof.
  apply Build_Is0Functor.
  intros [f ?] [g ?] p a ; exact (p (h a)).
Defined.

(** CRing forms a 1Cat *)
Global Instance is1cat_cring : Is1Cat CRing.
Proof.
  by rapply Build_Is1Cat.
Defined.

Global Instance hasmorext_cring `{Funext} : HasMorExt CRing.
Proof.
  srapply Build_HasMorExt.
  intros A B f g; cbn in *.
  snrapply @isequiv_homotopic.
  1: exact (equiv_path_cringhomomorphism^-1%equiv).
  1: exact _.
  intros []; reflexivity.
Defined.

Global Instance hasequivs_cring : HasEquivs CRing.
Proof.
  unshelve econstructor.
  + exact CRingIsomorphism.
  + exact (fun G H f => IsEquiv f).
  + intros G H f; exact f.
  + exact Build_CRingIsomorphism.
  + intros G H; exact rng_iso_inverse.
  + cbn; exact _.
  + reflexivity.
  + intros ????; apply eissect.
  + intros ????; apply eisretr.
  + intros G H f g p q.
    exact (isequiv_adjointify f g p q).
Defined.

(** ** Product ring *)

Definition cring_product : CRing -> CRing -> CRing.
Proof.
  intros R S.
  snrapply Build_CRing'.
  1: exact (ab_biprod R S).
  1: exact (fun '(r1 , s1) '(r2 , s2) => (r1 * r2 , s1 * s2)).
  1: exact (cring_one , cring_one).
  { intros [r1 s1] [r2 s2] [r3 s3].
    apply path_prod; cbn; apply rng_dist_l. }
  repeat split.
  1: exact _.
  { intros [r1 s1] [r2 s2] [r3 s3].
    apply path_prod; cbn; apply rng_mult_assoc. }
  1: intros [r1 s1]; apply path_prod; cbn; apply rng_mult_one_l.
  1: intros [r1 s1]; apply path_prod; cbn; apply rng_mult_one_r.
  intros [r1 s1] [r2 s2]; apply path_prod; cbn; apply rng_mult_comm.
Defined.

Infix "×" := cring_product : ring_scope.

Definition cring_product_fst {R S : CRing} : R × S $-> R.
Proof.
  snrapply Build_CRingHomomorphism.
  1: exact fst.
  repeat split.
Defined.

Definition cring_product_snd {R S : CRing} : R × S $-> S.
Proof.
  snrapply Build_CRingHomomorphism.
  1: exact snd.
  repeat split.
Defined.

Definition cring_product_corec (R S T : CRing)
  : (R $-> S) -> (R $-> T) -> (R $-> S × T).
Proof.
  intros f g.
  srapply Build_CRingHomomorphism'.
  1: apply (ab_biprod_corec f g).
  repeat split.
  1: cbn; intros x y; apply path_prod; apply rng_homo_mult.
  cbn; apply path_prod; apply rng_homo_one.
Defined.

Definition equiv_cring_product_corec `{Funext} (R S T : CRing)
  : (R $-> S) * (R $-> T) <~> (R $-> S × T).
Proof.
  snrapply equiv_adjointify.
  1: exact (uncurry (cring_product_corec _ _ _)).
  { intros f.
    exact (cring_product_fst $o f , cring_product_snd $o f). }
  { hnf; intros f.
    by apply path_hom. }
  intros [f g].
  apply path_prod.
  1,2: by apply path_hom.
Defined.

(** ** Image ring *)

(** The image of a ring homomorphism *)
Definition rng_image {R S : CRing} (f : R $-> S) : CRing.
Proof.
  snrapply (Build_CRing' (abgroup_image f)).
  { simpl.
    intros [x p] [y q].
    exists (x * y).
    strip_truncations; apply tr.
    destruct p as [p p'], q as [q q'].
    exists (p * q).
    refine (rng_homo_mult _ _ _ @ _).
    f_ap. }
  { exists 1.
    apply tr.
    exists 1.
    exact (rng_homo_one f). }
  (** Much of this proof is doing the same thing over, so we use some compact tactics. *)
  2: repeat split.
  2: exact _.
  all: intros [].
  1,2,5: intros [].
  1,2: intros [].
  all: apply path_sigma_hprop; cbn.
  1: apply distribute_l.
  1: apply associativity.
  1: apply commutativity.
  1: apply left_identity.
  apply right_identity.
Defined.

Lemma rng_homo_image_incl {R S} (f : CRingHomomorphism R S)
  : rng_image f $-> S.
Proof.
  snrapply Build_CRingHomomorphism.
  1: exact pr1.
  repeat split.
Defined.

(** Image of a surjective ring homomorphism *)
Lemma rng_image_issurj {R S} (f : CRingHomomorphism R S) {issurj : IsSurjection f}
  : rng_image f ≅ S.
Proof.
  snrapply Build_CRingIsomorphism.
  1: exact (rng_homo_image_incl f).
  exact _.
Defined.

(** *** More Ring laws *)

(** Powers of ring elements *)
Fixpoint rng_power {R : CRing} (x : R) (n : nat) : R :=
  match n with
  | 0%nat => cring_one
  | n.+1%nat => x * rng_power x n
  end.

(** Power laws *)
Lemma rng_power_mult_law {R : CRing} (x : R) (n m : nat)
  : (rng_power x n) * (rng_power x m) = rng_power x (n + m).
Proof.
  revert m.
  induction n.
  { intros m.
    apply rng_mult_one_l. }
  intros m; cbn.
  refine ((rng_mult_assoc _ _ _)^ @ _).
  f_ap.
Defined.

(** Powers commute with multiplication *)
Lemma rng_power_mult {R : CRing} (x y : R) (n : nat)
  : rng_power (x * y) n = rng_power x n * rng_power y n.
Proof.
  induction n.
  1: symmetry; apply rng_mult_one_l.
  cbn.
  rewrite rng_mult_assoc.
  rewrite <- (rng_mult_assoc x _ y).
  rewrite (rng_mult_comm (rng_power x n) y).
  rewrite rng_mult_assoc.
  rewrite <- (rng_mult_assoc _ (rng_power x n)).
  f_ap.
Defined.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Theorems about [gt] in [nat].

 This file is DEPRECATED now, see module [PeanoNat.Nat] instead,
 which favor [lt] over [gt].

 [gt] is defined in [Init/Peano.v] as:
<<
Definition gt (n m:nat) := m < n.
>>
*)

Require Import PeanoNat Le Lt Plus.
Local Open Scope nat_scope.

(** * Order and successor *)

Theorem gt_Sn_O n : S n > 0.
Proof Nat.lt_0_succ _.

Theorem gt_Sn_n n : S n > n.
Proof Nat.lt_succ_diag_r _.

Theorem gt_n_S n m : n > m -> S n > S m.
Proof.
 apply Nat.succ_lt_mono.
Qed.

Lemma gt_S_n n m : S m > S n -> m > n.
Proof.
 apply Nat.succ_lt_mono.
Qed.

Theorem gt_S n m : S n > m -> n > m \/ m = n.
Proof.
 intro. now apply Nat.lt_eq_cases, Nat.succ_le_mono.
Qed.

Lemma gt_pred n m : m > S n -> pred m > n.
Proof.
 apply Nat.lt_succ_lt_pred.
Qed.

(** * Irreflexivity *)

Lemma gt_irrefl n : ~ n > n.
Proof Nat.lt_irrefl _.

(** * Asymmetry *)

Lemma gt_asym n m : n > m -> ~ m > n.
Proof Nat.lt_asymm _ _.

(** * Relating strict and large orders *)

Lemma le_not_gt n m : n <= m -> ~ n > m.
Proof.
 apply Nat.le_ngt.
Qed.

Lemma gt_not_le n m : n > m -> ~ n <= m.
Proof.
 apply Nat.lt_nge.
Qed.

Theorem le_S_gt n m : S n <= m -> m > n.
Proof.
 apply Nat.le_succ_l.
Qed.

Lemma gt_S_le n m : S m > n -> n <= m.
Proof.
 apply Nat.succ_le_mono.
Qed.

Lemma gt_le_S n m : m > n -> S n <= m.
Proof.
 apply Nat.le_succ_l.
Qed.

Lemma le_gt_S n m : n <= m -> S m > n.
Proof.
 apply Nat.succ_le_mono.
Qed.

(** * Transitivity *)

Theorem le_gt_trans n m p : m <= n -> m > p -> n > p.
Proof.
 intros. now apply Nat.lt_le_trans with m.
Qed.

Theorem gt_le_trans n m p : n > m -> p <= m -> n > p.
Proof.
 intros. now apply Nat.le_lt_trans with m.
Qed.

Lemma gt_trans n m p : n > m -> m > p -> n > p.
Proof.
 intros. now apply Nat.lt_trans with m.
Qed.

Theorem gt_trans_S n m p : S n > m -> m > p -> n > p.
Proof.
 intros. apply Nat.lt_le_trans with m; trivial. now apply Nat.succ_le_mono.
Qed.

(** * Comparison to 0 *)

Theorem gt_0_eq n : n > 0 \/ 0 = n.
Proof.
 destruct n; [now right | left; apply Nat.lt_0_succ].
Qed.

(** * Simplification and compatibility *)

Lemma plus_gt_reg_l n m p : p + n > p + m -> n > m.
Proof.
 apply Nat.add_lt_mono_l.
Qed.

Lemma plus_gt_compat_l n m p : n > m -> p + n > p + m.
Proof.
 apply Nat.add_lt_mono_l.
Qed.

(** * Hints *)

Hint Resolve gt_Sn_O gt_Sn_n gt_n_S : arith.
Hint Immediate gt_S_n gt_pred : arith.
Hint Resolve gt_irrefl gt_asym : arith.
Hint Resolve le_not_gt gt_not_le : arith.
Hint Immediate le_S_gt gt_S_le : arith.
Hint Resolve gt_le_S le_gt_S : arith.
Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith.
Hint Resolve plus_gt_compat_l: arith.

(* begin hide *)
Notation gt_O_eq := gt_0_eq (only parsing).
(* end hide *)


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Ext_Cons.Prod_Cat.Prod_Cat.
Require Import Cat.Cat.
Require Import NatTrans.NatTrans NatTrans.Operations NatTrans.Func_Cat NatTrans.NatIso.

Local Open Scope isomorphism_scope.
Local Open Scope morphism_scope.
Local Open Scope object_scope.

(*
(** If two categories are isomorphic, then so are their duals. *)
Section Opposite_Cat_Iso.
  Context {C D : Category} (I : C ≃≃ D ::> Cat).

  Program Definition Opposite_Cat_Iso : (C^op)%category ≃≃ (D^op)%category ::> Cat
    :=
      {|
        iso_morphism := ((iso_morphism I)^op)%functor;
        inverse_morphism := ((inverse_morphism I)^op)%functor
      |}.

  Next Obligation.
    change (I ⁻¹ ^op ∘ (iso_morphism I) ^op)%functor
    with (((inverse_morphism I) ∘ (iso_morphism I))^op)%functor.
    cbn_rewrite (left_inverse I).
    trivial.
  Qed.

  Next Obligation.
    change ((iso_morphism I) ^op ∘ I ⁻¹ ^op)%functor
    with (((iso_morphism I) ∘ (inverse_morphism I))^op)%functor.
    cbn_rewrite (right_inverse I).
    trivial.
  Qed.

End Opposite_Cat_Iso.

(** Conversion from a category to another isomorphic category. *)
Section Cat_IConv.
  Context {C D : Category} (I : C ≃≃ D ::> Cat).

  (** Object conversion through an isomorphism and its inverse isomorphism gives back the same object. *)
  Definition Cat_Iso_Obj_conv (c : C) : c = (((inverse_morphism I) _o) (((iso_morphism I) _o) c))%object.
  Proof.
    change (I ⁻¹ _o ((iso_morphism I) _o c)) with ((I ⁻¹ ∘ I)%morphism _o c)%object;
    rewrite (left_inverse I); trivial.
  Qed.

  (** Homomorphism types remain the smae after object conversion through an isomorphism and its inverse isomorphism. *)
  Definition Cat_Iso_Hom_conv (c c' : C) :
    ((((inverse_morphism I) _o) (((iso_morphism I) _o) c))
      –≻
      (((inverse_morphism I) _o) (((iso_morphism I) _o) c')))%morphism = (c –≻ c').
  Proof.
    do 2 rewrite <- Cat_Iso_Obj_conv; trivial.
  Defined.

  (** Type conversion to the original hom type after conversion with an isomorphism and its inverse. *)
  Definition Cat_Iso_conv_inv {c c' : C}
             (h :
                (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
                  –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c'))) : c –≻ c' :=
    match Cat_Iso_Hom_conv c c' in _ = Y return Y with
      eq_refl => h
    end.

  (** Heterogenous equality of type conversion to the original hom type after conversion with an isomorphism and its inverse. *)
  Theorem Cat_Iso_conv_inv_JMeq {c c' : C}
          (h :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c'))) : Cat_Iso_conv_inv h ~= h.
  Proof.
    unfold Cat_Iso_conv_inv.
    destruct Cat_Iso_Hom_conv.
    trivial.
  Qed.

  (** Type conversion to the original hom type after conversion with the inverse of an isomorphism and that isomorphism. *)
  Definition Cat_Iso_conv {c c' : C} (h : c –≻ c') :
    (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
      –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c'))
    :=
    match eq_sym (Cat_Iso_Hom_conv c c') in _ = Y return Y with
      eq_refl => h
    end.

  (** Heterogenous equality of type conversion to the original hom type after conversion with the inverse of an isomorphism and that isomorphism. *)
  Theorem Cat_Iso_conv_JMeq {c c' : C} (h : c –≻ c') : Cat_Iso_conv h ~= h.
  Proof.
    unfold Cat_Iso_conv.
    destruct Cat_Iso_Hom_conv.
    trivial.
  Qed.

  (** Conversion once through an isomrphism and its inverse and once through its inverse and it gives back the same arrow as we strated with. *)
  Theorem Cat_Iso_conv_inv_Cat_Iso_conv {c c' : C} (h : c –≻ c') : Cat_Iso_conv_inv (Cat_Iso_conv h) = h.
  Proof.
    unfold Cat_Iso_conv_inv, Cat_Iso_conv.
    destruct Cat_Iso_Hom_conv; trivial.
  Qed.

  (** Conversion once through the inverse of an isomrphism and that isomorphism and once through that isomorphism and its inverse gives back the same arrow as we strated with. *)
  Theorem Cat_Iso_conv_Cat_Iso_conv_inv {c c' : C}
          (h :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c')))
    :
      Cat_Iso_conv (Cat_Iso_conv_inv h) = h.
  Proof.
    unfold Cat_Iso_conv_inv, Cat_Iso_conv.
    destruct Cat_Iso_Hom_conv; trivial.
  Qed.

  (** Conversion of an arrow through an ismorphism and its inverse (after correcting the homorphism type) is the same arrow as we started with. *)
  Theorem Cat_Iso_conv_inv_I_inv_I {c c' : C} (h : c –≻ c') :
    Cat_Iso_conv_inv (((inverse_morphism I) _a) (((iso_morphism I) _a) h)) = h.
  Proof.
    match goal with
      [|- ?A = ?B] =>
      let H := fresh "H" in
      cut (A ~= B); [intros H; rewrite H; trivial|]
    end.
    unfold Cat_Iso_conv_inv.
    destruct Cat_Iso_Hom_conv.
    change (I ⁻¹ _a ((iso_morphism I) _a h)) with ((I ⁻¹ ∘ I)%morphism _a h).
    apply (@JMeq_trans _ _ _ _ ((Functor_id _) _a h) _); trivial.
    cbn_rewrite <- (left_inverse I).
    trivial.
  Qed.

  (** Morphism composition commutes with conversion. *)
  Theorem Cat_Iso_conv_inv_compose {c c' c'' : C}
          (h :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c'))
          )
          (h' :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c'))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c''))
          )
    :
      Cat_Iso_conv_inv (compose C h h') = compose C (Cat_Iso_conv_inv h) (Cat_Iso_conv_inv h').
  Proof.
    unfold Cat_Iso_conv_inv, Cat_Iso_Hom_conv.
    do 3 destruct Cat_Iso_Obj_conv; trivial.
  Qed.

End Cat_IConv.

Section Cat_Iso_inv.
  Context {C D : Category} (I : C ≃≃ D ::> Cat).

  (** The main theorem of this module. Given an isomorphism I between categories C and D, for each morphism h: Hom (I _o c) (I _o c') in D, there is a morphism g in C such that the conversion of h through I (I _a g) gives back the smae arrow, i.e., h = (I _a h). *)
  Theorem Cat_Iso_inv {c c' : C} (h : ((iso_morphism I) _o c) –≻ ((iso_morphism I) _o c'))
    : {g : c –≻ c' | h = ((iso_morphism I) _a g)}.
  Proof.
    exists (Cat_Iso_conv_inv I ((inverse_morphism I) _a h)).
    match goal with
      [|- ?A = ?B] =>
        etransitivity;
        [apply (eq_sym (@Cat_Iso_conv_inv_I_inv_I D C (I⁻¹) _ _ A))|
         etransitivity; [|apply (@Cat_Iso_conv_inv_I_inv_I D C (I⁻¹) _ _ B)]]
    end.
    do 2 apply f_equal.
    match goal with
      [|- ?A = ?B] =>
        etransitivity;
        [apply (eq_sym (@Cat_Iso_conv_Cat_Iso_conv_inv C D I _ _ A))|
         etransitivity; [|apply (@Cat_Iso_conv_Cat_Iso_conv_inv C D I _ _ B)]]
    end.
    apply f_equal.
    rewrite Cat_Iso_conv_inv_I_inv_I; trivial.
  Qed.

End Cat_Iso_inv.

(**
Given I : C ≃ D for categories C and D and F : D -> E, F ∘ (I ∘ I⁻¹) and F are
naturally isomorphic.
*)
Section IsoCat_NatIso.
  Context {C D : Category} (I : (C ≃≃ D ::> Cat)%morphism) {E : Category} (F : (D –≻ E)%functor).

  Program Definition IsoCat_NatIso :
    ((F ∘ ((iso_morphism I) ∘ (I⁻¹)%morphism))%functor ≃ F)%natiso :=
    {|
      iso_morphism := IsoCat_NatTrans I F;
      inverse_morphism := IsoCat_NatTrans_back I F
    |}
  .

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    FunExt.
    cbn.
    match goal with
      [|- ((match ?e with _ => _ end) ∘ (match ?e with _ => _ end))%morphism = _] =>
      destruct e
    end.
    auto.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    FunExt.
    cbn.
    match goal with
      [|- ((match ?e with _ => _ end) ∘ (match ?e with _ => _ end))%morphism = _] =>
      destruct e
    end.
    auto.
  Qed.

End IsoCat_NatIso.
*)


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

Require Import Arith Bool List Relations Wf Eqdep_dec Omega.

Set Implicit Arguments.

(* Notations for subset or subrel set theoretic operators *)

Notation "X '⊆' Y" := (forall x, X x -> Y x) (at level 75, format "X  ⊆  Y", no associativity).
Notation "X '≃' Y" := ((X ⊆ Y) * (Y ⊆ X))%type (at level 75, format "X  ≃  Y", no associativity).

Fact inc1_refl X (A : X -> Type) : A ⊆ A.
Proof. auto. Qed.

Fact inc1_trans X (A B C : X -> Type) : A ⊆ B -> B ⊆ C -> A ⊆ C.
Proof. intros; auto. Qed.

Fact eq1_refl X (A : X -> Type) : A ≃ A.
Proof. tauto. Qed.

Fact eq1_sym X (A B : X -> Type) : A ≃ B -> B ≃ A.
Proof. tauto. Qed.

Fact eq1_trans X (A B C : X -> _) : A ≃ B -> B ≃ C -> A ≃ C.
Proof. intros [] [];  split; intros; auto. Qed.

Fact equal_eq1 X (A B : X -> _) : A = B -> A ≃ B.
Proof. intros []; auto. Qed.

(* intersection *)

Notation "A '∩' B" := (fun z => A z * B z : Type)%type (at level 50, format "A  ∩  B", left associativity).
Notation "A '∪' B" := (fun z => A z + B z : Type)%type (at level 50, format "A  ∪  B", left associativity).

(** ⊆ ≃ ∩ ∪ *)

Notation "X '≡' Y" := ((X->Y)*(Y->X))%type (at level 80, format "X  ≡  Y", no associativity).

Notation sg := (@eq _).

Fact sg_inc1 X (A : X -> Type) x : A x ≡ sg x ⊆ A.
Proof.
  split.
  + intros ? ? []; trivial.
  + intros H; apply H; auto.
Qed.


Require Export ZArith.
Require Export ZArithRing.

Open Scope Z_scope.

(* The following tactic looks for all the instances of
   "Zpos (xO p)" and "Zpos (xI p)" and replaces them with
   polynomial expressions in p, but avoids doing it for the numbers
   2 and 3 which are "Zpos (xO xH)" and "Zpos (xI xH)". *)

Ltac Zpos_x_tac :=
 match goal with
   |- context [Zpos (xO ?P)] =>
       match P with
        | xH => fail 1
        | ?X2 => rewrite (Zpos_xO X2); Zpos_x_tac
       end
 | |- context [Zpos (xI ?P)] =>
       match P with
        | xH => fail 1
        | ?X2 => rewrite (Zpos_xI X2); Zpos_x_tac
       end
 | |- _ => idtac
 end.

(* Here is an example using this tactic. *)

Theorem ex1 :
  forall p, Zpos (xO (xI p))=4*(Zpos p)+2.
Proof.
 intros p.
 Zpos_x_tac.
 rewrite Zmult_plus_distr_r; simpl (2*1).
 rewrite Zmult_assoc; reflexivity.
Qed.


Require Import Arith.
Require Import List.
Import ListNotations.

Set Implicit Arguments.

Lemma leb_false_lt : forall m n, leb m n = false -> n < m.
Proof.
  induction m; intros.
  - discriminate.
  - simpl in *.
    destruct n; subst; auto with arith.
Qed.


Require Import MSetInterface.
Module RedBlackTree.
Declare Module X:OrderedType.
Definition key := X.t.

Inductive color := Red | Black.

Inductive tree :=
  | Leaf : tree
  | Node : tree -> key -> tree -> color -> tree.

(** The [mem] function is deciding membership. It exploits the
    binary search tree invariant to achieve logarithmic complexity. *)
Fixpoint mem x s :=
   match s with
     |  Leaf => false
     |  Node l y r _ => match X.compare x y with
             | Lt => mem x l
             | Eq => true
             | Gt => mem x r
         end
   end.

(* inserts an element into a tree
 * needs and preserves red black binary search tree
 *)
Fixpoint insert (x:key) (t:tree) : tree := t.

(* deleets an element out of a tree
 * needs and preserves red black binary search tree
 *)
Fixpoint delete (x:key) (t:tree) : tree := t.

(** ** x is in a tree *)

Inductive isMem (x : key) : tree -> Prop :=
  | IsMemRoot : forall l y r c, X.eq x y -> isMem x (Node l y r c)
  | IsMemLeft : forall l y r c, isMem x l -> isMem x (Node l y r c)
  | IsMemRight : forall l y r c, isMem x r -> isMem x (Node l y r c).

(** ** Binary Search Tree property *)

(* all elements in s are less than x *)
Definition lt_tree x s := forall y, isMem y s -> X.lt y x.
(* all elemens in s are greater than x *)
Definition gt_tree x s := forall y, isMem y s -> X.lt x y.

(** [BST t] : [t] is a binary search tree
 * all in l are less than x
 * all in r are greater than x
 *)
Inductive isBST : tree -> Prop :=
  | BSTLeaf : isBST Leaf
  | BSTNode : forall x l r h, isBST l -> isBST r ->
     lt_tree x l -> gt_tree x r -> isBST (Node l x r h).

(** ** Not Red Red property *)

Inductive isBlack : tree -> Prop :=
  | IsBlackLeaf : isBlack Leaf
  | IsBlackNode : forall l x r, isBlack (Node l x r Black).

(* no two successing red nodes *)
Inductive isNotRedRed : tree -> Prop :=
  | IsBlack: forall t, isBlack t -> isNotRedRed t
  | IsNotRedRed : forall l x r, isBlack l -> isBlack r -> isNotRedRed (Node l x r Red).

(** ** Same Black Heights *)

(* "to every leaf the number of black nodes is the same" *)
Inductive isSameBlackdepth' : nat -> tree -> Prop :=
  | IsSameBlackdepthLeaf : isSameBlackdepth' O Leaf
  | IsSameBlackdepthRed   : forall n l x r, isSameBlackdepth' n l -> isSameBlackdepth' n r -> isSameBlackdepth' n (Node l x r Red)
  | IsSameBlackdepthBlack : forall n l x r, isSameBlackdepth' n l -> isSameBlackdepth' n r -> isSameBlackdepth' (S n) (Node l x r Black).

Inductive isSameBlackdepth : tree -> Prop :=
  | IsSameBlackdepth : forall t, (exists n, isSameBlackdepth' n t) -> isSameBlackdepth t.

(** ** Red Black property *)

Inductive isRedBlack : tree -> Prop :=
  | IsRedBlack : forall t, isNotRedRed t -> isSameBlackdepth t -> isRedBlack t.

(** ** Red Black Binary Search Tree *)

Inductive isRBBST : tree -> Prop :=
  | IsRBBST : forall t, isBST t -> isRedBlack t -> isRBBST t.

(** ** Proof of [mem] **)

Lemma mem_spec : forall t x `{isBST t}, mem x t = true <-> isMem x t.

(** ** Proofs of [insert] and [delete] *)

Definition stays_rbbst f := forall t, isRBBST t <-> isRBBST (f t).

(** ** Proof of [insert] *)

Lemma insert_inserts : forall x t, isMem x (insert x t).

Lemma insert_stays_rbbst : forall x, stays_rbbst (insert x).

(** ** Proof of [delete] *)

Lemma delete_deletes : forall x t, ~ isMem x (delete x t).

Lemma delete_stays_rbbst : forall x, stays_rbbst (delete x).


(* Require Import ZArith. *)
(* Open Scope Z_scope. *)
(* ... *)

(* Open Scope nat_scope. *)

Lemma congruence_demo :
  forall (f : nat -> nat -> nat) (g h : nat -> nat) (x y z : nat),
    (forall a, g a = h a) ->
    f (g x) (g y) = z ->
    g x = 2 ->
    f 2 (h y) = z.
Proof. congruence. Qed.

Lemma congruence_demo' :
  forall (f g : nat -> nat),
    (forall a, f a = g a) -> f (g (g 2)) = g (f (f 2)).
Proof. congruence. Qed.


Axiom law_of_excluded_middle : forall (P : Prop), P \/ ~P.

Theorem neq_comm : forall (A: Type)(a b : A), a <> b -> b <> a.
Proof.
intros. unfold not. intros. rewrite H0 in H. apply H. reflexivity.
Qed.

Theorem de_morgan1 : forall (P Q R : Prop),
  (P \/ Q) /\ R -> (P /\ R) \/ (Q /\ R).
Proof.
intros. destruct H. inversion H.
- apply or_introl. apply conj. apply H1. apply H0.
- apply or_intror. apply conj. apply H1. apply H0.
Qed.

Theorem de_morgan2 : forall (P Q R : Prop),
  (P /\ Q) \/ R -> (P \/ R) /\ (Q \/ R).
Proof.
intros. apply conj.
- inversion H.
  + apply proj1 in H0. apply or_introl. apply H0.
  + apply or_intror. apply H0.
- inversion H.
  + apply proj2 in H0. apply or_introl. apply H0.
  + apply or_intror. apply H0.
Qed.

Theorem reduce_or_P_and_notP : forall (P Q : Prop),
  (Q \/ P) /\ ~P -> Q.
Proof.
intros. apply de_morgan1 in H. inversion H.
- apply H0.
- apply proj1 in H0 as H1. apply proj2 in H0 as H2. contradiction.
Qed.

Theorem not_not_P : forall (P :Prop),
  not (not P) <-> P.
Proof.
intros. assert (lem : P \/ ~P).
{ apply law_of_excluded_middle. }
inversion lem.
- unfold iff. apply conj.
  + intros. apply H.
  + intros. intros H1. contradiction.
- unfold iff. apply conj.
  + intros. contradiction.
  + intros. contradiction.
Qed.

Theorem contrapositive : forall (P Q: Prop),
  (P -> Q) <-> (~Q -> ~P).
Proof.
intros. unfold iff. apply conj.
- intros. intro. apply H0. apply H. apply H1.
- intros. apply not_not_P. intro. apply H in H1. contradiction.
Qed.

Theorem not_or : forall (P Q: Prop),
  ~(P \/ Q) <-> ~P /\ ~Q.
Proof.
intros. unfold iff. apply conj.
- intros. apply conj.
  + intro. apply H. left. apply H0.
  + intro. apply H. right. apply H0.
- intros. destruct H as [nP nQ].
  intro. destruct H as [P_|Q_]. contradiction. contradiction.
Qed.

Theorem not_and : forall (P Q: Prop),
  ~(P /\ Q) <-> ~P \/ ~Q.
Proof.
intros. unfold iff. apply conj.
- intros. apply not_not_P. intro. apply not_or in H0. destruct H0 as [P_ Q_].
  apply H. apply not_not_P with (P:=P) in P_. apply not_not_P with (P:=Q) in Q_.
  apply conj. apply P_. apply Q_.
- intros. intro. destruct H0 as [Pt Qt]. destruct H as [Pf|Qf]. contradiction. contradiction.
Qed.

Theorem iff_iff_compat_l : forall A B C : Prop,
(B <-> C) -> ((A <-> B) <-> (A <-> C)).
Proof.
intros. apply iff_to_and. apply conj.
- intros. apply iff_trans with (B:=B). apply H0. apply H.
- intros. apply iff_trans with (B:=C). apply H0. apply iff_sym. apply H.
Qed.

Theorem iff_iff_compat_r : forall A B C : Prop,
(B <-> C) -> ((B <-> A) <-> (C <-> A)).
Proof.
intros. apply iff_to_and. apply conj.
- intros. apply iff_trans with (B:=B). apply iff_sym. apply H. apply H0.
- intros. apply iff_trans with (B:=C). apply H. apply H0.
Qed.

Theorem and_to_imply : forall A B C : Prop,
  ((A /\ B) -> C) <-> (A -> B -> C).
Proof.
intros. unfold iff. apply conj.
- intros. apply H. apply conj. apply H0. apply H1.
- intros. apply H. apply H0. apply H0.
Qed.


From mathcomp Require Import ssreflect.

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

Require Import function_theories.

Section FunctionCompositeTheories.
  Variable U:Type.
  Variables F G H: U -> U.
  Variables A B C D: Ensemble U.

  Theorem function_composite_assoc:
    forall (f g h: Ensemble (Ensemble (Ensemble U))),
      f ≔ F ⊦ A ⟼ B /\ g ≔ G ⊦ B ⟼ C /\ h ≔ H ⊦ C ⟼ D -> h ∘ (g ∘ f) = (h ∘ g) ∘ f.
  Proof.
    move => f g h.
    case => [[Hf HfS] [[Hg HgS] [Hh HhS]]].
    move: (compound_correspondence_assoc) => H0.
    apply (H0 U A B C D (fun (x y:U) => y = F x) (fun (x y:U) => y = G x) (fun (x y:U) => y = H x) f g h).
    split.
    apply Hf.
    split.
    apply Hg.
    apply Hh.
  Qed.

  Theorem function_composite_image:
    forall (f g: Ensemble (Ensemble (Ensemble U))) (X:Ensemble U),
      X ⊂ A /\ f ≔ F ⊦ A ⟼ B /\ g ≔ G ⊦ B ⟼ C ->
      (g ∘ f) '' X = g '' (f '' X).
  Proof.
    move => f g X.
    case => HA [[Hf HfS] [Hg HgS]].
    move: image_compound_correspondence_eq => H0.
    apply (H0 U A B C X (fun x y:U => y = F x) (fun x y:U => y = G x) f g).
    split; done.
  Qed.

  Theorem function_composite_value:
    forall (f g: Ensemble (Ensemble (Ensemble U))) (x:U),
      x ∈ A /\ f ≔ F ⊦ A ⟼ B /\ g ≔ G ⊦ B ⟼ C ->
      (g ∘ f) '' {| x |} = g '' (f '' {| x |}).
  Proof.
    move => f g x.
    case => HA [Hf Hg].
    move: function_composite_image => H0.
    apply (H0 f g {|x|}).
    split.
    move => x' Hx'.
    apply singleton_eq_iff in Hx'.
    rewrite Hx'.
    done.
    split; done.
  Qed.

  Goal forall (f idA: Ensemble (Ensemble (Ensemble U))),
      f ≔ F ⊦ A ⟼ B /\ IdentityMapping idA A -> f = f ∘ idA.
  Proof.
    move => f idA.
    case => [[Hf HfS] [HidA HidAS]].
    apply /Extensionality_Ensembles.
    rewrite Hf HidA.
    split => Z H0.
    +inversion H0 as [x y].
     inversion H1.
     split.
     exists x.
     split.
     split.
     split.
     reflexivity.
     inversion H4.
     inversion H5 as [x' [y']].
     inversion H7.
     inversion H9.
     apply ordered_pair_iff in H11.
     inversion H11.
     rewrite H12.
     split.
     exists x'.
     exists x'.
     split.
     apply H8.
     split.
     apply H8.
     done.
     rewrite H2.
     apply H0.
    +inversion H0.
     inversion H1.
     inversion H3.
     inversion H4.
     inversion H7.
     apply ordered_pair_iff in H6.
     inversion H6.
     rewrite -H10.
     rewrite -H8.
     rewrite H11.
     apply H5.
  Qed.

  Goal forall (f idB: Ensemble (Ensemble (Ensemble U))),
      f ≔ F ⊦ A ⟼ B /\ IdentityMapping idB B -> f = idB ∘ f.
  Proof.
    move => f idB.
    case => [[Hf HfS] [HidB HidBS]].
    rewrite Hf HidB.
    apply /Extensionality_Ensembles.
    split => Z H0.
    +inversion H0 as [x y].
     inversion H1.
     inversion H4.
     inversion H5 as [x' [y']].
     inversion H7 as [H8 [H9 H10]].
     apply ordered_pair_iff in H10.
     inversion H10.
     split.
     exists y.
     split.
     rewrite H2.
     apply H0.
     split.
     split.
     reflexivity.
     split.
     exists y'.
     exists y'.
     split.
     apply H9.
     split.
     apply H9.
     rewrite H12.
     done.
    +inversion H0.
     inversion H1 as [z [H3 H4]].
     inversion H4 as [x' y' [H5 H6]].
     rewrite H5 in H7.
     apply ordered_pair_iff in H7.
     inversion H7.
     rewrite H8 in H9.
     rewrite -H9.
     apply H3.
  Qed.

End FunctionCompositeTheories.

Require Export function_theories.


(** * Gambler.v : gambler dream to win a little might lead to loose a lot *)
(** Source : Abstraction, refinement and proof for probabilistic systems
    A. McIver and C. Morgan, Springer *)
Add Rec LoadPath "../src" as ALEA.

Require Export Cover.
Require Export Misc.
Require Export DistrTactic.
Require Export Arith.

(* begin hide *)
Set Implicit Arguments.
Open Local Scope U_scope.
Open Local Scope O_scope.

(* end hide *)

(** ** Strategy
the gambler doubles his bet until he wins or he runs out of money
he starts with enough money to play n-times, ie
   (1 + 2 + ...+ 2^{n-1})b = (2^n-1)b
<<
let rec play n b =
        if n = 0 then 0
        else if flip then (2^n) b else play n (2b)
>>
*)

Section Gamble.

Fixpoint pow2 (n:nat) : nat :=
   match n with O => 1%nat | S p => (2 * (pow2 p))%nat end.

Fixpoint play (n:nat) (b:nat) : distr nat :=
    match n with
      O => Munit O
    | S p => Mif Flip (Munit ((pow2 n) * b)%nat) (play p (2*b))
    end.

Lemma pow2not0 : forall n, pow2 n <> O.
induction n; simpl; omega.
Save.
Hint Resolve pow2not0.

Lemma proba_loose : forall n b, ~ b=O -> mu (play n b) (carac_eq O)== [1/2]^n.
induction n; intros.
simpl; auto.
simpl.
replace (pow2 n + (pow2 n + 0))%nat with (pow2 (S n)) by trivial.
rewrite (cover_eq_zero _ (is_eq O)).
repeat Usimpl.
apply IHn.
omega.
apply not_eq_sym.
apply NPeano.Nat.neq_mul_0; auto.
Save.

Lemma proba_win : forall n b, ~ b=O -> mu (play n b) (carac_eq ((pow2 n) * b)%nat)== [1-]([1/2]^n).
induction n; intros.
simpl; repeat Usimpl.
rewrite (cover_eq_zero _ (is_eq (b + 0))); intuition.
simpl.
rewrite (cover_eq_one _ (is_eq (pow2 (S n) * b)%nat)); trivial.
repeat Usimpl.
replace ((pow2 n + (pow2 n + 0)) * b)%nat with (pow2 n * (2*b))%nat.
rewrite IHn.
rewrite <- Uinv_half; repeat Usimpl; auto.
omega.
ring.
Save.

End Gamble.


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

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

(* The basic theory of paths over a dataSet; this is essentially a   *)
(* complement to seq.v.                                              *)
(* Paths are non-empty sequences that obey a progression relation.   *)
(* They are passed around in three parts : the head and tail of the  *)
(* sequence, and a (boolean) predicate asserting the progression.    *)
(* This is rarely embarrassing, as the first two are usually         *)
(* implicit parameters inferred from the predicate, and it saves the *)
(* hassle of constantly constructing and destructing a dependent     *)
(* record. We allow duplicates; uniqueness, if desired (as is the    *)
(* case for several geometric constructions), must be asserted       *)
(* separately. We do provide shorthand, but for cycles only, because *)
(* the equational properties of "path" and "uniq" are unfortunately  *)
(* incompatible (esp. wrt "cat").                                    *)
(*    We define similarly cycles, but in this case we allow the      *)
(* empty sequence (which is a non-rooted empty cycle; by contrast,   *)
(* the empty path from x is the one-item sequence containing only x) *)
(*    We define notations for the common cases of function paths,    *)
(* where the progress relation is actually a function. We also       *)
(* define additional traversal/surgery operations, many of which     *)
(* could have been in seq.v, but are here because they only really   *)
(* are useful for sequences considered as paths :                    *)
(*  - directed surgery : splitPl, splitP, splitPr are dependent      *)
(*    predicates whose elimination splits a path x0:p at one of its  *)
(*    elements (say x). The three variants differ as follows:        *)
(*      - splitPl applies when x in in x0:p, generates two paths p1  *)
(*        and p2, along with the equation x = (last x0 p), and       *)
(*        replaces p with (cat p1 p2) in the goal (the patterned     *)
(*        Elim can be used to select occurrences and generate an     *)
(*        equation p = (cat p1 p2).                                  *)
(*      - splitP applies when x is in p, and replaces p with         *)
(*        (cat (add_last p1 x) p2), where x appears explicitly at    *)
(*        the end of the left part.                                  *)
(*      - splitPr similarly replaces p with (cat p1 (Adds x p2)),    *)
(*        where appears explicitly at the right of the split, when x *)
(*        is actually in p.                                          *)
(*    The parts p1 and p2 are computed using index/take/drop. The    *)
(*    splitP variant (but not the others) attempts to replace the    *)
(*    explicit expressions for p1 and p2 by p1 and p2, respectively. *)
(*    This is moderately useful, allows for defining other splitting *)
(*    lemmas with conclusions of the form (split x p p1 p2), with    *)
(*    other expressions for p1 and p2 that might be known to occur.  *)
(*  - function trajectories: traject, and a looping predicate.       *)
(*  - cycle surgery : arc extracts the sub-arc between two points    *)
(*    (including the first, excluding the second). (arc p x y) is    *)
(*    thus only meaningful if x and y are different points in p.     *)
(*  - cycle traversal : next, prev                                   *)
(*  - path order: mem2 checks whether two points belong to a         *)
(*    and appear in order (i.e., (mem2 p x y) checks that y appears  *)
(*    after an occurrence of x in p). This predicate a crucial part  *)
(*    of the definition of the abstract Jordan property.             *)
(*  - loop removal : shorten returns a shorter, duplicate-free path  *)
(*    with the same endpoints as its argument. The related shortenP  *)
(*    dependent predicate simultaneously substitutes a new path p',  *)
(*    for (shorten e x p), (last x p') for (last x p), and generates *)
(*    predicates asserting that p' is a duplicate-free subpath of p. *)
(* Although these functions operate on the underlying sequences, we  *)
(* provide a series of lemmas that define their interaction with the *)
(* path and cycle predicates, e.g., the path_cat equation can be     *)
(* used to split the path predicate after splitting the underlying   *)
(* sequence.                                                         *)

Section Paths.

Variables (n0 : nat) (T : Type).

Section Path.

Variables (x0_cycle : T) (e : rel T).

Fixpoint path x (p : seq T) {struct p} :=
  if p is y :: p' then e x y && path y p' else true.

Lemma path_cat : forall x p1 p2,
  path x (p1 ++ p2) = path x p1 && path (last x p1) p2.
Proof.
by move=> x p1 p2; elim: p1 x => [|y p1 Hrec] x //=; rewrite Hrec -!andbA.
Qed.

Lemma pathP : forall x p x0,
  reflect (forall i, i < size p -> e (sub x0 (x :: p) i) (sub x0 p i))
          (path x p).
Proof.
move=> x p x0; elim: p x => [|y p Hrec] x /=; first by left.
apply: (iffP andP) => [[Hxy Hp]|Hp].
  move=> [|i] Hi //; exact: Hrec _ Hp i Hi.
split; first exact: Hp 0 (leq0n (size p)).
apply/(Hrec y) => i; exact: Hp i.+1.
Qed.

Definition cycle p := if p is x :: p' then path x (add_last p' x) else true.

Lemma cycle_path : forall p, cycle p = path (last x0_cycle p) p.
Proof. by move=> [|x p] //=; rewrite -cats1 path_cat /= andbT andbC. Qed.

Lemma cycle_rot : forall p, cycle (rot n0 p) = cycle p.
Proof.
case: (n0) => [|n] [|y0 p] //=; first by rewrite /rot /= cats0.
rewrite /rot /= -{3}(cat_take_drop n p) -cats1 -catA path_cat.
case: (drop n p) => [|z0 q]; rewrite /= -cats1 !path_cat /= !andbT andbC //.
by rewrite last_cat; repeat bool_congr.
Qed.

Lemma cycle_rotr : forall p, cycle (rotr n0 p) = cycle p.
Proof. by move=> p; rewrite -cycle_rot rotrK. Qed.

End Path.

Lemma eq_path : forall e e', e =2 e' -> path e =2 path e'.
Proof.
by move=> e e' Ee x p; elim: p x => [|y p Hrec] x //=; rewrite Ee Hrec.
Qed.

Lemma sub_path : forall e e', subrel e e' ->
  forall x p, path e x p -> path e' x p.
Proof.
move=> e e' He x p; elim: p x => [|y p Hrec] x //=.
by move/andP=> [Hx Hp]; rewrite (He _ _ Hx) (Hrec _ Hp).
Qed.

End Paths.

Implicit Arguments pathP [T e x p].
Prenex Implicits pathP.

Section EqPath.

Variables (n0 : nat) (T : eqType) (x0_cycle : T) (e : rel T).

CoInductive split x : seq T -> seq T -> seq T -> Type :=
  Split p1 p2 : split x (add_last p1 x ++ p2) p1 p2.

Lemma splitP : forall (p : seq T) x, x \in p ->
   let i := index x p in split x p (take i p) (drop i.+1 p).
Proof.
move=> p x Hx i; have := esym (cat_take_drop i p).
have Hi := Hx; rewrite -index_mem -/i in Hi; rewrite (drop_sub x Hi).
by rewrite -cat_add_last {2}/i (sub_index x Hx) => Dp; rewrite {1}Dp.
Qed.

CoInductive splitl (x1 x : T) : seq T -> Type :=
  Splitl p1 p2 of last x1 p1 = x : splitl x1 x (p1 ++ p2).

Lemma splitPl : forall x1 p x, x \in x1 :: p -> splitl x1 x p.
Proof.
move=> x1 p x; rewrite in_adds.
case: eqP => [->| _]; first by rewrite -(cat0s p).
case/splitP; split; exact: last_add_last.
Qed.

CoInductive splitr x : seq T -> Type :=
  Splitr p1 p2 : splitr x (p1 ++ x :: p2).

Lemma splitPr : forall (p : seq T) x, x \in p -> splitr x p.
Proof. by move=> p x; case/splitP=> p1 p2; rewrite cat_add_last. Qed.

Fixpoint next_at (x y0 y : T) (p : seq T) {struct p} :=
  match p with
  | seq0 => if x == y then y0 else x
  | y' :: p' => if x == y then y' else next_at x y0 y' p'
  end.

Definition next p x := if p is y :: p' then next_at x y y p' else x.

Fixpoint prev_at (x y0 y : T) (p : seq T) {struct p} :=
  match p with
  | seq0     => if x == y0 then y else x
  | y' :: p' => if x == y' then y else prev_at x y0 y' p'
  end.

Definition prev p x := if p is y :: p' then prev_at x y y p' else x.

Lemma next_sub : forall p x,
  next p x = if x \in p then
               if p is y :: p' then sub y p' (index x p) else x
             else x.
Proof.
move=> [|y0 p] x //=; elim: p {2 3 5}y0 => [|y' p Hrec] y /=;
  by rewrite (eq_sym y) in_adds; case (x == y); try exact: Hrec.
Qed.

Lemma prev_sub : forall p x,
  prev p x = if x \in p then
               if p is y :: p' then sub y p (index x p') else x
             else x.
Proof.
move=> [|y0 p] x //=; rewrite in_adds orbC.
elim: p {2 5}y0 => [|y' p Hrec] y; rewrite /= ?in_adds // (eq_sym y').
by case (x == y') => /=; auto.
Qed.

Lemma mem_next : forall (p : seq T) x, (next p x \in p) = (x \in p).
Proof.
move=> p x; rewrite next_sub; case Hpx: (x \in p) => //.
case: p (index x p) Hpx => [|y0 p'] //= i _; rewrite in_adds.
case: (ltnP i (size p')) => Hi; first by rewrite /= (mem_sub y0 Hi) orbT.
by rewrite (sub_default y0 Hi) eqxx.
Qed.

Lemma mem_prev : forall (p : seq T) x, (prev p x \in p) = (x \in p).
Proof.
move=> p x; rewrite prev_sub; case Hpx: (x \in p) => //.
case: p Hpx => [|y0 p'] Hpx //.
by apply mem_sub; rewrite /= ltnS index_size.
Qed.

(* ucycleb is the boolean predicate, but ucycle is defined as a Prop *)
(* so that it can be used as a coercion target. *)
Definition ucycleb p := cycle e p && uniq p.
Definition ucycle p : Prop := cycle e p && uniq p.

(* Projections, used for creating local lemmas. *)
Lemma ucycle_cycle : forall p, ucycle p -> cycle e p.
Proof. by move=> p; case/andP. Qed.

Lemma ucycle_uniq : forall p, ucycle p -> uniq p.
Proof. by move=> p; case/andP. Qed.

Lemma next_cycle : forall p x, cycle e p -> x \in p -> e x (next p x).
Proof.
move=> [|y0 p] //= x.
elim: p {1 3 5}y0 => [|y' p Hrec] y /=; rewrite in_adds.
  by rewrite andbT orbF => Hy Dy; rewrite Dy (eqP Dy).
move/andP=> [Hy Hp]; case: (x =P y) => [->|_] //; exact: Hrec.
Qed.

Lemma prev_cycle : forall p x, cycle e p -> x \in p -> e (prev p x) x.
Proof.
move=> [|y0 p] //= x; rewrite in_adds orbC.
elim: p {1 5}y0 => [|y' p Hrec] y /=; rewrite ?in_adds.
  by rewrite andbT=> Hy Dy; rewrite Dy (eqP Dy).
move/andP=> [Hy Hp]; case: (x =P y') => [->|_] //; exact: Hrec.
Qed.

Lemma ucycle_rot : forall p, ucycle (rot n0 p) = ucycle p.
Proof. by move=> *; rewrite /ucycle uniq_rot cycle_rot. Qed.

Lemma ucycle_rotr : forall p, ucycle (rotr n0 p) = ucycle p.
Proof. by move=> *; rewrite /ucycle uniq_rotr cycle_rotr. Qed.

(* The "appears no later" partial preorder defined by a path. *)

Definition mem2 (p : seq T) x y := y \in drop (index x p) p.

Lemma mem2l : forall p x y, mem2 p x y -> x \in p.
Proof.
move=> p x y; rewrite /mem2 -!index_mem size_drop; move=> Hxy.
by rewrite -ltn_0sub -(ltn_predK Hxy) ltnS leq0n.
Qed.

Lemma mem2lf : forall (p : seq T) x,
  (x \in p) = false -> forall y, mem2 p x y = false.
Proof. move=> p x Hx y; apply/idP => Hp; case/idP: Hx; apply: mem2l Hp. Qed.

Lemma mem2r : forall p x y, mem2 p x y -> y \in p.
Proof.
rewrite /mem2; move=> p x y Hxy.
by rewrite -(cat_take_drop (index x p) p) mem_cat Hxy orbT.
Qed.

Lemma mem2rf : forall (p : seq T) y,
  (y \in p) = false -> forall x, mem2 p x y = false.
Proof. move=> p y Hy x; apply/idP => [Hp]; case/idP: Hy; apply: mem2r Hp. Qed.

Lemma mem2_cat : forall p1 p2 x y,
  mem2 (p1 ++ p2) x y = mem2 p1 x y || mem2 p2 x y || (x \in p1) && (y \in p2).
Proof.
move=> p1 p2 x y; rewrite {1}/mem2 index_cat drop_cat; case Hp1x: (x \in p1).
  rewrite index_mem Hp1x mem_cat /= -orbA.
  by case Hp2: (y \in p2); [ rewrite !orbT // | rewrite (mem2rf Hp2) ].
by rewrite ltnNge leq_addr /= orbF addKn (mem2lf Hp1x).
Qed.

Lemma mem2_splice : forall p1 p3 x y p2,
  mem2 (p1 ++ p3) x y -> mem2 (p1 ++ p2 ++ p3) x y.
Proof.
move=> p1 p3 x y p2 Hxy; move: Hxy; rewrite !mem2_cat mem_cat.
case: (mem2 p1 x y) (mem2 p3 x y) => [|] // [|] /=; first by rewrite orbT.
by case: (x \in p1) => [|] //= Hy; rewrite Hy !orbT.
Qed.

Lemma mem2_splice1 : forall p1 p3 x y z,
  mem2 (p1 ++ p3) x y -> mem2 (p1 ++ z :: p3) x y.
Proof. move=> p1 p3 x y z; exact: (mem2_splice [::z]). Qed.

Lemma mem2_adds : forall x p y,
  mem2 (x :: p) y =1 if x == y then predU1 x (mem p) : pred T else mem2 p y.
Proof. by move=> x p y z; rewrite {1}/mem2 /=; case (x == y). Qed.

Lemma mem2_last : forall y0 p x,
  mem2 (y0 :: p) x (last y0 p) = (x \in y0 :: p).
Proof.
move=> y0 p x; apply/idP/idP; first by apply mem2l.
rewrite -index_mem /mem2; move: (index x _) => i Hi.
by rewrite lastI drop_add_last ?size_belast // mem_add_last mem_head.
Qed.

Lemma mem2l_cat : forall (p1 : seq T) x, (x \in p1) = false ->
  forall p2, mem2 (p1 ++ p2) x =1 mem2 p2 x.
Proof. by move=> p1 x Hx p2 y; rewrite mem2_cat (Hx) (mem2lf Hx) /= orbF. Qed.

Lemma mem2r_cat : forall (p2 : seq T) y, (y \in p2) = false ->
   forall p1 x, mem2 (p1 ++ p2) x y = mem2 p1 x y.
Proof.
by move=> p2 y Hy p1 x; rewrite mem2_cat (Hy) (mem2rf Hy) andbF !orbF.
Qed.

Lemma mem2lr_splice : forall (p2 : seq T) x y,
    (x \in p2) = false -> (y \in p2) = false ->
  forall p1 p3, mem2 (p1 ++ p2 ++ p3) x y = mem2 (p1 ++ p3) x y.
Proof.
move=> p2 x y Hx Hy p1 p3.
by rewrite catA !mem2_cat !mem_cat Hx Hy (mem2lf Hx) !andbF !orbF.
Qed.

CoInductive split2r (x y : T) : seq T -> Type :=
  Split2r p1 p2 of y \in x :: p2 : split2r x y (p1 ++ x :: p2).

Lemma splitP2r : forall p x y, mem2 p x y -> split2r x y p.
Proof.
move=> p x y Hxy; have Hx := mem2l Hxy.
have Hi := Hx; rewrite -index_mem in Hi.
move: Hxy; rewrite /mem2 (drop_sub x Hi) (sub_index x Hx).
by case (splitP Hx); move=> p1 p2; rewrite cat_add_last; split.
Qed.

Fixpoint shorten x (p : seq T) {struct p} :=
  if p is y :: p' then
    if x \in p then shorten x p' else y :: shorten y p'
  else seq0.

CoInductive shorten_spec (x : T) (p : seq T) : T -> seq T -> Type :=
   ShortenSpec p' of path e x p' & uniq (x :: p') & subpred (mem p') (mem p) :
     shorten_spec x p (last x p') p'.

Lemma shortenP : forall x p, path e x p ->
   shorten_spec x p (last x p) (shorten x p).
Proof.
move=> x p Hp; have: x \in x :: p by exact: mem_head.
elim: p x {1 3 5}x Hp => [|y2 p Hrec] x y1.
  by rewrite mem_seq1 => _; move/eqP->; split.
rewrite in_adds orbC /=; case/andP=> Hy12 Hp.
case: ifP => y2p_x.
  case: (Hrec _ _ Hp y2p_x) => p' Hp' Up' Hp'p _.
  by split=> // y; move/Hp'p; exact: predU1r.
case: (Hrec y2 _ Hp) => /= [|p' Hp' Up' Hp'p]; first by rewrite mem_head.
have{Hp'p} Hp'p: subpred (mem (y2 :: p')) (mem (y2 :: p)).
  by move=> z; rewrite /= !in_adds; case: (z == y2); last exact: Hp'p.
rewrite y2p_x -(last_adds x); move/eqP=> xy1.
split=> //=; first by rewrite xy1 Hy12.
by rewrite {}Up' andbT; apply/negP; move/Hp'p; case/negPf.
Qed.

End EqPath.

(* Ordered paths and sorting. *)

Section SortSeq.

Variable T : eqType.
Variable leT : rel T.

Definition sorted s := if s is x :: s' then path leT x s' else true.

Lemma path_sorted : forall x s, path leT x s -> sorted s.
Proof. by move=> x [|y s] //=; case/andP. Qed.

Section Transitive.

Hypothesis leT_tr : transitive leT.

Lemma order_path_min : forall x s, path leT x s -> all (leT x) s.
Proof.
move=> x [|y s] //=; case/andP=> le_xy; rewrite le_xy /=.
elim: s => //= z s IHs in y le_xy *; case/andP.
move/(leT_tr le_xy)=> le_xz; rewrite le_xz; exact: IHs.
Qed.

Lemma sorted_filter : forall a s, sorted s -> sorted (filter a s).
Proof.
move=> a s; elim: s => //= x s IHs ord_s.
move/(_ (path_sorted ord_s)): IHs; case: (a x) => //=.
case def_s': (filter a s) => //= [y s'] ->.
rewrite (allP (order_path_min ord_s)) //.
have: y \in filter a s by rewrite def_s' mem_head.
by rewrite mem_filter; case/andP.
Qed.

Lemma sorted_uniq : irreflexive leT -> forall s, sorted s -> uniq s.
Proof.
move=> leT_irr; elim=> //= x s IHs s_ord.
rewrite (IHs (path_sorted s_ord)) andbT; apply/negP=> s_x.
by case/allPn: (order_path_min s_ord); exists x; rewrite // leT_irr.
Qed.

Lemma eq_sorted : antisymmetric leT -> forall s1 s2,
   sorted s1 -> sorted s2 -> perm_eq s1 s2 -> s1 = s2.
Proof.
move=> leT_asym; elim=> [|x1 s1 IHs1] s2 //= ord_s1 ord_s2 eq_s12.
  by case: {+}s2 (perm_eq_size eq_s12).
have s2_x1: x1 \in s2 by rewrite -(perm_eq_mem eq_s12) mem_head.
case: s2 s2_x1 eq_s12 ord_s2 => //= x2 s2; rewrite in_adds.
case: eqP => [<- _| ne_x12 /= s2_x1] eq_s12 ord_s2.
  by rewrite {IHs1}(IHs1 s2) ?(@path_sorted x1) // -(perm_adds x1).
case: (ne_x12); apply: leT_asym; rewrite (allP (order_path_min ord_s2)) //.
have: x2 \in x1 :: s1 by rewrite (perm_eq_mem eq_s12) mem_head.
case/predU1P=> [eq_x12 | s1_x2]; first by case ne_x12.
by rewrite (allP (order_path_min ord_s1)).
Qed.

Lemma eq_sorted_irr : irreflexive leT -> forall s1 s2,
  sorted s1 -> sorted s2 -> s1 =i s2 -> s1 = s2.
Proof.
move=> leT_irr s1 s2 s1_sort s2_sort eq_s12.
have: antisymmetric leT.
  move=> m n; case/andP=> ? ltnm; case/idP: (leT_irr m); exact: leT_tr ltnm.
move/eq_sorted; apply=> //; apply: uniq_perm_eq => //; exact: sorted_uniq.
Qed.

End Transitive.

Hypothesis leT_total : total leT.

Fixpoint merge s1 :=
  if s1 is x1 :: s1' then
    let fix merge_s1 (s2 : seq T) :=
      if s2 is x2 :: s2' then
        if leT x2 x1 then x2 :: merge_s1 s2' else x1 :: merge s1' s2
      else s1 in
    merge_s1
  else id.

Lemma path_merge : forall x s1 s2,
  path leT x s1 -> path leT x s2 -> path leT x (merge s1 s2).
Proof.
move=> x s1 s2; elim: s1 s2 x => //= x1 s1 IHs1; elim=> //= x2 s2 IHs2 x.
case/andP=> le_x_x1 ord_s1; case/andP=> le_x_x2 ord_s2.
case: ifP => le_x21 /=; first by rewrite le_x_x2 {}IHs2 // le_x21.
by rewrite le_x_x1 IHs1 //=; have:= leT_total x2 x1; rewrite le_x21 /= => ->.
Qed.

Lemma sorted_merge : forall s1 s2,
  sorted s1 -> sorted s2 -> sorted (merge s1 s2).
Proof.
move=> [|x1 s1] [|x2 s2] //= ord_s1 ord_s2.
case: ifP => le_x21 /=.
  by apply: (@path_merge x2 (x1 :: s1)) => //=; rewrite le_x21.
by apply: path_merge => //=; have:= leT_total x2 x1; rewrite le_x21 /= => ->.
Qed.

Lemma perm_merge : forall s1 s2, perm_eql (merge s1 s2) (s1 ++ s2).
Proof.
move=> s1 s2; apply/perm_eqlP; rewrite perm_eq_sym.
elim: s1 s2 => //= x1 s1 IHs1.
elim=> [|x2 s2 IHs2]; rewrite /= ?cats0 //.
case: ifP => _ /=; last by rewrite perm_adds.
by rewrite (perm_catCA (_ :: _) [::x2]) perm_adds.
Qed.

Lemma mem_merge : forall s1 s2, merge s1 s2 =i s1 ++ s2.
Proof. by move=> s1 s2; apply: perm_eq_mem; rewrite perm_merge. Qed.

Lemma size_merge : forall s1 s2, size (merge s1 s2) = size (s1 ++ s2).
Proof. by move=> s1 s2; apply: perm_eq_size; rewrite perm_merge. Qed.

Lemma uniq_merge : forall s1 s2, uniq (merge s1 s2) = uniq (s1 ++ s2).
Proof. by move=> s1 s2; apply: perm_eq_uniq; rewrite perm_merge. Qed.

Fixpoint merge_sort_push (s1 : seq T) (ss : seq (seq T)) {struct ss} :=
  match ss with
  | [::] :: ss' | [::] as ss' => s1 :: ss'
  | s2 :: ss' => merge_sort_push (merge s1 s2) ss'
  end.

Fixpoint merge_sort_pop (s1 : seq T) (ss : seq (seq T)) {struct ss} :=
  if ss is s2 :: ss' then merge_sort_pop (merge s1 s2) ss' else s1.

Fixpoint merge_sort_rec (ss : seq (seq T)) (s : seq T) {struct s} :=
  if s is [:: x1, x2 & s'] then
    let s1 := if leT x1 x2 then [:: x1; x2] else [:: x2; x1] in
    merge_sort_rec (merge_sort_push s1 ss) s'
  else merge_sort_pop s ss.

Definition sort := merge_sort_rec [::].

Lemma sorted_sort : forall s, sorted (sort s).
Proof.
rewrite /sort => s; have allss: all sorted [::] by [].
elim: {s}_.+1 {-2}s [::] allss (ltnSn (size s)) => // n IHn s ss allss.
have: sorted s -> sorted (merge_sort_pop s ss).
  elim: ss allss s => //= s2 ss IHss.
  by case/andP=> *; exact: IHss (sorted_merge _ _).
case: s => [|x1 [|x2 s _]]; try by auto.
move/ltnW; move/IHn; apply; rewrite {n IHn s} ifE; set s1 := if_expr _ _ _.
have: sorted s1 by exact: (@sorted_merge [::x2] [::x1]).
elim: ss {x1 x2}s1 allss => /= [|s2 ss IHss] s1; first by rewrite andbT.
case/andP=> ord_s2 ord_ss ord_s1.
by case: {1}s2=> /= [|_ _]; [rewrite ord_s1 | exact: IHss (sorted_merge _ _)].
Qed.

Lemma perm_sort : forall s, perm_eql (sort s) s.
Proof.
rewrite /sort => s; apply/perm_eqlP; pose catss := foldr (@cat T) [::].
rewrite perm_eq_sym -{1}[s]/(catss [::] ++ s).
elim: {s}_.+1 {-2}s [::] (ltnSn (size s)) => // n IHn s ss.
have: perm_eq (catss ss ++ s) (merge_sort_pop s ss).
  elim: ss s => //= s2 ss IHss s1; rewrite -{IHss}(perm_eqrP (IHss _)).
  by rewrite perm_catC catA perm_catC perm_cat2l -perm_merge.
case: s => // x1 [//|x2 s _]; move/ltnW; move/IHn=> {n IHn} IHs.
rewrite -{IHs}(perm_eqrP (IHs _)) ifE; set s1 := if_expr _ _ _.
rewrite (catA _ [::_;_] s) {s}perm_cat2r.
apply: (@perm_eq_trans _ (catss ss ++ s1)).
  by rewrite perm_cat2l /s1 -ifE; case ifP; rewrite // (perm_catC [::_]).
elim: ss {x1 x2}s1 => /= [|s2 ss IHss] s1; first by rewrite cats0.
rewrite perm_catC; case def_s2: {2}s2=> /= [|y s2']; first by rewrite def_s2.
by rewrite catA -{IHss}(perm_eqrP (IHss _)) perm_catC perm_cat2l -perm_merge.
Qed.

Lemma mem_sort : forall s, sort s =i s.
Proof. by move=> s; apply: perm_eq_mem; rewrite perm_sort. Qed.

Lemma size_sort : forall s, size (sort s) = size s.
Proof. by move=> s; apply: perm_eq_size; rewrite perm_sort. Qed.

Lemma uniq_sort : forall s, uniq (sort s) = uniq s.
Proof. by move=> s; apply: perm_eq_uniq; rewrite perm_sort. Qed.

Lemma perm_sortP : transitive leT -> antisymmetric leT ->
  forall s1 s2, reflect (sort s1 = sort s2) (perm_eq s1 s2).
Proof.
move=> leT_tr leT_asym s1 s2; apply: (iffP idP) => eq12; last first.
  by rewrite -perm_sort eq12 perm_sort.
apply: eq_sorted; rewrite ?sorted_sort //.
by rewrite perm_sort (perm_eqlP eq12) -perm_sort.
Qed.

End SortSeq.

Lemma sorted_ltn_uniq_leq : forall s, sorted ltn s = uniq s && sorted leq s.
Proof.
case=> //= n s; elim: s n => //= m s IHs n.
rewrite inE ltn_neqAle negb_or IHs -!andbA.
case sn: (n \in s); last do !bool_congr.
rewrite andbF; apply/and5P=> [[ne_nm lenm _ _ le_ms]]; case/negP: ne_nm.
rewrite eqn_leq lenm; exact: (allP (order_path_min leq_trans le_ms)).
Qed.

Lemma sorted_iota : forall i n, sorted leq (iota i n).
Proof. by move=> i n; elim: n i => // [[|n] //= IHn] i; rewrite IHn leqW. Qed.

Lemma sorted_ltn_iota : forall i n, sorted ltn (iota i n).
Proof. by move=> i n; rewrite sorted_ltn_uniq_leq sorted_iota uniq_iota. Qed.

(* Function trajectories. *)

Notation "'fpath' f" := (path (frel f))
  (at level 10, f at level 8) : seq_scope.

Notation "'fcycle' f" := (cycle (frel f))
  (at level 10, f at level 8) : seq_scope.

Notation "'ufcycle' f" := (ucycle (frel f))
  (at level 10, f at level 8) : seq_scope.

Prenex Implicits path next prev cycle ucycle mem2.

Section Trajectory.

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

Fixpoint traject x (n : nat) {struct n} :=
  if n is n'.+1 then x :: traject (f x) n' else seq0.

Lemma size_traject : forall x n, size (traject x n) = n.
Proof. by move=> x n; elim: n x => [|n Hrec] x //=; nat_congr. Qed.

Lemma last_traject : forall x n, last x (traject (f x) n) = iter n f x.
Proof. by move=> x n; elim: n x => [|n Hrec] x //; rewrite -iter_f -Hrec. Qed.

Lemma sub_traject : forall i n, i < n ->
  forall x, sub x (traject x n) i = iter i f x.
Proof.
move=> i n Hi x; elim: n {2 3}x i Hi => [|n Hrec] y [|i] Hi //=.
by rewrite Hrec ?iter_f.
Qed.

End Trajectory.

Section EqTrajectory.

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

Lemma fpathP : forall x p,
  reflect (exists n, traject f (f x) n = p) (fpath f x p).
Proof.
move=> x p; elim: p x => [|y p Hrec] x; first by left; exists 0.
rewrite /= andbC; case: {Hrec}(Hrec y) => Hrec.
  apply: (iffP eqP); first by case: Hrec => [n <-] <-; exists n.+1.
  by case=> [] [|n] // [Dp].
by right; move=> [[|n] // [Dy Dp]]; case: Hrec; exists n; rewrite -Dy -Dp.
Qed.

Lemma fpath_traject : forall x n, fpath f x (traject f (f x) n).
Proof. by move=> x n; apply/(fpathP x); exists n. Qed.

Definition looping x n := iter n f x \in traject f x n.

Lemma loopingP : forall x n,
  reflect (forall m, iter m f x \in traject f x n) (looping x n).
Proof.
move=> x n; apply introP; last by move=> Hn Hn'; rewrite /looping Hn' in Hn.
case: n => [|n] Hn //; elim=> [|m Hrec]; first by exact: predU1l.
move: (fpath_traject x n) Hn; rewrite /looping -!f_iter -last_traject /=.
rewrite /= in Hrec; case/splitPl: Hrec; move: (iter m f x) => y p1 p2 Ep1.
rewrite path_cat last_cat Ep1; case: p2 => [|z p2] //; case/and3P=> [_ Dy _] _.
by rewrite !(in_adds, mem_cat) (eqP Dy) eqxx !orbT.
Qed.

Lemma trajectP : forall x n y,
  reflect (exists2 i, i < n & iter i f x = y) (y \in traject f x n).
Proof.
move=> x n y; elim: n x => [|n Hrec] x; first by right; case.
  rewrite /= in_adds orbC; case: {Hrec}(Hrec (f x)) => Hrec.
  by left; case: Hrec => [i Hi <-]; exists i.+1; last by rewrite iter_f.
apply: (iffP eqP); first by exists 0; first by rewrite ltnNge.
by move=> [[|i] Hi Dy] //; case Hrec; exists i; last by rewrite iter_f.
Qed.

Lemma looping_uniq : forall x n, uniq (traject f x n.+1) = ~~ looping x n.
Proof.
move=> x n; rewrite /looping; elim: n x => [|n Hrec] x //.
rewrite -iter_f {2}[succn]lock /= -lock {}Hrec -negb_or in_adds; bool_congr.
set y := iter n f (f x); case (trajectP (f x) n y); first by rewrite !orbT.
rewrite !orbF => Hy; apply/idP/eqP => [Hx|Dy]; last first.
  by rewrite -{1}Dy /y -last_traject mem_last.
case: {Hx}(trajectP _ n.+1 _ Hx) => [m Hm Dx].
have Hx': looping x m.+1 by rewrite /looping -iter_f Dx mem_head.
case/trajectP: (loopingP _ _ Hx' n.+1); rewrite -iter_f -/y.
move=> [|i] Hi //; rewrite -iter_f => Dy.
by case: Hy; exists i; first exact (leq_trans Hi Hm).
Qed.

End EqTrajectory.

Implicit Arguments fpathP [T f x p].
Implicit Arguments loopingP [T f x n].
Implicit Arguments trajectP [T f x n y].
Prenex Implicits traject fpathP loopingP trajectP.

Section UniqCycle.

Variables (n0 : nat) (T : eqType) (e : rel T) (p : seq T).

Hypothesis Up : uniq p.

Lemma prev_next : cancel (next p) (prev p).
Proof.
move=> x; rewrite prev_sub mem_next next_sub.
case Hpx: (x \in p) => [|] //; case Dp: p Up Hpx => [|y p'] //.
rewrite -(Dp) {1}Dp /=; move/andP=> [Hpy Hp'] Hx.
set i := index x p; rewrite -(sub_index y Hx) -/i; congr (sub y).
rewrite -index_mem -/i Dp /= ltnS leq_eqVlt in Hx.
case/predU1P: Hx => [Di|Hi]; last by apply: index_uniq.
rewrite Di (sub_default y (leqnn _)).
rewrite -index_mem -leqNgt in Hpy.
by apply: eqP; rewrite eqn_leq Hpy /index find_size.
Qed.

Lemma next_prev : cancel (prev p) (next p).
Proof.
move=> x; rewrite next_sub mem_prev prev_sub.
case Hpx: (x \in p) => [|] //; case Dp: p Up Hpx => [|y p'] //.
rewrite -Dp => Hp Hpx; set i := index x p'.
have Hi: i < size p by rewrite Dp /= ltnS /i /index find_size.
rewrite (index_uniq y Hi Hp); case Hx: (x \in p'); first by apply: sub_index.
rewrite Dp in_adds Hx orbF in Hpx; rewrite (eqP Hpx).
by apply: sub_default; rewrite leqNgt /i index_mem Hx.
Qed.

Lemma cycle_next : fcycle (next p) p.
Proof.
case Dp: {-2}p Up => [|x p'] Up' //; apply/(pathP x)=> i; rewrite size_add_last => Hi.
rewrite -cats1 -cat_adds sub_cat Hi /= next_sub {}Dp mem_sub //.
rewrite index_uniq // sub_cat /=; rewrite ltnS leq_eqVlt in Hi.
case/predU1P: Hi => [Di|Hi]; last by rewrite Hi eqxx.
by rewrite Di ltnn subnn sub_default ?leqnn /= ?eqxx.
Qed.

Lemma cycle_prev : cycle (fun x y => x == prev p y) p.
Proof.
apply: etrans cycle_next; symmetry; case Dp: p => [|x p'] //.
apply: eq_path; rewrite -Dp; exact (can2_eq prev_next next_prev).
Qed.

Lemma cycle_from_next : (forall x, x \in p -> e x (next p x)) -> cycle e p.
Proof.
move=> He; case Dp: p cycle_next => [|x p'] //; rewrite -Dp !(cycle_path x).
have Hx: last x p \in p by rewrite Dp /= mem_last.
move: (next p) He {Hx}(He _ Hx) => np.
elim: (p) {x p' Dp}(last x p) => [|y p' Hrec] x He Hx //=.
case/andP=> [Dy Hp']; rewrite -{1}(eqP Dy) Hx /=.
apply: Hrec Hp' => [z Hz|]; apply: He; [exact: predU1r | exact: predU1l].
Qed.

Lemma cycle_from_prev : (forall x, x \in p -> e (prev p x) x) -> cycle e p.
Proof.
move=> He; apply: cycle_from_next => [x Hx].
by rewrite -{1}[x]prev_next He ?mem_next.
Qed.

Lemma next_rot : next (rot n0 p) =1 next p.
Proof.
move=> x; have Hp := cycle_next; rewrite -(cycle_rot n0) in Hp.
case Hx: (x \in p); last by rewrite !next_sub mem_rot Hx.
rewrite -(mem_rot n0) in Hx; exact (esym (eqP (next_cycle Hp Hx))).
Qed.

Lemma prev_rot : prev (rot n0 p) =1 prev p.
Proof.
move=> x; have Hp := cycle_prev; rewrite -(cycle_rot n0) in Hp.
case Hx: (x \in p); last by rewrite !prev_sub mem_rot Hx.
rewrite -(mem_rot n0) in Hx; exact (eqP (prev_cycle Hp Hx)).
Qed.

End UniqCycle.

Section UniqRotrCycle.

Variables (n0 : nat) (T : eqType) (p : seq T).

Hypothesis Up : uniq p.

Lemma next_rotr : next (rotr n0 p) =1 next p. Proof. exact: next_rot. Qed.

Lemma prev_rotr : prev (rotr n0 p) =1 prev p. Proof. exact: prev_rot. Qed.

End UniqRotrCycle.

Section UniqCycleRev.

Variable T : eqType.

Lemma prev_rev : forall p : seq T, uniq p -> prev (rev p) =1 next p.
Proof.
move=> p Up x; case Hx: (x \in p); last first.
  by rewrite next_sub prev_sub mem_rev Hx.
case/rot_to: Hx (Up) => [i p' Dp] Urp; rewrite -uniq_rev in Urp.
rewrite -(prev_rotr i Urp); do 2 rewrite -(prev_rotr 1) ?uniq_rotr //.
rewrite -rev_rot -(next_rot i Up) {i p Up Urp}Dp.
case: p' => [|y p'] //; rewrite !rev_adds rotr1_add_last /= eqxx.
by rewrite -add_last_adds rotr1_add_last /= eqxx.
Qed.

Lemma next_rev : forall p : seq T, uniq p -> next (rev p) =1 prev p.
Proof. by move=> p Up x; rewrite -{2}[p]revK prev_rev // uniq_rev. Qed.

End UniqCycleRev.

Section MapPath.

Variables (T T' : Type) (h : T' -> T) (e : rel T) (e' : rel T').

Definition rel_base (b : pred T) :=
  forall x' y', ~~ b (h x') -> e (h x') (h y') = e' x' y'.

Lemma path_maps : forall b x' p', rel_base b ->
    ~~ has (preim h b) (belast x' p') ->
  path e (h x') (maps h p') = path e' x' p'.
Proof.
move=> b x' p' Hb; elim: p' x' => [|y' p' Hrec] x' //=; move/norP=> [Hbx Hbp].
congr andb; auto.
Qed.

End MapPath.

Section MapEqPath.

Variables (T T' : eqType) (h : T' -> T) (e : rel T) (e' : rel T').

Hypothesis Hh : injective h.

Lemma mem2_maps : forall x' y' p',
  mem2 (maps h p') (h x') (h y') = mem2 p' x' y'.
Proof. by move=> *; rewrite {1}/mem2 (index_maps Hh) -maps_drop mem_maps. Qed.

Lemma next_maps : forall p, uniq p ->
  forall x, next (maps h p) (h x) = h (next p x).
Proof.
move=> p Up x; case Hx: (x \in p); last by rewrite !next_sub (mem_maps Hh) Hx.
case/rot_to: Hx => [i p' Dp].
rewrite -(next_rot i Up); rewrite -(uniq_maps Hh) in Up.
rewrite -(next_rot i Up) -maps_rot {i p Up}Dp /=.
by case: p' => [|y p] //=; rewrite !eqxx.
Qed.

Lemma prev_maps : forall p, uniq p ->
  forall x, prev (maps h p) (h x) = h (prev p x).
Proof.
by move=> p Up x; rewrite -{1}[x](next_prev Up) -(next_maps Up) prev_next ?uniq_maps.
Qed.

End MapEqPath.

Definition fun_base (T T' : eqType) (h : T' -> T) f f' :=
  rel_base h (frel f) (frel f').

Section CycleArc.

Variable T : eqType.

Definition arc (p : seq T) x y :=
  let px := rot (index x p) p in take (index y px) px.

Lemma arc_rot : forall i p, uniq p -> {in p, arc (rot i p) =2 arc p}.
Proof.
move=> i p Up x Hx y; congr (fun q => take (index y q) q); move: Up Hx {y}.
rewrite -{1 2 5 6}(cat_take_drop i p) /rot uniq_cat; move/and3P=> [_ Hp _].
rewrite !drop_cat !take_cat !index_cat mem_cat orbC.
case Hx: (x \in drop i p) => /= => [_|Hx'].
  rewrite [x \in _](negbET (hasPn Hp _ Hx)).
  by rewrite index_mem Hx ltnNge leq_addr /= addKn catA.
by rewrite Hx' index_mem Hx' ltnNge leq_addr /= addKn catA.
Qed.

Lemma left_arc : forall x y p1 p2,
  let p := x :: p1 ++ y :: p2 in uniq p -> arc p x y = x :: p1.
Proof.
move=> x y p1 p2 p Up; rewrite /arc {1}/p /= eqxx rot0.
move: Up; rewrite /p -cat_adds uniq_cat index_cat; move: (x :: p1) => xp1.
rewrite /= negb_or -!andbA; move/and3P=> [_ Hy _].
by rewrite (negbET Hy) eqxx addn0 take_size_cat.
Qed.

Lemma right_arc : forall x y p1 p2,
  let p := x :: p1 ++ y :: p2 in uniq p -> arc p y x = y :: p2.
Proof.
move=> x y p1 p2 p Up; set n := size (x :: p1); rewrite -(arc_rot n Up).
  move: Up; rewrite -(uniq_rot n) /p -cat_adds /n rot_size_cat.
  by move=> *; rewrite /= left_arc.
by rewrite /p -cat_adds mem_cat /= mem_head orbT.
Qed.

CoInductive rot_to_arc_spec (p : seq T) (x y : T) : Type :=
    RotToArcSpec i p1 p2 of x :: p1 = arc p x y
                          & y :: p2 = arc p y x
                          & rot i p = x :: p1 ++ y :: p2 :
    rot_to_arc_spec p x y.

Lemma rot_to_arc : forall p x y,
  uniq p -> x \in p -> y \in p -> x != y -> rot_to_arc_spec p x y.
Proof.
move=> p x y Up Hx Hy Hxy; case: (rot_to Hx) (Hy) (Up) => [i p' Dp] Hy'.
rewrite -(mem_rot i) Dp in_adds eq_sym (negPf Hxy) in Hy'.
rewrite -(uniq_rot i) Dp.
case/splitPr: p' / Hy' Dp => [p1 p2] Dp Up'; exists i p1 p2; auto.
  by rewrite -(arc_rot i Up Hx) Dp (left_arc Up').
by rewrite -(arc_rot i Up Hy) Dp (right_arc Up').
Qed.

End CycleArc.

Prenex Implicits arc.