Require Import nat.
Require Import le.
Require Import list.
Require Import In.
Require Import disjoint.

Theorem pigeon_hole_with_LEM : forall (a:Type)(l k:list a),
    (forall (x y:a), x = y \/ x <> y) ->
    (forall x, In x l -> In x k) ->
    length k < length l ->
    repeats l.
Proof.
    intros a l k EqDec I L.
    assert (forall (x:a) (l:list a), In x l \/ ~In x l) as InDec.
    { apply In_Decidable. exact EqDec. } clear EqDec.
    revert I. revert L. revert k. induction l as [|x xs IH].
    - intros k H. inversion H.
    - intros k L I. destruct (InDec x xs) as [Hx|Hx].
        + apply repeat_In. exact Hx.
        + apply repeat_cons.
            assert (exists k1 k2, k = k1 ++ x :: k2) as [k1 [k2 H0]].
            { apply In_split. apply I. left. reflexivity. }
            apply (IH (k1++k2)).
                { apply Sn_lt_Sm__n_lt_m. rewrite app_length.
                    rewrite H0 in L. rewrite app_length in L.
                    simpl in L. rewrite plus_n_Sm in L. exact L.
                }
                { intros y Hy.
                    assert (y <> x) as Exy.
                        { intros E. apply Hx. rewrite <- E. exact Hy. }
                    assert (In y k) as Iyk.
                        { apply I. right. exact Hy. }
                    rewrite H0 in Iyk. rewrite In_app_iff.
                    rewrite In_app_iff in Iyk. destruct Iyk as [H1|[H1|H1]].
                        { left. exact H1. }
                        { exfalso. apply Exy. symmetry. exact H1. }
                        { right. exact H1. }
                }
Qed.

