Require Export Induction.

Module NatList.

Inductive natprod : Type :=
  pair : nat -> nat -> natprod.

Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.
Definition snd (p : natprod) : nat :=
  match p with
  | pair x y => y
  end.

Notation "( x , y )" := (pair x y).

Definition swap_pair (p : natprod) : natprod :=
  match p with
  | (x,y) => (y,x)
  end.

Theorem surjective_pairing' : forall (n m : nat),
  (n,m) = (fst (n,m), snd (n,m)).
Proof.
  reflexivity.
Qed.

Theorem surjective_pairing : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  intros p.
  destruct p as [m n].
  simpl.
  reflexivity.
Qed.

Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros.
  destruct p as [m n].
  simpl.
  reflexivity.
Qed.

Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros.
  destruct p as [m n].
  simpl.
  reflexivity.
Qed.

Inductive natlist : Type :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

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

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => nil
  | S count' => n :: (repeat n count')
  end.

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil    => l2
  | h :: t => h :: (app t l2)
  end.

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Example test_app1:             [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity.  Qed.
Example test_app2:             nil ++ [4;5] = [4;5].
Proof. reflexivity.  Qed.
Example test_app3:             [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity.  Qed.

Definition hd (default:nat) (l:natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
  end.

Definition tl (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

Example test_hd1:             hd 0 [1;2;3] = 1.
Proof. reflexivity.  Qed.
Example test_hd2:             hd 0 [] = 0.
Proof. reflexivity.  Qed.
Example test_tl:              tl [1;2;3] = [2;3].
Proof. reflexivity.  Qed.

Fixpoint nonzeros (l:natlist) : natlist :=
  match l with
  | [] => []
  | x :: xs =>
    match x with
    | 0 => nonzeros xs
    | _ => x :: (nonzeros xs)
    end
  end.

Example test_nonzeros:            nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. reflexivity. Qed.

Fixpoint oddmembers (l:natlist) : natlist :=
  match l with
  | [] => []
  | x :: xs =>
    match oddb x with
    | true => x :: (oddmembers xs)
    | false => oddmembers xs
    end
  end.

Example test_oddmembers:            oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof. reflexivity. Qed.

Fixpoint snoc (l:natlist) (v:nat) : natlist :=
  match l with
  | nil    => [v]
  | h :: t => h :: (snoc t v)
  end.

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil    => nil
  | h :: t => snoc (rev t) h
  end.

Fixpoint subalternate (n : nat) (ys l1 l2 : natlist) : natlist :=
  match n with
  | 0 => rev ys
  | S n' =>
    match l1 with
    | [] => (rev ys) ++ l2
    | x :: xs => subalternate n' (x :: ys) l2 xs
    end
  end.

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  subalternate (length l1 + length l2) nil l1 l2.

(* Eval compute in alternate [1;2;3] [4;5;6]. *)

Example test_alternate1:        alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof. reflexivity. Qed.
Example test_alternate2:        alternate [1] [4;5;6] = [1;4;5;6].
Proof. reflexivity. Qed.
Example test_alternate3:        alternate [1;2;3] [4] = [1;4;2;3].
Proof. reflexivity. Qed.
Example test_alternate4:        alternate [] [20;30] = [20;30].
Proof. reflexivity. Qed.

Theorem nil_app_l : forall l:natlist,
  [] ++ l = l.
Proof. reflexivity. Qed.

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons n l'".
    reflexivity.  Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros.
  induction l1 as [|n l1'].
  reflexivity.
  simpl.
  rewrite IHl1'.
  reflexivity.
Qed.

Theorem nil_app_r : forall l:natlist,
  l ++ [] = l.
Proof.
  intros.
  induction l as [| n k].
  reflexivity.
  simpl.
  rewrite IHk.
  reflexivity.
Qed.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros.
  induction l1 as [| n l1'].
  reflexivity.
  simpl.
  rewrite IHl1'.
  reflexivity.
Qed.

Example test_rev1:            rev [1;2;3] = [3;2;1].
Proof. reflexivity.  Qed.
Example test_rev2:            rev nil = nil.
Proof. reflexivity.  Qed.

Theorem length_snoc : forall n : nat, forall l : natlist,
  length (snoc l n) = S (length l).
Proof.
  intros.
  induction l as [| n' l'].
  reflexivity.
  simpl.
  rewrite IHl'.
  reflexivity.
Qed.

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros.
  induction l as [| n l'].
  reflexivity.
  simpl.
  rewrite length_snoc.
  rewrite IHl'.
  reflexivity.
Qed.

Theorem absorb_snoc : forall n m: nat, forall l : natlist, n :: (snoc l m) = snoc (n :: l) m.
Proof.
  intros.
  reflexivity.
Qed.

(* SearchAbout rev. *)

Theorem rev_snoc : forall n : nat, forall l : natlist, rev (snoc l n) = n :: rev l.
Proof.
  intros.
  induction l as [| n' l'].
  reflexivity.
  simpl.
  rewrite absorb_snoc.
  rewrite IHl'.
  reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist, rev (rev l) = l.
Proof.
  intros. induction l as [| n l'].
  reflexivity.
  simpl.
  rewrite rev_snoc.
  rewrite IHl'.
  reflexivity.
Qed.

Theorem cons_append : forall n : nat, forall l : natlist, cons n l = [n] ++ l.
Proof.
  intros.
  induction l as [|m k].
  reflexivity.
  simpl.
  reflexivity.
Qed.

Theorem snoc_append : forall (l:natlist) (n:nat),
  snoc l n = l ++ [n].
Proof.
  intros.
  induction l as [|m k].
  reflexivity.
  simpl.
  rewrite IHk.
  reflexivity.
Qed.

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros.
  rewrite app_assoc.
  rewrite app_assoc.
  reflexivity.
Qed.

Theorem rev_injective : forall (l1 l2 : natlist), rev l1 = rev l2 -> l1 = l2.
Proof.
  intros.
  assert (H4: rev (rev l1) = l2).
    rewrite H.
    rewrite rev_involutive.
    reflexivity.
  rewrite rev_involutive in H4.
  assumption.
Qed.

End NatList.


(******************************************************************************)
(* Chapter 1.6.1: Product Categories                                          *)
(******************************************************************************)

(*
(0)
同じディレクトリにある Categories.v と Functor.v を使う。

(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Require Import Aw_0_Notations.              (* coq standard libs. *)
Require Import Aw_1_3_Categories.           (* same dir. *)
Require Import Aw_1_4_Functors.             (* same dir. *)
Require Import Aw_1_5_Isomorphisms.         (* same dir. *)

(* 積圏 *)
Section ProductCategories.

  Locate "_ ~~{ _ }~~> _".                  (* Categories.v *)

(*
  Context `(C1 : Category Obj1 Hom1).
  Context `(C2 : Category Obj2 Hom2).
*)
  Context `(C1 : Category).                 (* Obj Hom *)
  Context `(C2 : Category).                 (* Obj0 Hom0 *)

  (* trying to use the standard "prod" here causes a universe
  inconsistency once we get to coqBinoidal; moreover, using a
  general fully-polymorphic pair type seems to trigger some serious
  memory leaks in Coq *)

  Inductive  prod_obj : Type :=
  | pair_obj : C1 -> C2 -> prod_obj.

  Definition fst_obj (x : prod_obj) : C1 :=
    match x with
      | pair_obj a _ => a
    end.

  Definition snd_obj (x : prod_obj) : C2 :=
    match x with
      | pair_obj _ b => b
    end.

  Inductive prod_mor (a b : prod_obj) : Type :=
    pair_mor :
      ((fst_obj a) ~~{C1}~~> (fst_obj b)) -> (* f1 *)
      ((snd_obj a) ~~{C2}~~> (snd_obj b)) -> (* f2 *)
      prod_mor a b.                          (* f *)
  Check prod_mor : prod_obj → prod_obj → Type.

  Definition prod_eqv (a b : prod_obj)
             (f : prod_mor a b) (g : prod_mor a b) : Prop :=
    match f with
      | pair_mor f1 f2 =>
        match g with
          | pair_mor g1 g2 =>
            f1 === g1 /\ f2 === g2
        end
    end.

  Program Instance prod_Equiv (a b : prod_obj) : Equivalence (@prod_eqv a b).
  Obligation 1.                             (* Reflexive *)
  Proof.
    rewrite /prod_eqv /Reflexive /=.
    case=> f1 f2.
    split.
    - reflexivity.
    - reflexivity.
  Qed.
  Obligation 2.                             (* Symmetric *)
  Proof.
    rewrite /prod_eqv /Symmetric /=.
    case=> f1 f2.
    case=> g1 g2.
    case=> H1 H2.
    split.
    - rewrite H1.
      reflexivity.
    - rewrite H2.
      reflexivity.
  Qed.
  Obligation 3.                             (* Transitive *)
  Proof.
    rewrite /prod_eqv /Transitive /=.
    case=> f1 f2.
    case=> g1 g2.
    case=> h1 h2.
    case=> Hfg1 Hfg2.
    case=> Hgh1 Hgh2.
    split.
    - rewrite Hfg1 Hgh1.
      reflexivity.
    - rewrite Hfg2 Hgh2.
      reflexivity.
  Qed.

  (* 射はSetoidでないといけない。 *)
  Instance PC_mor (a b : prod_obj) : Setoid :=
    {
      carrier := prod_mor a b;
      eqv := @prod_eqv a b;
      eqv_equivalence := prod_Equiv a b
    }.
  Check PC_mor : prod_obj → prod_obj → Setoid.
  Print PC_mor.

  Definition fst_mor {a b : prod_obj} (f : prod_mor a b) :=
    match f with
      | pair_mor a _ => a
    end.

  Definition snd_mor {a b : prod_obj} (f : prod_mor a b) :=
    match f with
      | pair_mor _ b => b
    end.

  Check @Category.
  Check prod_obj : Type.
  Check prod_mor : prod_obj → prod_obj → Type.
  Check PC_mor   : prod_obj → prod_obj → Setoid.
  Check @Category prod_obj PC_mor.

  Program Instance ProductCategory : @Category prod_obj PC_mor.
  Obligation 1.                             (* iid *)
  Proof.
    apply pair_mor.
    - apply iid.
    - apply iid.
  Defined.
  Obligation 2.                             (* comp *)
  Proof.
    apply pair_mor.
    Check (fun (f1 : fst_obj a ~~{ C1 }~~> fst_obj b)
               (g1 : fst_obj b ~~{ C1 }~~> fst_obj c) => (g1 \\o f1)).
    - apply (fun (f1 : fst_obj a ~~{ C1 }~~> fst_obj b)
                 (g1 : fst_obj b ~~{ C1 }~~> fst_obj c) => (g1 \\o f1));
        by [apply X | apply X0].
    - apply (fun (f2 : snd_obj a ~~{ C2 }~~> snd_obj b)
                 (g2 : snd_obj b ~~{ C2 }~~> snd_obj c) => (g2 \\o f2));
        by [apply X | apply X0].
  Defined.
  Obligation 3.                             (* comp_respects *)
  Proof.
    rewrite /ProductCategory_obligation_2.
    move=> g1 g2 Hg.
    move=> f1 f2 Hf.
    move: Hg Hf.
    rewrite /prod_eqv.
    case g1 => gf1 gs1.
    case f1 => ff1 fs1.
    case g2 => gf2 gs2.
    case f2 => ff2 fs2.
    case=> Hgf Hgs.
    case=> Hff Hfs.
    split.
    - rewrite Hgf Hff.
      reflexivity.
    - rewrite Hgs Hfs.
      reflexivity.
  Defined.
  Obligation 4.                             (* iid \\o f === f  *)
  Proof.
    case: f => ff fs.
    split.
    - rewrite left_identity.
      reflexivity.
    - rewrite left_identity.
      reflexivity.
  Defined.
  Obligation 5.                             (* f \\o iid === f  *)
  Proof.
    case: f => ff fs.
    split.
    - rewrite right_identity.
      reflexivity.
    - rewrite right_identity.
      reflexivity.
  Defined.
  Obligation 6.                             (* f \\o g \\o h === f \\o (g \\o h) *)
  Proof.
    case: f => ff fs.
    split.
    - case: g => gf gs.
      case: h => hf hs.
      rewrite associativity.
      reflexivity.
    - case: g => gf gs.
      case: h => hf hs.
      rewrite associativity.
      reflexivity.
  Defined.
End ProductCategories.

Notation "C ×× D" := (ProductCategory C D).

(*
Implicit Arguments pair_obj [ Ob1 Hom1 Ob2 Hom2 C1 C2 ].
Implicit Arguments pair_mor [ Ob1 Hom1 Ob2 Hom2 C1 C2 ].
 *)

Check @pair_obj : ∀Obj Hom C1 Obj Hom C2 a b, prod_obj C1 C2.
Check @pair_mor : ∀Obj Hom C1 Obj Hom C2 a b f g, prod_mor a b.
Check @fst_obj.
Check @fst_mor.
Arguments pair_obj {Obj1 Hom1 C1 Obj2 Hom2 C2} a b : rename.
Arguments pair_mor {Obj1 Hom1 C1 Obj2 Hom2 C2 a b} f g : rename.
Arguments fst_obj  {Obj1 Hom1 C1 Obj2 Hom2 C2} D : rename.
Arguments snd_obj  {Obj1 Hom1 C1 Obj2 Hom2 C2} D : rename.
Arguments fst_mor  {Obj1 Hom1 C1 Obj2 Hom2 C2 a b} i : rename.
Arguments snd_mor  {Obj1 Hom1 C1 Obj2 Hom2 C2 a b} i : rename.
Check pair_obj : _ -> _ -> prod_obj _ _.    (* 圏の指定は要らない。 *)
Check pair_mor : _ ~> _ ->  _ ~> _ -> prod_mor _ _.
Check fst_obj  : prod_obj _ _ -> _.
Check snd_obj  : prod_obj _ _ -> _.
Check fst_mor  : prod_mor _ _ -> _ ~> _.

Check @PC_mor : ∀Obj Hom C1 Obj0 Hom0 C2 _ _, Setoid.
Arguments PC_mor {Obj1 Hom1 C1 Obj2 Hom2 C2} f g : rename.
Check PC_mor : prod_obj _ _ → prod_obj _ _ → Setoid.

Check @Functor : ∀Obj Hom C1 Obj0 Hom0 C2 _, Type.
Arguments Functor {Obj Hom} C1 {Obj0 Hom0} C2 i : rename.

Section ProductCategoryFunctors.

  Context `{C : Category}.                  (* Obj Hom C *)
  Context `{D:Category}.                    (* Obj0 Hom0 D *)

  Check @Functor.
  Check @Functor _ _ (C ×× D) Obj Hom C (fun c => fst_obj c).
  Check Functor (C ×× D) C (fun c => fst_obj c).

  Check @prod_obj Obj Hom C Obj0 Hom0 D.
  Check prod_obj C D.

  Check @PC_mor Obj Hom C Obj0 Hom0 D.
  Check PC_mor.

  Check @fst_obj Obj Hom C Obj0 Hom0 D : prod_obj C D → C.
  Check fst_obj : prod_obj C D → C.

  Check fun (c : prod_obj C D) => @fst_obj Obj Hom C Obj0 Hom0 D c.
  Check fun (c : prod_obj C D) => fst_obj c.

  Check @Functor (prod_obj C D) (@PC_mor Obj Hom C Obj0 Hom0 D) (C ×× D)
        Obj Hom C (fun c => fst_obj _ c).
  Check Functor (C ×× D) C (fun (c : prod_obj C D) => @fst_obj Obj Hom C Obj0 Hom0 D c).

  (* 積圏からもとの圏をとりだす関手 *)
  Program Instance func_pi1 : Functor (C ×× D) C
                                      (fun (c : prod_obj C D) => fst_obj c).
  Obligation 1.
  (* fst_obj a ~~{ C }~~> fst_obj b *)
  Proof.
    by apply fst_mor.
  Defined.
  Obligation 2.
  (* fst_mor f === fst_mor f' *)
  Proof.
    rewrite /func_pi1_obligation_1.
    case: f H => ff fs.
    case: f' => f'f f's H /=.
    by case: H.
  Defined.
  Obligation 3.
  (* iid === iid *)
  Proof.
    reflexivity.
  Defined.
  Obligation 4.
  Proof.
    rewrite /func_pi1_obligation_1.
    case: f => ff fs.
    case: g => gf gs.
    reflexivity.
  Defined.

  Program Instance func_pi2 : Functor (C ×× D) D
                                      (fun (c : prod_obj C D) => snd_obj c).
  Obligation 1.
  (* snd_obj a ~~{ D }~~> snd_obj b *)
  Proof.
    by apply snd_mor.
  Defined.
  Obligation 2.
  (* snd_mor f === snd_mor f' *)
  Proof.
    rewrite /func_pi2_obligation_1.
    case: f H => ff fs.
    case: f' => f'f f's H /=.
    by case: H.
  Defined.
  Obligation 3.
  (* iid === iid *)
  Proof.
    reflexivity.
  Defined.
  Obligation 4.
  Proof.
    rewrite /func_pi2_obligation_1.
    case: f => ff fs.
    case: g => gf gs.
    reflexivity.
  Defined.

  (* 積圏の左が恒等射である場合 *)
  Definition llecnac_fmor (I : C) (a b : D) (g : a ~~{D}~~> b) :
    (pair_obj I a) ~~{C××D}~~> (pair_obj I b).
  Proof.
    apply: pair_mor => /=.
    - by apply: iid.
    - by apply: g.
  Defined.

  (* 圏から左が恒等射である積圏への関手 *)
  Program Instance func_llecnac (I : C) : Functor D (C ×× D) (pair_obj I).
  Obligation 1.
  (* prod_mor (pair_obj I a) (pair_obj I b) *)
   Proof.
    apply: pair_mor;
      by apply llecnac_fmor.
  Defined.
  Obligation 2.
  Proof.
    split; [reflexivity | done].
  Defined.
  Obligation 3.
    split; [reflexivity | reflexivity].
  Defined.
  Obligation 4.
  Proof.
    split.
    - rewrite left_identity.
      reflexivity.
    - reflexivity.
  Defined.

  (* 積圏の右が恒等射である場合 *)
  Definition rlecnac_fmor (I : D) (a b : C) (f : a ~~{C}~~> b) :
    (pair_obj a I) ~~{C××D}~~> (pair_obj b I).
  Proof.
    apply: pair_mor => /=.
    - by apply: f.
    - by apply: iid.
  Defined.

  (* 圏から右が恒等射である積圏への関手 *)
  Program Instance func_rlecnac (I : D) : Functor C (C ×× D) (fun c => (pair_obj c I)).
  Obligation 1.
  (* prod_mor (pair_obj a I) (pair_obj b I) *)
  Proof.
    apply: pair_mor;
      by apply rlecnac_fmor.
  Defined.
  Obligation 2.
  Proof.
    split; [done | reflexivity].
  Defined.
  Obligation 3.
    split; [reflexivity | reflexivity].
  Defined.
  Obligation 4.
  Proof.
    split.
    - reflexivity.
    - rewrite right_identity.
      reflexivity.
  Defined.

  Context `{E : Category}.

  (* 積圏の結合律 *)
  Definition cossa : ((C ×× D) ×× E) -> (C ×× (D ×× E)).
  Proof.
    move=> [[HC HD] HE].
    by [].
  Defined.

  (* 次の定理のための補題 *)
  Definition cossa_fmor (a : ((C ×× D) ×× E)) (b : ((C ×× D) ×× E))
             (f : a ~~{(C ×× D) ×× E}~~> b) :
    (cossa a) ~~{C ×× (D ×× E)}~~> (cossa b).
  Proof.
    case: a f => HCxD HE.
    case: b => GCxD GE.
    case: HCxD.
    case: GCxD.
    move=> HC HD GC GD.
    case=> fCD fE.
    case: fCD => fC fD.
    done.
  Defined.

  (* cossa は、関手である。 *)
  Program Instance func_cossa : Functor ((C ×× D) ×× E) (C ×× (D ×× E)) cossa :=
    {|
      fmor := fun a b f => cossa_fmor f
    |}.
  Obligation 1.
  Proof.
    move: a b f f' H.
    (* ∀a b f f' _, cossa_fmor f === cossa_fmor f' *)
    move=> [[a11 a12] a2].                  (* case a *)
    move=> [[b11 b12] b2].                  (* case b *)
    move=> [[f11 f12] f2].                  (* case f *)
    move=> [[g11 g12] g2].                  (* case f' *)
    case; case.
    split; [exact | split; exact].
  Defined.
  Obligation 2.
  Proof.
    (* ∀ a : (C ×× D) ×× E, cossa_fmor iid === iid *)
    case: a => HCxD HE.
    case: HCxD => HC HD.
    split; [reflexivity | split; reflexivity].
  Defined.
  Obligation 3.
  Proof.
    move: a b c f g.
    (* ∀a b c f g, cossa_fmor g \\o cossa_fmor f === cossa_fmor (g \\o f) *)
    move=> [[a11 a12] a2].                  (* case a *)
    move=> [[b11 b12] b2].                  (* case b *)
    move=> [[c11 c12] c2].                  (* case c *)
    move=> [[f11 f12] f2].                  (* case f *)
    move=> [[g11 g12] g2].                  (* case g *)
    rewrite /=; split; [reflexivity | split; reflexivity].
  Defined.

  (* 同じ圏の積 C^2 *)
  Program Instance func_diagonal : Functor C (C ×× C) (fun c => (pair_obj c c)).
  Obligation 1.
  (* prod_mor (pair_obj a a) (pair_obj b b) *)
  Proof.
    by apply: pair_mor.
  Defined.
  Obligation 3.
  (* iid === iid ∧ iid === iid *)
  Proof.
    split; reflexivity.
  Defined.
  Obligation 4.
  (* g \\o f === g \\o f ∧ g \\o f === g \\o f *)
  Proof.
    split; reflexivity.
  Defined.
End ProductCategoryFunctors.

Section func_prod.

  Context `{C1 : Category} `{C2 : Category} `{C3 : Category} `{C4 : Category}.
  Variables (Fobj1 : C1 -> C2) (Fobj2 : C3 -> C4).
  Variables (F1 : Functor C1 C2 Fobj1) (F2 : Functor C3 C4 Fobj2).

  Definition functor_product_fobj (a : prod_obj C1 C3) :=
    pair_obj (Fobj1 (fst_obj a)) (Fobj2 (snd_obj a)).
  Check functor_product_fobj.
  Check functor_product_fobj : prod_obj C1 C3 → prod_obj C2 C4.

  Definition functor_product_fmor (a b : (C1 ×× C3)) (f : a ~~{C1 ×× C3}~~> b) :
    (functor_product_fobj a) ~~{C2 ×× C4}~~> (functor_product_fobj b).
  Proof.
    case: a f => HC1 HC3 H.
    apply: pair_mor => /=.
    - apply (fmor F1); by case H.
    - apply (fmor F2); by case H.
  Defined.

  Hint Unfold fst_obj.

  Program Instance func_prod : Functor (C1 ×× C3) (C2 ×× C4) functor_product_fobj :=
    {|
      fmor := fun a b (f:a~~{C1 ×× C3}~~>b) => functor_product_fmor f
    |}.
  Obligation 1.
  Proof.
    move: a b f f' H.
    (* ∀a b f f' _, functor_product_fmor f === functor_product_fmor f' *)
    move=> [a1 a2].                         (* case a *)
    move=> [b1 b2].                         (* case b *)
    move=> [f1 f2].                         (* case f *)
    move=> [g1 g2].                         (* case g *)
    case=> H1 H2.                           (* case H *)
    split; [rewrite H1 | rewrite H2]; reflexivity.
  Defined.
  Obligation 2.
  Proof.
  (* ∀ a : C1 ×× C3, functor_product_fmor iid === iid *)
    case: a => [a1 a2] /=.
      by split; apply fmor_preserves_id.
  Defined.
  Obligation 3.
  Proof.
    move: a b c f g.
  (* ∀a b c f g,
   functor_product_fmor g \\o functor_product_fmor f ===
   functor_product_fmor (g \\o *)
    move=> [a1 a2].                         (* case a *)
    move=> [b1 b2].                         (* case b *)
    move=> [c1 c2].                         (* case c *)
    case=> f1 f3.                           (* case f *)
    case=> g1 g3.                           (* csae g *)
    by move=> /=; split; apply fmor_preserves_comp.
  Defined.
End func_prod.

Notation "f **** g" := (func_prod f g).

Program Instance iso_prod `{C : Category} `{D : Category} {a b : C} {c d : D}
         (ic : a ≅ b) (id : @Isomorphic _ _ D c d) :
  @Isomorphic _ _ (C ×× D) (pair_obj a c) (pair_obj b d).
Obligation 1.                               (* prod_mor (pair_obj a c) (pair_obj b d) *)
Proof.
  apply: pair_mor => /=.
  - by case: ic.
  - by case: id.
Defined.
Obligation 2.                               (* prod_mor (pair_obj b d) (pair_obj a c) *)
Proof.
  apply: pair_mor => /=.
  - by case: ic.
  - by case: id.
Defined.
Obligation 3.
Proof.
   by split; apply iso_comp1.
Defined.
Obligation 4.
Proof.
   by split; apply iso_comp2.
Defined.

(* END *)


(* For a equal function to be valid it should be reflexive, symmetric and transitive. *)

Definition Reflexive (T : Type) (equal : T -> T -> Prop) :=
  forall e : T,
    equal e e.

Definition Symmetric (T : Type) (equal : T -> T -> Prop) :=
  forall e1 e2 : T,
    equal e1 e2 -> equal e2 e1.

Definition Transitive (T : Type) (equal : T -> T -> Prop) :=
  forall e1 e2 e3 : T,
    equal e1 e2 ->
    equal e2 e3 ->
    equal e1 e3.

Definition Equal (T : Type)
                 (equal : T -> T-> Prop) :=
  Reflexive T equal /\
  Symmetric T equal /\
  Transitive T equal.

Corollary eq_is_a_valid_Equal :
  forall T : Type,
    Equal T eq.
Proof.
  intro T.
  unfold Equal.
  split.
    unfold Reflexive.
    intro e.
    reflexivity.

    split.
      unfold Symmetric.
      intros e1 e2.
      intro H.
      symmetry.
      exact H.

      unfold Transitive.
      intros e1 e2 e3.
      intros H1 H2.
      rewrite -> H2 in H1.
      exact H1.
Qed.

(* Please continue with Algebra *)


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


Require Import ProofCheckingEuclid.euclidean_axioms.

Section Euclid.

Context `{Ax:euclidean_neutral}.

(* Originally known as lemma_3_6a *)
Lemma lemma_orderofpoints_ABC_ACD_BCD :
	forall A B C D,
	BetS A B C ->
	BetS A C D ->
	BetS B C D.
Proof.
	intros A B C D.
	intros BetS_A_B_C.
	intros BetS_A_C_D.
	apply (axiom_betweennesssymmetry) in BetS_A_B_C as BetS_C_B_A.
	apply (axiom_betweennesssymmetry) in BetS_A_C_D as BetS_D_C_A.
	pose proof (axiom_orderofpoints_ABD_BCD_ABC D C B A BetS_D_C_A BetS_C_B_A) as BetS_D_C_B.
	apply (axiom_betweennesssymmetry) in BetS_D_C_B as BetS_B_C_D.
	exact BetS_B_C_D.
Qed.

End Euclid.


From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(* Additional lemmas about counting. *)
Section Counting.

  Lemma count_filter_fun :
    forall (T: eqType) (l: seq T) P,
      count P l = size (filter P l).
  Proof.
    intros T l P.
    induction l; simpl; first by done.
    by destruct (P a); [by rewrite add1n /=; f_equal | by rewrite add0n].
  Qed.

End Counting.


Require Import Coq.Relations.Relations.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.

Module Type SemigroupSig.
  Parameters (Carrier: Type)(Req: relation Carrier).
  Context `{Requiv: Equivalence Carrier Req}.
  Parameters (op: Carrier -> Carrier -> Carrier).
  Parameters (op_proper: Proper (Req ==> Req ==> Req) op).

  Infix "~" := Req (at level 60, no associativity).
  Infix "<*>" := op (at level 40, left associativity).

  Axiom associativity:
    forall (a b c: Carrier),
      a <*> b <*> c ~ a <*> (b <*> c).
End SemigroupSig.

Module SemigroupTheory (Import SS: SemigroupSig).
  Context `{Requiv: Equivalence Carrier Req}.
  Theorem op_l:
    forall (a b: Carrier),
      a ~ b ->
      forall (c: Carrier), c <*> a ~ c <*> b.
  Proof.
    intros a b Hab c.
    apply op_proper;
      [reflexivity | assumption].
  Qed.

  Theorem op_r:
    forall (a b: Carrier),
      a ~ b ->
      forall (c: Carrier), a <*> c ~ b <*> c.
  Proof.
    intros a b Hab c.
    apply op_proper;
      [assumption | reflexivity].
  Qed.
End SemigroupTheory.


Require Import Coq.Lists.List.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.Bool.Bool.

Open Scope list_scope.

Import ListNotations.

Inductive QSAcc : list nat -> Type :=
    | qsAcc_nil  : QSAcc nil
    | qsAcc_cons : forall (x : nat) (xs : list nat),
                    QSAcc (filter (fun y => ltb y x) xs) ->
                    QSAcc (filter (fun y => negb (ltb y x)) xs) ->
                    QSAcc (x :: xs).

Fixpoint quicksort (l : list nat)  (qs_acc : QSAcc l) : list nat :=
    match qs_acc with
    | qsAcc_nil => nil
    | (qsAcc_cons p ps lesser greater) =>
            quicksort (filter (fun y => ltb y p) ps) lesser
            ++ p :: nil
            ++ quicksort (filter (fun y => negb (ltb y p)) ps) greater
    end.

(* Example list and usage of quicksort with Bove-Capretta predicate *)
Definition list := 5::3::1::4::nil.

Theorem exTerm: QSAcc list.
Proof.
    apply qsAcc_cons.
    apply qsAcc_cons.
    apply qsAcc_cons.
    simpl. apply qsAcc_nil.
    simpl. apply qsAcc_nil.

    apply qsAcc_cons; simpl; apply qsAcc_nil.
    simpl. apply qsAcc_nil.
Qed.

Eval simpl in filter (fun y => ltb y 5) list.

Definition res := quicksort list exTerm.

Eval simpl in res.s


Theorem id: forall A : Prop, A -> A.
Proof.
intros.
apply H.
Qed.

Theorem const : forall A B : Prop, A -> B -> A.
Proof.
intros.
apply H.
Qed.

Theorem s_comb : forall A B C : Prop, (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
intros.
apply H.
apply H1.
apply H0.
apply H1.
Qed.

Theorem b_comb1 : forall A B C : Prop, (A -> B) -> (B -> C) -> A -> C.
Proof.
intros.
apply H0.
apply H.
apply H1.
Qed.

Theorem b_comb2 : forall A B C : Prop, (B -> C) -> (A -> B) -> A -> C.
Proof.
intros.
apply H.
apply H0.
apply H1.
Qed.

Theorem split : forall A B C : Prop, (A -> B -> C) -> (B -> A -> C).
Proof.
intros.
apply H.
apply H1.
apply H0.
Qed.

Theorem pair_intro : forall A B : Prop, (A -> (B -> (A /\ B))).
Proof.
intros.
split.
apply H.
apply H0.
Qed.

Theorem fst : forall A B : Prop, (A /\ B) -> A.
Proof.
intros.
apply H.
Qed.

Theorem snd : forall A B : Prop, (A /\ B) -> B.
Proof.
intros.
apply H.
Qed.

Theorem curry : forall A B C : Prop, (A /\ B) -> C -> (A -> (B -> C)).
Proof.
intros.
apply H0.
Qed.

Theorem uncurry : forall A B C : Prop, (A -> (B -> C)) -> ((A /\ B) -> C).
Proof.
intros.
apply H.
apply H0.
apply H0.
Qed.

Theorem uniProd : forall A B C : Prop, (A -> B) -> (A -> C) -> A -> (B /\ C).
Proof.
intros.
split.
apply H.
apply H1.
apply H0.
apply H1.
Qed.

Theorem prod2 : forall A B C D : Prop, (A -> B) -> (D -> C) -> (A /\ D) -> (B /\ C).
Proof.
intros.
split.
apply H.
apply H1.
apply H0.
apply H1.
Qed.

Theorem trans2 : forall A B C : Prop, (A -> B) /\ (B -> C) -> A -> C.
Proof.
intros.
apply H.
apply H.
apply H0.
Qed.

Theorem con_com : forall A B : Prop, (A /\ B) -> (B /\ A).
Proof.
intros.
split.
apply H.
apply H.
Qed.

Theorem con_assoc : forall A B C: Prop, (A /\ B) /\ C -> A /\ (B /\ C).
Proof.
intros.
split.
apply H.
split.
apply H.
apply H.
Qed.

Theorem con_assoc1 : forall A B C : Prop, A /\ (B /\ C) -> (A /\ B) /\ C.
Proof.
intros.
split.
split.
apply H.
apply H.
apply H.
Qed.

Theorem con_assoc2 : forall A B C : Prop, A /\ (B /\ C) <-> (A /\ B) /\ C.
Proof.
intros.
split.
apply con_assoc1.
apply con_assoc.
Qed.

Theorem disj_intro_left : forall A B : Prop, A -> A \/ B.
Proof.
intros.
left.
apply H.
Qed.

Theorem disj_intro_right : forall A B : Prop, B -> A \/ B.
Proof.
intros.
right.
apply H.
Qed.

Theorem disj_elim : forall A B C : Prop, (A -> C) -> (B -> C) -> A \/ B -> C.
Proof.
intros.
destruct H1.
apply H.
apply H1.
apply H0.
apply H1.
Qed.

Theorem disj_assoc : forall A B C : Prop, (A \/ B) \/ C -> A \/ (B \/ C).
Proof.
intros.
tauto.
Qed.

Theorem disj_assoc1 : forall A B C : Prop, A \/ (B \/ C) -> (A \/ B) \/ C.
Proof.
intros.
tauto.
Qed.

Theorem disj_assoc2 : forall A B C : Prop, (A \/ B) \/ C <-> A \/ (B \/ C).
Proof.
intros.
split.
apply disj_assoc.
apply disj_assoc1.
Qed.


(* Definitions and theory of natural numbers that is useful in cryptographi proofs. *)

Set Implicit Arguments.

Require Export Arith.
Require Export Omega.
Require Export Arith.Div2.
Require Export Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.NArith.BinNat.

Lemma mult_same_r : forall n1 n2 n3,
  n3 > 0 ->
  n1 * n3 = n2 * n3 ->
  n1 = n2.

  induction n1; destruct n2; intuition; simpl in *.
  remember (n2 * n3) as x.
  omega.
  remember (n1 * n3) as x.
  omega.

  f_equal.
  eapply IHn1; eauto.

  eapply plus_reg_l. eauto.
Qed.

Lemma mult_same_l : forall n3 n1 n2,
  n3 > 0 ->
  n3 * n1 = n3 * n2 ->
  n1 = n2.

  intuition.
  eapply mult_same_r; eauto.
  rewrite mult_comm.
  rewrite (mult_comm n2 n3).
  trivial.
Qed.

Lemma mult_gt_0 : forall n1 n2,
  n1 > 0 ->
  n2 > 0 ->
  n1 * n2 > 0.
  destruct n1; intuition; simpl in *.
  remember (n1 * n2) as x.
  omega.
Qed.

Lemma minus_eq_compat : forall n1 n2 n3 n4,
  n1 = n2 ->
  n3 = n4 ->
  n1 - n3 = n2 - n4.

  intuition.
Qed.

Lemma plus_eq_compat : forall n1 n2 n3 n4,
  n1 = n2 ->
  n3 = n4 ->
  n1 + n3 = n2 + n4.

  intuition.
Qed.

Lemma minus_diag_eq : forall n1 n2,
  n1 = n2 ->
  n1 - n2 = 0.

  intuition.
Qed.

Lemma le_eq : forall n1 n2,
  n1 = n2 ->
  n1 <= n2.

  intuition.
Qed.

Lemma minus_add_assoc : forall n1 n2 n3,
  (n3 <= n2)%nat ->
  (n1 + (n2 - n3) = n1 + n2 - n3)%nat.

  intuition.
Qed.

Class nz (a : nat) := {
  agz : a > 0
}.

Instance nz_nat : forall (n : nat), nz (S n).
intuition.
econstructor.
omega.
Defined.

Definition posnat := {n : nat | n > 0}.

Definition posnatToNat(p : posnat) :=
  match p with
    | exist n _ => n
  end.

Inductive posnatEq : posnat -> posnat -> Prop :=
  | posnatEq_intro :
    forall (n1 n2 : nat) pf1 pf2,
      n1 = n2 ->
      posnatEq (exist _ n1 pf1) (exist _ n2 pf2).

Definition posnatMult(p1 p2 : posnat) : posnat :=
    match (p1, p2) with
      | (exist n1 pf1, exist n2 pf2) =>
        (exist (fun n => n > 0) (n1 * n2) (mult_gt_0 pf1 pf2))
    end.

Lemma posnatMult_comm : forall p1 p2,
  (posnatEq (posnatMult p1 p2) (posnatMult p2 p1)).

  intuition.
  unfold posnatMult.
  destruct p1; destruct p2.
  econstructor.
  apply mult_comm.
Qed.

Coercion posnatToNat : posnat >-> nat.

Lemma posnat_pos : forall (p : posnat),
  p > 0.

  intuition.
  destruct p.
  unfold posnatToNat.
  trivial.
Qed.

Instance nz_posnat : forall (p : posnat),
  nz p.

intuition.
econstructor.
eapply posnat_pos.

Qed.

Definition natToPosnat(n : nat)(pf : nz n) :=
  (exist (fun x => x > 0) n agz).

Notation "'pos' x" := (@natToPosnat x _) (at level 40).

Fixpoint expnat n1 n2 :=
  match n2 with
    | 0 => 1
    | S n2' =>
      n1 * (expnat n1 n2')
  end.

Theorem expnat_pos : forall x n,
  x > 0 ->
  expnat x n > 0.

  induction n; intuition; simpl in *.
  remember (x * expnat x n) as y.
  assert (y <> 0); try omega.
  intuition; subst.
  apply mult_is_O in H1.
  destruct H1; omega.

Qed.

Lemma div2_le : forall n,
  le (div2 n) n.

  intuition.
  eapply NPeano.div2_decr.
  omega.

Qed.

Lemma div2_ge_double : forall n,
  n >= (div2 n) + (div2 n).

  intuition.
  destruct (Even.even_odd_dec n).

  rewrite (even_double n) at 1.
  unfold double.
  omega.
  trivial.
  rewrite (odd_double n) at 1.
  unfold double.
  omega.
  trivial.
Qed.

Local Open Scope N_scope.
Definition modNat (n : nat)(p : posnat) : nat :=
  N.to_nat ((N.of_nat n) mod (N.of_nat p)).

Lemma modNat_plus : forall n1 n2 p,
    (modNat (n1 + n2) p = modNat ((modNat n1 p) + n2) p)%nat.

  unfold modNat.

  intuition.
  rewrite Nnat.Nat2N.inj_add.

  rewrite <- N.add_mod_idemp_l.
  f_equal.
  rewrite <- (Nnat.Nat2N.id n2) at 2.
  rewrite Nnat.Nat2N.inj_add.
  repeat rewrite Nnat.N2Nat.id.
  trivial.

  destruct p.
  simpl.

  destruct x;
  simpl.
  omega.

  Lemma Npos_nz : forall p,
    Npos p <> N0.

    destruct p; intuition; simpl in *.
    inversion H.
    inversion H.
    inversion H.
  Qed.

  apply Npos_nz.

Qed.

Lemma modNat_arg_eq : forall (p : posnat),
  modNat p p = O.

  intuition.
  unfold modNat.
  rewrite N.mod_same.
  trivial.
  unfold N.of_nat, posnatToNat.
  destruct p.
  destruct x.
  omega.
  apply Npos_nz.

Qed.

Lemma of_nat_ge_0 : forall n,
  0 <= N.of_nat n.

  intuition.
  unfold N.of_nat.
  destruct n.
  intuition.

  simpl.
  unfold N.le.
  case_eq ((0 ?= N.pos (Pos.of_succ_nat n))); intuition;
    try discriminate.
Qed.

Lemma of_posnat_gt_0 : forall (p : posnat),
  0 < N.of_nat p.

  intuition.
  unfold N.of_nat, posnatToNat.
  destruct p.
  destruct x.
  omega.
  destruct x; intuition; simpl in *.

  case_eq (N.compare 0 1)%N; intuition.
  inversion H.
  inversion H.

  case_eq (N.compare 0 (N.pos (Pos.succ (Pos.of_succ_nat x))))%N; intuition.
  inversion H.
  inversion H.
Qed.

Lemma modNat_lt : forall x p, (modNat x p < p)%nat.

  intuition.
  unfold modNat.
  assert (N.of_nat x mod N.of_nat p < N.of_nat p)%N.
  apply N.mod_bound_pos.
  apply of_nat_ge_0.
  apply of_posnat_gt_0.

  specialize (Nnat.N2Nat.inj_compare); intuition.
  rewrite <- (Nnat.Nat2N.id p) at 2.
  apply nat_compare_lt.
  rewrite <- H0.
  apply N.compare_lt_iff.
  trivial.

Qed.

Lemma modNat_eq : forall (n : posnat) x, (x < n -> modNat x n = x)%nat.

  intuition.
  unfold modNat.
  rewrite N.mod_small.
  apply Nnat.Nat2N.id.
  specialize (Nnat.N2Nat.inj_compare); intuition.
  specialize (N.compare_lt_iff (N.of_nat x) (N.of_nat n)); intuition.
  apply H2.
  rewrite H0.
  repeat rewrite Nnat.Nat2N.id.
  apply nat_compare_lt.
  trivial.
Qed.

Definition modNatAddInverse (n : nat)(p : posnat) :=
  (p - (modNat n p))%nat.

Lemma modNatAddInverse_correct_gen : forall x y p,
  modNat x p = modNat y p ->
  modNat (x + modNatAddInverse y p) p = O.

  intuition.
  unfold modNatAddInverse.
  rewrite <- H.
  rewrite modNat_plus.
  rewrite minus_add_assoc.
  rewrite (plus_comm).
  rewrite <- minus_add_assoc.
  rewrite minus_diag.
  rewrite plus_0_r.
  apply modNat_arg_eq.

  trivial.

  assert (modNat x p < p)%nat.
  apply modNat_lt.
  omega.

Qed.

Lemma modNatAddInverse_correct : forall n p,
    modNat (n + modNatAddInverse n p) p = O.

  intuition.
  eapply modNatAddInverse_correct_gen.
  trivial.

Qed.

Lemma modNat_correct : forall x (p : posnat),
  exists k, (x = k * p + modNat x p)%nat.

  intuition.
  unfold modNat in *.
  assert (p > 0)%nat.
  eapply posnat_pos.
  assert (posnatToNat p <> 0)%nat.
  omega.
  assert (N.of_nat p <> 0%N).
  intuition.
  eapply H0.

  rewrite <- Nnat.Nat2N.id.
  rewrite <- (Nnat.Nat2N.id p).
  f_equal.
  trivial.

  exists (N.to_nat (N.of_nat x / N.of_nat p)).
  rewrite N.mod_eq; trivial.

  rewrite <- (Nnat.Nat2N.id p) at 2.
  rewrite <- Nnat.N2Nat.inj_mul.
  rewrite <- Nnat.N2Nat.inj_add.
  rewrite N.mul_comm.
  remember (N.of_nat p * (N.of_nat x / N.of_nat p)) as z.
  rewrite N.add_sub_assoc.
  rewrite N.add_comm.
  rewrite N.add_sub.
  rewrite Nnat.Nat2N.id.
  trivial.

  subst.
  eapply N.mul_div_le.
  trivial.
Qed.

Lemma modNat_divides : forall x p,
  modNat x p = O ->
  exists k, (x = k * p)%nat.

  intuition.
  destruct (modNat_correct x p).
  rewrite H in H0.
  econstructor.
  rewrite plus_0_r in H0.
  eauto.
Qed.

Local Open Scope nat_scope.
Lemma modNatAddInverse_sum_0 : forall x y p,
  modNat (x + (modNatAddInverse y p)) p = O ->
  modNat x p = modNat y p.

  intuition.

  assert (modNat x p < p).
  eapply modNat_lt.
  assert (modNat y p < p).
  eapply modNat_lt.

  rewrite modNat_plus in H.
  unfold modNatAddInverse in *.
  rewrite minus_add_assoc in H; intuition.
  rewrite plus_comm in H.

  apply modNat_divides in H.
  destruct H.

  remember (modNat x p) as a.
  remember (modNat y p) as b.
  assert (p + a >= p).
  omega.
  assert (p + a < 2 * p)%nat.
  omega.
  assert (p + a - b < 2 * p).
  omega.
  assert (p + a - b > 0).
  omega.

  assert (x0 * p > 0).
  omega.
  assert (x0 * p < 2 * p).
  omega.

  destruct x0.
  omega.
  destruct x0.

  simpl in H.
  rewrite plus_0_r in H.
  omega.

  assert (p > 0).
  eapply posnat_pos.
  simpl in H7.
  remember (x0 * p)%nat as c.
  omega.
Qed.

Lemma modNat_correct_if : forall x y z (p : posnat),
  x * p + y = z ->
  modNat z p = modNat y p.

  induction x; intuition; simpl in *.
  subst.
  trivial.

  assert (x * p + (y + p) = z).
  omega.
  apply IHx in H0.

  rewrite H0.
  rewrite plus_comm.
  rewrite modNat_plus.
  rewrite modNat_arg_eq.
  rewrite plus_0_l.
  trivial.
Qed.

Lemma modNat_mult : forall x (p : posnat),
  modNat (x * p) p = 0.

  induction x; intuition; simpl in *.
  rewrite modNat_plus.
  rewrite modNat_arg_eq.
  rewrite plus_0_l.
  eauto.

Qed.

Lemma modNat_add_same_l : forall x y z p,
  modNat (x + y) p = modNat (x + z) p ->
  modNat y p = modNat z p.

  induction x; intuition; simpl in *.
  assert (S (x + y) = x + S y).
  omega.
  rewrite H0 in H.
  clear H0.
  assert (S (x + z) = x + S z).
  omega.
  rewrite H0 in H.
  clear H0.
  apply IHx in H.

  destruct (modNat_correct (S y) p).
  destruct (modNat_correct (S z) p).
  rewrite H in H0.

  assert (S y - x0 * p = modNat (S z) p).
  omega.
  assert (S z - x1 * p = modNat (S z) p).
  omega.
  rewrite <- H2 in H3.

  assert (z - x1 * p = y - x0 * p).
  omega.

  assert (x1 * p + y = x0 * p + z).
  omega.

  apply modNat_correct_if in H5.
  rewrite modNat_plus in H5.

  rewrite modNat_mult in H5.
  rewrite plus_0_l in H5.
  auto.

Qed.

Lemma modNat_add_same_r : forall x y z p,
  modNat (y + x) p = modNat (z + x) p ->
  modNat y p = modNat z p.

  intuition.
  eapply (modNat_add_same_l x y z).
  rewrite plus_comm.
  rewrite H.
  rewrite plus_comm.
  trivial.
Qed.

Lemma expnat_base_S : forall n k,
  ((expnat k n) + n * (expnat k (pred n)) <= expnat (S k) n)%nat.

  induction n; intuition.
  simpl in *.
  eapply le_trans.
  Focus 2.
  eapply plus_le_compat.
  eapply IHn.
  eapply mult_le_compat.
  eapply le_refl.
  eapply IHn.

  rewrite mult_plus_distr_l.
  repeat rewrite mult_assoc.
  repeat rewrite plus_assoc.
  eapply plus_le_compat.
  rewrite plus_comm.
  eapply plus_le_compat.
  rewrite <- (plus_0_r (expnat k n)) at 1.
  eapply plus_le_compat.
  omega.
  intuition.
  intuition.

  rewrite (mult_comm k n).
  rewrite <- (mult_assoc n).
  destruct n; simpl; intuition.
Qed.

Lemma expnat_base_S_same : forall n,
  n > 0 ->
  (2 * (expnat n n) <= expnat (S n) n)%nat.

  intuition.
  simpl in *.
  rewrite plus_0_r.
  eapply le_trans.
  Focus 2.
  eapply expnat_base_S.
  destruct n; simpl.
  omega.
  intuition.
Qed.

Lemma sqrt_le_lin_gen : forall a b,
  (a <= b ->
    sqrt a <= b)%nat.

  intuition.
  eapply le_trans.
  eapply Nat.sqrt_le_lin.
  trivial.
Qed.

Lemma div2_le_mono : forall n1 n2,
  (n1 <= n2 ->
    div2 n1 <= div2 n2)%nat.

  induction n1; intuition.
  destruct n2.
  omega.
  destruct (Even.even_odd_dec n1).
  destruct (Even.even_odd_dec n2).
  repeat rewrite <- even_div2; trivial.
  eapply IHn1.
  omega.

  rewrite <- even_div2; trivial.
  rewrite <- odd_div2; trivial.
  econstructor.
  eapply IHn1.
  omega.

  destruct (Even.even_odd_dec n2).
  destruct (lt_dec n1 n2).
  assert (n1 <= (S n2))%nat.
  omega.
  destruct n2.
  omega.
  rewrite <- odd_div2; trivial.
  rewrite <- even_div2.
  rewrite <- odd_div2.
  eapply le_n_S.
  eapply IHn1.
  omega.
  inversion e.
  trivial.
  trivial.
  assert (n1 = n2).
  omega.
  subst.
  exfalso.
  eapply Even.not_even_and_odd; eauto.

  rewrite <- odd_div2; trivial.
  rewrite <- odd_div2; trivial.
  eapply le_n_S.
  eapply IHn1.
  omega.

Qed.

Lemma div2_ge : forall n n',
  n >= n' ->
  forall x,
    (n' = 2 * x)%nat ->
    div2 n >= x.

  induction 1; intuition; subst; simpl in *.
  specialize (div2_double x); intuition; simpl in *.
  rewrite H.
  omega.

  destruct m.
  omega.
  destruct (Even.even_odd_dec m).
  rewrite even_div2.
  assert (div2 (S m) >= x).
  eapply IHle.
  trivial.
  omega.
  trivial.

  rewrite odd_div2.

  eapply IHle.
  trivial.
  trivial.
Qed.

Instance expnat_nz : forall k n (p : nz n),
  nz (expnat n k).

intuition.

induction k; intuition; simpl in *.
econstructor.
omega.
econstructor.
edestruct IHk; eauto.
destruct p.
eapply mult_gt_0; intuition.

Qed.

Lemma expnat_2_ge_1 : forall n,
  (1 <= expnat 2 n)%nat.

  induction n; intuition; simpl in *.
  omega.
Qed.

Lemma le_expnat_2 : forall n,
  (n <= expnat 2 n)%nat.

  induction n; intuition; simpl in *.
  rewrite plus_0_r.
  assert (S n = 1 + n)%nat.
  omega.
  rewrite H.
  eapply plus_le_compat.
  eapply expnat_2_ge_1.
  trivial.

Qed.

Lemma expnat_1 : forall k,
  expnat 1%nat k = 1%nat.

  induction k; intuition; simpl in *.
  rewrite plus_0_r.
  trivial.

Qed.

Theorem expnat_base_le :
  forall k n1 n2,
    n1 <= n2 ->
    expnat n1 k <=
    expnat n2 k.

  induction k; intuition; simpl in *.
  eapply mult_le_compat; intuition.

Qed.

Theorem expnat_double_le :
  forall k n,
    n >= 2 ->
    expnat n (S k) >= 2 * expnat n k.

  induction k; intuition; simpl in *.
  omega.
  rewrite plus_0_r.
  rewrite <- mult_plus_distr_l.
  eapply mult_le_compat.
  trivial.
  rewrite <- plus_0_r at 1.
  rewrite <- plus_assoc.
  eapply IHk.
  trivial.
Qed.

Theorem nat_half_plus :
  forall x,
    x > 1 ->
    exists a b,
      a > 0 /\ b <= 1 /\ x = 2 * a + b.

  induction x; intuition; simpl in *.
  omega.

  destruct (eq_nat_dec x 1); subst.
  exists 1.
  exists 0.
  intuition; omega.

  edestruct (IHx).
  omega.
  destruct H0.
  intuition.
  destruct x1.
  rewrite plus_0_r in H3.
  exists x0.
  exists 1.
  subst.
  intuition; omega.

  exists (S x0).
  exists 0.
  subst.
  intuition.

Qed.

Theorem log2_div2 :
  forall x y,
    S y = log2 x ->
    log2 (div2 x) = y.

  intuition.
  specialize (Nat.log2_double); intuition.

  destruct (@nat_half_plus x).
  eapply Nat.log2_lt_cancel.
  rewrite Nat.log2_1.
  omega.
  destruct H1.
  intuition.
  subst.
  destruct x1.
  rewrite plus_0_r in *.
  rewrite div2_double.
  rewrite H0 in H.
  omega.
  omega.

  destruct x1.

  rewrite plus_comm.
  rewrite div2_double_plus_one.

  rewrite Nat.log2_succ_double in H.
  omega.
  omega.

  omega.

Qed.

Lemma log2_0 :
  log2 0 = 0.
  trivial.
Qed.

Theorem expnat_0 :
  forall k,
    k > 0 ->
    expnat 0 k = 0.

  induction k; intuition; simpl in *.

Qed.

Theorem expnat_plus :
  forall k1 k2 n,
    expnat n (k1 + k2) = expnat n k1 * expnat n k2.

  induction k1; simpl in *; intuition.
  rewrite IHk1.
  rewrite mult_assoc.
  trivial.

Qed.

Theorem expnat_ge_1 :
  forall k n,
    n > 0 ->
    1 <= expnat n k.

  induction k; intuition; simpl in *.
  rewrite <- mult_1_r at 1.
  eapply mult_le_compat.
  omega.
  eauto.
Qed.

Theorem expnat_exp_le :
  forall n2 n4 n,
    (n2 > 0 \/ n > 0) ->
    n2 <= n4 ->
    expnat n n2 <= expnat n n4.

  induction n2; destruct n4; simpl in *; intuition.
  rewrite <- mult_1_l at 1.
  eapply mult_le_compat.
  omega.
  eapply expnat_ge_1; trivial.

  destruct (eq_nat_dec n 0); subst.
  simpl; intuition.
  eapply mult_le_compat; intuition.

Qed.

Lemma mult_lt_compat :
  forall a b c d,
    a < b ->
    c < d ->
    a * c < b * d.

  intuition.
  eapply le_lt_trans.
  eapply mult_le_compat.
  assert (a <= b).
  omega.
  eapply H1.
  eapply le_refl.
  eapply mult_lt_compat_l.
  trivial.
  omega.
Qed.

Theorem orb_same_eq_if :
  forall a b c,
    (a = false -> b = c) ->
    orb a b = orb a c.

  intuition.
  destruct a; trivial; intuition.

Qed.


Add LoadPath "megacz-coq-categories/build".

Require Import Coq.Classes.RelationClasses.
Require Import Coq.Unicode.Utf8.

Require Import Categories_ch1_3.

Definition Rel : Type -> Type -> Type
  := fun a b : Type => a -> b -> Prop.

Definition rel_id : ∀ a : Type, Rel a a
  := (fun a : Type => @eq a).

Definition rel_comp : ∀ a b c : Type, Rel a b -> Rel b c -> Rel a c
  := fun a b c r1 r2 x y => exists z, r1 x z /\ r2 z y.

Definition rel_eqv : ∀ a b : Type, Rel a b -> Rel a b -> Prop
  := fun a b r1 r2 => ∀ x y, r1 x y <-> r2 x y.

Theorem relation_category : Category Type Rel.
Proof.
  apply (@Build_Category Type Rel rel_id rel_comp rel_eqv).
  intros.
  apply Build_Equivalence.
  intro.
  unfold rel_eqv.
  intros.
  reflexivity.

  intro.
  unfold rel_eqv.
  intros.
  symmetry.
  auto.

  intro.
  unfold rel_eqv.
  intros.
  transitivity (y x0 y0).
  auto.
  auto.

  intros.
  constructor.
  unfold rel_comp.

  intros [z [??]].
  exists z.
  rewrite <- (H x1 z).
  rewrite <- (H0 z y1).
  auto.

  unfold rel_comp.
  intros [z [??]].
  exists z.
  rewrite (H x1 z).
  rewrite (H0 z y1).
  auto.

  unfold rel_id.
  unfold rel_comp.
  unfold rel_eqv.
  intros.
  split.
  intros.
  destruct H.
  destruct H.
  rewrite H.
  auto.

  intros.
  exists x.
  auto.

  intros.
  unfold rel_id.
  unfold rel_comp.
  unfold rel_eqv.
  intros.
  split.
  intro.
  destruct H.
  destruct H.
  rewrite <- H0.
  auto.

  intro.
  exists y.
  auto.

  intros.
  unfold rel_comp.
  unfold rel_eqv.
  intros.
  split.
  intro.
  destruct H.
  destruct H.
  destruct H.
  destruct H.
  exists x1.
  split.
  auto.

  exists x0.
  auto.

  intro.
  destruct H.
  destruct H.
  destruct H0.
  destruct H0.
  exists x1.
  split.
  exists x0.
  auto.
  auto.
Defined.

(*
Definition rel_comp : forall a b c : Type, Rel a b -> Rel b c -> Rel a c.
Proof.
  intros.
  intro.
  intro.
  refine (exists b' : b, _ /\ _).
  exact (X X1 b').
  exact (X0 b' X2).
Defined.
*)


Structure BooleanAlgebra := {
 carrier :> Set; (* Coercion *)
 and : carrier -> carrier-> carrier;
 or : carrier -> carrier -> carrier;
 neg : carrier -> carrier;
 zero : carrier;
 one : carrier;
 and_p_0 : forall p, and p zero = zero;
 and_p_1 : forall p, and p one = p;
 and_p_Np : forall p, and p (neg p) = zero;
 and_p_p : forall p, and p p = p;
 neg_0 : neg zero = one;
 neg_neg : forall p, neg (neg p) = p;
 or_p_1 : forall p, or p one = one;
 or_p_0 : forall p, or p zero = p;
 or_p_Np : forall p, or p (neg p) = one;
 or_p_p : forall p, or p p = p;
 neg_or : forall p q, neg (or p q) = and (neg p) (neg q);
 neg_and : forall p q, neg (and p q) = or (neg p) (neg q);
 and_or : forall p q r, and p (or q r) = or (and p q) (and p r);
 or_and : forall p q r, or p (and q r) = and (or p q) (or p r);
 and_p_qr : forall p q r, and p (and q r) = and (and p q) r;
 or_p_qr : forall p q r, or p (or q r) = or (or p q) r;
 and_pq : forall p q, and p q = and q p;
 or_pq : forall p q, or p q = or q p
}.

Notation "p & q" := (and _ p q) (at level 40, left associativity).
Notation "p | q" := (or _ p q) (at level 50, left associativity).
Notation "! p" := (neg _ p) (at level 20).
Notation "1" := (one _).
Notation "0" := (zero _).

Structure Hom (A B : BooleanAlgebra) := {
  action :> A -> B;
  mor_and: forall x y, action (x & y) = action x & action y;
  mor_or: forall x y, action (x | y) = action x | action y;
  mor_neg: forall x, action (! x) = !(action x)
}.

Lemma id (B : BooleanAlgebra) : Hom B B.
Proof.
  refine {| action := fun x => x |} ; reflexivity.
Defined.

Definition compose A B C :
  Hom B C -> Hom A B -> Hom A C.
Proof.
  intros g f.
  refine {| action := fun x => g (f x) |}.
  -intros.
  rewrite->mor_and.
  rewrite->mor_and.
  reflexivity.
  -intros. rewrite->mor_or. rewrite->mor_or. reflexivity.
  -intros. rewrite->mor_neg. rewrite ->mor_neg. reflexivity.
Defined.

Notation "g 'o' f" := (compose _ _ _ g f) (at level 65, left associativity).

Lemma Hom_0 (A B : BooleanAlgebra) (f : Hom A B) :
  f 0 = 0.
Proof.
  rewrite <- (and_p_Np A 0).
  rewrite mor_and.
  rewrite mor_neg.
  rewrite and_p_Np.
  reflexivity.
Qed.

Lemma Hom_1 (A B : BooleanAlgebra) (f: Hom A B):
 f 1 = 1.
Proof.
Admitted.

Lemma id_comp(A B : BooleanAlgebra)(f : Hom A B) : (id B) o f = f.
Admitted.

Lemma assos_o (A B C D : BooleanAlgebra)(f : Hom A B) (g : Hom B C) (h : Hom C D): h o (g o f) = (h o g) o f.
Admitted.

Lemma and_pq_r (B : BooleanAlgebra) (p q r : B) :
  (p | q) & r = p & r | q & r.
Proof.
 rewrite <-and_pq.
 rewrite->and_or.
 rewrite->and_pq.
 rewrite->or_pq.
 rewrite->and_pq.
 rewrite->or_pq.
 reflexivity.
Qed.

Lemma neg_1 (L : BooleanAlgebra) : ! 1 = (0 : L).
Proof.
  rewrite <- neg_0.
  rewrite -> neg_neg.
  reflexivity.
Qed.

Definition Two : BooleanAlgebra.
Proof.
  (* We use bool and its operations from the standard library *)
  refine {| carrier := bool ;
            and := andb ;
            or := orb ;
            neg := negb ;
            zero := false ;
            one := true
         |} ; repeat (intros [|]) ; reflexivity.
Defined.

Definition pointwise0 {B : Set} (c : B) (I : Set) :
  (I -> B) :=
  fun i => c.

Definition pointwise1 {B : Set} (op : B -> B) (I : Set) :
  (I -> B) -> (I -> B) :=
  fun f i => op (f i).

Definition pointwise2 {B : Set} (op : B -> B -> B) (I : Set) :
  (I -> B) -> (I -> B) -> (I -> B) :=
  fun f g i => op (f i) (g i).

(* Function extensionality. *)
Axiom funext :
  forall (X : Type) (P : X -> Type) (f g : (forall x, P x)),
    (forall x, f x = g x) -> f = g.

(* Function extensionality for simple types. *)
Lemma funext_simple (X Y : Type) (f g : X -> Y) :
  (forall x, f x = g x) -> f = g.
Proof.
  apply (funext X (fun x => Y)).
Defined.

Definition Power (B : BooleanAlgebra) (I : Set) : BooleanAlgebra.
Proof.
  refine {| carrier := I -> B ;
            and := pointwise2 (and B) I ;
            or := pointwise2 (or B) I ;
            neg := pointwise1 (neg B) I ;
            zero := pointwise0 (zero B) I ;
            one := pointwise0 (one B) I
         |} ;
  (intros ; apply funext_simple ; intro i ; unfold pointwise0, pointwise1, pointwise2).
  - apply and_p_0.
  - apply and_p_1.
  - apply and_p_Np.
  - apply and_p_p.
  - apply neg_0.
  - apply neg_neg.
  - apply or_p_1.
  - apply or_p_0.
  - apply or_p_Np.
  - apply or_p_p.
  - apply neg_or.
  - apply neg_and.
  - apply and_or.
  - apply or_and.
  - apply and_p_qr.
  - apply or_p_qr.
  - apply and_pq.
  - apply or_pq.
Defined.

Inductive Colors := Red | Green | Blue.

(* Boolean algebra with eight elements. *)
Definition EightBA := Power Two Colors.

(* The opposite algebra. *)
Definition Opposite (B : BooleanAlgebra) : BooleanAlgebra.
Proof.
  refine {| carrier := carrier B ;
            and := or B ;
            or := and B ;
            neg := neg B ;
            one := zero B ;
            zero := one B
         |}.
intros.
-apply or_p_1.
-apply or_p_0.
-apply or_p_Np.
-apply or_p_p.
-apply neg_1.
-apply neg_neg.
-apply and_p_0.
-apply and_p_1.
-apply and_p_Np.
-apply and_p_p.
-apply neg_and.
-apply neg_or.
-apply or_and.
-apply and_or.
-apply or_p_qr.
-apply and_p_qr.
-apply or_pq.
-apply and_pq.
Defined.


Require Import Coq.Arith.Arith.

Lemma l1: forall m n : nat,
  m * m = n * n -> m = n.
Proof.
  intros m n H. apply (f_equal Nat.sqrt) in H.
  rewrite Nat.sqrt_square in H. rewrite Nat.sqrt_square in H.
  apply H.
Qed.


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


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

(* ** Definition of FRACTRAN *)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac utils_list utils_nat gcd rel_iter pos vec.

Require Import Undecidability.FRACTRAN.FRACTRAN.

Set Default Proof Using "Type".

Set Implicit Arguments.

Section fractran_utils.

  Implicit Type l : list (nat*nat).

  Fact fractran_step_nil_inv x y : nil /F/ x → y <-> False.
  Proof. split; inversion 1. Qed.

  Fact fractran_step_cons_inv p q l x y :
     (p,q)::l /F/ x → y <-> q*y = p*x \/ ~ divides q (p*x) /\ l /F/ x → y.
  Proof.
    split.
    + inversion 1; auto.
    + intros [ H | (H1 & H2) ]; [ constructor 1 | constructor 2 ]; auto.
  Qed.

  Fact mul_pos_inj_l q x y : q <> 0 -> q*x = q*y -> x = y.
  Proof.
    intros H1 H2.
    destruct q; try lia.
    apply le_antisym; apply mult_S_le_reg_l with q; lia.
  Qed.

  Lemma fractran_step_inv P x y :
            P /F/ x → y
         -> exists l p q r, P = l++(p,q)::r
                         /\ (forall u v, In (u,v) l -> ~ divides v (u*x))
                         /\ q*y=p*x.
  Proof.
    induction 1 as [ p q P x y H | u v P x y H1 H2 IH2 ].
    + exists nil, p, q, P; simpl; tauto.
    + destruct IH2 as (l & p & q & r & -> & H4 & H5).
      exists ((u,v)::l), p, q, r; simpl; msplit 2; auto.
      intros ? ? [ H | H ]; auto; inversion H; subst; auto.
  Qed.

  (* Regular FRACTRAN programs define a deterministic step relation *)

  Lemma fractran_step_fun l x y1 y2 :
           fractran_regular l
        -> l /F/ x → y1
        -> l /F/ x → y2 -> y1 = y2.
  Proof.
    intros H1 H2 ; revert H2 H1 y2.
    induction 1 as [ p q l x y1 H1 | p q l x y1 H1 H2 IH2 ];
      intros H0 y2 H3; rewrite fractran_step_cons_inv in H3;
      destruct H3 as [ H3 | (H3 & H4) ].
    + apply Forall_cons_inv, proj1 in H0.
      simpl in H0.
      revert H1; rewrite <- H3.
      apply mul_pos_inj_l; auto.
    + destruct H3; exists y1; rewrite <- H1; ring.
    + destruct H1; exists y2; rewrite <- H3; ring.
    + apply Forall_cons_inv, proj2 in H0; auto.
  Qed.

  (* Regular FRACTRAN programs deefine a linearly bounded step relation
     The bound computed in the following proofs is very lazy.
     Indeed we choose p1+...+pn whereas ideally,
     one could choose max(ceil(pi/qi)) where l = [p1/q1;...;pn/qn] *)

  Lemma fractran_step_bound l :
          fractran_regular l
       -> { k | forall x y, l /F/ x → y -> y <= k*x }.
  Proof.
    unfold fractran_regular.
    induction l as [ | (p,q) l IHl ].
    + intros _; exists 1; auto.
      intros ? ? H; exfalso; revert H; apply fractran_step_nil_inv.
    + intros H; rewrite Forall_cons_inv in H; simpl in H.
      destruct H as (Hq & H).
      destruct (IHl H) as (k & H2).
      exists (p+k).
      intros x y Hxy.
      apply fractran_step_cons_inv in Hxy.
      destruct Hxy as [ Hxy | (_ & Hxy) ].
      * rewrite Nat.mul_add_distr_r, <- Hxy.
        destruct q; simpl; try lia.
      * apply le_trans with (1 := H2 _ _ Hxy).
        apply mult_le_compat; lia.
  Qed.

  Fact fractan_stop_nil_inv x : fractran_stop nil x <-> True.
  Proof.
    split; try tauto; intros _ z; rewrite fractran_step_nil_inv; tauto.
  Qed.

  Fact fractan_stop_cons_inv p q l x :
       fractran_stop ((p,q)::l) x <-> ~ divides q (p*x) /\ fractran_stop l x.
  Proof.
    split.
      * intros H.
        assert (~ divides q (p*x)) as H'.
        { intros (z & Hz); apply (H z); constructor; rewrite Hz; ring. }
        split; auto.
        intros z Hz; apply (H z); constructor 2; auto.
      * intros (H1 & H2) z Hz.
        apply fractran_step_cons_inv in Hz.
        destruct Hz as [ H3 | (H3 & H4) ].
        - apply H1; exists z; rewrite <- H3; ring.
        - apply (H2 _ H4).
  Qed.

  Fact fractran_step_dec l x : { y | l /F/ x → y } + { fractran_stop l x }.
  Proof.
    induction l as [ | (a,b) l IH ].
    + right; rewrite fractan_stop_nil_inv; auto.
    + destruct (divides_dec (a*x) b) as [ (y & Hy) | ].
      * left; exists y; constructor 1; rewrite Hy; ring.
      * destruct IH as [ (y & ?) | ].
        - left; exists y; now constructor 2.
        - right; apply fractan_stop_cons_inv; auto.
  Qed.

  (* Now we treat the cases where (_,0) occurs in l *)

  Let remove_zero_den l := filter (fun c => if eq_nat_dec (snd c) 0 then false else true) l.

  Let remove_zero_den_Forall l : fractran_regular (remove_zero_den l).
  Proof.
    unfold fractran_regular.
    induction l as [ | (p,q) ]; simpl; auto.
    destruct (eq_nat_dec q 0); auto.
  Qed.

  Section zero_cases.

    Fact fractran_zero_num_step l :
            Exists (fun c => fst c = 0) l
         -> forall x, exists y, l /F/ x → y.
    Proof.
      induction 1 as [ (p,q) l Hl | (p,q) l Hl IHl ]; simpl in Hl.
      + intros x; exists 0; subst; constructor; lia.
      + intros x.
        destruct (divides_dec (p*x) q) as [ (y & Hy) | C ].
        * exists y; constructor; rewrite Hy, mult_comm; auto.
        * destruct (IHl x) as (y & Hy); exists y; constructor 2; auto.
    Qed.

    Lemma FRACTRAN_HALTING_zero_num l x :
             Exists (fun c => fst c = 0) l
          -> FRACTRAN_HALTING (l,x) <-> False.
    Proof.
      intros H; split; try tauto.
      intros (y & _ & H3).
      destruct fractran_zero_num_step with (1 := H) (x := y) as (z & Hz).
      apply H3 with (1 := Hz).
    Qed.

    Fact fractran_step_head_not_zero p q l y : q <> 0 -> (p,q)::l /F/ 0 → y -> y = 0.
    Proof.
      intros H2 H3.
      apply fractran_step_cons_inv in H3.
      destruct H3 as [ H3 | (H3 & _) ].
      + rewrite Nat.mul_0_r in H3; apply mult_is_O in H3; lia.
      + destruct H3; exists 0; ring.
    Qed.

    Fact fractran_rt_head_not_zero p q l n y : q <> 0 -> fractran_steps ((p,q)::l) n 0 y -> y = 0.
    Proof.
      intros H2.
      induction n as [ | n IHn ].
      + simpl; auto.
      + intros (a & H3 & H4).
        apply fractran_step_head_not_zero in H3; subst; auto.
    Qed.

    Lemma FRACTRAN_HALTING_on_zero_first_no_zero_den p q l : q <> 0 -> FRACTRAN_HALTING ((p,q)::l,0) <-> False.
    Proof.
      intros Hq; split; try tauto.
      intros (y & (k & H1) & H2).
      apply fractran_rt_head_not_zero in H1; auto.
      subst y; apply (H2 0); constructor 1; ring.
    Qed.

    Fact fractran_step_no_zero_den l x y : fractran_regular l -> l /F/ x → y -> x = 0 -> y = 0.
    Proof.
      unfold fractran_regular.
      intros H1 H2; revert H2 H1.
      induction 1 as [ p q l x y H | p q l x y H1 H2 IH2 ]; rewrite Forall_cons_inv; simpl; intros (H3 & H4) ?; subst.
      + rewrite Nat.mul_0_r in H; apply mult_is_O in H; lia.
      + destruct H1; exists 0; ring.
    Qed.

    Fact fractran_step_no_zero_num l : Forall (fun c => fst c <> 0) l -> forall x y, l /F/ x → y -> y = 0 -> x = 0.
    Proof.
      intros H1 x y H2; revert H2 H1.
      induction 1 as [ p q l x y H1 | p q l x y H1 H2 IH2 ]; intros H3; rewrite Forall_cons_inv in H3; simpl in H3; destruct H3 as (H3 & H4); auto.
      intros; subst y; rewrite Nat.mul_0_r in H1; symmetry in H1; apply mult_is_O in H1; lia.
    Qed.

    Fact fractran_rt_no_zero_den l n y : fractran_regular l -> fractran_steps l n 0 y -> y = 0.
    Proof.
      intros H; induction n as [ | n IHn ].
      + simpl; auto.
      + intros (x & H1 & H2).
        apply fractran_step_no_zero_den with (1 := H) in H1; subst; auto.
    Qed.

    Fact fractran_rt_no_zero_num l : Forall (fun c => fst c <> 0) l -> forall n x, fractran_steps l n x 0 -> x = 0.
    Proof.
      intros H; induction n as [ | n IHn ]; intros x; simpl; auto.
      intros (y & H1 & H2).
      apply IHn in H2.
      revert H1 H2; apply fractran_step_no_zero_num; auto.
    Qed.

    Fact fractran_zero_num l x : Exists (fun c => fst c = 0) l -> exists y, l /F/ x → y.
    Proof.
      induction 1 as [ (p,q) l | (p,q) l Hl IHl ]; simpl in *.
      + exists 0; constructor 1; subst; ring.
      + destruct (divides_dec (p*x) q) as [ (y & Hy) | H ].
        * exists y; constructor 1; rewrite Hy; ring.
        * destruct IHl as (y & Hy); exists y; constructor 2; auto.
    Qed.

    Corollary FRACTRAN_HALTING_0_num l x : Exists (fun c => fst c = 0) l -> FRACTRAN_HALTING (l,x) <-> False.
    Proof.
      intros H1; split; try tauto; intros (y & H2 & H3).
      destruct (fractran_zero_num y H1) as (z & ?).
      apply (H3 z); auto.
    Qed.

    Lemma fractran_step_zero l :
             Forall (fun c => fst c <> 0) l
          -> forall x y, x <> 0 -> l /F/ x → y
                     <-> remove_zero_den l /F/ x → y.
    Proof.
      induction 1 as [ | (p,q) l H1 H2 IH2 ]; intros x y Hxy; simpl in *.
      * split; simpl; inversion 1.
      * simpl; destruct (eq_nat_dec q 0) as [ Hq | Hq ].
        - rewrite <- IH2; auto; subst; split; intros H.
          + apply fractran_step_cons_inv in H; destruct H as [ H | (H3 & H4) ]; auto.
            simpl in H; symmetry in H; apply mult_is_O in H; lia.
          + constructor 2; auto; intros H'.
            apply divides_0_inv, mult_is_O in H'; lia.
        - split; intros H.
          + apply fractran_step_cons_inv in H; destruct H as [ H | (H3 & H4) ]; auto.
            -- constructor 1; auto.
            -- constructor 2; auto; apply IH2; auto.
          + apply fractran_step_cons_inv in H; destruct H as [ H | (H3 & H4) ]; auto.
            -- constructor 1; auto.
            -- constructor 2; auto; apply IH2; auto.
    Qed.

    Lemma fractran_rt_no_zero_den_0_0 l :
           l <> nil -> fractran_regular l -> fractran_step l 0 0.
    Proof.
      destruct l as [ | (p,q) l ]; intros H1 H.
      + destruct H1; auto.
      + clear H1; apply Forall_cons_inv, proj1 in H.
        constructor 1; ring.
    Qed.

    Corollary FRACTRAN_HALTING_l_0_no_zero_den l :
            l <> nil -> fractran_regular l -> FRACTRAN_HALTING (l,0) <-> False.
    Proof.
      intros H1 H2; split; try tauto.
      generalize (fractran_rt_no_zero_den_0_0 H1 H2); intros H3.
      intros (y & (n & H5) & H6).
      apply fractran_rt_no_zero_den in H5; auto; subst.
      apply (H6 0); auto.
    Qed.

    Lemma FRACTRAN_HALTING_nil_x x : FRACTRAN_HALTING (nil,x) <-> True.
    Proof.
      split; try tauto; intros _.
      exists x; split.
      + exists 0; simpl; auto.
      + inversion 1.
    Qed.

    Lemma FRACTRAN_HALTING_l_1_no_zero_den l x :
           l <> nil
        -> x <> 0
        -> Forall (fun c => fst c <> 0) l
        -> FRACTRAN_HALTING (l,x) <-> FRACTRAN_HALTING (remove_zero_den l,x).
    Proof.
      intros H1 H2 H3.
      generalize (fractran_step_zero H3); intros H4.
      assert (forall n y, fractran_steps l n x y -> y <> 0) as H5.
      { intros n y H ?; subst; apply H2; revert H; apply fractran_rt_no_zero_num; auto. }
      assert (forall n y, fractran_steps (remove_zero_den l) n x y -> y <> 0) as H6.
      { intros n y H ?; subst; apply H2; revert H; apply fractran_rt_no_zero_num; auto; apply Forall_filter; auto. }
      assert (forall n y, rel_iter (fractran_step l) n x y <-> rel_iter (fractran_step (remove_zero_den l)) n x y) as H7.
      { induction n as [ | n IHn ]; intros y.
        + simpl; try tauto.
        + do 2 rewrite rel_iter_S; split.
          * intros (a & G1 & G2); exists a; split.
            - apply IHn; auto.
            - apply H4; auto.
              apply H5 with (1 := G1).
          * intros (a & G1 & G2); exists a; split.
            - apply IHn; auto.
            - apply H4; auto.
              apply H6 with (1 := G1). }
      split; intros (y & (n & G1) & G3); exists y; split.
      + exists n; apply H7; auto.
      + intros z Hz; apply (G3 z); revert Hz; apply H4, H5 with n; auto.
      + exists n; apply H7; auto.
      + intros z Hz; apply (G3 z); revert Hz; apply H4, H6 with n; auto.
    Qed.

    Lemma FRACTRAN_HALTING_hard p l :
           p <> 0
        -> FRACTRAN_HALTING ((p,0)::l,0)
       <-> exists x, x <> 0 /\ FRACTRAN_HALTING ((p,0)::l,x).
    Proof.
      intros H; split.
      + intros (y & (n & H1) & H2).
        assert (y <> 0) as Hy.
        { intro; subst; apply (H2 0); constructor; auto. }
        unfold fractran_steps in H1; rewrite rel_iter_sequence in H1.
        destruct H1 as (f & F1 & F2 & F3).
        destruct (first_non_zero f n) as (i & G1 & G2 & G3); subst; auto.
        exists (f (i+1)); split; auto.
        exists (f n); split; auto.
        exists (n-i-1); red; rewrite rel_iter_sequence.
        exists (fun j => f (j+i+1)); split; auto.
        split; [ f_equal; lia | ].
        intros j Hj; apply F3; lia.
      + intros (x & H1 & (y & (n & Hn) & H2)).
        exists y; split; auto.
        exists (S n), x; split; auto.
        constructor 1; ring.
    Qed.

  End zero_cases.

  (* The case (l,0) where l does not contains (0,_) but is of the form (p,0)::_ (with p <> 0) is complicated
     because first step could lead to any value and then we have to find some x <> 0 such that FRACTRAN_HALTING (l,x)

     Summary: forall ll a list of nat*nat, x input

       1) if (_,0) does not appear in ll, this is solved by FRACTRAN_HALTING_diophantine_0
       2) if (_,0) occurs in ll
        2.1) if (0,_) occurs in ll, then the program never halts
        2.2) if (0,_) does not appear in ll
          2.2.1) if x <> 0, the same halting as with removing all the (_,0) from ll
          2.2.2) if x = 0,
            2.2.2.1) if l starts with (_,0) let ll' be ll where (_,0) are removed
                        halting equivalent to exists y, y <> 0 /\ halting ll' y
            2.2.2.2) if l starts with (_,q) and q <> 0, never halts

   *)

  Fact FRACTAN_cases ll :  { Exists (fun c => fst c = 0) ll }
                         + { Forall (fun c => snd c <> 0) ll }
                         + { p : nat & { mm | Forall (fun c => fst c <> 0) ll /\ Exists (fun c => snd c = 0) ll
                                           /\ ll = (p,0):: mm /\ p <> 0 } }
                         + { p : nat & { q : nat & { mm | Forall (fun c => fst c <> 0) ll /\ Exists (fun c => snd c = 0) ll
                                          /\ ll = (p,q):: mm /\ q <> 0 /\ p <> 0 } } }.
  Proof.
    destruct (Forall_Exists_dec (fun c : nat * nat => snd c <> 0)) with (l := ll) as [ ? | Hl1 ]; auto.
    { intros (p, q); destruct (eq_nat_dec q 0); simpl; subst; [ right | left]; lia. }
    assert (Exists (fun c => snd c = 0) ll) as H1.
    { revert Hl1; induction 1; [ constructor 1 | constructor 2 ]; auto; lia. }
    clear Hl1.
    destruct (Forall_Exists_dec (fun c : nat * nat => fst c <> 0)) with (l := ll) as [ Hl3 | Hl3 ].
    { intros (p, q); destruct (eq_nat_dec p 0); simpl; subst; [ right | left ]; lia. }
    2: { do 3 left; clear H1; revert Hl3; induction 1; [ constructor 1 | constructor 2 ]; auto; lia. }
    case_eq ll.
    { intro; subst; exfalso; inversion H1. }
    intros (p,q) mm Hll.
    destruct (eq_nat_dec p 0) as [ Hp | Hp ].
    { subst; rewrite Forall_cons_inv in Hl3; simpl in Hl3; lia. }
    destruct q.
    + left; right; exists p, mm; subst; auto.
    + right; exists p, (S q), mm; subst; repeat (split; auto).
  Qed.

End fractran_utils.


Include Nat.
Require Import ZArith.
Require Import NArith.

Lemma even_p : forall n, even n = true -> exists x, n = 2 * x.
Proof.
  assert (Main: forall n, (even n = true -> exists x, n = 2 * x) /\
                  (even (S n) = true -> exists x, S n = 2 * x)).
  induction n.
  split.
  exists 0.
  simpl.
  reflexivity.
  simpl.
  discriminate.
  split.
  intros.
  apply IHn in H.
  exact H.
  intros.
  destruct IHn as [H' _].
  simpl even in H.
  simpl even in H.
  destruct H'.
  exact H.
  exists (x + 1).
  simpl.
  intuition.
  intros.
  destruct (Main n) as [H' _].
  apply H'.
  exact H.
Qed.

Lemma pred_S_eq : forall (x y : nat), x = S y -> pred x = y.
Proof.
intros.
unfold pred.
rewrite H.
reflexivity.
Qed.

Fixpoint sum_odd_n (n : nat) : nat :=
  match n with
    | 0 => 0
    | S n => (2 * n + 1) + sum_odd_n n
  end.

Compute sum_odd_n 4.

Lemma lemma1 : forall (a b : nat), S (a + b) = S a + b.
Proof.
intros.
induction a.
intuition.
simpl.
replace (S (a + b)) with (S a + b).
reflexivity.
Qed.

Lemma lemma3 : forall (a b : nat), S (a + b) = a + S b.
Proof.
intros.
induction a.
intuition.
simpl.
replace (S (a + b)) with (a + S b).
reflexivity.
Qed.

Lemma lemma2 : forall (a b : nat), a * (S b) = a * b + a.
Proof.
intros.
induction a.
simpl.
reflexivity.
symmetry.
intuition.
Qed.

Theorem sum_odd_squares : forall (n : nat), sum_odd_n n = n * n.
Proof.
  induction n.
  simpl.
  reflexivity.
  simpl.
  replace (sum_odd_n n) with (n * n).
  replace (n + 0) with n.
  replace (S (n + n* S n)) with (n + 1 + (n * n) + n).
  intuition.
  replace (S (n + n * S n)) with (S n + n * S n).
  replace (S n + n * S n) with (S n + n * n + n).
  intuition.
  replace (n * S n) with (n * n + n).
  intuition.
  replace (n * S n) with (n * n + n).
  intuition.
  symmetry.
  apply lemma2.
  simpl.
  reflexivity.
  intuition.
Qed.

Lemma succ_inj : forall (x y : nat), x = y -> pred x = pred y.
Proof.
intros.
destruct x.
destruct y.
unfold pred.
reflexivity.
discriminate.
destruct x.
rewrite H.
reflexivity.
rewrite H.
reflexivity.
Qed.

SearchPattern (nat -> nat -> bool).

Fixpoint upTo (n : nat) : list nat :=
  match n with
  | 0 => 0 :: nil
  | S k => S k :: upTo k
  end.

Compute upTo 3.

Lemma or_comm : forall (a b : Prop), a \/ b -> b \/ a.
Proof.
intros.
destruct H as [H1 | H2].
right.
exact H1.
left.
exact H2.
Qed.

Definition pierce := forall (p q : Prop), ((p -> q) -> p) -> p.

Definition lem := forall (p :Prop), p \/ ~p.

Theorem piece_lem_equiv : pierce <-> lem.
Proof.
  unfold pierce, lem.
  firstorder.
  apply H with (q := ~(p \/ ~p)).
  tauto.
  destruct (H p).
  assumption.
  tauto.
Qed.

Fixpoint add (a b : nat) : nat :=
  match a with
  | 0 => b
  | S n => S (add n b)
  end.

Theorem left_add_ident : forall (a : nat), (add 0 a) = a.
Proof.
  intro.
  reflexivity.
Qed.

Theorem right_add_ident : forall (a : nat), (add a 0) = a.
Proof.
  induction a.
  reflexivity.
  simpl.
  rewrite IHa.
  reflexivity.
Qed.

Lemma eq_nat_inductive : forall (a b : nat), (a = b) -> (S a = S b).
Proof.
  intros.
  subst.
  reflexivity.
Qed.

Theorem add_comm : forall (a b : nat), add a b = add b a.
Proof.
  induction a.
  induction b.
  reflexivity.
  rewrite left_add_ident.
  rewrite right_add_ident.
  reflexivity.
  induction b.
  rewrite left_add_ident.
  rewrite right_add_ident.
  reflexivity.
  simpl.
  apply eq_nat_inductive.
  symmetry in IHb.
  assert (e := IHa).
  change (add (S a) b) with (S (add a b)) in IHb.
  specialize (IHa b).
  apply eq_nat_inductive in IHa.
  rewrite IHa in IHb.
  change (S (add b a)) with (add (S b) a) in IHb.
  symmetry in IHa.
  change (S (add a b)) with (S (add b a)) in IHb.
  symmetry in IHb.
  specialize e with (b := S b).
  rewrite <- IHb.
  apply e.
Qed.

Theorem add_assoc : forall (a b c : nat), add a (add b c) = add (add a b) c.
Proof.
  induction a.
  induction b.
  intro c.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
  simpl.
  intro b.
  intro c.
  specialize (IHa b c).
  apply eq_nat_inductive in IHa.
  apply IHa.
Qed.