(*
Lemma temp : forall (a:Type) (l k:list a) (x:a),
    In x k -> length l = length k -> (forall u, In u l -> In u k) ->
    repeats (x :: l).
Proof.

Show.
*)

 (*
Theorem pigeon_hole : forall (a:Type) (l k:list a),
    (forall x, In x l -> In x k) ->
    length k < length l ->
    repeats l.
Proof.
    intros a l. induction l as [|x xs IHl].
    - intros k H H'. inversion H'.
    - intros k. revert IHl. revert xs x. induction k as [|y ys IHk].
        + intros xs x IHl H. assert (In x []) as H'.
            { apply H. left. reflexivity. }
            inversion H'.
        + intros xs x H H' L. assert (In x (y::ys)) as H0.
            { apply H'. left. reflexivity. }
            destruct H0 as [H0|H0].
                {
Show.
*)


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


Require Import ssreflect.
Require Import Metalib.Metatheory.

(* ------- these should be added to the metatheory library ------------------------- *)

(* If we have identified a variable in the middle of a uniq environment,
   it fixes the front and back. *)
Lemma uniq_mid A x (a a':A) G1 : forall G2 G1' G2',
    uniq (G1 ++ (x ~ a) ++ G2) ->
    (G1 ++ x ~ a ++ G2) = (G1' ++ x ~ a' ++ G2') ->
    G1 = G1' /\ a = a' /\ G2 = G2'.
Proof.
  induction G1.
  + intros.
    destruct G1'; inversion H0; simpl_env in *. auto.
    subst. destruct_uniq. fsetdec.
  + intros.
    destruct a0 as [y b].
    simpl_env in *.
    destruct_uniq.
    have NE: not (y = x). fsetdec.
    destruct G1' as [|[z c]]. simpl_env in H0. inversion H0. done.
    inversion H0. subst.
    simpl_env in *.
    specialize (IHG1 G2 G1' G2').
    destruct IHG1 as [E1 [E2 E3]]; auto.
    subst. auto.
Qed.

(* If x is in an environment, it is either in the front half or
   the back half. *)
Lemma binds_split A x (a:A) G : binds x a G -> exists G1 G2, G = G2 ++ [(x, a)] ++ G1.
Proof.
  move=>B. induction G.
  + inversion B.
  + destruct a0 as [y b].
    apply binds_cons_1 in B.
    destruct B as [[E1 E2]|E]. subst.
    ++ exists G. exists nil. auto.
    ++ destruct (IHG E) as [G1 [G2 E2]].
       subst.
       eexists. exists ((y ~ b) ++ G2). simpl_env.
       eauto.
Qed.

(* If we divide up a context containing a variable, it either appears in the
   front half or the back half *)
Lemma ctx_align_eq A G1 G2 (x:atom) (a:A) G0 G3 :
  uniq (G2 ++ x ~ a ++ G1) ->
  G2 ++ x ~ a ++ G1 = G0 ++ G3 ->
  (exists G0' G0'', G0 = G0' ++ x ~ a ++ G0'' /\ G2 = G0' /\ G1 = G0'' ++ G3) \/
  (exists G3' G3'', G3 = G3' ++ x ~ a ++ G3'' /\ G2 = G0 ++ G3' /\ G1 = G3'').
Proof.
  intros U E.
  have B: binds x a (G0 ++ G3). { rewrite <- E. auto. }
  rewrite -> binds_app_iff in B.
  destruct B as [h1|h1].
  + left.
    destruct (binds_split _ _ _ _ h1) as [G0'' [G0' E2]].
    exists G0'. exists G0''. split. auto.
    subst.
    simpl_env in E.
    edestruct uniq_mid with (G1 := G2) (G1' := G0')
                            (G2 := G1) (G2' := G0'' ++ G3); eauto.
    tauto.
  + right.
    destruct (binds_split _ _ _ _ h1) as [G0'' [G0' E2]].
    exists G0'. exists G0''. split. auto.
    subst.
    edestruct uniq_mid with (G1 := G2) (G1' := G0 ++ G0')
                            (G2 := G1) (G2' := G0''); simpl_env; eauto.
    tauto.
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 (lf3 : natural) (x : natural) : natural :=
  plus Zero (mult lf3 x).


Require Import Recdef.
Require Import Integer.

Inductive ExoticZ : Type :=
| Zero' : ExoticZ
| MinusOne : ExoticZ
| Next : ExoticZ -> ExoticZ.

(* Add for ExoticZ *)
Function succ' (k : ExoticZ) : ExoticZ :=
match k with
| Zero' => Next Zero'
| MinusOne => Zero'
| Next Zero' => Next (Next Zero')
| Next MinusOne => MinusOne
| Next k' => Next (succ' k')
end.

Function pred' (k : ExoticZ) : ExoticZ :=
match k with
| Zero' => MinusOne
| MinusOne => Next MinusOne
| Next Zero' => Zero'
| Next MinusOne => Next (Next MinusOne)
| Next k' => Next (pred' k')
end.

Function abs (k: ExoticZ) : nat :=
match k with
| Zero'    => 0
| MinusOne => 1
| Next k'  => S (abs k')
end.

Function pos (k: ExoticZ) : bool :=
match k with
| Zero'    => true
| MinusOne => false
| Next k'  => pos k'
end.

Definition add' (a b : ExoticZ) : ExoticZ :=
match pos a with
| true  => map_n (abs a) succ' b
| false => map_n (abs a) pred' b
end.

Lemma next_pos_is_same : forall z: ExoticZ, pos z = pos (Next z).
Proof.
  intros z. induction z; auto.
Qed.

Lemma if_pos_next_is_succ : forall z: ExoticZ, pos z = true -> Next z = succ' z.
Proof.
  intro z. induction z; auto.
  - intros H. cbn in *. discriminate H.
  - intros H. assert (P: pos z = true) by (rewrite <- H; apply next_pos_is_same; auto).
    cbn. specialize (IHz P). rewrite <- IHz. destruct z; auto. cbn in P. discriminate.
Qed.

Lemma if_neg_next_is_pred : forall z: ExoticZ, pos z = false -> Next z = pred' z.
Proof.
  intro z. induction z; auto.
  - intros H. cbn in *. discriminate H.
  - intros H. assert (P: pos z = false) by (rewrite <- H; apply next_pos_is_same; auto).
    cbn. specialize (IHz P). rewrite <- IHz. destruct z; auto. cbn in P. discriminate.
Qed.

Theorem ExoticZ_ind' (P : ExoticZ -> Prop) (base: P Zero') (suc: forall z: ExoticZ, P z -> P (succ' z))
  (pre: forall z: ExoticZ, P z -> P (pred' z)) : forall z: ExoticZ, P z.
Proof.
  intro z. induction z; auto.
  - apply (pre _ base).
  - destruct (pos z) eqn:pos.
    + rewrite (if_pos_next_is_succ z pos). apply (suc _ IHz).
    + rewrite (if_neg_next_is_pred z pos). apply (pre _ IHz).
Qed.

(* Izomorphism *)
Definition h (n: ExoticZ) : Z :=
match n with
| Zero'    => Zero
| MinusOne => Neg O
| Next n'  => if pos n'
              then Pos (abs n')
              else Neg (abs n')
end.

Definition h_inv (n: Z) : ExoticZ :=
match n with
| Pos n' => map_n (S n') Next Zero'
| Zero   => Zero'
| Neg n' => map_n n' Next MinusOne
end.

Lemma abs_for_map_n : forall n: nat, abs (map_n n Next Zero') = n.
Proof.
  intros n. induction n; auto. cbn. f_equal. assumption.
Qed.

Lemma abs_for_map_n' : forall n: nat, abs (map_n n Next MinusOne) = S n.
Proof.
  intros n. induction n; auto. cbn. f_equal. assumption.
Qed.

Lemma pos_for_map_n : forall n: nat, pos (map_n n Next Zero') = true.
Proof.
  intros n. induction n; auto.
Qed.

Lemma pos_for_map_n' : forall n: nat, pos (map_n n Next MinusOne) = false.
Proof.
  intros n. induction n; auto.
Qed.

Lemma map_n_abs_pos : forall n: ExoticZ, pos n = true -> map_n (abs n) Next Zero' = n.
Proof.
  intros n H. induction n; auto.
  - cbn in *. discriminate.
  - cbn in *. f_equal. apply IHn. assumption.
Qed.

Lemma map_n_abs_neg : forall n: ExoticZ, pos n = false -> map_n (abs n) Next MinusOne = Next n.
Proof.
  intros n H. induction n; auto.
  - cbn in *. discriminate.
  - cbn in *. f_equal. apply IHn. assumption.
Qed.

(* Bijection of h function *)
Theorem h_bijection : forall x : Z, h (h_inv x) = x.
Proof.
  intros x. induction x using Z_ind''; [auto| auto | auto |..]; cbn.
  - now rewrite pos_for_map_n, abs_for_map_n.
  - now rewrite pos_for_map_n', abs_for_map_n'.
Qed.

Theorem h_bijection' : forall x : ExoticZ, h_inv (h x) = x.
Proof.
  intros x. destruct x; auto. cbn. destruct (pos x) eqn:P; cbn.
  - f_equal. now apply map_n_abs_pos.
  - now apply map_n_abs_neg.
Qed.

Lemma h_surjection : forall y: Z, exists x: ExoticZ, h x = y.
Proof.
  intros y. exists (h_inv y). apply h_bijection.
Qed.

Lemma h_iniection : forall x y: ExoticZ, h x = h y -> x = y.
Proof.
  intros x y H. rewrite <- (h_bijection' x), <- (h_bijection' y). f_equal. assumption.
Qed.

Lemma pred'_for_pos : forall x : ExoticZ, pos x = true -> pred' (Next x) = x.
Proof.
  intros x P. induction x; cbn in *; [auto | discriminate |]. specialize (IHx P).
  now rewrite IHx.
Qed.

Lemma succ'_for_neg : forall x : ExoticZ, pos x = false -> succ' (Next x) = x.
Proof.
  intros x P. induction x; cbn in *; [discriminate | auto |]. specialize (IHx P).
  now rewrite IHx.
Qed.

Lemma pred'_for_neg : forall x : ExoticZ, pos x = false -> pred' x = Next x.
Proof.
  intros x P. induction x; cbn in *; [discriminate | auto |]. specialize (IHx P).
  rewrite IHx. destruct x; [| auto | auto]. cbn in *. discriminate.
Qed.

Lemma succ'_for_pos : forall x : ExoticZ, pos x = true -> succ' x = Next x.
Proof.
  intros x P. induction x; cbn in *; [auto | discriminate |]. specialize (IHx P).
  rewrite IHx. destruct x; [auto | | auto]. cbn in *. discriminate.
Qed.

Lemma succ'_pred': forall k : ExoticZ, succ' (pred' k) = k.
Proof.
  intros x. functional induction (pred' x); cbn; [auto | auto | auto | auto |].
  rewrite IHe. functional induction (pred' k'); cbn; auto. contradiction.
Qed.

Lemma pred'_succ' : forall k : ExoticZ, pred' (succ' k) = k.
Proof.
  intros k; functional induction (succ' k); cbn; [auto | auto | auto | auto |].
  rewrite IHe. functional induction (succ' k'); cbn in *; auto.
  contradiction.
Qed.

Lemma pred_h : forall x: ExoticZ, pred (h x) = h (pred' x).
Proof.
  intro x. destruct (pos x) eqn:P; destruct x; auto; cbn in P.
  - rewrite pred'_for_pos; auto. cbn. rewrite P.
    destruct x; cbn in *; [auto | discriminate|]. now rewrite P.
  - rewrite pred'_for_neg; auto. cbn. now rewrite P.
Qed.

Lemma succ_h : forall x: ExoticZ, succ (h x) = h (succ' x).
Proof.
  intro x. destruct (pos x) eqn:P; destruct x; auto; cbn in P.
  - rewrite succ'_for_pos; auto. cbn. now rewrite P.
  - rewrite succ'_for_neg; auto. cbn. rewrite P.
    destruct x; cbn in *; [auto | auto |]. now rewrite P.
Qed.

Lemma add'_l_succ' : forall x y: ExoticZ, add' (succ' x) y = succ' (add' x y).
Proof.
  intros x y. induction y using ExoticZ_ind'.
  - destruct x; auto. unfold add'. destruct (pos x) eqn:P.
    + rewrite succ'_for_pos; auto. cbn. now rewrite P.
    + rewrite succ'_for_neg; auto. cbn. now rewrite P, succ'_pred'.
  - destruct x; auto.
    + cbn. now  rewrite succ'_pred'.
    + unfold add'. destruct (pos x) eqn:P.
      * rewrite succ'_for_pos; auto. cbn. now rewrite P.
      * rewrite succ'_for_neg; auto. cbn. now rewrite P, succ'_pred'.
  - destruct x; auto.
    + cbn. now rewrite succ'_pred'.
    + unfold add'. destruct (pos x) eqn:P.
      * rewrite succ'_for_pos; auto. cbn. now rewrite P.
      * rewrite succ'_for_neg; auto. cbn. now rewrite P, succ'_pred'.
Qed.

Lemma add'_l_pred' : forall x y: ExoticZ, add' (pred' x) y = pred' (add' x y).
Proof.
  intros x y. induction y using ExoticZ_ind'.
  - destruct x; auto. unfold add'. destruct (pos x) eqn:P.
    + rewrite pred'_for_pos; auto. cbn. now rewrite P, pred'_succ'.
    + rewrite pred'_for_neg; auto. cbn. now rewrite P.
  - destruct x; auto. unfold add'. destruct (pos x) eqn:P.
    + rewrite pred'_for_pos; auto. cbn. now rewrite P, pred'_succ'.
    + rewrite pred'_for_neg; auto. cbn. now rewrite P.
  - destruct x; auto. unfold add'. destruct (pos x) eqn:P.
    + rewrite pred'_for_pos; auto. cbn. now rewrite P, pred'_succ'.
    + rewrite pred'_for_neg; auto. cbn. now rewrite P.
Qed.

(* Homomorphism of algebraic structures *)
Theorem Z_ExoticZ_homo : forall x y: ExoticZ, add (h x) (h y) = h (add' x y).
Proof.
  intros x y. induction x using ExoticZ_ind'; [auto|..].
  - now rewrite add'_l_succ', <- succ_h, <- succ_h, <- IHx, add_l_succ.
  - now rewrite add'_l_pred', <- pred_h, <- pred_h, <- IHx, add_l_pred.
Qed.


(***************************************************************************
* Generic Variables for Programming Language Metatheory                    *
* Brian Aydemir & Arthur Charguéraud, July 2007, Coq v8.1      é            *
***************************************************************************)

Set Implicit Arguments.
Require Import List Max Omega OrderedType OrderedTypeEx.
Require Import Lib_Tactic Lib_ListFacts Lib_FinSet Lib_FinSetImpl.
Require Export Lib_ListFactsMore.

(* ********************************************************************** *)
(** * Abstract Definition of Variables *)

Module Type VARIABLES.

(** We leave the type of variables abstract. *)

Parameter var : Set.

(** This type is inhabited. *)

Parameter var_default : var.

(** Variables are ordered. *)

Declare Module Var_as_OT : UsualOrderedType with Definition t := var.

(** We can form sets of variables. *)

Declare Module Import VarSet : FinSet with Module E := Var_as_OT.
Open Local Scope set_scope.

Definition vars := VarSet.S.t.

(** Finally, we have a means of generating fresh variables. *)

Parameter var_generate : vars -> var.
Parameter var_generate_spec : forall E, (var_generate E) \notin E.
Parameter var_fresh : forall (L : vars), { x : var | x \notin L }.

End VARIABLES.

(* ********************************************************************** *)
(** * Concrete Implementation of Variables *)

Module Variables : VARIABLES.

Definition var := nat.

Definition var_default : var := O.

Module Var_as_OT := Nat_as_OT.

Module Import VarSet : FinSet with Module E := Var_as_OT :=
  Lib_FinSetImpl.Make Var_as_OT.
Open Local Scope set_scope.

Definition vars := VarSet.S.t.

Open Scope nat_scope.

Lemma max_lt_l :
  forall (x y z : nat), x <= y -> x <= max y z.
Proof.
  induction x; auto with arith.
  induction y; induction z; simpl; auto with arith.
Qed.

Lemma finite_nat_list_max : forall (l : list nat),
  { n : nat | forall x, In x l -> x <= n }.
Proof.
  induction l as [ | l ls IHl ].
  exists 0; intros x H; inversion H.
  inversion IHl as [x H].
  exists (max x l); intros y J; simpl in J; inversion J.
    subst; auto with arith.
    assert (y <= x); auto using max_lt_l.
Qed.

Lemma finite_nat_list_max' : forall (l : list nat),
  { n : nat | ~ In n l }.
Proof.
  intros l.
  case (finite_nat_list_max l); intros x H.
  exists (S x).
  intros J.
  assert (K := H _ J); omega.
Qed.

Definition var_generate (L : vars) : var :=
  proj1_sig (finite_nat_list_max' (S.elements L)).

Lemma var_generate_spec : forall E, (var_generate E) \notin E.
Proof.
  unfold var_generate. intros E.
  destruct (finite_nat_list_max' (S.elements E)) as [n pf].
  simpl. intros a.
  assert (In n (S.elements E)). rewrite <- InA_iff_In.
  auto using S.elements_1.
  intuition.
Qed.

Lemma var_fresh : forall (L : vars), { x : var | x \notin L }.
Proof.
  intros L. exists (var_generate L). apply var_generate_spec.
Qed.

End Variables.

(* ********************************************************************** *)
(** * Properties of variables *)

Export Variables.
Export Variables.VarSet.
Module Export VarSetFacts := FinSetFacts VarSet.

Open Scope set_scope.

(** Equality on variables is decidable. *)

Module Import Var_as_OT_Facts := OrderedTypeFacts Variables.Var_as_OT.

Lemma eq_var_dec : forall x y : var, {x = y} + {x <> y}.
Proof.
  exact Var_as_OT_Facts.eq_dec.
Qed.

(* ********************************************************************** *)
(** ** Dealing with list of variables *)

(** Freshness of n variables from a set L and from one another. *)

Fixpoint fresh (L : vars) (n : nat) (xs : list var) {struct xs} : Prop :=
  match xs, n with
  | nil, O => True
  | x::xs', S n' => x \notin L /\ fresh (L \u {{x}}) n' xs'
  | _,_ => False
  end.

Hint Extern 1 (fresh _ _ _) => simpl.

(** Triviality : If a list xs contains n fresh variables, then
    the length of xs is n. *)

Lemma fresh_length : forall xs L n,
  fresh L n xs -> n = length xs.
Proof.
  induction xs; simpl; intros; destruct n;
  try solve [ contradictions* | f_equal* ].
Qed.

(* It is possible to build a list of n fresh variables. *)

Lemma var_freshes : forall L n,
  { xs : list var | fresh L n xs }.
Proof.
  intros. gen L. induction n; intros L.
  exists* (nil : list var).
  destruct (var_fresh L) as [x Fr].
   destruct (IHn (L \u {{x}})) as [xs Frs].
   exists* (x::xs).
Qed.

(* ********************************************************************** *)
(** ** Tactics: Case Analysis on Variables *)

(** We define notations for the equality of variables (our free variables)
  and for the equality of naturals (our bound variables represented using
  de Bruijn indices). *)

Notation "x == y" := (eq_var_dec x y) (at level 67).
Notation "i === j" := (Peano_dec.eq_nat_dec i j) (at level 67).

(** Tactic for comparing two bound or free variables. *)

Ltac case_nat :=
  let destr x y := destruct (x === y); [try subst x | idtac] in
  match goal with
  | H: context [?x === ?y] |- _ => destr x y
  | |- context [?x === ?y]      => destr x y
  end.

Tactic Notation "case_nat" "*" := case_nat; auto*.

Tactic Notation "case_var" :=
  let destr x y := destruct (x == y); [try subst x | idtac] in
  match goal with
  | H: context [?x == ?y] |- _ => destr x y
  | |- context [?x == ?y]      => destr x y
  end.

Tactic Notation "case_var" "*" := case_var; auto*.

(* ********************************************************************** *)
(** ** Tactics: Picking Names Fresh from the Context *)

(** [gather_vars_for_type T F] return the union of all the finite sets
  of variables [F x] where [x] is a variable from the context such that
  [F x] type checks. In other words [x] has to be of the type of the
  argument of [F]. The resulting union of sets does not contain any
  duplicated item. This tactic is an extreme piece of hacking necessary
  because the tactic language does not support a "fold" operation on
  the context. *)

Ltac gather_vars_with F :=
  let rec gather V :=
    match goal with
    | H: ?S |- _ =>
      let FH := constr:(F H) in
      match V with
      | {} => gather FH
      | context [FH] => fail 1
      | _ => gather (FH \u V)
      end
    | _ => V
    end in
  let L := gather {} in eval simpl in L.

(** [beautify_fset V] assumes that [V] is built as a union of finite
  sets and return the same set cleaned up: empty sets are removed and
  items are laid out in a nicely parenthesized way *)

Ltac beautify_fset V :=
  let rec go Acc E :=
     match E with
     | ?E1 \u ?E2 => let Acc1 := go Acc E1 in
                     go Acc1 E2
     | {}  => Acc
     | ?E1 => match Acc with
              | {} => E1
              | _ => constr:(Acc \u E1)
              end
     end
  in go {} V.

(** [pick_fresh_gen L Y] expects [L] to be a finite set of variables
  and adds to the context a variable with name [Y] and a proof that
  [Y] is fresh for [L]. *)

Ltac pick_fresh_gen L Y :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (var_fresh L) as [Y Fr]).

(** [pick_fresh_gens L n Y] expects [L] to be a finite set of variables
  and adds to the context a list of variables with name [Y] and a proof
  that [Y] is of length [n] and contains variable fresh for [L] and
  distinct from one another. *)

Ltac pick_freshes_gen L n Y :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (var_freshes L n) as [Y Fr]).

(** Demo of pick_fresh_gen *)

Ltac test_pick_fresh_filter Y :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => {{ x }}) in
  let C := gather_vars_with (fun x : var => {}) in
  pick_fresh_gen (A \u B \u C) Y.

Lemma test_pick_fresh : forall (x y z : var) (L1 L2 L3: vars), True.
Proof.
  intros. test_pick_fresh_filter k. auto.
Qed.

(** The above invokation of [pick_fresh] generates a
  variable [k] and the hypothesis
  [k \notin L1 \u L2 \u L3 \u {{x}} \u {{y}} \u {{z}}] *)

(* ********************************************************************** *)
(** ** Tactics: Applying Lemmas With Quantification Over Cofinite Sets *)

(** [apply_fresh_base] tactic is a helper to build tactics that apply an
  inductive constructor whose first argument should be instanciated
  by the set of names already used in the context. Those names should
  be returned by the [gather] tactic given in argument. For each premise
  of the inductive rule starting with an universal quantification of names
  outside the set of names instanciated, a subgoal with be generated by
  the application of the rule, and in those subgoal we introduce the name
  quantified as well as its proof of freshness. *)

Ltac apply_fresh_base_simple lemma gather :=
  let L0 := gather in let L := beautify_fset L0 in
  first [apply (@lemma L) | eapply (@lemma L)].

Ltac apply_fresh_base lemma gather var_name :=
  apply_fresh_base_simple lemma gather;
  try match goal with |- forall _, _ \notin _ -> _ =>
    let Fr := fresh "Fr" in intros var_name Fr end.

(** [inst_notin H y as H'] expects [H] to be of the form
  [forall x, x \notin L, P x] and creates an hypothesis [H']
  of type [P y]. It tries to prove the subgoal [y \notin L]
  by [auto]. This tactic is very useful to apply induction
  hypotheses given in the cases with binders. *)

Tactic Notation "inst_notin" constr(lemma) constr(var)
                "as" ident(hyp_name) :=
  let go L := let Fr := fresh in assert (Fr : var \notin L);
     [ auto | poses hyp_name (@lemma var Fr); clear Fr ] in
  match type of lemma with
  | forall _, _ \notin ?L -> _ => go L
  | forall _, (_ \in ?L -> False) -> _ => go L
  end.

Tactic Notation "inst_notin" "*" constr(lemma) constr(var)
                "as" ident(hyp_name) :=
  inst_notin lemma var as hyp_name; auto*.


(* Running Example: Commutativity of Addition *)

Lemma add_comm (x y : nat) :
  x + y = y + x.
Proof.
  induction x.
  - cbn. rewrite <- plus_n_O. reflexivity.
  - cbn. rewrite IHx, plus_n_Sm. reflexivity.
Qed.

(* Defining commutativity as first-order formula *)
(* Variant 1: de Bruijn formula *)

From Undecidability.FOL Require Import Syntax PA.
Import FullSyntax.

Definition add_comm_fol : form :=
  ∀ ∀ $1 ⊕ $0 == $0 ⊕ $1.

(* Variant 2: HOAS formula *)

From Undecidability.FOL Require Import Hoas.
Require Import Vector.
Import VectorNotations.

Notation "x '⊕' y" := (bFunc Plus ([x; y])) (at level 39) : hoas_scope.
Notation "x '==' y" := (bAtom Eq ([x; y])) (at level 40) : hoas_scope.

Definition add_comm_hoas : form :=
  << ∀' x y, x ⊕ y == y ⊕ x.

Print add_comm_hoas.


Set Warnings "-notation-overridden,-parsing".
From LF Require Export Poly.

Theorem rev_exercise1 : forall (l l' : list nat),
    l = rev l' -> l' = rev l.
Proof.
  intros. rewrite H. rewrite rev_involutive. reflexivity.
Qed.

Theorem trans_eq : forall (X : Type) (n m o : X),
    n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2. rewrite eq1, <- eq2. reflexivity.
Qed.

Example trans_eq_example : forall (a b c d e f : nat),
    [a;b] = [c;d] -> [c;d] = [e;f] -> [a;b] = [e;f].
Proof.
  intros a b c d e f. apply trans_eq. Qed.

Example trans_eq_exercise : forall (n m o p : nat),
    m = (minustwo o) ->
    (n + p) = m ->
    (n + p) = (minustwo o).
Proof.
  intros. apply trans_eq with (m := m).
  - assumption.
  - assumption.
Qed.

Theorem S_injective : forall n m : nat,
    S n = S m -> n = m.
Proof.
  intros n m H. injection H. intros Hnm. apply Hnm.
Qed.

Theorem injection_ex1 : forall (n m o : nat),
    [n; m] = [o; o] -> [n] = [m].
Proof.
  intros. injection H. intros. rewrite H0, H1. reflexivity.
Qed.

Theorem injection_ex2 : forall (n m : nat),
    [n] = [m] -> n = m.
Proof.
  intros n m H. injection H as Hnm. rewrite Hnm.
  reflexivity.
Qed.

Example injection_ex3 : forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = z :: j ->
    y :: l = x :: j ->
    x = y.
Proof.
  intros. injection H0 as Hyx. symmetry. apply Hyx.
Qed.

Theorem eqb_O_l : forall n, 0 =? n = true -> n = 0.
Proof.
  intros. simpl in H. destruct n as [| n'] eqn:E.
  - reflexivity.
  - discriminate H.
Qed.

Theorem discriminate_ex1 : forall n : nat,
    S n = O -> 2 + 2 = 5.
Proof.
  intros n H. discriminate H.
Qed.

Theorem discrimiante_ex2: forall (n m : nat),
    false = true -> [n] = [m].
Proof. intros. discriminate H. Qed.

Example discrimiate_ex3 :
  forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] -> x = z.
Proof. intros. discriminate H. Qed.

Theorem f_equal : forall (A B : Type) (f : A -> B) (x y : A),
    x = y -> f x = f y.
Proof. intros. rewrite H. reflexivity. Qed.

Theorem S_inj : forall (n m : nat) (b : bool),
    (S n) =? (S m) = b -> n =? m = b.
Proof. intros. simpl in H. apply H. Qed.

Theorem plus_n_n_injective : forall n m,
    n + n = m + m -> n = m.
Proof.
  intro n. induction n as [| n' IHn'].
  - intros m H. simpl in H.
    induction m as [| m' IHm'].
    + reflexivity.
    + simpl in *. discriminate H.
  - intros m H. simpl in H.
    induction m as [| m' IHm'].
    + simpl in H. discriminate H.
    + simpl in *. injection H as H'.
      Search plus. rewrite <- plus_n_Sm in H'.
      rewrite <- plus_n_Sm in H'.
      injection H' as H''. apply IHn' in H''.
      rewrite H''. reflexivity.
Qed.

Theorem double_injective : forall n m,
    double n = double m -> n = m.
Proof.
  intros n m. rewrite double_plus, double_plus.
  apply plus_n_n_injective.
Qed.

Theorem eqb_true : forall n m, n =? m = true -> n = m.
Proof.
  intro n. induction n.
  - intros m H. destruct m as [| m'] eqn:E.
    + reflexivity.
    + discriminate H.
  - intros m H. destruct m as [| m'] eqn:E.
    + discriminate H.
    + simpl in H. apply IHn in H. rewrite H.
      reflexivity.
Qed.

Theorem eqb_refl : forall n, n =? n = true.
Proof.
  intro n. induction n.
  - reflexivity.
  - simpl. apply IHn.
Qed.

Theorem double_injective_take2 : forall n m,
    double n = double m -> n = m.
Proof.
  intros n m.
  (* n and m are both in the context *)
  generalize dependent n.
  (* Now n is back in the goal and we can do induction on
     m and get a sufficiently general IH. *)
  induction m as [| m'].
  - simpl. intros n eq. destruct n as [| n' ] eqn:E.
    + reflexivity.
    + discriminate eq.
  - simpl. intros n eq. destruct n as [| n' ] eqn:E.
    + discriminate eq.
    + simpl in eq. injection eq as eq. apply IHm' in eq.
      rewrite eq. reflexivity.
Qed.

Theorem eqb_id_true : forall x y,
    eqb_id x y = true -> x = y.
Proof.
  intros [m] [n]. simpl. intro H.
  apply eqb_true in H.
  rewrite H. reflexivity.
Qed.

Theorem nth_error_after_last : forall (n : nat) (X : Type) (l : list X),
    length l = n -> nth_error l n = None.
Proof.
  intros n X l. generalize n. induction l.
  - reflexivity.
  - intros n0 H. induction n0.
    + discriminate H.
    + simpl in H. injection H as H. apply IHl in H.
      simpl. apply H.
Qed.

Definition square n := n * n.

Lemma plus_mult_l : forall a b c, (a + b) * c = a * c + b * c.
Proof.
  intros a b c. induction a.
  - simpl. reflexivity.
  - simpl. rewrite IHa. rewrite plus_assoc. reflexivity.
Qed.

Lemma mult_assoc : forall a b c, a * b * c = a * (b * c).
Proof.
  intros a b c. induction a.
  - simpl. reflexivity.
  - simpl. rewrite <- IHa. rewrite plus_mult_l. reflexivity.
Qed.

Lemma mult_comm : forall n m, n * m = m * n.
Proof.
  intros n m. induction n.
  - simpl. rewrite <- mult_n_O. reflexivity.
  - simpl. rewrite IHn. rewrite plus_comm. rewrite mult_n_Sm.
    reflexivity.
Qed.

Lemma square_mult : forall n m, square (n * m) = square n * square m.
Proof.
  intros n m. unfold square. rewrite <- mult_assoc.
  rewrite <- mult_assoc.
  assert (H: n * m * n = n * n * m).
  { rewrite mult_comm. rewrite mult_assoc. reflexivity. }
  rewrite H. reflexivity.
Qed.

Definition foo (x : nat) := 5.

Fact silly_fact_1 : forall m, foo m + 1 = foo (m + 1) + 1.
Proof. intro m. simpl. reflexivity. Qed.

Definition bar x :=
  match x with
  | O => 5
  | S _ => 5
  end.

Fact silly_fact_2 : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intro m. destruct m as [| m'] eqn:E.
  - reflexivity.
  - simpl. reflexivity.
Qed.

Definition sillyfun (n : nat) : bool :=
  if n =? 3 then false
  else if n =? 5 then false
  else false.

Theorem sillyfun_false : forall n : nat,
    sillyfun n = false.
Proof.
  intro n. unfold sillyfun.
  destruct (n =? 3) eqn:E1.
  - reflexivity.
  - destruct (n =? 5) eqn:E2.
    + reflexivity.
    + reflexivity.
Qed.

Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
    split l = (l1, l2) -> combine l1 l2 = l.
Proof.
  intros X Y l. induction l as [| h t IHt].
  - intros l1 l2 H. inversion H. reflexivity.
  - intros l1 l2 H. destruct h as [a b] eqn:E in H. simpl in H.
    destruct (split t) as [l1' l2'] eqn:Et in H. inversion H.
    simpl. inversion E.
    assert (Heq : forall (X : Type) (x : X) (l1 l2 : list X),
               l1 = l2 -> x :: l1 = x::l2).
    { intros. rewrite H3. reflexivity. }
    apply Heq. apply IHt. apply Et.
Qed.

Definition sillyfun1 (n : nat) : bool :=
  if n =? 3 then true
  else if n =? 5 then true
       else false.

Theorem sillyfun1_odd : forall (n : nat),
    sillyfun1 n = true -> oddb n = true.
Proof.
  intros n H.
  unfold sillyfun1 in H.
  destruct (n =? 3) eqn:E3 in H.
  - apply eqb_true in E3. rewrite E3. reflexivity.
  - destruct (n =? 5) eqn:E5 in H.
    + apply eqb_true in E5. rewrite E5. reflexivity.
    + discriminate H.
Qed.

Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool), f (f (f b)) = f b.
Proof.
  intros f b. destruct b eqn:Eb.
  - destruct (f true) eqn:Eft.
    + rewrite Eft. apply Eft.
    + destruct (f false) eqn:Eff.
      * apply Eft.
      * apply Eff.
  - destruct (f false) eqn:Eff.
    + destruct (f true) eqn:Eft.
      * apply Eft.
      * apply Eff.
    + rewrite Eff. apply Eff.
Qed.

Theorem eqb_sym : forall n m : nat, (n =? m) = (m =? n).
Proof.
  intro n. induction n as [| n' IHn'].
  - intro m. simpl. destruct m as [| m'] eqn:Em.
    + reflexivity.
    + simpl. reflexivity.
  - intro m. destruct m as [| m'] eqn:Em.
    + simpl. reflexivity.
    + simpl. apply IHn'.
Qed.

Theorem eqb_trans : forall n m p,
    n =? m = true ->
    m =? p = true ->
    n =? p = true.
Proof.
  intro n. induction n as [| n' IHn'].
  - intro m. induction m as [| m' IHm'].
    + intro p. intro H1. destruct p as [| p'] eqn:Ep.
      * reflexivity.
      * simpl. intro H2. apply H2.
    + intro p. intro H1. simpl in H1. discriminate H1.
  - intro m. induction m as [| m' IHm'].
    + intro p. intro H1. simpl in H1. discriminate H1.
    + intro p. intro H1. simpl in H1. destruct p as [| p'] eqn:Ep.
      * intro H2. simpl in H2. discriminate H2.
      * intro H2. simpl in H2. simpl. apply IHn' with m'.
        apply H1. apply H2.
Qed.

Definition split_combine_statement : Prop :=
  forall X Y (l1 : list X) (l2 : list Y),
    length l1 = length l2 -> split (combine l1 l2) = (l1, l2).

Theorem split_combine : split_combine_statement.
Proof.
  unfold split_combine_statement.
  intros X Y l1. induction l1 as [| h1 l1' IHl1'].
  - intros l2 H. destruct l2 as [| h2 l2'] eqn:El2.
    + reflexivity.
    + simpl in H. discriminate H.
  - intros l2 H. destruct l2 as [| h2 l2'] eqn:El2.
    + simpl in H. discriminate H.
    + simpl in H. injection H as H. apply IHl1' in H.
      simpl. rewrite H. reflexivity.
Qed.

Theorem filter_exercise :
  forall (X : Type) (test : X -> bool) (x : X) (l lf : list X),
    filter test l = x :: lf -> test x = true.
Proof.
  intros X test x l. induction l as [| h l' IHl'].
  - intros lf H. simpl in H. discriminate H.
  - intros lf H. simpl in H. destruct (test h) eqn:E in H.
    + inversion H. rewrite H1 in E. apply E.
    + apply IHl' with lf. apply H.
Qed.

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

Example test_forallb_1 : forallb oddb [1;3;5;7;9] = true.
Proof. reflexivity. Qed.
Example test_forallb_2 : forallb negb [false;false] = true.
Proof. reflexivity. Qed.
Example test_forallb_3 : forallb evenb [0;2;4;5] = false.
Proof. reflexivity. Qed.
Example test_forallb_4 : forallb (eqb 5) [] = true.
Proof. reflexivity. Qed.

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

Example test_existsb_1 : existsb (eqb 5) [0;2;3;6] = false.
Proof. reflexivity. Qed.
Example test_existsb_2 : existsb (andb true) [true;true;false] = true.
Proof. reflexivity. Qed.
Example test_existsb_3 : existsb oddb [1;0;0;0;0;3] = true.
Proof. reflexivity. Qed.
Example test_existsb_4 : existsb evenb [] = false.
Proof. reflexivity. Qed.

Definition existsb' {X : Type} (test : X -> bool) (l : list X) : bool :=
  negb (forallb (fun x => negb (test x)) l).

Theorem existsb_existsb' :
  forall (X : Type) (test : X -> bool) (l : list X),
    existsb test l = existsb' test l.
Proof.
  intros. induction l as [| h t IHt].
  - reflexivity.
  - simpl. destruct (test h) eqn:E.
    + unfold existsb'. simpl. rewrite E.
      simpl. reflexivity.
    + unfold existsb'. simpl. rewrite E.
      simpl. fold (existsb' test t). apply IHt.
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) (lf3 : natural) : natural :=
  plus lf2 (plus Zero lf3).


Section NetKAT.
  Variable (Fields: Type).
  Variable (Vals: Type).

  Inductive test :=
  | t_unit | t_fail (* 1 and 0 *)
  | t_check : Fields -> Vals -> test (* f = v *)
  | t_or : test -> test -> test (* l + r *)
  | t_and : test -> test -> test (* l . r *)
  | t_neg : test -> test. (* ! t *)

  Inductive kat :=
  | k_test : test -> kat
  | k_put : Fields -> Vals -> kat (* f <- v *)
  | k_or : kat -> kat -> kat (* l + r *)
  | k_and : kat -> kat -> kat (* l . r *)
  | k_star : kat -> kat  (* x^* *)
  | k_dup : kat.

  (* non-empty lists *)
  Inductive ne_list (V: Type) : Type :=
  | ne_nil : V -> ne_list V (* p :: <> *)
  | ne_cons : V -> ne_list V -> ne_list V. (* p :: h *)

  Arguments ne_nil {_}.
  Arguments ne_cons {_}.

  Fixpoint ne_app {V} (l r: ne_list V) :=
    match l with
    | ne_nil x => ne_cons x r
    | ne_cons x l =>
      ne_cons x (ne_app l r)
    end.

  (* packets are maps from fields to values *)
  Definition pkt := Fields -> Vals.
  Definition history := ne_list pkt.

  (* An interpretation relates tests/kats with input/output histories.
     Notice that the original paper maps to a powerset; the intuition here is that interp_test t pre post is true for all possible histories post in the powerset of the paper's interp definition.
  *)
  (* #[ bypass_check(positivity=yes) ] *)
  Fixpoint interp_test (t: test) (h: history) :=
    match t with
    | t_unit => True
    | t_fail => False
    | t_check f v => (* syntax for pkt . f = v *)
      match h with
      | ne_nil p =>
        p f = v  (* semantics for pkt . f = v when the history is pkt :: <> *)
      | ne_cons p _ =>
        p f = v  (* semantics for pkt . f = v when the history is pkt :: h' *)
      end
    | t_or t_l t_r =>
      interp_test t_l h \/ interp_test t_r h
    | t_and t_l t_r =>
      interp_test t_l h /\ interp_test t_r h
    | t_neg t =>
      ~ interp_test t h
    end.

  (* Two tests are equivalent (i.e. KAT equal) if they have identical behavior on histories *)
  Definition equiv_test (l r : test) : Prop :=
    forall h,
      interp_test l h <-> interp_test r h.

  Lemma ba_seq_idem :
    forall x,
      equiv_test (t_and x x) x.
  Proof.
    unfold equiv_test.
    intros.
    split; intros.
    - simpl in H.
      intuition.
    - simpl.
      intuition.
  Qed.

  Require Import Coq.Classes.EquivDec.

  Context `{FEqDec: EquivDec.EqDec Fields eq}.

  Definition pkt_put (p: pkt) f v := fun f' =>
    if f' == f then v else p f'.

  Inductive interp_kat : kat -> history -> history -> Prop :=
  | interp_k_test :
    forall t h,
      interp_test t h ->
      interp_kat (k_test t) h h
  | interp_put_nil :
    forall p f v,
      interp_kat (k_put f v) (ne_nil p) (ne_nil (pkt_put p f v))
  | interp_put_cons :
    forall p h f v,
      interp_kat (k_put f v) (ne_cons p h) (ne_cons (pkt_put p f v) h)
  | interp_k_or :
    forall k_l k_r pre post,
      interp_kat k_l pre post \/ interp_kat k_r pre post ->
      interp_kat (k_or k_l k_r) pre post
  | interp_k_and :
    forall k_l k_r pre post post',
      interp_kat k_l pre post /\ interp_kat k_r post post' ->
      interp_kat (k_and k_l k_r) pre post'
  | interp_star_one :
    forall k pre post,
      interp_kat k pre post ->
      interp_kat (k_star k) pre post
  | interp_star_many :
    forall k pre post post',
      interp_kat k pre post ->
      interp_kat (k_star k) post post' ->
      interp_kat (k_star k) pre post'
  | interp_dup_nil :
    forall p, interp_kat k_dup (ne_nil p) (ne_cons p (ne_nil p))
  | interp_dup_cons :
    forall p h, interp_kat k_dup (ne_cons p h) (ne_cons p (ne_cons p h)).

  Definition equiv_kat l r :=
    forall pre post,
      interp_kat l pre post <-> interp_kat r pre post.

  Require Import Coq.Logic.FunctionalExtensionality.

  Lemma put_pkt_iota :
    forall p f,
      pkt_put p f (p f) = p.
  Proof.
    intros.
    extensionality x.
    unfold pkt_put.
    destruct (_ == _) eqn:?.
    - inversion e;
      subst.
      trivial.
    - trivial.
  Qed.

  Lemma check_put :
    forall f v h,
      interp_test (t_check f v) h ->
      interp_kat (k_put f v) h h.
  Proof.
    intros.
    simpl in H.
    destruct h;
    subst.
    - assert (p = pkt_put p f (p f)) by now erewrite put_pkt_iota.
      erewrite H at 3.
      econstructor.
    - assert (p = pkt_put p f (p f)) by now erewrite put_pkt_iota.
      erewrite H at 3.
      econstructor.
  Qed.

  Lemma put_inj:
    forall f v pre post post',
      interp_kat (k_put f v) pre post ->
      interp_kat (k_put f v) pre post' ->
      post = post'.
  Proof.
    destruct pre;
    intros;
    inversion H; subst;
    inversion H0; subst;
    trivial.
  Qed.

  Lemma pa_filter_mod :
    forall f v,
      equiv_kat
        (k_and (k_test (t_check f v)) (k_put f v))
        (k_test (t_check f v)).
  Proof.
    unfold equiv_kat.
    intros;
    split;
    intros.
    - inversion H; subst;
      clear H.
      destruct H4.
      inversion H; subst.
      pose proof (check_put _ _ _ H2).
      assert (post = post0) by (eapply put_inj; eauto).
      subst.
      econstructor.
      trivial.
    - inversion H; subst.
      clear H.
      econstructor.
      split; try econstructor;
      try eapply check_put;
      trivial.
  Qed.
End NetKAT.

Arguments t_unit {_ _}.
Arguments t_fail {_ _}.
Arguments t_check {_ _}.
Arguments t_or {_ _}.
Arguments t_and {_ _}.
Arguments t_neg {_ _}.

Arguments k_test {_ _}.
Arguments k_put {_ _}.
Arguments k_or {_ _}.
Arguments k_and {_ _}.
Arguments k_star {_ _}.
Arguments k_dup {_ _}.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Coq.Logic.ClassicalUniqueChoice.

Require Import Types.

Module Type MapCtxMonoid
  ( KM : Types.ModuleType )
  ( VM : Types.ModuleType ).

  Definition K : Type := KM.T.
  Definition V : Type := VM.T.

  Definition T : Type := K -> V -> Prop.

  Definition contains (A : T) (k : K) (v : V) : Prop := A k v.

  Definition subseteq (A B : T) : Prop :=
    forall (k : K) (v : V), contains A k v -> contains B k v.

  (* Equivalence, Equality, and Extionsionality *)
  Definition eq (A B : T) : Prop := subseteq A B /\ subseteq B A.

  Lemma eq_refl : forall A : T, eq A A.
  Proof.
    intros. unfold eq. assert (H : subseteq A A).
    { unfold subseteq. intros. apply H. } split; apply H.
  Qed.

  Axiom extensionality : forall (A B : T), eq A B -> A = B.

  Lemma extensionality_converse : forall (A B : T), A = B -> eq A B.
  Proof.
    intros. rewrite <- H. apply eq_refl.
  Qed.

  Lemma extensionality_inverse : forall (A B : T), ~ eq A B -> A <> B.
  Proof.
    intros. unfold not. intros Hf. apply extensionality_converse in Hf.
    apply H in Hf. apply Hf.
  Qed.

  Lemma extensionality_contraposition : forall (A B : T), A <> B -> ~ eq A B.
  Proof.
    intros. unfold not. intros Hf. apply extensionality in Hf.
    unfold not in H. apply H in Hf. apply Hf.
  Qed.

  (* Empty, Singleton, Union *)
  Inductive empty : T := .

  Inductive singleton (k : K) (v : V) : T :=
    singleton_contains : contains (singleton k v) k v.

  Inductive union (B C : T) : T :=
  | union_l : forall (k : K) (v : V), contains B k v -> contains (union B C) k v
  | union_r : forall (k : K) (v : V), contains C k v -> contains (union B C) k v.

  (* Commutativity *)
  Lemma commut : forall (B C : T), union B C = union C B.
  Proof.
    intros B C. apply extensionality. unfold eq. split.
    - unfold subseteq. intros. inversion H.
      + apply union_r. apply H0.
      + apply union_l. apply H0.
    - unfold subseteq. intros. inversion H.
      + apply union_r. apply H0.
      + apply union_l. apply H0.
  Qed.

  (* Notations *)
  Notation "s1 'o' s2" := (union s1 s2) (at level 20, left associativity).
  Notation "'Ø'" := (empty).

  (* Empty Union *)
  Lemma empty_union : forall A B : T, A o B = Ø -> A = Ø /\ B = Ø.
  Proof.
    intros. apply extensionality_converse in H. inversion H as [Hl Hr].
    unfold subseteq in Hl. split.
    - apply extensionality. unfold eq. split.
      + unfold subseteq. intros. apply Hl. apply union_l. apply H0.
      + unfold subseteq. intros. inversion H0.
    - apply extensionality. unfold eq. split.
      + unfold subseteq. intros. apply Hl. apply union_r. apply H0.
      + unfold subseteq. intros. inversion H0.
  Qed.

  (* Associativity of Union *)
  Lemma assoc : forall A B C : T, (A o B) o C = A o (B o C).
  Proof.
    intros. apply extensionality. unfold eq. split; unfold subseteq.
    - intros. inversion H.
      + inversion H0.
        * apply union_l. apply H3.
        * apply union_r. apply union_l. apply H3.
      + apply union_r. apply union_r. apply H0.
    - intros. inversion H.
      + apply union_l. apply union_l. apply H0.
      + inversion H0.
        * apply union_l. apply union_r. apply H3.
        * apply union_r. apply H3.
  Qed.

  (* Exchange *)
  Lemma exchange : forall A B C D, A o B o C o D = A o C o B o D.
  Proof.
    intros.
    assert (H : B o C = C o B). { apply commut. }
    assert (H' : B o (C o D) = C o (B o D)).
      { repeat rewrite <- assoc. rewrite -> H. reflexivity. }
    repeat rewrite -> assoc. rewrite -> H'. reflexivity.
  Qed.

  (* Identity Element of Union *)
  Lemma id_l : forall A : T, Ø o A = A.
  Proof.
    intros. apply extensionality. unfold eq. split; unfold subseteq.
    - intros. inversion H.
      + inversion H0.
      + apply H0.
    - intros. apply union_r. apply H.
  Qed.

  Lemma id_r : forall A : T, A o Ø = A.
  Proof.
    intros. apply extensionality. unfold eq. split; unfold subseteq.
    - intros. inversion H.
      + apply H0.
      + inversion H0.
    - intros. apply union_l. apply H.
  Qed.

  (* Append *)
  Definition append (A : T) (k : K) (v : V) : T := union A (singleton k v).

  Lemma singleton_empty : forall (k : K) (v : V), singleton k v = append Ø k v.
  Proof.
    intros. apply extensionality. unfold eq. split; unfold subseteq.
    - intros k' v' H. inversion H. subst k' v'. apply union_r. apply H.
    - intros k' v' H. inversion H as [k'' v'' H' | k'' v'' H'].
      + inversion H'.
      + apply H'.
  Qed.

  (* Set Minus *)
  Inductive setminus (B C : T) : T :=
    contains_setminus : forall (k : K) (v : V),
      contains B k v /\ ~ contains C k v -> contains (setminus B C) k v.

  (* Remove *)
  Definition subtract (B : T) (k : K) (v : V) : T := setminus B (singleton k v).

  Lemma append_subtract : forall (B : T) (k : K) (v : V),
    contains B k v -> append (subtract B k v) k v = B.
  Proof.
    intros. apply extensionality. unfold eq. split; unfold subseteq.
    - intros k' v' H'. inversion H'.
      + inversion H0. apply H3.
      + inversion H0. subst k0 v0 k' v'. apply H.
    - intros k' v' H'. unfold append. unfold subtract.
      assert (H'' : (k = k' /\ v = v') \/ ~ (k = k' /\ v = v')).
      { apply classic. } inversion H'' as [H''l | H''r].
      + inversion H''l as [Hk Hv]. subst k' v'.
        apply union_r. apply singleton_contains.
      + apply union_l. apply contains_setminus. split; try apply H'.
        unfold not. intros Hf. inversion Hf. subst k' v'. unfold not in H''r.
        assert (Ht : k = k /\ v = v). { split; reflexivity. }
        apply H''r in Ht. apply Ht.
  Qed.

  Lemma decide_contains_subtract : forall (B : T) (k : K) (v : V),
    contains B k v -> exists A, append A k v = B /\ A = subtract B k v.
  Proof.
    intros. exists (subtract B k v). split; try reflexivity.
    apply append_subtract. apply H.
  Qed.

  Lemma decide_append : forall (B : T),
    B <> Ø ->
    exists (A : T) (k : K) (v : V), B = append A k v.
  Proof.
    intros. apply extensionality_contraposition in H. unfold eq in H.
    apply not_and_or in H. inversion H as [Hl | Hr].
    - unfold subseteq in Hl. apply not_all_ex_not in Hl.
      inversion Hl as [k Hl']. apply not_all_ex_not in Hl'.
      inversion Hl' as [v Hl'']. apply imply_to_and in Hl''.
      inversion Hl'' as [H' H'']. apply decide_contains_subtract in H'.
      inversion H' as [A HA]. inversion HA as [HAl HAr].
      exists A. exists k. exists v. rewrite -> HAl. reflexivity.
    - unfold subseteq in Hr. apply not_all_ex_not in Hr.
      inversion Hr as [k Hr']. apply not_all_ex_not in Hr'.
      inversion Hr' as [v Hr'']. apply not_imply_elim in Hr''.
      inversion Hr''.
  Qed.

  (* Contains Key *)
  Inductive contains_key : T -> K -> Prop :=
    contains_key_contains : forall (A : T) (k : K) (v : V),
      contains A k v -> contains_key A k.

  (* Duplicate Keys *)
  Inductive duplicated : T -> Prop :=
    duplicate_keys : forall (A : T) (k : K) (v v' : V),
      contains A k v -> contains A k v' -> v <> v' -> duplicated A.

  Definition well_defined (A : T) : Prop := ~ duplicated A.

  Lemma contains_unique : forall (A : T) (k : K),
    well_defined A -> contains_key A k -> (exists! (v : V), contains A k v).
  Proof.
    intros A k H H'. inversion H'. subst A0 k0. exists v. unfold unique. split.
    - apply H0.
    - intros v'. unfold well_defined in H. unfold not in H. intros.
      (* reductio ad absurdum *)
      assert (Hx : v = v' \/ v <> v'). { apply classic. }
      inversion Hx; try apply H2. assert (Hf : duplicated A).
      { eapply duplicate_keys. apply H0. apply H1. apply H2. }
      apply H in Hf. inversion Hf.
  Qed.

  (* Pair Uniqueness *)
  Lemma unique_append : forall (A : T) (k : K) (v : V),
    contains A k v -> append A k v = A.
  Proof.
    intros. apply extensionality. unfold eq. split; unfold subseteq; intros k' v'.
    - intros H'. unfold append in H'. inversion H'.
      + subst k0 v0. apply H0.
      + subst k0 v0. inversion H0. subst k' v'. apply H.
    - intros H'. unfold append. apply union_l. apply H'.
  Qed.

  (* Alloc *)


Require Import Reals.
Require Import Interval.Tactic.

Open Scope R_scope.

Goal
  forall x, -1 <= x <= 1 ->
  sqrt (1 - x) <= 3/2.
Proof.
  intros.
  interval.
Qed.

Goal
  forall x, -1 <= x <= 1 ->
  sqrt (1 - x) <= 141422/100000.
Proof.
  intros.
  interval.
Qed.

Goal
  forall x, -1 <= x <= 1 ->
  sqrt (1 - x) <= 141422/100000.
Proof.
  intros.
  interval_intro (sqrt (1 - x)) upper as H'.
  apply Rle_trans with (1 := H').
  interval.
Qed.

Goal
  forall x, 3/2 <= x <= 2 ->
  forall y, 1 <= y <= 33/32 ->
  Rabs (sqrt(1 + x/sqrt(x+y)) - 144/1000*x - 118/100) <= 71/32768.
Proof.
  intros.
  interval with (i_prec 19, i_bisect x).
Qed.

Goal
  forall x, 1/2 <= x <= 2 ->
  Rabs (sqrt x - (((((122 / 7397 * x + (-1733) / 13547) * x
                   + 529 / 1274) * x + (-767) / 999) * x
                   + 407 / 334) * x + 227 / 925))
    <= 5/65536.
Proof.
  intros.
  interval with (i_bisect x, i_taylor x, i_degree 3).
Qed.

Goal
  forall x, -1 <= x ->
  x < 1 + powerRZ x 3.
Proof.
  intros.
  apply Rminus_lt.
  interval with (i_bisect x, i_autodiff x).
Qed.

Require Import Coquelicot.Coquelicot.

Goal
  Rabs (RInt (fun x => atan (sqrt (x*x + 2)) / (sqrt (x*x + 2) * (x*x + 1))) 0 1
        - 5/96*PI*PI) <= 1/1000.
Proof.
  integral with (i_fuel 2, i_degree 5).
Qed.

Goal
  RInt_gen (fun x => 1 * (powerRZ x 3 * ln x^2))
           (at_right 0) (at_point 1) = 1/32.
Proof.
  refine ((fun H => Rle_antisym _ _ (proj2 H) (proj1 H)) _).
  integral.
Qed.

(*
Goal
  Rabs (RInt_gen (fun t => 1/sqrt t * exp (-(1*t)))
                 (at_point 1) (Rbar_locally p_infty)
        - 2788/10000) <= 1/1000.
Proof.
  interval.
Qed.
*)


Require Import Category.
Require Import Monoid.

(* given a monoid m, we define the data necessary to create a category *)

(* the source of any arrow is the identity of the monoid *)

Definition source_  (A:Type) (m:Monoid A) (x:A) : A := identity m.

Arguments source_ {A} _ _. (* type argument is inferred *)

(* the target of any arrow is the identity of the monoid *)

Definition target_  (A:Type) (m:Monoid A) (x:A) : A := identity m.

Arguments target_ {A} _ _. (* type argument is inferred *)

(* composition of arrows coincides with the monoid product *)

Definition compose_ (A:Type) (m:Monoid A) (x y: A) : option A :=
    Some (product m x y).

Arguments compose_ {A} _ _ _. (* type argument is inferred *)

(* source of source is source *)

Definition proof_ss_ (A:Type) (m:Monoid A) : forall f:A,
    source_ m (source_ m f) = source_ m f.
Proof. reflexivity. Qed.

(* target of source is source *)

Definition proof_ts_ (A:Type) (m:Monoid A) : forall f:A,
    target_ m (source_ m f) = source_ m f.
Proof. reflexivity. Qed.

(* target of target is target *)

Definition proof_tt_ (A:Type) (m:Monoid A) : forall f:A,
    target_ m (target_ m f) = target_ m f.
Proof. reflexivity. Qed.

(* source of target is target *)

Definition proof_st_ (A:Type) (m:Monoid A) : forall f:A,
    source_ m (target_ m f) = target_ m f.
Proof. reflexivity. Qed.

(* composition is defined iff target and source line up *)

Definition proof_dom_ (A:Type) (m:Monoid A) : forall f g:A,
    target_ m f = source_ m g <-> compose_ m f g <> None.
Proof.
    intros f g. split.
    - intros. discriminate.
    - intros. reflexivity.
Qed.

(* the source of composed arrow is source of first argument *)

Definition proof_src_ (A:Type) (m:Monoid A) : forall f g h: A,
    compose_ m f g = Some h -> source_ m h = source_ m f.
Proof. intros f g h H. clear H. reflexivity. Qed.

(* the target of composed arrow is target of second argument *)

Definition proof_tgt_ (A:Type) (m:Monoid A) : forall f g h: A,
    compose_ m f g = Some h -> target_ m h = target_ m g.
Proof. intros f g h H. clear H. reflexivity. Qed.

(* composing from the left with an object (= identity arrow) has no effect *)

Definition proof_idl_ (A:Type) (m:Monoid A) : forall a f: A,
    a = source_ m f -> compose_ m a f = Some f.
Proof.
    intros a f H.
    unfold compose_. unfold source_ in H. rewrite H.
    rewrite (proof_idl m). reflexivity.
Qed.

(* composing from the right with an object (= identity arrow) has no effect *)

Definition proof_idr_ (A:Type) (m:Monoid A) : forall a f: A,
    a = target_ m f -> compose_ m f a = Some f.
Proof.
    intros a f H.
    unfold compose_. unfold source_ in H. rewrite H.
    rewrite (proof_idr m). reflexivity.
Qed.

(* composition is associative *)

Definition proof_asc_ (A:Type) (m:Monoid A) : forall f g h fg gh: A,
    compose_ m f g = Some fg ->
    compose_ m g h = Some gh ->
    compose_ m f gh = compose_ m fg h.
Proof.
    intros f g h fg gh H H'. unfold compose_ in H. unfold compose_ in H'.
    injection H. clear H. intro H.
    injection H'. clear H'. intro H'.
    rewrite <- H. rewrite <- H'. unfold compose_.
    rewrite (proof_asc m). reflexivity.
Qed.

(* A monoid with support A, can be turned into a category with support A *)

Definition toCategory (A:Type) (m:Monoid A) : Category A := category
    (source_      m)
    (target_      m)
    (compose_     m)
    (proof_ss_  A m)
    (proof_ts_  A m)
    (proof_tt_  A m)
    (proof_st_  A m)
    (proof_dom_ A m)
    (proof_src_ A m)
    (proof_tgt_ A m)
    (proof_idl_ A m)
    (proof_idr_ A m)
    (proof_asc_ A m).

Arguments toCategory {A} _.


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

(* ** Two infinite sequences of primes *)

Require Import List Arith Lia Bool Permutation.

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

Set Implicit Arguments.

Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).

Set Implicit Arguments.

(* Unique decomposition with a prime *)

Lemma prime_neq_0 p : prime p -> p <> 0.
Proof.
  intros ? % prime_ge_2; lia.
Qed.

#[export] Hint Resolve prime_neq_0 : core.

Lemma power_factor_lt_neq p i j x y :
         p <> 0
      -> i < j
      -> ~ divides p x
      -> p^i * x <> p^j * y.
Proof.
  intros H1 H2 H3 H5.
  replace j with (i+S (j-i-1)) in H5 by lia.
  rewrite Nat.pow_add_r, <- Nat.mul_assoc in H5.
  rewrite Nat.mul_cancel_l in H5.
  2: apply Nat.pow_nonzero; auto.
  apply H3; subst x; simpl.
  do 2 apply divides_mult_r; apply divides_refl.
Qed.

Lemma power_factor_uniq p i j x y :
         p <> 0
      -> ~ divides p x
      -> ~ divides p y
      -> p^i * x = p^j * y
      -> i = j /\ x = y.
Proof.
  intros H1 H2 H3 H4.
  destruct (lt_eq_lt_dec i j) as [ [ H | H ] | H ].
  + exfalso; revert H4; apply power_factor_lt_neq; auto.
  + split; auto; subst j.
    rewrite Nat.mul_cancel_l in H4; auto.
    apply Nat.pow_nonzero; auto.
  + exfalso; symmetry in H4; revert H4; apply power_factor_lt_neq; auto.
Qed.

(* The unboundedness of primes *)

Lemma prime_above m : { p | m < p /\ prime p }.
Proof.
  destruct (prime_factor (n := fact m + 1)) as (p & ? & ?).
  - pose proof (lt_O_fact m); lia.
  - exists p; eauto. destruct (Nat.lt_ge_cases m p); eauto.
    eapply divides_plus_inv in H0.
    + eapply divides_1_inv in H0; subst. destruct H; lia.
    + eapply divides_fact. eapply prime_ge_2 in H; eauto.
Qed.

Lemma prime_dec p : { prime p } + { ~ prime p }.
Proof.
  destruct (le_lt_dec 2 p) as [ H | H ].
  + destruct (prime_or_div H) as [ (q & H1 & H2) | ? ]; auto.
    right; intros C; apply C in H2; lia.
  + right; intros (H1 & H2).
    destruct (H2 2); try lia.
    exists 0; simpl; lia.
Qed.

Lemma first_prime_above m : { p | m < p /\ prime p /\ forall q, m < q -> prime q -> p <= q }.
Proof.
  destruct min_dec with (P := fun p => m < p /\ prime p)
    as (p & H1 & H2).
  + intros n.
    destruct (lt_dec m n); destruct (prime_dec n); tauto.
  + destruct (prime_above m) as (p & ?); exists p; auto.
  + exists p; firstorder.
Qed.

Lemma prime_divides p q :
  prime p -> prime q -> divides p q -> p = q.
Proof.
  now intros Hp Hq [ [] % Hp | ] % Hq.
Qed.

Definition nxtprime n := proj1_sig (first_prime_above n).

Fact nxtprime_spec1 n : n < nxtprime n.
Proof. apply (proj2_sig (first_prime_above n)). Qed.

Fact nxtprime_spec2 n : prime (nxtprime n).
Proof. apply (proj2_sig (first_prime_above n)). Qed.

#[export] Hint Resolve nxtprime_spec1 nxtprime_spec2 prime_2 : core.

Fixpoint notprime_bool_rec n k :=
  match k with
    | 0   => true
    | S k' => negb (prime_bool n) && notprime_bool_rec (S n) k'
  end.

Theorem prime_bool_spec' p : prime_bool p = false <-> ~ prime p.
Proof.
  rewrite <- not_true_iff_false, prime_bool_spec; tauto.
Qed.

Fact notprime_bool_rec_spec n k : notprime_bool_rec n k = true <-> forall i, n <= i < k+n -> ~ prime i.
Proof.
  revert n; induction k as [ | k IHk ]; intros n; simpl.
  + split; auto; intros; lia.
  + rewrite andb_true_iff, negb_true_iff,
            <- not_true_iff_false, prime_bool_spec, IHk.
    split.
    * intros (H1 & H2) i Hi.
      destruct (eq_nat_dec n i); subst; auto.
      apply H2; lia.
    * intros H; split; intros; apply H; lia.
Qed.

Definition nxtprime_bool n p := Nat.leb (S n) p && notprime_bool_rec (S n) (p - S n) && prime_bool p.

Fact nxtprime_bool_spec n p : nxtprime_bool n p = true <-> nxtprime n = p.
Proof.
  unfold nxtprime_bool.
  rewrite !andb_true_iff, Nat.leb_le, notprime_bool_rec_spec, prime_bool_spec.
  unfold nxtprime.
  destruct (first_prime_above n) as (q & G1 & G2 & G3); simpl.
  split.
  + intros ((H1 & H2) & H3).
    apply Nat.le_antisymm.
    * apply G3; auto.
    * apply Nat.nlt_ge.
      intro; apply (H2 q); auto; lia.
  + intros ->; lsplit 2; auto.
    intros q Hq C; apply G3 in C; lia.
Qed.

Definition nthprime (n : nat) := iter nxtprime 2 n.

Lemma nthprime_prime n : prime (nthprime n).
Proof. unfold nthprime; destruct n; simpl; auto; rewrite iter_swap; auto. Qed.

#[export] Hint Resolve nthprime_prime : core.

Lemma nthprime_ge n m : n < m -> nthprime n < nthprime m.
Proof.
  unfold nthprime.
  induction 1; simpl iter; rewrite iter_swap; auto.
  apply Nat.lt_trans with (2 := nxtprime_spec1 _); auto.
Qed.

Lemma nthprime_inj n m : nthprime n = nthprime m -> n = m.
Proof.
  destruct (lt_eq_lt_dec n m) as [ [ H | ] | H ]; auto;
    intros; eapply nthprime_ge in H; lia.
Qed.

Fact nthprime_nxt i p q : nthprime i = p -> nxtprime p = q -> nthprime (S i) = q.
Proof.
  replace (S i) with (i+1) by lia.
  unfold nthprime at 2.
  rewrite iter_plus; fold (nthprime i).
  intros -> ?; simpl; auto.
Qed.

(* Certified Erastosthene sieve would be helpfull here *)

Fact nthprime_0 : nthprime 0 = 2.
Proof. auto. Qed.

Local Ltac nth_prime_tac H :=
  apply nthprime_nxt with (1 := H);
  apply nxtprime_bool_spec; auto.

Fact nthprime_1 : nthprime 1 = 3.    Proof. nth_prime_tac nthprime_0. Qed.
Fact nthprime_2 : nthprime 2 = 5.    Proof. nth_prime_tac nthprime_1. Qed.
Fact nthprime_3 : nthprime 3 = 7.    Proof. nth_prime_tac nthprime_2. Qed.
Fact nthprime_4 : nthprime 4 = 11.   Proof. nth_prime_tac nthprime_3. Qed.
Fact nthprime_5 : nthprime 5 = 13.   Proof. nth_prime_tac nthprime_4. Qed.
Fact nthprime_6 : nthprime 6 = 17.   Proof. nth_prime_tac nthprime_5. Qed.

Record primestream :=
  {
    str :> nat -> nat;
    str_inj : forall n m, str n = str m -> n = m;
    str_prime : forall n, prime (str n);
  }.

#[export] Hint Immediate str_prime : core.
#[export] Hint Resolve str_inj : core.

Lemma primestream_divides (ps : primestream) n m :  divides (ps n) (ps m) -> n = m.
Proof.
  destruct ps as [ str H1 H2 ]; simpl.
  intros ? % prime_divides; eauto.
Qed.

Definition ps : primestream.
Proof.
  exists (fun n => nthprime (2 * n)); auto.
  intros; apply nthprime_inj in H; lia.
Defined.

Fact ps_1 : ps 1 = 5.
Proof. simpl; apply nthprime_2. Qed.

Definition qs : primestream.
Proof.
  exists (fun n => nthprime (1 + 2 * n)); auto.
  intros; apply nthprime_inj in H; lia.
Defined.

Fact qs_1 : qs 1 = 7.
Proof. simpl; apply nthprime_3. Qed.

Lemma ps_qs : forall n m, ps n = qs m -> False.
Proof. intros ? ? ? % nthprime_inj; lia. Qed.

#[export] Hint Resolve ps_qs : core.

Lemma ps_qs_div n m : ~ divides (ps n) (qs m).
Proof. intros ? % prime_divides; eauto. Qed.

Lemma qs_ps_div n m : ~ divides (qs n) (ps m).
Proof. intros ? % prime_divides; eauto. Qed.

Fixpoint exp {n} (i : nat) (v : vec nat n) : nat :=
  match v with
    | vec_nil => 1
    | x##v    => qs i ^ x * exp (S i) v
  end.

Fact exp_nil i : exp i vec_nil = 1.
Proof. auto. Qed.

Fact exp_cons n i x v : @exp (S n) i (x##v) = qs i^x*exp (S i) v.
Proof. auto. Qed.

Fact exp_zero n i : @exp n i vec_zero = 1.
Proof.
  revert i; induction n as [ | n IHn ]; intros i; simpl; auto.
  rewrite IHn; ring.
Qed.

Fact exp_app n m i v w : @exp (n+m) i (vec_app v w) = exp i v * exp (n+i) w.
Proof.
  revert i; induction v as [ | x n v IHv ]; intros i.
  + rewrite vec_app_nil, exp_zero; simpl; ring.
  + rewrite vec_app_cons, exp_cons.
    simpl plus; rewrite exp_cons, IHv.
    replace (n+S i) with (S (n+i)) by lia; ring.
Qed.

Local Notation divides_mult_inv := prime_div_mult.

Lemma not_prime_1 : ~ prime 1.
Proof. intros [ [] ]; auto. Qed.

Lemma not_ps_1 n : ~ ps n = 1.
Proof.
  intros H; generalize (str_prime ps n).
  rewrite H; apply not_prime_1.
Qed.

Lemma not_qs_1 n : ~ qs n = 1.
Proof.
  intros H; generalize (str_prime qs n).
  rewrite H; apply not_prime_1.
Qed.

#[export] Hint Resolve not_prime_1 not_qs_1 : core.

Lemma divides_pow p n k : prime p -> divides p (n ^ k) -> divides p n.
Proof.
  induction k.
  - cbn; intros H H0 % divides_1_inv; subst; exfalso; revert H; apply not_prime_1.
  - cbn; intros ? [ | ] % divides_mult_inv; eauto.
Qed.

Opaque ps qs.

Lemma ps_exp n m (v : vec nat m) i : ~ divides (ps n) (exp i v).
Proof.
  revert i; induction v as [ | m x v IHv ]; intros i; simpl.
  - intros H % divides_1_inv; revert H; apply not_ps_1.
  - intros [H % divides_pow | ] % divides_mult_inv; eauto.
    + now eapply ps_qs_div in H.
    + eapply IHv; eauto.
Qed.

Coercion tonat {n} := @pos2nat n.

Lemma vec_prod_div m (v : vec nat m) (u0 : nat) (p : pos m) i :
    vec_pos v p = S u0 -> qs (p + i) * exp i (vec_change v p u0) = exp i v.
Proof.
  revert p i; induction v; intros p i; analyse pos p; simpl; intros H.
  - rewrite pos2nat_fst; subst; simpl; ring.
  - rewrite pos2nat_nxt; simpl.
    rewrite <- IHv with (1 := H).
    unfold tonat.
    replace (S (pos2nat p + i)) with (pos2nat p+S i); ring.
Qed.

Lemma qs_exp_div i j n v : i < j -> ~ divides (qs i) (@exp n j v).
Proof with eauto.
  revert i j; induction v; intros i j Hi.
  + cbn; intros ? % divides_1_inv % not_qs_1; auto.
  + cbn; intros [ H % divides_pow | H  ] % divides_mult_inv; eauto.
    * eapply primestream_divides in H; lia.
    * eapply IHv in H; eauto.
Qed.

Lemma qs_shift n m j k (v : vec nat k) :
  divides (qs n) (exp j v) <-> divides (qs (m + n)) (exp (m + j) v).
Proof.
  revert m n j; induction v as [ | x k v IHv ]; intros m n j.
  - cbn; split; intros ? % divides_1_inv % not_qs_1; tauto.
  - cbn. split.
    + intros [ | ] % divides_mult_inv; auto.
      * destruct x.
        -- cbn in H; revert H.
           intros ? % divides_1_inv % not_qs_1; tauto.
        -- eapply divides_pow in H; auto.
           eapply primestream_divides in H as ->.
           cbn; do 2 apply divides_mult_r; apply divides_refl.
      * eapply divides_mult.
        rewrite IHv with (m := m) in H.
        rewrite <- plus_n_Sm in H; auto.
    + intros [ | ] % divides_mult_inv; auto.
      * destruct x.
        -- cbn in H; revert H.
           intros ? % divides_1_inv % not_qs_1; tauto.
        -- eapply divides_pow in H; auto.
           eapply primestream_divides in H.
           assert (n = j) by lia. subst.
           cbn; do 2 apply divides_mult_r; apply divides_refl.
      * eapply divides_mult. replace (S (m + j)) with (m + S j) in H by lia.
        rewrite <- IHv in H. eauto.
Qed.

Lemma vec_prod_mult m v (u : pos m) i : @exp m i (vec_change v u (1 + vec_pos v u)) = qs (u + i) * exp i v.
Proof.
  revert i; induction v; analyse pos u; intros.
  + rewrite pos2nat_fst; simpl; ring.
  + rewrite pos2nat_nxt; simpl; rewrite IHv.
    unfold tonat.
    replace (pos2nat u+S i) with (S (pos2nat u+i)) by lia; ring.
Qed.

Lemma inv_exp q p1 p2 x y :
         q <> 0
      -> ~ divides q p1
      -> ~ divides q p2
      -> q ^ x * p1 = q ^ y * p2
      -> x = y.
Proof.
  intros H1 H2 H3 H4.
  apply power_factor_uniq in H4; tauto.
Qed.

Lemma exp_inj n i v1 v2 :
  @exp n i v1 = exp i v2 -> v1 = v2.
Proof.
  revert i v2; induction v1 as [ | x n v1 IH ]; intros i v2.
  + vec nil v2; auto.
  + vec split v2 with y.
    simpl; intros H.
    assert (forall v, ~ divides (qs i) (@exp n (S i) v)) as G.
    { intros v; apply qs_exp_div; auto. }
    apply power_factor_uniq in H; auto.
    destruct H; f_equal; subst; eauto.
Qed.

Lemma exp_inv_inc n u v1 :
  @exp n 0 (vec_change v1 u (S (vec_pos v1 u))) = qs u * exp 0 v1.
Proof.
  enough (forall i, exp i (vec_change v1 u (S (vec_pos v1 u))) = qs (i + u) * exp i v1). eapply H.
  induction v1 as [ | n x v1 IHv1 ]; analyse pos u; intros.
  + rewrite pos2nat_fst, Nat.add_0_r; cbn; ring.
  + intros; rewrite pos2nat_nxt; simpl; rewrite IHv1; unfold tonat.
    replace (S i+pos2nat u) with (i+S (pos2nat u)) by lia; ring.
Qed.


From mathcomp Require Import ssreflect.

Require Import img_example.
Require Import Coq.Sets.Relations_3_facts.

Section RelationExample.

Definition ID (U:Type): Relation U := fun x:U => fun y:U => x = y.
Definition ID' (U:Type): U -> U -> Prop := fun x:U => fun y:U => x = y.

Check (forall (U:Type) (x:U), (ID U x x)).

Check Equivalence.
Check ID.
Check ID'.

Check (forall (U:Type) (x:U), ID U x x).

Goal forall (U:Type), Equivalence U (ID U).
Proof.
  move => U.
  split.
  unfold Reflexive.
  move => x.
  unfold ID.
  reflexivity.
  unfold Transitive.
  move => x y z.
  unfold ID.
  move => H0 H1.
  rewrite H0.
  apply H1.
  unfold Symmetric.
  move => x y.
  unfold ID.
  move => H.
  rewrite H.
  reflexivity.
Qed.

Goal forall (U:Type), Equivalence U (ID' U).
Proof.
  move => U.
  split.
  unfold Reflexive.
  move => x.
  unfold ID'.
  reflexivity.
  unfold Transitive.
  move => x y z.
  unfold ID'.
  move => H0 H1.
  rewrite H0.
  apply H1.
  unfold Symmetric.
  move => x y.
  unfold ID'.
  move => H.
  rewrite H.
  reflexivity.
Qed.

End RelationExample.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf3 : natural) (lf2 : natural) : natural :=
  plus lf3 (Succ lf2).


Require Import List.
Set Implicit Arguments.

Section A_fixed.

Variable A: Type.

Inductive lfactor  : list A -> list A -> Prop :=
  | lf1 : forall u:list A, lfactor nil u
  | lf2 : forall (a:A) (u v:list A), lfactor u v ->
                                     lfactor (a :: u) (a :: v).

 Lemma lfactor_inv_head : forall a b  u v, lfactor (a::u) (b::v) ->
                                           a = b.
 Proof.
   now inversion_clear 1.
 Qed.

Definition lfactor_suffix :
  forall  u v:list A, lfactor u v -> {w : list A | v = u ++ w}.
 intros  u; induction  u as [| a u IHu].
 - intros v; now exists v.
 - intro v; case v.
    + intros Hf; exfalso; inversion_clear Hf.
    + intros b v' Hv';  generalize (lfactor_inv_head Hv'); intro;subst b.
      destruct (IHu v') as [w Hw].
      * now  inversion_clear Hv'.
      * exists w; rewrite Hw;auto.
Defined.

End A_fixed.


(* Cap. 1: Funciones y computación *)

From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.

(* =====================================================================
   § 1. Funciones
   ================================================================== *)

(* =====================================================================
   §§ 1.1. Definición de funciones y evaluación de expresiones
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      f : nat -> nat
   tal que (f n) es el sigiente de n. Por ejemplo,
      f 3 == 4.
   ------------------------------------------------------------------ *)

Definition f := fun n => n + 1.

(* ---------------------------------------------------------------------
   Ejercicio. Calcular información sobre la función `f`.
   ------------------------------------------------------------------ *)

About f.

(* Se obtiene
      f : nat -> nat

      f is not universe polymorphic
      Arguments f _%nat_scope
      f is transparent
      Expands to: Constant T1_Computacion.f
 *)

(* ---------------------------------------------------------------------
   Ejercicio. Obtener la definición de `f`.
   ------------------------------------------------------------------ *)

Print f.

(* Se obtiene
      f = addn^~ 1
           : nat -> nat

      Arguments f _%nat_scope
 *)

(* ---------------------------------------------------------------------
   Ejercicio. Obtener información sobre ^~
   ------------------------------------------------------------------ *)

Locate "_ ^~ _".

(* Se obtiene
      Notation "f ^~ y" := (fun x => f x y) : fun_scope (default interpretation)
 *)

(* ---------------------------------------------------------------------
   Ejercicio. Calcular el tipo de `f 3`.
   ------------------------------------------------------------------ *)

Check f 3.

(* Se obtiene
      f 3
           : nat
 *)

(* ---------------------------------------------------------------------
   Ejercicio. Calcular el valor de `f 3`.
   ------------------------------------------------------------------ *)

Eval compute in f 3.

(* Se obtiene
           = 4
           : nat
 *)

(* =====================================================================
   §§ 1.2 Funciones con varios argumentos
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      g : nat -> nat -> nat
   tal que (g n m) es n+m*2. Por ejemplo,
      g 4 5 = 14
   ------------------------------------------------------------------ *)

Definition g (n m : nat) : nat := n + m * 2.

Eval compute in g 4 5.

(* =====================================================================
   §§ 1.3. Funciones de orden superior
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      repeat_twice : (nat -> nat) -> nat -> nat
   tal que (repeat_twice g) es la función obtenida aplicando dos veces
   la función `g`. Por ejemplo,
      repeat_twice f 2 = 4
   ------------------------------------------------------------------ *)

Definition repeat_twice (g : nat -> nat) : nat -> nat :=
  fun x => g (g x).

Eval compute in repeat_twice f 2.

(* =====================================================================
   §§ 1.4. Definiciones locales
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejercicio. Calcular el valor de
      let n := 33 : nat in
      let e := n + n + n in
      e + e + e.
   ------------------------------------------------------------------ *)

Compute
  let n := 33 : nat in
  let e := n + n + n in
  e + e + e.

(* Se obtiene
         = 297
         : nat
*)

(* =====================================================================
   § 2. Tipos de datos
   ================================================================== *)

(* =====================================================================
   §§ 2.1. Valores booleanos
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejercicio. Calcular el tipo de `true`
   ------------------------------------------------------------------ *)

Check true.

(* Se obtiene
      true
           : bool
 *)

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      f23 : bool -> nat
   tal que (f23 b) es 2 si b es verdadero y 3 en caso contrario. Por
   ejemplo,
      Ejemplos
   ------------------------------------------------------------------ *)

Definition f23 b := if b then 2 else 3.

Eval compute in f23 true.  (* da 2 *)
Eval compute in f23 false. (* da 3*)

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      andb ; bool -> bool -> bool
   tal que (andb b1 b2) es la conjunción de b1 y b2. Por ejemplo,
      andb true false = false
   ------------------------------------------------------------------ *)

Definition andb b1 b2 := if b1 then b2 else false.

Eval compute in andb true false.

(* =====================================================================
   §§ 2.2. Números naturales
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      pred : nat -> nat
   tal que (pred n) es el predecesor de n. Por ejemplo,
      pred 6 = 5
   ------------------------------------------------------------------ *)

Definition pred n := if n is u.+1 then u else n.

Eval compute in pred 6. (* da 5 *)

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      pred5 : nat -> nat
   tal que (pred5 n) es n-5. Por ejemplo,
      pred5 8 = 3
      pred5 4 = 0
   ------------------------------------------------------------------ *)

Definition pred5 n :=
  if n is u.+1.+1.+1.+1.+1 then u else 0.

Eval compute in pred5 8. (* da 3 *)
Eval compute in pred5 4. (* da 0 *)

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      three_patterns : nat -> nat
   tal que (three_patterns) es n-5, si n >= 5, n-1 si n pertenece a
   {1,2,3,4] y 0 en caso contrario. Por ejemplo,
      Ejemplos
   ------------------------------------------------------------------ *)

Definition three_patterns n :=
  match n with
    u.+1.+1.+1.+1.+1 => u
  | v.+1 => v
  | 0 => n
  end.

Eval compute in three_patterns 8. (* da 3 *)
Eval compute in three_patterns 3. (* da 2 *)
Eval compute in three_patterns 0. (* da 0 *)

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      same_bool : bool -> bool -> bool
   tal que (same_bool b1 b2) se verifica si b1 y b2 son iguales. Por
   ejemplo,
   ------------------------------------------------------------------ *)

Definition same_bool b1 b2 :=
  match b1, b2 with
  | true, true => true
  | _, _ => false
  end.

Definition same_bool2 b1 b2 :=
  match b1 with
  | true => match b2 with true => true | _ => false end
  | _ => false
  end.

(* =====================================================================
   §§ 2.3. Recursión sobre los números naturales
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      addn : nat -> nat -> nat
   tal que (addn n m) es la suma de n y m. Por ejemplo,
      addn 2 3 = 5
   ------------------------------------------------------------------ *)

Fixpoint addn n m :=
  if n is p.+1 then (addn p m).+1 else m.

Fixpoint addn2 n m :=
  match n with
  | 0 => m
  | p.+1 => (addn2 p m).+1
  end.

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      subn : nat -> nat -> nat
   tal que (subn m n) es m menos n. Por ejemplo,
      subn 5 3 = 2
      subn 3 5 = 0
   ------------------------------------------------------------------ *)

Fixpoint subn m n : nat :=
  match m, n with
  | p.+1, q.+1 => subn p q
  | _ , _ => m
  end.

Eval compute in subn 5 3. (* da 2 *)
Eval compute in subn 3 5. (* da 0 *)

(* ---------------------------------------------------------------------
   Ejercicio. Definir la función
      eqn : nat -> nat -> bool
   tal que (eqn m n) que se verifica si m y n son iguales. Por ejemplo,
      eqn 2 2 = true
      eqn 2 3 = false

   Usar la notación `x == y` para `eqn x y`.
   ------------------------------------------------------------------ *)

Fixpoint eqn m n :=
  match m, n with
  | 0, 0 => true
  | p.+1, q.+1 => eqn p q
  | _, _ => false
  end.
Notation "x == y" := (eqn x y).

Eval compute in 2 == 2. (* da true *)
Eval compute in 2 == 3. (* da false *)

Compute 2 == 2. (* da true *)
Compute 2 == 3. (* da false *)

(* =====================================================================
   § 3. Contenedores
   ================================================================== *)

About cons.
Check cons 2 nil.
Check 1 :: 2 :: 3 :: nil.
Check fun l => 1 :: 2 :: 3 :: l.
Definition first_element_or_0 (s : seq nat) :=
  if s is a :: _ then a else 0.

Fixpoint size A (s : seq A) :=
  if s is _ :: tl then (size tl).+1 else 0.
Fixpoint map A B (f : A -> B) s :=
  if s is e :: tl then f e :: map f tl else nil.
Eval compute in [seq i.+1 | i <- [:: 2; 3]].
Check (3, false).
Eval compute in (true, false).1.

Definition only_odd (n : nat) : option nat :=
  if odd n then Some n else None.

Definition ohead (A : Type) (s : seq A) :=
  if s is x :: _ then Some x else None.

(* section *)
Section iterators.
 Variables (T : Type) (A : Type).
 Variables (f : T -> A -> A).
 Implicit Type x : T.
 Fixpoint iter n op x :=
   if n is p.+1 then op (iter p op x) else x.
 Fixpoint foldr a s :=
   if s is x :: xs then f x (foldr a xs) else a.
 About foldr.
 Variable init : A.
 Variables x1 x2 x3 : T.
  Eval compute in foldr init [:: x1; x2; x3].
End iterators.
About iter.
About foldr.
Eval compute in iter 5 pred 7.
Eval compute in foldr addn 0 [:: 1; 2; 3].
Fixpoint addn_alt m n := if m is u.+1 then addn_alt u n.+1 else n.
Section symbolic.
  Variable n : nat.
  Eval simpl in pred (addn_alt n.+1 7).
  Eval simpl in pred (addn n.+1 7).
End symbolic.

(* iterated ops *)
Fixpoint iota m n := if n is u.+1 then m :: iota m.+1 u else [::].
Notation "\sum_ ( m <= i < n ) F" :=
  (foldr (fun i a => F + a) 0 (iota m (n-m))).
Eval compute in \sum_( 1 <= i < 5 ) (i * 2 - 1).
Eval compute in \sum_( 1 <= i < 5 ) i.

(* aggregated data *)
Record point := Point { x : nat; y : nat; z : nat }.
Eval compute in x (Point 3 0 2).
Eval compute in y (Point 3 0 2).

(** Exercises *************************************** *)

Module exercises.
(* pair *)

Eval compute in fst (4,5).

(* iter add *)
Definition addn n1 n2 := iter n1 S n2.

Eval compute in addn 3 4.

(* iter mul *)
Definition muln n1 n2 := iter n1 (addn n2) 0.

Eval compute in muln 3 4.

(* nth *)
Fixpoint nth T (def : T) (s : seq T) n :=
  if s is x :: s' then if n is n'.+1 then nth def s' n' else x else def.

Eval compute in nth 0 [:: 3; 7; 11; 22] 2.
Eval compute in nth 0 [:: 3; 7; 11; 22] 7.

(* rev *)
Fixpoint catrev T (s1 s2 : seq T) :=
  if s1 is x :: xs then catrev xs (x :: s2) else s2.

Definition rev T (s : seq T) := catrev s [::].

Eval compute in rev [:: 1; 2; 3].

(* flatten *)
Definition flatten T (s : seq (seq T)) := foldr cat [::] s.

Eval compute in
  flatten [:: [:: 1; 2; 3]; [:: 4; 5] ].

(* all_words *)
Definition all_words n T (alphabet : seq T) :=
  let prepend x wl := [seq x :: w | w <- wl] in
  let extend wl := flatten [seq prepend x wl | x <- alphabet] in
  iter n extend [::[::]].

Eval compute in all_words 2 [:: 1; 2; 3].

End exercises.


(* Exercise 69 *)

Require Import BenB.

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

Theorem exercise_069 : (exists x : D, ~ P x) -> ~ (forall x : D, P x).
Proof.
imp_i a1.
neg_i (1=1) a2.
exi_e (exists x:D, ~P x) a a3.
hyp a1.
neg_e (P a).
hyp a3.
all_e (forall x:D, P x) a.
hyp a2.
lin_solve.
Qed.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := nil : Lst | cons : Nat -> Lst -> Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Theorem theorem0 : forall (x : Lst) (y : Nat) (z : Lst), eq (append (append x (cons y nil)) z) (append x (cons y z)).
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.


(* Software Foundations *)
(* Exercice 3 stars, beq_nat_sym *)

Lemma nat_eqb_succ: forall n m: nat,
  Nat.eqb (S n) (S m) = Nat.eqb n m.
Proof.
    intros. simpl. reflexivity.
Qed.

Theorem beq_nat_sym : forall (n m : nat), Nat.eqb n m=Nat.eqb m n.
Proof.
    induction n as [|n']. induction m as [|m'].
    simpl. reflexivity.
    simpl. reflexivity.
    intros. simpl. destruct m as [|m'].
    simpl. reflexivity. rewrite nat_eqb_succ. apply IHn'.
Qed.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_collinear_ABC_ABD_BCD.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_collinear_ABC_ABD_ABE_CDE :
	forall A B C D E,
	neq A B ->
	Col A B C ->
	Col A B D ->
	Col A B E ->
	Col C D E.
Proof.
	intros A B C D E.
	intros neq_A_B.
	intros Col_A_B_C.
	intros Col_A_B_D.
	intros Col_A_B_E.

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_A_B_C Col_A_B_D neq_A_B) as Col_B_C_D.
	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_A_B_C Col_A_B_E neq_A_B) as Col_B_C_E.
	assert (eq B C \/ neq B C) as [eq_B_C|neq_B_C] by (apply Classical_Prop.classic).
	{
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_A_B_D Col_A_B_E neq_A_B) as Col_B_D_E.
		assert (Col C D E) as Col_C_D_E by (rewrite <- eq_B_C; exact Col_B_D_E).
		exact Col_C_D_E.
	}
	{
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_B_C_D Col_B_C_E neq_B_C) as Col_C_D_E.
		exact Col_C_D_E.
	}
Qed.

End Euclid.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf3 : natural) (lf2 : natural) : natural :=
  plus (Succ lf3) lf2.


(* コンストラクタの名前は例えば、SOとSにするとよい。 *)
Inductive pos : Set :=
  | SO : pos
  | S  : pos -> pos
  (* posの定義を書く *) .

Fixpoint plus(n m:pos) : pos :=
  match n with
  | SO => S m
  | S p => S (plus p m)
  end.

Infix "+" := plus.

Theorem plus_assoc : forall n m p, n + (m + p) = (n + m) + p.
Proof.
  intros.
  induction n.
  simpl.
  reflexivity.
  simpl.
  rewrite IHn.
  reflexivity.
Qed.


Require Export Basics.

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  (* WORKED IN CLASS *)
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)
    simpl. reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity. Qed.

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

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

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

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

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

Lemma double_plus : forall n, double n = n + n .
Proof.
  intros n. induction n as [| n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'. rewrite -> plus_n_Sm. reflexivity.
Qed.

Theorem evenb_S : forall n : nat,
  evenb (S n) = negb (evenb n).
Proof.
  intros n. induction n as [| n' IHn'].
  - simpl. reflexivity.
  - rewrite -> IHn'. simpl. rewrite -> negb_involutive. reflexivity.
Qed.

(******************************* Proof within Proofs ***************************)

(* why can't rewrite recur down the tree? *)
Theorem plus_rearrange_firsttry : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  (* We just need to swap (n + m) for (m + n)... seems
     like plus_comm should do the trick! *)
  rewrite -> plus_comm.
  (* Doesn't work...Coq rewrote the wrong plus! *)
Abort.

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
  { rewrite -> plus_comm. reflexivity. }
  rewrite -> H. reflexivity. Qed.

(************************* Formal vs Informal Proofs ***************************)
Theorem plus_assoc'' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n' IHn'].
  - (* n = 0 *)
    reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity. Qed.

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  assert (n + p = p + n) as H.
    rewrite plus_comm. simpl. reflexivity.
  rewrite plus_comm.
rewrite -> H. rewrite plus_assoc. simpl. reflexivity. Qed.

Theorem mult_n_Sm : forall n m : nat,
  n * S m = n + n * m.
Proof.
  intros. induction n as [].
  - simpl. reflexivity.
  - simpl. rewrite IHn. rewrite <- plus_swap. reflexivity. Qed.

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  intros. induction n as [].
  - simpl. apply mult_0_r.
  - rewrite -> mult_n_Sm. simpl. rewrite -> IHn. reflexivity. Qed.
(** [] *)

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

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  intros n m p. induction n as [].
  - reflexivity.
  - simpl. rewrite IHn. rewrite mult_plus_distr_r. reflexivity. Qed.