(**************************************************************************)
(**  Mechanised Framework for Local Interactions & Distributed Algorithms

     P. Courtieu, L. Rieg, X. Urbain

     PACTOLE project

     This file is distributed under the terms of the CeCILL-C licence
                                                                          *)
(**************************************************************************)

Require Import SetoidDec SetoidList.
Require Import Arith_base.
Require Import Lia.
Require Import Pactole.Util.Coqlib.

Set Implicit Arguments.
Typeclasses eauto := (bfs).

(* TODO: should we add a fold operator? *)
(* FIXME: change the equalities to use equiv and the Setoid class *)

(** Finite sets as a prefix of natural numbers. *)
Notation "'fin' N" := {n : nat | n < N} (at level 10).

Lemma subset_dec : forall N (x y : fin N), {x = y} + {x <> y}.
Proof using .
intros N [x Hx] [y Hy]. destruct (Nat.eq_dec x y).
+ subst. left. f_equal. apply le_unique.
+ right. intro Habs. inv Habs. auto.
Qed.

Lemma eq_proj1 : forall N (x y : fin N), proj1_sig x = proj1_sig y -> x = y.
Proof using . intros N [x Hx] [y Hy] ?. simpl in *. subst. f_equal. apply le_unique. Qed.

Program Fixpoint build_enum N k (Hle : k <= N) acc : list (fin N) :=
  match k with
    | 0 => acc
    | S m => @build_enum N m _ (exist (fun x => x < N) m _ :: acc)
  end.
Next Obligation.
lia.
Qed.

(** A list containing all elements of [fin N]. *)
Definition enum N : list (fin N) := build_enum (Nat.le_refl N) nil.

(** Specification of [enum]. *)
Lemma In_build_enum : forall N k (Hle : k <= N) l x, In x (build_enum Hle l) <-> In x l \/ proj1_sig x < k.
Proof using .
intros N k. induction k; intros Hle l x; simpl.
+ intuition.
+ rewrite IHk. simpl. split; intro Hin.
  - destruct Hin as [[Hin | Hin] | Hin]; intuition; [].
    subst. simpl. right. lia.
  - destruct Hin as [Hin | Hin]; intuition; [].
    assert (Hcase : proj1_sig x < k \/ proj1_sig x = k) by lia.
    destruct Hcase as [Hcase | Hcase]; intuition; [].
    subst. do 2 left. destruct x; f_equal; simpl in *. apply le_unique.
Qed.

Lemma In_enum : forall N x, In x (enum N) <-> proj1_sig x < N.
Proof using . intros. unfold enum. rewrite In_build_enum. simpl. intuition. Qed.

(** Length of [enum]. *)
Lemma build_enum_length : forall N k (Hle : k <= N) l, length (build_enum Hle l) = k + length l.
Proof using .
intros N k. induction k; intros Hle l; simpl.
+ reflexivity.
+ rewrite IHk. simpl. lia.
Qed.

Lemma enum_length : forall N, length (enum N) = N.
Proof using . intro. unfold enum. now rewrite build_enum_length. Qed.

(** [enum] does not contain duplicates. *)
Lemma build_enum_NoDup : forall N k (Hle : k <= N) l,
  (forall x, In x l -> k <= proj1_sig x) -> NoDup l -> NoDup (build_enum Hle l).
Proof using .
intros N k. induction k; intros Hle l Hin Hl; simpl; auto; [].
apply IHk.
+ intros x [Hx | Hx].
  - now subst.
  - apply Hin in Hx. lia.
+ constructor; trivial; [].
  intro Habs. apply Hin in Habs. simpl in Habs. lia.
Qed.

Lemma enum_NoDup : forall N, NoDup (enum N).
Proof using . intro. unfold enum. apply build_enum_NoDup; simpl; intuition; constructor. Qed.

(** [enum] is sorted in increasing order. *)
Notation Flt := (fun x y => lt (proj1_sig x) (proj1_sig y)).

Lemma build_enum_Sorted : forall N k (Hle : k <= N) l,
  (forall x, In x l -> k <= proj1_sig x) -> Sorted Flt l -> Sorted Flt (build_enum Hle l).
Proof using .
intros N k. induction k; intros Hle l Hin Hl; simpl; auto; [].
apply IHk.
+ intros x [Hx | Hx].
  - now subst.
  - apply Hin in Hx. lia.
+ constructor; trivial; [].
  destruct l; constructor; []. simpl. apply Hin. now left.
Qed.

Lemma enum_Sorted : forall N, Sorted Flt (enum N).
Proof using . intro. unfold enum. apply build_enum_Sorted; simpl; intuition. Qed.

(** Extensional equality of functions is decidable over finite domains. *)
Lemma build_enum_app_nil : forall N k (Hle : k <= N) l,
  build_enum Hle l = build_enum Hle nil ++ l.
Proof using .
intros N k. induction k; intros Hle l; simpl.
+ reflexivity.
+ now rewrite (IHk _ (_ :: nil)), IHk, <- app_assoc.
Qed.

Theorem build_enum_eq : forall {A} eqA N (f g : fin N -> A) k (Hle : k <= N) l,
  eqlistA eqA (List.map f (build_enum Hle l)) (List.map g (build_enum Hle l)) ->
  forall x, proj1_sig x < k -> eqA (f x) (g x).
Proof using .
intros A eqA N f g k. induction k; intros Hle l Heq x Hx; simpl.
* destruct x; simpl in *; lia.
* assert (Hlt : k <= N) by lia.
  assert (Hcase : proj1_sig x < k \/ proj1_sig x = k) by lia.
  destruct Hcase as [Hcase | Hcase].
  + apply IHk with (x := x) in Heq; auto.
  + subst k. simpl in Heq. rewrite build_enum_app_nil, map_app, map_app in Heq.
    destruct (eqlistA_app_split _ _ _ _ Heq) as [_ Heq'].
    - now do 2 rewrite map_length, build_enum_length.
    - simpl in Heq'. inv Heq'.
      assert (Heqx : x = exist (fun x => x < N) (proj1_sig x) Hle).
      { clear. destruct x; simpl. f_equal. apply le_unique. }
      now rewrite Heqx.
Qed.

Corollary enum_eq : forall {A} eqA N (f g : fin N -> A),
  eqlistA eqA (List.map f (enum N)) (List.map g (enum N)) -> forall x, eqA (f x) (g x).
Proof using .
unfold enum. intros A eqA N f g Heq x.
apply build_enum_eq with (x := x) in Heq; auto; []. apply proj2_sig.
Qed.

(** Cutting [enum] after some number of elements. *)
Lemma firstn_build_enum_le : forall N k (Hle : k <= N) l k' (Hk : k' <= N), k' <= k ->
  firstn k' (build_enum Hle l) = @build_enum N k' Hk nil.
Proof using .
intros N k. induction k; intros Hk l k' Hk' Hle.
* assert (k' = 0) by lia. now subst.
* rewrite build_enum_app_nil, firstn_app, build_enum_length.
  replace (k' - (S k + length (@nil (fin N)))) with 0 by lia.
  rewrite app_nil_r.
  destruct (Nat.eq_dec k' (S k)) as [Heq | Heq].
  + subst k'. rewrite firstn_all2.
    - f_equal. apply le_unique.
    - rewrite build_enum_length. simpl. lia.
  + simpl build_enum. erewrite IHk.
    - f_equal.
    - lia.
Qed.

Lemma firstn_build_enum_lt : forall N k (Hle : k <= N) l k', k <= k' ->
  firstn k' (build_enum Hle l) = build_enum Hle (firstn (k' - k) l).
Proof using .
intros N k. induction k; intros Hle l k' Hk.
+ now rewrite Nat.sub_0_r.
+ rewrite build_enum_app_nil, firstn_app, build_enum_length, Nat.add_0_r.
  rewrite firstn_all2, <- build_enum_app_nil; trivial; [].
  rewrite build_enum_length. simpl. lia.
Qed.

Lemma firstn_enum_le : forall N k (Hle : k <= N), firstn k (enum N) = build_enum Hle nil.
Proof using . intros. unfold enum. now apply firstn_build_enum_le. Qed.

Lemma firstn_enum_lt : forall N k, N <= k -> firstn k (enum N) = enum N.
Proof using . intros. unfold enum. now rewrite firstn_build_enum_lt, firstn_nil. Qed.

Lemma firstn_enum_spec : forall N k x, In x (firstn k (enum N)) <-> proj1_sig x < k.
Proof using .
intros N k x. destruct (le_lt_dec k N) as [Hle | Hlt].
+ rewrite (firstn_enum_le Hle), In_build_enum. simpl. intuition.
+ rewrite (firstn_enum_lt (lt_le_weak _ _ Hlt)).
  split; intro Hin.
  - transitivity N; trivial; []. apply proj2_sig.
  - apply In_enum, proj2_sig.
Qed.

(** Removing some number of elements from the head of [enum]. *)
Lemma skipn_build_enum_lt : forall N k (Hle : k <= N) l k', k <= k' ->
  skipn k' (build_enum Hle l) = skipn (k' - k) l.
Proof using .
intros N k Hle l k' Hk'. apply app_inv_head with (firstn k' (build_enum Hle l)).
rewrite firstn_skipn, firstn_build_enum_lt; trivial; [].
rewrite (build_enum_app_nil Hle (firstn _ _)).
now rewrite build_enum_app_nil, <- app_assoc, firstn_skipn.
Qed.

Lemma skipn_enum_lt : forall N k, N <= k -> skipn k (enum N) = nil.
Proof using . intros. unfold enum. now rewrite skipn_build_enum_lt, skipn_nil. Qed.

Lemma skipn_enum_spec : forall N k x, In x (skipn k (enum N)) <-> k <= proj1_sig x < N.
Proof using .
intros N k x. split; intro Hin.
+ assert (Hin' : ~In x (firstn k (enum N))).
  { intro Habs. rewrite <- InA_Leibniz in *. revert x Habs Hin. apply NoDupA_app_iff; autoclass; [].
    rewrite firstn_skipn. rewrite NoDupA_Leibniz. apply enum_NoDup. }
  rewrite firstn_enum_spec in Hin'. split; auto with zarith; []. apply proj2_sig.
+ assert (Hin' : In x (enum N)) by apply In_enum, proj2_sig.
  rewrite <- (firstn_skipn k), in_app_iff, firstn_enum_spec in Hin'. intuition lia.
Qed.

(** ** Byzantine Robots *)

(** We have finitely many robots. Some are good, others are Byzantine.
    Both are represented by an abtract type that can be enumerated. *)
Class Names := {
  (** Number of good and Byzantine robots *)
  nG : nat;
  nB : nat;
  (** Types representing good and Byzantine robots *)
  G : Type;
  B : Type;
  (** Enumerations of robots *)
  Gnames : list G;
  Bnames : list B;
  (** The enumerations are complete and without duplicates *)
  In_Gnames : forall g : G, In g Gnames;
  In_Bnames : forall b : B, In b Bnames;
  Gnames_NoDup : NoDup Gnames;
  Bnames_NoDup : NoDup Bnames;
  (** There is the right amount of robots *)
  Gnames_length : length Gnames = nG;
  Bnames_length : length Bnames = nB;
  (** We can tell robots apart *)
  Geq_dec : forall g g' : G, {g = g'} + {g <> g'};
  Beq_dec : forall b b' : B, {b = b'} + {b <> b'};
  (** Being a finite type, extensional function equality is decidable *)
  fun_Gnames_eq : forall {A : Type} eqA f g,
    @eqlistA A eqA (List.map f Gnames) (List.map g Gnames) -> forall x, eqA (f x) (g x);
  fun_Bnames_eq : forall {A : Type} eqA f g,
    @eqlistA A eqA (List.map f Bnames) (List.map g Bnames) -> forall x, eqA (f x) (g x)}.

Global Opaque In_Gnames In_Bnames Gnames_NoDup Bnames_NoDup
              Gnames_length Bnames_length Geq_dec Beq_dec fun_Gnames_eq fun_Bnames_eq.

(** Identifiers make good and Byzantine robots undistinguishable.
    They have their own enumeration without duplicates,
    and both equality and extensional function equality are decidable. *)
Inductive ident `{Names} : Type :=
  | Good (g : G)
  | Byz (b : B).

Definition names `{Names} : list ident := List.map Good Gnames ++ List.map Byz Bnames.

Lemma In_names `{Names} : forall r : ident, In r names.
Proof using .
intro r. cbn. unfold names. rewrite in_app_iff. destruct r as [g | b].
- left. apply in_map, In_Gnames.
- right. apply in_map, In_Bnames.
Qed.

Lemma names_NoDup `{Names} : NoDup names.
Proof using .
unfold names. rewrite <- NoDupA_Leibniz. apply (NoDupA_app _).
+ apply (map_injective_NoDupA _ _).
  - now repeat intro; hnf in *; subst.
  - intros ? ? Heq. now inversion Heq.
  - rewrite NoDupA_Leibniz. apply Gnames_NoDup.
+ apply (map_injective_NoDupA _ _).
  - now repeat intro; hnf in *; subst.
  - intros ? ? Heq. now inversion Heq.
  - rewrite NoDupA_Leibniz. apply Bnames_NoDup.
+ intros id HinA HinB. rewrite (InA_map_iff _ _) in HinA. rewrite (InA_map_iff _ _) in HinB.
  - destruct HinA as [? [? ?]], HinB as [? [? ?]]. subst. discriminate.
  - now repeat intro; hnf in *; subst.
  - now repeat intro; hnf in *; subst.
Qed.

Lemma names_length `{Names} : length names = nG + nB.
Proof using . unfold names. now rewrite app_length, map_length, map_length, Gnames_length, Bnames_length. Qed.

Lemma names_eq_dec `{Names} : forall id id' : ident, {id = id'} + { id <> id'}.
Proof using .
intros id id'.
destruct id as [g | b], id' as [g' | b']; try (now right; discriminate); [|].
+ destruct (Geq_dec g g').
  - left; subst; auto.
  - right; intro Habs. now injection Habs.
+ destruct (Beq_dec b b').
  - left; subst; auto.
  - right; intro Habs. now injection Habs.
Qed.

Instance ident_Setoid `{Names} : Setoid ident := { equiv := eq; setoid_equiv := eq_equivalence }.
Instance ident_EqDec `{Names} : EqDec ident_Setoid := names_eq_dec.

Instance fun_refl `{Names} : forall A (f : ident -> A) R,
  Reflexive R -> Proper (@SetoidClass.equiv ident _ ==> R) f.
Proof using . intros A f R HR ? ? Heq. simpl in Heq. now subst. Qed.

Instance list_ident_Setoid `{Names} : Setoid (list ident) := { equiv := eq; setoid_equiv := eq_equivalence }.
Instance list_ident_Eqdec `{Names} : EqDec list_ident_Setoid := list_eq_dec ident_EqDec.

Lemma fun_names_eq `{Names} : forall {A : Type} eqA f g,
  @eqlistA A eqA (List.map f names) (List.map g names) -> forall x, eqA (f x) (g x).
Proof using .
intros A eqA f h Heq id.
unfold names in Heq. repeat rewrite ?map_app, map_map in Heq. apply eqlistA_app_split in Heq.
+ destruct id as [g | b].
  - change (eqA ((fun x => f (Good x)) g) ((fun x => h (Good x)) g)). apply fun_Gnames_eq, Heq.
  - change (eqA ((fun x => f (Byz x)) b) ((fun x => h (Byz x)) b)). apply fun_Bnames_eq, Heq.
+ now do 2 rewrite map_length.
Qed.

(** Given a number of good and byzntine robots, we can build canonical names.
    It is not declared as a global instance to avoid creating spurious settings. *)
Definition Robots (n m : nat) : Names.
Proof.
refine {|
  nG := n;
  nB := m;
  G := fin n;
  B := fin m;
  Gnames := enum n;
  Bnames := enum m |}.
+ abstract (intro g; apply In_enum, proj2_sig).
+ abstract (intro b; apply In_enum, proj2_sig).
+ apply enum_NoDup.
+ apply enum_NoDup.
+ apply enum_length.
+ apply enum_length.
+ apply subset_dec.
+ apply subset_dec.
+ intros ? ?. apply enum_eq.
+ intros ? ?. apply enum_eq.
Defined.

Global Opaque G B.


(** CS6225 -- Problem Set 3a (100 points) *)

(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 1 *)

Require Import Frap.

(* Authors:
 * Peng Wang (wangpeng@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu),
 * Joonwon Choi (joonwonc@csail.mit.edu),
 * Benjamin Sherman (sherman@csail.mit.edu)
 *)

(* In this assignment, we will work with a simple language
 * of imperative arithmetic programs that sequentially apply operations
 * to a natural-number-valued state.

 * The [Prog] datatype defines abstract syntax trees for this language.
 *)

Inductive Prog :=
  | Done                             (* Don't modify the state. *)
  | AddThen (n : nat) (p : Prog)     (* Add [n] to the state, then run [p]. *)
  | MulThen (n : nat) (p : Prog)     (* Multiply the state by [n], then run [p]. *)
  | SetToThen (n : nat) (p : Prog)   (* Set the state to [n], then run [p]. *)
  .

(* Your job is to define a module implementing the following
 * signature.  We ask you to implement a file Pset3a.v, where the skeleton is
 * already given, such that it can be checked against this signature by
 * successfully processing a third file (Pset3aCheck.v) with a command like so:
 * <<
    Require Pset3aSig Pset3a.

    Module M : Pset3aSig.S := Pset3a.
   >>
 * You'll need to build your module first, which the default target of our
 * handy Makefile does for you automatically. Just issue [make] in this
 * directory.
 *
 * Note that the _CoqProject file included here is also important for making
 * compilation and interactive editing work.  Your Pset3a.v file is what you
 * upload to the course web site to get credit for doing the assignment.
 *)

(* Finally, here's the actual signature to implement. *)
Module Type S.

  (* Define [run] such that [run p n] gives the final state
   * that running the program [p] should result in, when the
   * initial state is [n].
   *)
  Parameter run : Prog -> nat -> nat.
  (* 10 points *)

  Axiom run_Example1 : run Done 0 = 0.
  Axiom run_Example2 : run (MulThen 5 (AddThen 2 Done)) 1 = 7.
  Axiom run_Example3 : run (SetToThen 3 (MulThen 2 Done)) 10 = 6.
  (* 10 points *)

  (* Define [numInstructions] to compute the number of instructions
   * in a program, not counting [Done] as an instruction.
   *)
  Parameter numInstructions : Prog -> nat.
  (* 10 points *)

  Axiom numInstructions_Example :
    numInstructions (MulThen 5 (AddThen 2 Done)) = 2.
  (* 10 points *)

  (* Define [concatProg] such that [concatProg p1 p2] is the program
   * that first runs [p1] and then runs [p2].
   *)
  Parameter concatProg : Prog -> Prog -> Prog.
  (* 10 points *)

  Axiom concatProg_Example :
     concatProg (AddThen 1 Done) (MulThen 2 Done)
   = AddThen 1 (MulThen 2 Done).
  (* 10 points *)

  (* Prove that the number of instructions in the concatenation of
   * two programs is the sum of the number of instructions in each
   * program.
   *)
  Axiom concatProg_numInstructions : forall p1 p2,
      numInstructions (concatProg p1 p2)
      = numInstructions p1 + numInstructions p2.
  (* 20 points *)

  (* Prove that running the concatenation of [p1] with [p2] is
     equivalent to running [p1] and then running [p2] on the
     result. *)
  Axiom concatProg_run : forall p1 p2 initState,
      run (concatProg p1 p2) initState =
      run p2 (run p1 initState).
  (* 20 points *)
End S.


From Nominal Require Export Prelude.

(** *Group operations *)
Class Neutral A := neutral : A.
#[global] Hint Mode Neutral ! : typeclass_instances.
Notation ɛ := neutral.
Notation "ɛ@{ A }" := (@neutral A _) (only parsing) : nominal_scope.

Class Operator A := op: A → A → A.
#[global] Hint Mode Operator ! : typeclass_instances.
Instance: Params (@op) 2 := {}.

Infix "+" := op : nominal_scope.
Notation "(+)" := op (only parsing) : nominal_scope.
Notation "(+ x )" := (op x) (only parsing) : nominal_scope.
Notation "( x +)" := (λ y, op y x) (only parsing) : nominal_scope.

Class Inverse A := inv : A → A.
#[global] Hint Mode Inverse ! : typeclass_instances.
Instance: Params (@inv) 1 := {}.

Notation "- x" := (inv x) : nominal_scope.
Notation "(-)" := inv (only parsing) : nominal_scope.
Notation "x - y" := (x + (-y))%nom : nominal_scope.

Class Group (A : Type) `{Ntr: Neutral A, Opr: Operator A, Inv: Inverse A, Equiv A} : Prop := {
  grp_setoid :> Equivalence(≡@{A});
  grp_op_proper :> Proper ((≡@{A}) ⟹ (≡@{A}) ⟹ (≡@{A})) (+);
  grp_inv_proper :> Proper ((≡@{A}) ⟹ (≡@{A})) (-);

  grp_assoc : ∀ (x y z : A), x + (y + z) ≡@{A} (x + y) + z;

  grp_left_id : ∀ (x : A), ɛ@{A} + x ≡@{A} x;
  grp_right_id : ∀ (x : A), x + ɛ@{A} ≡@{A} x;

  grp_left_inv : ∀ (x : A), (-x) + x ≡@{A} ɛ@{A};
  grp_right_inv : ∀ (x : A), x - x ≡@{A} ɛ@{A};
}.
(* #[global] Hint Mode Group ! - - - -: typeclass_instances. *)

Arguments grp_assoc {_ _ _ _ _ Grp} : rename.
Arguments grp_left_id {_ _ _ _ _ Grp} : rename.
Arguments grp_right_id {_ _ _ _ _ Grp} : rename.
Arguments grp_left_inv {_ _ _ _ _ Grp} : rename.
Arguments grp_right_inv {_ _ _ _ _ Grp} : rename.
Arguments grp_op_proper {_ _ _ _ _ Grp} : rename.
Arguments grp_inv_proper {_ _ _ _ _ Grp} : rename.

(* Basic group properties *)
Section GroupProperties.
  Context `{Group G}.

  Lemma grp_inv_involutive (x: G): -(-x) ≡ x.
  Proof with auto.
    rewrite <-(grp_left_id x) at 2;
     rewrite <-grp_left_inv, <-grp_assoc, grp_left_inv, grp_right_id...
  Qed.

  Corollary grp_inv_neutral: -ɛ ≡@{G} ɛ.
  Proof with auto.
    rewrite <-grp_left_inv at 1; rewrite grp_right_id, grp_inv_involutive...
  Qed.

  Corollary grp_inv_inj (x y: G): x ≡ y → (-x) ≡ (-y).
  Proof. apply grp_inv_proper. Qed.

  Lemma perm_op_inv (x y : G) : -x - y ≡ -(y + x).
  Proof. Admitted.
End GroupProperties.

(* Group Action  *)
(* Class Action `{Grp: Group A} A X := action: A -> X -> X. *)
Class Action A X := action: A → X → X.
#[global] Hint Mode Action ! ! : typeclass_instances.
(* CAUSA PROBLEMAS COM REESCRITA ENVOLVENDO action (- p)
  Instance: Params (@action) 2 := {}. *)

Infix "•" := action (at level 60, right associativity) : nominal_scope.
Notation "(•)" := action (only parsing) : nominal_scope.
Notation "(• x )" := (action x) (only parsing) : nominal_scope.
Notation "( x •)" := (λ y, action y x) (only parsing): nominal_scope.

(* GroupAction não é uma ação, por isso preferimos a implementação abaixo. *)
(* Section GroupAction.
  Context (A X: Type) `{Grp: Group A, Act : Action A X, Equiv X}.

  Class GAction : Prop := {
    gact_group : Group A;
    gact_setoid :> Equivalence(≡@{X});
    gact_proper :> Proper ((≡@{A}) ==> (≡@{X}) ==> (≡@{X})) (•);

    gact_id : ∀ (x: X), ɛ@{A} • x ≡@{X} x;
    gact_compat: ∀ (p q: A) (x: X), p • (q • x) ≡@{X} (q + p) • x
  }.
End GroupAction. *)

Class GAction `(Group G) (X : Type) `{Act : Action G X, Equiv X} : Prop := {
  gact_setoid :> Equivalence(≡@{X});
  gact_proper :> Proper ((≡@{G}) ⟹ (≡@{X}) ⟹ (≡@{X})) (•);

  gact_id : ∀ (x: X), ɛ@{G} • x ≡@{X} x;
  gact_compat: ∀ (p q: G) (x: X), p • (q • x) ≡@{X} (q + p) • x
}.

Existing Instance gact_proper.

Arguments gact_id {_ _ _ _ _ Grp _ _ _ GAct} : rename.
Arguments gact_compat {_ _ _ _ _ Grp _ _ _ GAct} : rename.
Arguments gact_proper {_ _ _ _ _ Grp _ _ _ GAct} : rename.

Section GroupActionProperties.
  Context `{GAction G X}.

  Corollary perm_left_inv (x: X) (p : G): (-p) • p • x ≡ x.
  Proof. rewrite gact_compat, grp_right_inv, gact_id; auto. Qed.

  Corollary perm_rigth_inv (x: X) (p : G): p • (-p) • x ≡ x.
  Proof. rewrite gact_compat, grp_left_inv, gact_id; auto. Qed.

  Lemma perm_iff (x y: X) (p : G): p • x ≡ y ↔ x ≡ (-p) • y.
  Proof. split; intros A;
    [rewrite <-A, perm_left_inv | rewrite A, perm_rigth_inv]; auto.
  Qed.

  Lemma perm_inj (x y: X) (p : G): p • x ≡ p • y ↔ x ≡ y.
  Proof. split; intros A;
    [apply perm_iff in A; rewrite <-(perm_left_inv y p) | rewrite A]; auto.
  Qed.

  Lemma perm_inv_empty_act (x : X) : -ɛ@{G} • x ≡ x.
  Proof. rewrite grp_inv_neutral; apply gact_id. Qed.
End GroupActionProperties.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Const_Func.
Require Import NatTrans.NatTrans NatTrans.Func_Cat.

(** The functor that maps each object c in C to the constant functor that maps each object of D to c in Func_Cat D C. *)
Section Const_Func_Functor.
  Context (C D : Category).

  Program Definition Const_Func_Functor : (C –≻ (Func_Cat D C))%functor :=
    {|
      FO := fun c => Const_Func D c;
      FA := fun _ _ h => {|Trans := fun c => h|}
    |}.

End Const_Func_Functor.


(*
Verificación Formal - 2020-II
Archivo de definiciones - Lógica Clásica

Definiciones de lógica clásica.

Se define el operador binario cotenable, además de la definición de la notación para el operador
*)
Definition cotenable (A B : Prop) := ~ (A -> ~ B).
Notation " A ° B " := ( cotenable A B ) (at level 50, no associativity).


Require Import Coq.ZArith.ZArith. Local Open Scope Z_scope.

(* For the division canceler, we use statements of the form (a = d * a') instead of
   (a / d = a'), because the former also states that the remainder of the division is 0.
   Using the following lemma, we can go from the former to the latter form: *)
Lemma cancel_div_done: forall [d x x': Z], d <> 0 -> x = d * x' -> x / d = x'.
Proof. intros. subst. rewrite Z.mul_comm. apply Z.div_mul. assumption. Qed.

Lemma cancel_div_same: forall (d: Z), d = d * 1. intros. symmetry. apply Z.mul_1_r. Qed.

Lemma cancel_div_add_eq: forall [d a b a' b': Z],
    a = d * a' ->
    b = d * b' ->
    a + b = d * (a' + b').
Proof. intros. subst. symmetry. apply Z.mul_add_distr_l. Qed.

Lemma cancel_div_sub_eq: forall [d a b a' b': Z],
    a = d * a' ->
    b = d * b' ->
    a - b = d * (a' - b').
Proof. intros. subst. symmetry. apply Z.mul_sub_distr_l. Qed.

Lemma cancel_div_opp_eq: forall [d a a': Z],
    a = d * a' ->
    - a = d * (- a').
Proof. intros. subst. symmetry. apply Z.mul_opp_r. Qed.

Lemma cancel_div_mul_l_eq: forall [d a a'] (b: Z),
    a = d * a' ->
    a * b = d * (a' * b).
Proof. intros. subst. symmetry. apply Z.mul_assoc. Qed.

Lemma cancel_div_mul_r_eq: forall [d b b': Z] (a: Z),
    b = d * b' ->
    a * b = d * (a * b').
Proof. intros. subst. ring. Qed.

(* Given a divisor d and an expression e of type Z,
   returns a proof of type `e = d * q` for some quotient q if possible, or else fails. *)
Ltac cancel_div_rec d e :=
  lazymatch e with
  | d => constr:(cancel_div_same d)
  | Z.add ?a ?b =>
      let pfa := cancel_div_rec d a in
      let pfb := cancel_div_rec d b in
      constr:(cancel_div_add_eq pfa pfb)
  | Z.sub ?a ?b =>
      let pfa := cancel_div_rec d a in
      let pfb := cancel_div_rec d b in
      constr:(cancel_div_sub_eq pfa pfb)
  | Z.mul d ?a => constr:(@eq_refl Z e)
  | Z.mul ?a d => constr:(Z.mul_comm a d)
  | Z.mul ?a ?b =>
      match constr:(Set) with
      | _ => let pfa := cancel_div_rec d a in constr:(cancel_div_mul_l_eq b pfa)
      | _ => let pfb := cancel_div_rec d b in constr:(cancel_div_mul_r_eq a pfb)
      end
  | Z.opp ?a => let pfa := cancel_div_rec d a in constr:(cancel_div_opp_eq pfa)
  end.

(* Given a divisor d, a proof that `d <> 0`, and an expression e of type Z,
   returns a proof of type `e / d = q` for some quotient q if possible, or else fails. *)
Ltac cancel_div d d_nonzero_pf e :=
  let e_eq_prod_pf := cancel_div_rec d e in
  constr:(cancel_div_done d_nonzero_pf e_eq_prod_pf).

Goal forall (i j k count d: Z),
    d <> 0 ->
    (d * j - i * d * k + count * d) / d = j - i * k + count.
Proof.
  intros.
  lazymatch goal with
  | |- ?e / _ = _ => let r := cancel_div d H e in exact r
  end.
Abort.


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

(* ** Reification for bounded quantification *)

Require Import Arith Lia.

Set Implicit Arguments.

(* A nat indexed finite number of conjunctions *)

Definition fmap_reifier_t X (Q : nat -> X -> Prop) k :
             (forall i, i < k -> sig (Q i))
          -> { f : forall i, i < k -> X | forall i Hi, Q i (f i Hi) }.
Proof.
  assert (H_lt_S_n : forall n m, S n < S m -> n < m) by (now intros; apply Nat.succ_lt_mono).
  revert Q; induction k as [ | k IHk ]; intros Q HQ.
  + assert (f : forall i, i < 0 -> X) by (intros i Hi; exfalso; revert Hi; apply Nat.nlt_0_r).
    exists f; intros i Hi; exfalso; revert Hi; apply Nat.nlt_0_r.
  + destruct (HQ 0) as (f0 & H0).
    * apply Nat.lt_0_succ.
    * destruct (IHk (fun i => Q (S i))) as (f & Hf).
      - intros; apply HQ. apply -> Nat.succ_lt_mono; trivial.
      - set (f' :=
        fun i => match i return i < S k -> X with
                   | 0   => fun _  => f0
                   | S j => fun Hj => f j (H_lt_S_n _ _ Hj)
                 end).
        exists f'; intros [ | i ] Hi; simpl; trivial.
Defined.

Definition fmap_reifier_t_default X (Q : nat -> X -> Prop) k (x : X) :
             (forall i, i < k -> sig (Q i))
          -> { f : nat -> X | forall i, i < k -> Q i (f i) }.
Proof.
  intros H.
  apply fmap_reifier_t in H.
  destruct H as (f & Hf).
  exists (fun i => match le_lt_dec k i with
                          | left _ => x
                          | right Hi => f i Hi
                        end).
  intros i Hi.
  destruct (le_lt_dec k i) as [ H1 | ]; auto.
  exfalso; revert Hi H1; apply Nat.lt_nge.
Defined.

(* Given predicate P : nat -> nat -> Prop such that
      1/ P x is satisfiable for any x < n

    then there is a bound m such that for any x < n
    P x y is satisfied for some y below m *)

Theorem fmap_bound n P :
           (forall x, x < n -> ex (P x))
        -> exists m, forall x, x < n -> exists y, y < m /\ P x y.
Proof with try lia.
  revert P; induction n as [ | n IHn ]; intros P HP.
  + exists 0; intros...
  + destruct (HP 0) as (m0 & H0)...
    destruct (IHn (fun n => P (S n))) as (m1 & Hm1).
    - intros; apply HP...
    - exists (1+m0+m1); intros [ | x ] Hx.
      * exists m0; split; auto...
      * destruct (Hm1 x) as (y & H1 & H2)...
        exists y; split; auto...
Qed.

Theorem fmap_reifier_default X n (P : nat -> X -> Prop) :
           inhabited X
        -> (forall x, x < n -> ex (P x))
        -> exists f, forall x, x < n -> P x (f x).
Proof with try lia.
  intros [ u ].
  revert P; induction n as [ | n IHn ]; intros P HP.
  + exists (fun _ => u); intros...
  + destruct (IHn (fun i => P (S i))) as (f & Hf).
    { intros; apply HP... }
    destruct (HP 0) as (x & Hx)...
    exists (fun i => match i with 0 => x | S i => f i end).
    intros [|] ?; auto; apply Hf...
Qed.

Theorem fmap_reifer_bound n P :
           (forall x, x < n -> ex (P x))
        -> exists m f, forall x, x < n -> f x < m /\ P x (f x).
Proof.
  intros H.
  apply fmap_bound in H.
  destruct H as (m & Hm); exists m.
  revert Hm; apply fmap_reifier_default; auto.
Qed.

(* equal_upto m f g means f 0 = g 0, ... f (m-1) = g (m-1) *)

Local Notation equal_upto := (fun m (f g : nat -> nat) => forall n, n < m -> f n = g n).

(* Given a predicate P over nat * (nat -> nat), which is supposed to be finitary

  1/ for any x, P x only takes the first p values of its argument into acounts
  2/ P x is satisfiable for any value of x lower than n

  then there is a bound m such that for any x, there is always a solution f to
  P x f which is uniformly bounded by m

*)

Theorem fmmap_bound p n (P : nat -> (nat -> nat) -> Prop) :
             (forall x f g, equal_upto p f g -> P x f -> P x g)
          -> (forall x, x < n -> exists f, P x f)
          -> exists m, forall x, x < n -> exists f, (forall i, i < p -> f i < m) /\ P x f.
Proof.
  revert P.
  induction p as [ | p IHp ]; intros P HP H.
  + exists 1; intros x Hx.
    destruct (H _ Hx) as (f & Hf).
    exists (fun _ => 0); split; auto.
    apply (HP x f); auto.
    intros ? ?; lia.
  + set (Q x y := exists f, P x (fun i => match i with 0 => y | S i => f i end)).
    destruct (@fmap_bound n Q) as (m1 & Hm1).
    { intros x Hx.
      destruct (H _ Hx) as (f & Hf).
      exists (f 0); red.
      exists (fun i => f (S i)).
      revert Hf; apply HP.
      intros [ | i ]; auto. }
    set (R x f := exists y, y < m1 /\ P x (fun i => match i with 0 => y | S i => f i end)).
    destruct (IHp R) as (m2 & Hm2).
    { intros x f g Hfg (y & H1 & H2); exists y; split; auto.
      revert H2; apply HP; intros [ | ]; auto; intros; apply Hfg; lia. }
    { intros x Hx.
      destruct (Hm1 _ Hx) as (y & H1 & f & H2).
      exists f, y; split; auto. }
    exists (m1+m2).
    intros x Hx.
    destruct (Hm2 _ Hx) as (f & H1 & y & H2 & H3).
    eexists; split; [ | exact H3 ].
    intros [ | j ] Hj; try lia.
    specialize (H1 j); intros; lia.
Qed.

Theorem fmmap_reifer_bound p n (P : nat -> (nat -> nat) -> Prop) :
             (forall x f g, equal_upto p f g -> P x f -> P x g)
          -> (forall x, x < n -> exists f, P x f)
          -> exists m f, forall x, x < n -> (forall j, j < p -> f x j < m) /\ P x (f x).
Proof.
  intros H1 H2.
  apply fmmap_bound with (1 := H1) in H2.
  destruct H2 as (m & Hm).
  apply fmap_reifier_default in Hm; auto.
  destruct Hm as (f & Hf); exists m, f; auto.
Qed.


Require Import Coq.ZArith.BinIntDef.
Require Import Coq.NArith.BinNatDef.
Require Import Coq.PArith.BinPosDef.

Require Coq.ZArith.Znumtheory Coq.Numbers.BinNums.

Require Crypto.Arithmetic.ModularArithmeticPre.

Delimit Scope positive_scope with positive.
Bind Scope positive_scope with BinPos.positive.
Infix "+" := BinPos.Pos.add : positive_scope.
Infix "*" := BinPos.Pos.mul : positive_scope.
Infix "-" := BinPos.Pos.sub : positive_scope.
Infix "^" := BinPos.Pos.pow : positive_scope.

Delimit Scope N_scope with N.
Bind Scope N_scope with BinNums.N.
Infix "+" := BinNat.N.add : N_scope.
Infix "*" := BinNat.N.mul : N_scope.
Infix "-" := BinNat.N.sub : N_scope.
Infix "/" := BinNat.N.div : N_scope.
Infix "^" := BinNat.N.pow : N_scope.

Delimit Scope Z_scope with Z.
Bind Scope Z_scope with BinInt.Z.
Infix "+" := BinInt.Z.add : Z_scope.
Infix "*" := BinInt.Z.mul : Z_scope.
Infix "-" := BinInt.Z.sub : Z_scope.
Infix "/" := BinInt.Z.div : Z_scope.
Infix "^" := BinInt.Z.pow : Z_scope.
Infix "mod" := BinInt.Z.modulo (at level 40, no associativity) : Z_scope.

Local Open Scope Z_scope.
Global Coercion BinInt.Z.pos : BinPos.positive >-> BinInt.Z.
Global Coercion BinInt.Z.of_N : BinNums.N >-> BinInt.Z.
Global Set Printing Coercions.

Module F.
  Definition F (m : BinPos.positive) := { z : BinInt.Z | z = z mod m }.
  Local Obligation Tactic := cbv beta; auto using ModularArithmeticPre.Z_mod_mod.
  Program Definition of_Z  m  (a:BinNums.Z) : F m := a mod m.
  Definition to_Z {m} (a:F m) : BinNums.Z := proj1_sig a.

  Section FieldOperations.
    Context {m : BinPos.positive}.
    Definition zero : F m := of_Z m 0.
    Definition one : F m := of_Z m 1.

    Definition add (a b:F m) : F m := of_Z m (to_Z a + to_Z b).
    Definition mul (a b:F m) : F m := of_Z m (to_Z a * to_Z b).
    Definition opp (a : F m) : F m := of_Z m (0 - to_Z a).
    Definition sub (a b:F m) : F m := add a (opp b).

    Definition inv_with_spec : { inv : F m -> F m
                               | inv zero = zero
                                 /\ ( Znumtheory.prime m ->
                                      forall a, a <> zero -> mul (inv a) a = one )
                               } := ModularArithmeticPre.inv_impl.
    Definition inv : F m -> F m := Eval hnf in proj1_sig inv_with_spec.
    Definition div (a b:F m) : F m := mul a (inv b).

    Definition pow_with_spec : { pow : F m -> BinNums.N -> F m
                               | forall a, pow a 0%N = one
                                           /\ forall x, pow a (1 + x)%N = mul a (pow a x)
                               } := ModularArithmeticPre.pow_impl.
    Definition pow : F m -> BinNums.N -> F m := Eval hnf in proj1_sig pow_with_spec.
  End FieldOperations.

  Definition of_nat m (n:nat) := F.of_Z m (BinInt.Z.of_nat n).
  Definition to_nat {m} (x:F m) := BinInt.Z.to_nat (F.to_Z x).
  Notation nat_mod := of_nat (only parsing).

  Definition of_N m n := F.of_Z m (BinInt.Z.of_N n).
  Definition to_N {m} (x:F m) := BinInt.Z.to_N (F.to_Z x).
  Notation N_mod := of_N (only parsing).

  Notation Z_mod := of_Z (only parsing).
End F.

Notation F := F.F.
Declare Scope F_scope.
Delimit Scope F_scope with F.
Bind Scope F_scope with F.F.
Infix "+" := F.add : F_scope.
Infix "*" := F.mul : F_scope.
Infix "-" := F.sub : F_scope.
Infix "/" := F.div : F_scope.
Infix "^" := F.pow : F_scope.
Notation "0" := F.zero : F_scope.
Notation "1" := F.one : F_scope.


Fixpoint pow m n :=
  match n with
  | O => 1
  | S n' => m * pow m n'
  end.

Lemma pow_le : forall n x y,
    n >= 1 ->
    x <= y <-> pow n x <= pow n y.
Proof.
Admitted.

Lemma pow_plus : forall n x y,
    pow n (x + y) = pow n x * pow n y.
Proof.
Admitted.

Infix "^^" := pow (at level 30, right associativity) : nat_scope.


Require Import RelationClasses.

Theorem iff_refl: forall o:Prop, iff o o.
Proof.
  intros;split;auto.
Qed.

Theorem iff_symmetric: forall (o1 o2: Prop),
  iff o1 o2 -> iff o2 o1.
Proof.
  intros.
  destruct H; split; auto.
Qed.

Theorem iff_transitive: forall (o1 o2 o3: Prop),
  iff o1 o2 -> iff o2 o3 -> iff o1 o3.
Proof.
  intros; destruct H; destruct H0; split; auto.
Qed.

Theorem iff_Equiv: Equivalence iff.
Proof.
  intros.
  eapply Build_Equivalence.
  unfold Reflexive; apply iff_refl; auto.
  unfold Symmetric; apply iff_symmetric; auto.
  unfold Transitive; apply iff_transitive; auto.
Qed.


Require Import nat.
Require Import syntax.
Require Import transform.
Require Import fold_constants.

Fixpoint optimize_0plus_aexp (a:aexp) : aexp :=
    match a with
    | ANum n            => ANum n
    | AKey k            => AKey k
    | APlus (ANum 0) a2 => optimize_0plus_aexp a2
    | APlus a1 a2       => APlus  (optimize_0plus_aexp a1)(optimize_0plus_aexp a2)
    | AMinus a1 a2      => AMinus (optimize_0plus_aexp a1)(optimize_0plus_aexp a2)
    | AMult a1 a2       => AMult  (optimize_0plus_aexp a1)(optimize_0plus_aexp a2)
    end.

Definition optimize_0plus_bexp:= btrans optimize_0plus_aexp.
Definition optimize_0plus_com := ctrans optimize_0plus_aexp optimize_0plus_bexp.

Definition optimize_aexp (a:aexp) : aexp :=
    optimize_0plus_aexp(fold_constants_aexp a).
Definition optimize_bexp := btrans optimize_aexp.
Definition optimize_com  := ctrans optimize_aexp optimize_bexp.


(** 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 (z : natural) (y : natural) (lf2 : natural) (lf1 : natural)
  : natural := mult (Succ Zero) lf1.


Require Import init.

Require Export cauchy_real_plus.

Lemma cauchy_bounded : ∀ a : real_base, ∃ M, ∀ n, |r_seq a n| < M.
Proof.
    intros [a a_cauchy]; cbn.
    specialize (a_cauchy 1 one_pos) as [N a_cauchy].
    pose (S := image_under (λ n, |a n|) (initial_segment N)).
    assert (has_upper_bound le S) as [M M_max].
    {
        nat_destruct N.
        {
            exists 0.
            intros x [n [n_lt n_eq]].
            contradiction (nat_neg2 n_lt).
        }
        assert (simple_finite (set_type S)) as S_fin.
        {
            apply (simple_finite_trans _ _ (simple_finite_nat (nat_suc N))).
            exists (λ x : set_type S, [ex_val [|x] | land (ex_proof [|x])]).
            split.
            intros x y.
            rewrite set_type_eq2.
            rewrite_ex_val m [m_lt x_eq].
            rewrite_ex_val n [n_lt y_eq].
            intros eq; subst n.
            rewrite <- y_eq in x_eq.
            rewrite set_type_eq in x_eq.
            exact x_eq.
        }
        pose proof (simple_finite_max S_fin) as x_ex.
        prove_parts x_ex.
        {
            exists (|a 0|).
            exists 0.
            split; [>|reflexivity].
            apply nat_pos2.
        }
        destruct x_ex as [[x Sx] x_greatest].
        exists x.
        intros m Sm.
        exact (x_greatest [m|Sm]).
    }
    exists (max (M + 1) (|a N| + 1)).
    intros n.
    classic_case (n < N) as [ltq|leq].
    -   apply (lt_le_trans2 (lmax _ _)).
        specialize (M_max (|a n|)).
        prove_parts M_max; [>exists n; split; [>exact ltq|reflexivity]|].
        apply (le_lt_trans M_max).
        apply lt_plus_one.
    -   apply (lt_le_trans2 (rmax _ _)).
        rewrite nlt_le in leq.
        specialize (a_cauchy n N leq (refl _)).
        apply (le_lt_trans (abs_reverse_tri2 _ _)) in a_cauchy.
        rewrite lt_plus_rlmove.
        rewrite plus_comm.
        exact a_cauchy.
Qed.

Lemma cauchy_mult : ∀ a b : real_base, cauchy_seq (λ n, r_seq a n * r_seq b n).
Proof.
    intros a b ε ε_pos.
    pose proof (cauchy_bounded a) as [M1 M1_gt].
    pose proof (cauchy_bounded b) as [M2 M2_gt].
    destruct a as [a a_cauchy], b as [b b_cauchy]; cbn in *.
    assert (0 < M1) as M1_pos by (apply (le_lt_trans2 (M1_gt 0));apply abs_pos).
    assert (0 < M2) as M2_pos by (apply (le_lt_trans2 (M2_gt 0));apply abs_pos).
    pose proof (half_pos ε_pos) as ε2_pos.
    specialize (a_cauchy _ (lt_mult (div_pos M2_pos) ε2_pos)) as [N1 a_cauchy].
    specialize (b_cauchy _ (lt_mult (div_pos M1_pos) ε2_pos)) as [N2 b_cauchy].
    exists (max N1 N2).
    intros i j i_ge j_ge.
    specialize (a_cauchy i j (trans (lmax _ _) i_ge) (trans (lmax _ _) j_ge)).
    specialize (b_cauchy i j (trans (rmax _ _) i_ge) (trans (rmax _ _) j_ge)).
    rewrite <- lt_mult_llmove_pos in a_cauchy by exact M2_pos.
    rewrite <- lt_mult_llmove_pos in b_cauchy by exact M1_pos.
    pose proof (lt_lrplus a_cauchy b_cauchy) as ltq.
    rewrite plus_half in ltq.
    rewrite <- (plus_rlinv (a i * b i) (a i * b j)).
    rewrite <- mult_rneg, <- ldist.
    rewrite <- plus_assoc.
    rewrite <- mult_lneg, <- rdist.
    rewrite (mult_comm _ (b j)).
    apply (le_lt_trans (abs_tri _ _)).
    rewrite plus_comm.
    apply (le_lt_trans2 ltq).
    do 2 rewrite abs_mult.
    apply le_lrplus.
    -   apply le_rmult_pos; [>apply abs_pos|].
        apply M2_gt.
    -   apply le_rmult_pos; [>apply abs_pos|].
        apply M1_gt.
Qed.

Notation "a ⊗ b" := (make_real _ (cauchy_mult a b)) : real_scope.

Lemma real_mult_wd : ∀ a b c d, a ~ b → c ~ d → a ⊗ c ~ b ⊗ d.
    intros [a a_cauchy] b c [d d_cauchy] ab cd ε ε_pos.
    pose proof (cauchy_bounded b) as [M1 M1_gt].
    pose proof (cauchy_bounded c) as [M2 M2_gt].
    destruct b as [b b_cauchy], c as [c c_cauchy]; cbn in *.
    assert (0 < M1) as M1_pos by (apply (le_lt_trans2 (M1_gt 0));apply abs_pos).
    assert (0 < M2) as M2_pos by (apply (le_lt_trans2 (M2_gt 0));apply abs_pos).
    pose proof (half_pos ε_pos) as ε2_pos.
    specialize (ab _ (lt_mult (div_pos M2_pos) ε2_pos)) as [N1 ab].
    specialize (cd _ (lt_mult (div_pos M1_pos) ε2_pos)) as [N2 cd].
    exists (max N1 N2).
    intros i i_ge.
    specialize (ab i (trans (lmax _ _) i_ge)).
    specialize (cd i (trans (rmax _ _) i_ge)).
    rewrite <- lt_mult_llmove_pos in ab by exact M2_pos.
    rewrite <- lt_mult_llmove_pos in cd by exact M1_pos.
    pose proof (lt_lrplus ab cd) as ltq.
    rewrite plus_half in ltq.
    rewrite <- (plus_rlinv (a i * c i) (b i * c i)).
    rewrite <- mult_lneg, <- rdist.
    rewrite <- plus_assoc.
    rewrite <- mult_rneg, <- ldist.
    rewrite (mult_comm _ (c i)).
    apply (le_lt_trans (abs_tri _ _)).
    apply (le_lt_trans2 ltq).
    do 2 rewrite abs_mult.
    apply le_lrplus.
    -   apply le_rmult_pos; [>apply abs_pos|].
        apply M2_gt.
    -   apply le_rmult_pos; [>apply abs_pos|].
        apply M1_gt.
Qed.

Global Instance real_mult : Mult real := {
    mult := binary_op (binary_self_wd real_mult_wd)
}.

Global Instance real_one : One real := {
    one := rat_to_real 1
}.

Definition real_div_base (a : real_base) :=
    If (0 = to_equiv real_equiv a)
    then λ _, 0
    else λ n, /(r_seq a n).

Lemma cauchy_nz : ∀ a : real_base, 0 ≠ to_equiv real_equiv a →
    ∃ ε N, 0 < ε ∧ (∀ i, N ≤ i → ε ≤ |r_seq a i|).
Proof.
    intros [a a_cauchy] a_neq; cbn in *.
    rewrite neq_sym in a_neq.
    unfold zero in a_neq; cbn in a_neq.
    unfold rat_to_real in a_neq; equiv_simpl in a_neq.
    rewrite not_all in a_neq.
    destruct a_neq as [ε a_neq].
    rewrite not_impl in a_neq.
    rewrite not_ex in a_neq.
    destruct a_neq as [ε_pos a_neq].
    specialize (a_cauchy _ (half_pos ε_pos)) as [N a_cauchy].
    specialize (a_neq N).
    rewrite not_all in a_neq.
    destruct a_neq as [n a_neq].
    rewrite not_impl in a_neq.
    destruct a_neq as [n_ge an_ge].
    rewrite nlt_le in an_ge.
    rewrite neg_zero, plus_rid in an_ge.
    exists (ε/2), N.
    split; [>exact (half_pos ε_pos)|].
    intros i i_ge.
    specialize (a_cauchy n i n_ge i_ge).
    apply (le_lt_trans (abs_reverse_tri2 _ _)) in a_cauchy.
    rewrite <- lt_plus_rrmove in a_cauchy.
    pose proof (le_lt_trans an_ge a_cauchy) as ltq.
    rewrite <- (plus_half ε) in ltq at 1.
    apply lt_plus_lcancel in ltq.
    apply ltq.
Qed.

Lemma cauchy_div : ∀ a : real_base, cauchy_seq (real_div_base a).
    intros [a a_cauchy].
    unfold real_div_base; cbn.
    case_if [a_eq|a_neq]; [>apply rat_to_real_cauchy|].
    apply cauchy_nz in a_neq as [ε' [N1 [ε'_pos nz]]].
    cbn in nz.
    intros ε ε_pos.
    pose proof (div_pos ε'_pos) as ε''_pos.
    specialize (a_cauchy _ (lt_mult ε_pos (lt_mult ε'_pos ε'_pos)))
        as [N2 a_cauchy].
    exists (max N1 N2).
    intros i j i_ge j_ge.
    pose proof (nz i (trans (lmax N1 N2) i_ge)) as i_gt.
    pose proof (nz j (trans (lmax N1 N2) j_ge)) as j_gt.
    clear nz.
    assert (0 ≠ a i) as ai_nz.
    {
        intros contr.
        rewrite <- contr in i_gt.
        rewrite <- abs_zero in i_gt.
        destruct (lt_le_trans ε'_pos i_gt); contradiction.
    }
    assert (0 ≠ a j) as aj_nz.
    {
        intros contr.
        rewrite <- contr in j_gt.
        rewrite <- abs_zero in j_gt.
        destruct (lt_le_trans ε'_pos j_gt); contradiction.
    }
    rewrite <- (mult_lrinv (/(a i)) (a j)) by exact aj_nz.
    rewrite <- (mult_lrinv (/(a j)) (a i)) at 2 by exact ai_nz.
    rewrite (mult_comm (/(a j))).
    rewrite <- mult_lneg, <- rdist.
    do 2 rewrite abs_mult.
    specialize (a_cauchy j i (trans (rmax _ _) j_ge) (trans (rmax _ _) i_ge)).
    rewrite mult_assoc.
    rewrite <- abs_div by exact ai_nz.
    rewrite <- abs_div by exact aj_nz.
    rewrite <- lt_mult_rrmove_pos by (exact (abs_pos2 aj_nz)).
    rewrite <- lt_mult_rrmove_pos by (exact (abs_pos2 ai_nz)).
    apply (lt_le_trans a_cauchy).
    rewrite <- mult_assoc.
    apply le_lmult_pos; [>apply ε_pos|].
    apply le_lrmult_pos.
    -   apply ε'_pos.
    -   apply ε'_pos.
    -   apply j_gt.
    -   apply i_gt.
Qed.

Notation "⊘ a" := (make_real _ (cauchy_div a)) : real_scope.

Lemma real_div_wd : ∀ a b, a ~ b → ⊘a ~ ⊘b.
Proof.
    intros a b ab ε ε_pos; cbn.
    assert (to_equiv real_equiv a = to_equiv real_equiv b) as ab'
        by (equiv_simpl; exact ab).
    unfold real_div_base.
    case_if [a_z|a_nz]; case_if [b_z|b_nz].
    {
        exists 0.
        intros i i_ge.
        rewrite neg_zero, plus_rid, <- abs_zero.
        exact ε_pos.
    }
    {
        rewrite <- ab' in b_nz.
        contradiction.
    }
    {
        rewrite ab' in a_nz.
        contradiction.
    }
    clear ab'.
    apply cauchy_nz in a_nz as [ε1 [N1 [ε1_pos a_nz]]].
    apply cauchy_nz in b_nz as [ε2 [N2 [ε2_pos b_nz]]].
    destruct a as [a a_cauchy], b as [b b_cauchy]; cbn in *.
    specialize (ab _ (lt_mult ε_pos (lt_mult ε1_pos ε2_pos))) as [N ab].
    exists (max N (max N1 N2)).
    intros i i_ge.
    specialize (a_nz i (trans (lmax _ _) (trans (rmax _ _) i_ge))).
    specialize (b_nz i (trans (rmax _ _) (trans (rmax _ _) i_ge))).
    specialize (ab i (trans (lmax _ _) i_ge)).
    assert (0 ≠ a i) as ai_nz.
    {
        intros contr.
        rewrite <- contr in a_nz.
        rewrite <- abs_zero in a_nz.
        destruct (lt_le_trans ε1_pos a_nz); contradiction.
    }
    assert (0 ≠ b i) as bi_nz.
    {
        intros contr.
        rewrite <- contr in b_nz.
        rewrite <- abs_zero in b_nz.
        destruct (lt_le_trans ε2_pos b_nz); contradiction.
    }
    rewrite <- (mult_lrinv (/(a i)) (b i)) by exact bi_nz.
    rewrite <- (mult_lrinv (/(b i)) (a i)) at 2 by exact ai_nz.
    rewrite (mult_comm (/(a i))).
    rewrite <- mult_lneg, <- rdist.
    do 2 rewrite abs_mult.
    rewrite mult_assoc.
    rewrite <- abs_div by exact bi_nz.
    rewrite <- abs_div by exact ai_nz.
    rewrite <- lt_mult_rrmove_pos by (exact (abs_pos2 ai_nz)).
    rewrite <- lt_mult_rrmove_pos by (exact (abs_pos2 bi_nz)).
    rewrite abs_minus.
    apply (lt_le_trans ab).
    rewrite <- mult_assoc.
    apply le_lmult_pos; [>apply ε_pos|].
    apply le_lrmult_pos.
    -   apply ε1_pos.
    -   apply ε2_pos.
    -   apply a_nz.
    -   apply b_nz.
Qed.

Global Instance real_div : Div real := {
    div := unary_op (unary_self_wd real_div_wd)
}.

Global Instance real_ldist : Ldist real.
Proof.
    split.
    intros a b c.
    equiv_get_value a b c.
    unfold mult, plus; equiv_simpl.
    intros ε ε_pos.
    exists 0.
    intros i i_ge.
    rewrite ldist.
    rewrite plus_rinv.
    rewrite <- abs_zero.
    exact ε_pos.
Qed.

Global Instance real_mult_comm : MultComm real.
Proof.
    split.
    intros a b.
    equiv_get_value a b.
    unfold mult; equiv_simpl.
    intros ε ε_pos.
    exists 0.
    intros i i_ge.
    rewrite mult_comm.
    rewrite plus_rinv.
    rewrite <- abs_zero.
    exact ε_pos.
Qed.

Global Instance real_mult_assoc : MultAssoc real.
Proof.
    split.
    intros a b c.
    equiv_get_value a b c.
    unfold mult; equiv_simpl.
    intros ε ε_pos.
    exists 0.
    intros i i_ge.
    rewrite mult_assoc.
    rewrite plus_rinv.
    rewrite <- abs_zero.
    exact ε_pos.
Qed.

Global Instance real_mult_lid : MultLid real.
Proof.
    split.
    intros a.
    equiv_get_value a.
    unfold mult, one; equiv_simpl.
    intros ε ε_pos.
    exists 0.
    intros i i_ge.
    rewrite mult_lid.
    rewrite plus_rinv.
    rewrite <- abs_zero.
    exact ε_pos.
Qed.

Global Instance real_mult_linv : MultLinv real.
Proof.
    split.
    intros a a_nz.
    equiv_get_value a.
    unfold mult, div, one; cbn.
    unfold rat_to_real; equiv_simpl.
    intros ε ε_pos.
    unfold real_div_base.
    case_if [a_z|a_nz']; [>contradiction|].
    apply cauchy_nz in a_nz' as [ε' [N [ε'_pos a_nz']]].
    exists N.
    intros i i_ge.
    specialize (a_nz' i i_ge).
    pose proof (lt_le_trans ε'_pos a_nz') as ai_pos.
    destruct ai_pos as [ai_pos ai_nz].
    rewrite abs_nz in ai_nz.
    rewrite mult_linv by exact ai_nz.
    rewrite plus_rinv.
    rewrite <- abs_zero.
    exact ε_pos.
Qed.

#[refine]
Global Instance real_not_trivial : NotTrivial real := {
    not_trivial_a := 0;
    not_trivial_b := 1;
}.
Proof.
    unfold zero, one; cbn.
    unfold rat_to_real; equiv_simpl.
    intros contr.
    specialize (contr 1 one_pos) as [N contr].
    specialize (contr N (refl _)).
    rewrite abs_minus, neg_zero, plus_rid in contr.
    rewrite abs_one in contr.
    destruct contr; contradiction.
Qed.


Require Import Coq.Strings.String.
Require Import syntax.

(* Helpers *)
Section helpers.

Inductive freeVar (x1 : termId) : term -> Prop :=
| freeEvar :
    forall x2,
    x1 = x2 ->
    freeVar x1 (evar x2)
| freeAbs :
    forall x2 t e,
    x1 <> x2 ->
    freeVar x1 e ->
    freeVar x1 (eabs x2 t e)
| freeApp1 :
    forall e1 e2,
    freeVar x1 e1 ->
    freeVar x1 (eapp e2 e1)
| freeApp2 :
    forall e1 e2,
    freeVar x1 e2 ->
    freeVar x1 (eapp e2 e1).

(* Proves either equality or inequality of identifiers. *)
Theorem eqId :
  forall (idT : idType) (x1 : id idT) (x2 : id idT),
  {x1 = x2} + {x1 <> x2}.
Proof.
  intros T x1 x2.
  destruct x1 as [H1 s1].
  destruct x2 as [H1 s2].
  pose (H2 := string_dec s1 s2).
  case H2.
  - intros H3.
    apply left.
    congruence.
  - intros H3.
    apply right.
    congruence.
Qed.

(* Look up variables in the context *)
Fixpoint lookupEvar (c1 : context) (x1 : termId) :=
  match c1 with
  | cempty => None
  | cextend c2 x2 t =>
    match eqId idTerm x1 x2 with
    | left _ => Some t
    | right _ => lookupEvar c2 x1
    end
  end.

Fixpoint subst (e1 : term) (x1 : termId) (e2 : term) :=
  match e1 with
  | eunit => e1
  | evar x2 =>
    match eqId idTerm x1 x2 with
    | left _ => e2
    | right _ => e1
    end
  | eabs x2 t e3 =>
    match eqId idTerm x1 x2 with
    | left _ => e1
    | right _ => eabs x2 t (subst e3 x1 e2)
    end
  | eapp e3 e4 => eapp (subst e3 x1 e2) (subst e4 x1 e2)
  end.
End helpers.

(* Typing rules *)
Inductive hasType : context -> term -> type -> Prop :=
| tUnit :
    forall c,
    hasType c eunit tunit
| tVar :
    forall c x t,
    lookupEvar c x = Some t ->
    hasType c (evar x) t
| tAbs :
    forall c x e1 t1 t2,
    hasType (cextend c x t2) e1 t1 ->
    hasType c (eabs x t2 e1) (tarrow t2 t1)
| tApp :
    forall c e1 e2 t1 t2,
    hasType c e2 (tarrow t1 t2) ->
    hasType c e1 t1 ->
    hasType c (eapp e2 e1) t2.

(* Operational semantics *)
Inductive value : term -> Prop :=
| valUnit : value eunit
| valAbs : forall x e1 t1, value (eabs x t1 e1).

Inductive step : term -> term -> Prop :=
| stAppAbs :
    forall x e1 e2 t1,
    value e2 ->
    step (eapp (eabs x t1 e1) e2) (subst e1 x e2)
| stApp1 :
    forall e1 e2 e3,
    step e1 e2 ->
    step (eapp e1 e3) (eapp e2 e3)
| stApp2 :
    forall e1 e2 e3,
    value e1 ->
    step e2 e3 ->
    step (eapp e1 e2) (eapp e1 e3).

Inductive bigstep : term -> term -> Prop :=
| bigRefl :
    forall e,
    bigstep e e
| bigInd :
    forall e1 e2 e3,
    bigstep e1 e2 ->
    step e2 e3 ->
    bigstep e1 e3.


(* Slope_base.v *)

Require Import Utf8.
Require Import QArith.

Definition slope_expr pt₁ pt₂ :=
  (snd pt₂ - snd pt₁) / (fst pt₂ - fst pt₁).


Require Import Arith.
Require Import Bool.
Require Import NAxioms NSub NZDiv.

(* group size *)
Variable gs : nat.

(* max_lvl = number of levels - 1 (so nl=0 means one level).  The "highest" level
   (i.e., the one numbered max_lvl) consists of a single group comprising the entire graph.
   The "lowest" level (numbered 0) conceptually consists of gs^max_lvl groups, all of size 1. *)
Variable max_lvl : nat.

(* Graphs are assumed to have gs^max_lvl nodes numbered from 0 to gs^max_lvl - 1.
   We represent them as boolean functions on pairs of nodes. *)
Definition node := nat.
Definition graph:= node -> node -> bool.

(* has_path g n x y:  Graph g has a path of length n from node x to node y. *)
Inductive has_path (g:graph) : nat -> node -> node -> Prop :=
| HP_Self (x:node): has_path g O x x
| HP_Step (n:nat) (x y z:node) (ST: g x y = true) (HP: has_path g n y z): has_path g (S n) x z.

(* number of level-v groups *)
Definition num_groups v := gs^(max_lvl-v).

(* level-v group number containing node x *)
Definition group_of v x := x/(gs^v).

(* Decide whether two groups are in the same super-group (one level up). *)
Definition same_supergroup p1 p2 := p1/gs = p2/gs.

(* Strongly connected Netsukuku property: For every level v, and every pair of groups p1
   and p2 at level v contained within the same supergroup (at level v+1), there exists a
   path (having some length n) from a node x within p1 to a node y within p2. *)
Definition is_netsukuku_strong (g:graph) : Prop :=
  forall v p1 p2, v <= max_lvl -> p1 < num_groups v -> p2 < num_groups v ->
                  same_supergroup p1 p2 ->
    exists n x y, group_of v x = p1 /\ group_of v y = p2 /\ has_path g n x y.

(* Fully connected Netsukuku property: For every level v, and every pair of groups p1
   and p2 at level v contained within the same supergroup (at level v+1), there exists a
   direct link from a node x within p1 to a node y within p2. *)
Definition is_netsukuku_full (g:graph) : Prop :=
  forall v p1 p2, v <= max_lvl -> p1 < num_groups v -> p2 < num_groups v ->
                  same_supergroup p1 p2 ->
    exists x y, group_of v x = p1 /\ group_of v y = p2 /\ g x y = true.

Definition mygraph (x y:nat):bool:=
(Nat.eqb y (x+1) || Nat.eqb y (x-1)).

Lemma xyz:
  forall x n, has_path mygraph n x (x+n) -> has_path mygraph n (x+n) x.
Proof.
  induction n.
  intros.
  SearchAbout plus.
  rewrite <- plus_n_O in H.
  rewrite <- plus_n_O.
  assumption.
  intros.
  inversion H. subst.
  apply IHn with (n:=S n).
Admitted.
(* If all we know is that a graph obeys the strongly connected Netsukuku property, then
   there might exist nodes x and y such that the shortest path between them has length
   gs^max_lvl - 1. *)
Theorem strong_worst_case:
  exists g x y, is_netsukuku_strong g /\ x < gs^max_lvl /\ y < gs^max_lvl /\
    forall n, has_path g n x y -> n >= gs^max_lvl - 1.
Proof.
  exists mygraph.
  exists (gs-1).
  exists (gs-2).
  split.
    unfold is_netsukuku_strong.
    intros.
    exists (p2-p1).
    exists (p1).
    exists (p2).
    split.
    induction v.
    unfold group_of. simpl.

    inversion H0. destruct H0.
    inversion H1. destruct H1.
    inversion H2. destruct H2.

Admitted.

(* But if we know a graph obeys the fully connected Netsukuku property, then the worst
   path length is always less than 2^max_lvl. *)
Theorem full_worst_case:
  forall g x y, is_netsukuku_full g -> x < gs^max_lvl -> y < gs^max_lvl ->
      exists n, n < 2^max_lvl /\ has_path g n x y.
Proof.
  intros.
  exists O.
  split.
    induction max_lvl.
    simpl.
    apply Nat.lt_0_1.
    SearchPattern (_<_).
    admit.
Admitted.


Require Import Reals Lra.
From Coquelicot Require Import Coquelicot.
Require Import Interval.Tactic Interval.Plot.
Open Scope R_scope.

(***************************************************************************)
(****************************** Real functions *****************************)
(***************************************************************************)

Check PI.

Lemma PI_approx2 : 3.14 <= PI <= 3.15.
Proof.
interval.
Qed.

Definition psin := ltac:(plot sin 0 PI).

Plot psin.

Definition psinv := ltac:(plot (fun x => sin (1 / x)) (0.01) (0.2)).

Plot psinv.
(* By comparison, gnuplot has a strange and erroneous behavior close to 0.
   Here is the command line:

   echo "set xrange [0.01:0.2]; plot sin(1/x)" | gnuplot -p

*)

(* Decimal value of PI is 3.141592653589793238462643383279... *)
Lemma val_sin_gt0 :
  forall x, (0 < sin 3.1415926535) /\
   (0 < x <= 3.14159265358979 -> 0 < sin x).
Proof.
intros x.
  split.
    interval.
set (y := 3.14159265358979).
assert (x_lt_pi : 0 < y < PI).
  unfold y; split.
    interval.
  Fail interval.
  interval with (i_prec 128).
intros intx.
apply sin_gt_0.
  tauto.
apply Rle_lt_trans with y.
  tauto.
tauto.
Qed.

(* This property can be visualize using gnuplot by typing
  echo "set xrange [0:10]; plot x, sin(x)" | gnuplot -p
*)
Lemma sinx_ltx x : 0 < x -> sin x < x.
Proof.
intros xgt0.
Fail interval.
apply Rminus_gt_0_lt.
(* Cut the proof in two parts: after PI/2 and before. *)
case (Rgt_ge_dec x (PI / 2)).
  assert (sin x <= 1) by (assert (tmp := SIN_bound x); lra).
  assert (tmp := PI2_1).
  lra.
intros xsmall.
(* Show the value of the derivative. *)
assert (der : forall c, 0 <= c <= x ->
         derivable_pt_lim (fun x => x - sin x) c
           (1 - cos c)).
  intros c _.
  auto_derive.
    auto.
  ring.
destruct (MVT_cor2 (fun x => x - sin x)
           (fun x => 1 - cos x) 0 x xgt0 der) as
  [c [feq cint]].
rewrite sin_0, !Rminus_0_r in feq; rewrite feq.
apply Rmult_lt_0_compat; cycle 1.
  auto.
enough (cos c < 1) by lra.
rewrite <- cos_0.
apply cos_decreasing_1.
        lra.
      lra.
    lra.
  lra.
lra.
Qed.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden,-parsing".
From LF Require Export Logic.
Require Coq.omega.Omega.

Inductive even : nat -> Prop :=
| ev_0 : even 0
| ev_SS (n : nat) (H : even n) : even (S (S n)).

Fail Inductive wrong_ev (n : nat) : Prop :=
| wrong_ev_0 : wrong_ev 0
| wrong_ev_SS : wrong_ev n -> wrong_ev (S (S n)).

Theorem ev_4 : even 4.
Proof. hammer_hook "IndProp" "IndProp.ev_4". apply ev_SS. apply ev_SS. apply ev_0. Qed.

Theorem ev_4' : even 4.
Proof. hammer_hook "IndProp" "IndProp.ev_4'". apply (ev_SS 2 (ev_SS 0 ev_0)). Qed.

Theorem ev_plus4 : forall n, even n -> even (4 + n).
Proof. hammer_hook "IndProp" "IndProp.ev_plus4".
intros n. simpl. intros Hn.
apply ev_SS. apply ev_SS. apply Hn.
Qed.

Theorem ev_double : forall n,
even (double n).
Proof. hammer_hook "IndProp" "IndProp.ev_double".
Admitted.

Theorem ev_inversion :
forall (n : nat), even n ->
(n = 0) \/ (exists n', n = S (S n') /\ even n').
Proof. hammer_hook "IndProp" "IndProp.ev_inversion".
intros n E.
destruct E as [ | n' E'].
-
left. reflexivity.
-
right. exists n'. split. reflexivity. apply E'.
Qed.

Theorem ev_minus2 : forall n,
even n -> even (pred (pred n)).
Proof. hammer_hook "IndProp" "IndProp.ev_minus2".
intros n E.
destruct E as [| n' E'].
-  simpl. apply ev_0.
-  simpl. apply E'.
Qed.

Theorem evSS_ev : forall n,
even (S (S n)) -> even n.

Proof. hammer_hook "IndProp" "IndProp.evSS_ev".
intros n E.
destruct E as [| n' E'].
-

Abort.

Theorem evSS_ev : forall n, even (S (S n)) -> even n.
Proof. hammer_hook "IndProp" "IndProp.evSS_ev". intros n H. apply ev_inversion in H. destruct H.
- discriminate H.
- destruct H as [n' [Hnm Hev]]. injection Hnm.
intro Heq. rewrite Heq. apply Hev.
Qed.

Theorem evSS_ev' : forall n,
even (S (S n)) -> even n.
Proof. hammer_hook "IndProp" "IndProp.evSS_ev'".
intros n E.
inversion E as [| n' E'].

apply E'.
Qed.

Theorem one_not_even : ~ even 1.
Proof. hammer_hook "IndProp" "IndProp.one_not_even".
intros H. apply ev_inversion in H.
destruct H as [ | [m [Hm _]]].
- discriminate H.
- discriminate Hm.
Qed.

Theorem one_not_even' : ~ even 1.
intros H. inversion H. Qed.

Theorem SSSSev__even : forall n,
even (S (S (S (S n)))) -> even n.
Proof. hammer_hook "IndProp" "IndProp.SSSSev__even".
Admitted.

Theorem even5_nonsense :
even 5 -> 2 + 2 = 9.
Proof. hammer_hook "IndProp" "IndProp.even5_nonsense".
Admitted.

Theorem inversion_ex1 : forall (n m o : nat),
[n; m] = [o; o] ->
[n] = [m].
Proof. hammer_hook "IndProp" "IndProp.inversion_ex1".
intros n m o H. inversion H. reflexivity. Qed.

Theorem inversion_ex2 : forall (n : nat),
S n = O ->
2 + 2 = 5.
Proof. hammer_hook "IndProp" "IndProp.inversion_ex2".
intros n contra. inversion contra. Qed.

Lemma ev_even_firsttry : forall n,
even n -> exists k, n = double k.
Proof. hammer_hook "IndProp" "IndProp.ev_even_firsttry".

intros n E. inversion E as [| n' E'].
-
exists 0. reflexivity.
-  simpl.

assert (I : (exists k', n' = double k') ->
(exists k, S (S n') = double k)).
{ intros [k' Hk']. rewrite Hk'. exists (S k'). reflexivity. }
apply I.

Abort.

Lemma ev_even : forall n,
even n -> exists k, n = double k.
Proof. hammer_hook "IndProp" "IndProp.ev_even".
intros n E.
induction E as [|n' E' IH].
-
exists 0. reflexivity.
-
destruct IH as [k' Hk'].
rewrite Hk'. exists (S k'). reflexivity.
Qed.

Theorem ev_even_iff : forall n,
even n <-> exists k, n = double k.
Proof. hammer_hook "IndProp" "IndProp.ev_even_iff".
intros n. split.
-  apply ev_even.
-  intros [k Hk]. rewrite Hk. apply ev_double.
Qed.

Theorem ev_sum : forall n m, even n -> even m -> even (n + m).
Proof. hammer_hook "IndProp" "IndProp.ev_sum".
Admitted.

Inductive even' : nat -> Prop :=
| even'_0 : even' 0
| even'_2 : even' 2
| even'_sum n m (Hn : even' n) (Hm : even' m) : even' (n + m).

Theorem even'_ev : forall n, even' n <-> even n.
Proof. hammer_hook "IndProp" "IndProp.even'_ev".
Admitted.

Theorem ev_ev__ev : forall n m,
even (n+m) -> even n -> even m.
Proof. hammer_hook "IndProp" "IndProp.ev_ev__ev".
Admitted.

Theorem ev_plus_plus : forall n m p,
even (n+m) -> even (n+p) -> even (m+p).
Proof. hammer_hook "IndProp" "IndProp.ev_plus_plus".
Admitted.

Module Playground.

Inductive le : nat -> nat -> Prop :=
| le_n n : le n n
| le_S n m (H : le n m) : le n (S m).

Notation "m <= n" := (le m n).

Theorem test_le1 :
3 <= 3.
Proof. hammer_hook "IndProp" "IndProp.Playground.test_le1".

apply le_n.  Qed.

Theorem test_le2 :
3 <= 6.
Proof. hammer_hook "IndProp" "IndProp.Playground.test_le2".

apply le_S. apply le_S. apply le_S. apply le_n.  Qed.

Theorem test_le3 :
(2 <= 1) -> 2 + 2 = 5.
Proof. hammer_hook "IndProp" "IndProp.Playground.test_le3".

intros H. inversion H. inversion H2.  Qed.

End Playground.

Definition lt (n m:nat) := le (S n) m.

Notation "m < n" := (lt m n).

Inductive square_of : nat -> nat -> Prop :=
| sq n : square_of n (n * n).

Inductive next_nat : nat -> nat -> Prop :=
| nn n : next_nat n (S n).

Inductive next_even : nat -> nat -> Prop :=
| ne_1 n : even (S n) -> next_even n (S n)
| ne_2 n (H : even (S (S n))) : next_even n (S (S n)).

Lemma le_trans : forall m n o, m <= n -> n <= o -> m <= o.
Proof. hammer_hook "IndProp" "IndProp.le_trans".
Admitted.

Theorem O_le_n : forall n,
0 <= n.
Proof. hammer_hook "IndProp" "IndProp.O_le_n".
Admitted.

Theorem n_le_m__Sn_le_Sm : forall n m,
n <= m -> S n <= S m.
Proof. hammer_hook "IndProp" "IndProp.n_le_m__Sn_le_Sm".
Admitted.

Theorem Sn_le_Sm__n_le_m : forall n m,
S n <= S m -> n <= m.
Proof. hammer_hook "IndProp" "IndProp.Sn_le_Sm__n_le_m".
Admitted.

Theorem le_plus_l : forall a b,
a <= a + b.
Proof. hammer_hook "IndProp" "IndProp.le_plus_l".
Admitted.

Theorem plus_lt : forall n1 n2 m,
n1 + n2 < m ->
n1 < m /\ n2 < m.
Proof. hammer_hook "IndProp" "IndProp.plus_lt".
unfold lt.
Admitted.

Theorem lt_S : forall n m,
n < m ->
n < S m.
Proof. hammer_hook "IndProp" "IndProp.lt_S".
Admitted.

Theorem leb_complete : forall n m,
n <=? m = true -> n <= m.
Proof. hammer_hook "IndProp" "IndProp.leb_complete".
Admitted.

Theorem leb_correct : forall n m,
n <= m ->
n <=? m = true.
Proof. hammer_hook "IndProp" "IndProp.leb_correct".
Admitted.

Theorem leb_true_trans : forall n m o,
n <=? m = true -> m <=? o = true -> n <=? o = true.
Proof. hammer_hook "IndProp" "IndProp.leb_true_trans".
Admitted.

Theorem leb_iff : forall n m,
n <=? m = true <-> n <= m.
Proof. hammer_hook "IndProp" "IndProp.leb_iff".
Admitted.

Module R.

Inductive R : nat -> nat -> nat -> Prop :=
| c1 : R 0 0 0
| c2 m n o (H : R m n o) : R (S m) n (S o)
| c3 m n o (H : R m n o) : R m (S n) (S o)
| c4 m n o (H : R (S m) (S n) (S (S o))) : R m n o
| c5 m n o (H : R m n o) : R n m o.

Definition manual_grade_for_R_provability : option (nat*string) := None.

Definition fR : nat -> nat -> nat
. Admitted.

Theorem R_equiv_fR : forall m n o, R m n o <-> fR m n = o.
Proof. hammer_hook "IndProp" "IndProp.R.R_equiv_fR".
Admitted.

End R.

Inductive subseq : list nat -> list nat -> Prop :=

.

Theorem subseq_refl : forall (l : list nat), subseq l l.
Proof. hammer_hook "IndProp" "IndProp.subseq_refl".
Admitted.

Theorem subseq_app : forall (l1 l2 l3 : list nat),
subseq l1 l2 ->
subseq l1 (l2 ++ l3).
Proof. hammer_hook "IndProp" "IndProp.subseq_app".
Admitted.

Theorem subseq_trans : forall (l1 l2 l3 : list nat),
subseq l1 l2 ->
subseq l2 l3 ->
subseq l1 l3.
Proof. hammer_hook "IndProp" "IndProp.subseq_trans".
Admitted.

Inductive reg_exp {T : Type} : Type :=
| EmptySet
| EmptyStr
| Char (t : T)
| App (r1 r2 : reg_exp)
| Union (r1 r2 : reg_exp)
| Star (r : reg_exp).

Inductive exp_match {T} : list T -> reg_exp -> Prop :=
| MEmpty : exp_match [] EmptyStr
| MChar x : exp_match [x] (Char x)
| MApp s1 re1 s2 re2
(H1 : exp_match s1 re1)
(H2 : exp_match s2 re2) :
exp_match (s1 ++ s2) (App re1 re2)
| MUnionL s1 re1 re2
(H1 : exp_match s1 re1) :
exp_match s1 (Union re1 re2)
| MUnionR re1 s2 re2
(H2 : exp_match s2 re2) :
exp_match s2 (Union re1 re2)
| MStar0 re : exp_match [] (Star re)
| MStarApp s1 s2 re
(H1 : exp_match s1 re)
(H2 : exp_match s2 (Star re)) :
exp_match (s1 ++ s2) (Star re).

Notation "s =~ re" := (exp_match s re) (at level 80).

Example reg_exp_ex1 : [1] =~ Char 1.
Proof. hammer_hook "IndProp" "IndProp.reg_exp_ex1".
apply MChar.
Qed.

Example reg_exp_ex2 : [1; 2] =~ App (Char 1) (Char 2).
Proof. hammer_hook "IndProp" "IndProp.reg_exp_ex2".
apply (MApp [1] _ [2]).
- apply MChar.
- apply MChar.
Qed.

Example reg_exp_ex3 : ~ ([1; 2] =~ Char 1).
Proof. hammer_hook "IndProp" "IndProp.reg_exp_ex3".
intros H. inversion H.
Qed.

Fixpoint reg_exp_of_list {T} (l : list T) :=
match l with
| [] => EmptyStr
| x :: l' => App (Char x) (reg_exp_of_list l')
end.

Example reg_exp_ex4 : [1; 2; 3] =~ reg_exp_of_list [1; 2; 3].
Proof. hammer_hook "IndProp" "IndProp.reg_exp_ex4".
simpl. apply (MApp [1]).
{ apply MChar. }
apply (MApp [2]).
{ apply MChar. }
apply (MApp [3]).
{ apply MChar. }
apply MEmpty.
Qed.

Lemma MStar1 :
forall T s (re : @reg_exp T) ,
s =~ re ->
s =~ Star re.
Proof. hammer_hook "IndProp" "IndProp.MStar1".
intros T s re H.
rewrite <- (app_nil_r _ s).
apply (MStarApp s [] re).
- apply H.
- apply MStar0.
Qed.

Lemma empty_is_empty : forall T (s : list T),
~ (s =~ EmptySet).
Proof. hammer_hook "IndProp" "IndProp.empty_is_empty".
Admitted.

Lemma MUnion' : forall T (s : list T) (re1 re2 : @reg_exp T),
s =~ re1 \/ s =~ re2 ->
s =~ Union re1 re2.
Proof. hammer_hook "IndProp" "IndProp.MUnion'".
Admitted.

Lemma MStar' : forall T (ss : list (list T)) (re : reg_exp),
(forall s, In s ss -> s =~ re) ->
fold app ss [] =~ Star re.
Proof. hammer_hook "IndProp" "IndProp.MStar'".
Admitted.

Lemma reg_exp_of_list_spec : forall T (s1 s2 : list T),
s1 =~ reg_exp_of_list s2 <-> s1 = s2.
Proof. hammer_hook "IndProp" "IndProp.reg_exp_of_list_spec".
Admitted.

Fixpoint re_chars {T} (re : reg_exp) : list T :=
match re with
| EmptySet => []
| EmptyStr => []
| Char x => [x]
| App re1 re2 => re_chars re1 ++ re_chars re2
| Union re1 re2 => re_chars re1 ++ re_chars re2
| Star re => re_chars re
end.

Theorem in_re_match : forall T (s : list T) (re : reg_exp) (x : T),
s =~ re ->
In x s ->
In x (re_chars re).
Proof. hammer_hook "IndProp" "IndProp.in_re_match".
intros T s re x Hmatch Hin.
induction Hmatch
as [| x'
| s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
| s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
| re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2].

-
apply Hin.
-
apply Hin.
- simpl. rewrite In_app_iff in *.
destruct Hin as [Hin | Hin].
+
left. apply (IH1 Hin).
+
right. apply (IH2 Hin).
-
simpl. rewrite In_app_iff.
left. apply (IH Hin).
-
simpl. rewrite In_app_iff.
right. apply (IH Hin).
-
destruct Hin.

-
simpl. rewrite In_app_iff in Hin.
destruct Hin as [Hin | Hin].
+
apply (IH1 Hin).
+
apply (IH2 Hin).
Qed.

Fixpoint re_not_empty {T : Type} (re : @reg_exp T) : bool
. Admitted.

Lemma re_not_empty_correct : forall T (re : @reg_exp T),
(exists s, s =~ re) <-> re_not_empty re = true.
Proof. hammer_hook "IndProp" "IndProp.re_not_empty_correct".
Admitted.

Lemma star_app: forall T (s1 s2 : list T) (re : @reg_exp T),
s1 =~ Star re ->
s2 =~ Star re ->
s1 ++ s2 =~ Star re.
Proof. hammer_hook "IndProp" "IndProp.star_app".
intros T s1 s2 re H1.

induction H1
as [|x'|s1 re1 s2' re2 Hmatch1 IH1 Hmatch2 IH2
|s1 re1 re2 Hmatch IH|re1 s2' re2 Hmatch IH
|re''|s1 s2' re'' Hmatch1 IH1 Hmatch2 IH2].

-
simpl. intros H. apply H.

-
Abort.

Lemma star_app: forall T (s1 s2 : list T) (re re' : reg_exp),
re' = Star re ->
s1 =~ re' ->
s2 =~ Star re ->
s1 ++ s2 =~ Star re.

Abort.

Lemma star_app: forall T (s1 s2 : list T) (re : reg_exp),
s1 =~ Star re ->
s2 =~ Star re ->
s1 ++ s2 =~ Star re.
Proof. hammer_hook "IndProp" "IndProp.star_app".
intros T s1 s2 re H1.
remember (Star re) as re'.

generalize dependent s2.
induction H1
as [|x'|s1 re1 s2' re2 Hmatch1 IH1 Hmatch2 IH2
|s1 re1 re2 Hmatch IH|re1 s2' re2 Hmatch IH
|re''|s1 s2' re'' Hmatch1 IH1 Hmatch2 IH2].

-   discriminate.
-    discriminate.
-     discriminate.
-  discriminate.
-  discriminate.

-
injection Heqre'. intros Heqre'' s H. apply H.

-
injection Heqre'. intros H0.
intros s2 H1. rewrite <- app_assoc.
apply MStarApp.
+ apply Hmatch1.
+ apply IH2.
* rewrite H0. reflexivity.
* apply H1.
Qed.

Lemma MStar'' : forall T (s : list T) (re : reg_exp),
s =~ Star re ->
exists ss : list (list T),
s = fold app ss []
/\ forall s', In s' ss -> s' =~ re.
Proof. hammer_hook "IndProp" "IndProp.MStar''".
Admitted.

Module Pumping.

Fixpoint pumping_constant {T} (re : @reg_exp T) : nat :=
match re with
| EmptySet => 0
| EmptyStr => 1
| Char _ => 2
| App re1 re2 =>
pumping_constant re1 + pumping_constant re2
| Union re1 re2 =>
pumping_constant re1 + pumping_constant re2
| Star _ => 1
end.

Fixpoint napp {T} (n : nat) (l : list T) : list T :=
match n with
| 0 => []
| S n' => l ++ napp n' l
end.

Lemma napp_plus: forall T (n m : nat) (l : list T),
napp (n + m) l = napp n l ++ napp m l.
Proof. hammer_hook "IndProp" "IndProp.Pumping.napp_plus".
intros T n m l.
induction n as [|n IHn].
- reflexivity.
- simpl. rewrite IHn, app_assoc. reflexivity.
Qed.

Lemma pumping : forall T (re : @reg_exp T) s,
s =~ re ->
pumping_constant re <= length s ->
exists s1 s2 s3,
s = s1 ++ s2 ++ s3 /\
s2 <> [] /\
forall m, s1 ++ napp m s2 ++ s3 =~ re.

Import Coq.omega.Omega.

Proof. hammer_hook "IndProp" "IndProp.Pumping.pumping".
intros T re s Hmatch.
induction Hmatch
as [ | x | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
| s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
| re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2 ].
-
simpl. omega.
Admitted.

End Pumping.

Theorem filter_not_empty_In : forall n l,
filter (fun x => n =? x) l <> [] ->
In n l.
Proof. hammer_hook "IndProp" "IndProp.filter_not_empty_In".
intros n l. induction l as [|m l' IHl'].
-
simpl. intros H. apply H. reflexivity.
-
simpl. destruct (n =? m) eqn:H.
+
intros _. rewrite eqb_eq in H. rewrite H.
left. reflexivity.
+
intros H'. right. apply IHl'. apply H'.
Qed.

Inductive reflect (P : Prop) : bool -> Prop :=
| ReflectT (H :   P) : reflect P true
| ReflectF (H : ~ P) : reflect P false.

Theorem iff_reflect : forall P b, (P <-> b = true) -> reflect P b.
Proof. hammer_hook "IndProp" "IndProp.iff_reflect".

intros P b H. destruct b.
- apply ReflectT. rewrite H. reflexivity.
- apply ReflectF. rewrite H. intros H'. discriminate.
Qed.

Theorem reflect_iff : forall P b, reflect P b -> (P <-> b = true).
Proof. hammer_hook "IndProp" "IndProp.reflect_iff".
Admitted.

Lemma eqbP : forall n m, reflect (n = m) (n =? m).
Proof. hammer_hook "IndProp" "IndProp.eqbP".
intros n m. apply iff_reflect. rewrite eqb_eq. reflexivity.
Qed.

Theorem filter_not_empty_In' : forall n l,
filter (fun x => n =? x) l <> [] ->
In n l.
Proof. hammer_hook "IndProp" "IndProp.filter_not_empty_In'".
intros n l. induction l as [|m l' IHl'].
-
simpl. intros H. apply H. reflexivity.
-
simpl. destruct (eqbP n m) as [H | H].
+
intros _. rewrite H. left. reflexivity.
+
intros H'. right. apply IHl'. apply H'.
Qed.

Fixpoint count n l :=
match l with
| [] => 0
| m :: l' => (if n =? m then 1 else 0) + count n l'
end.

Theorem eqbP_practice : forall n l,
count n l = 0 -> ~(In n l).
Proof. hammer_hook "IndProp" "IndProp.eqbP_practice".
Admitted.

Inductive nostutter {X:Type} : list X -> Prop :=

.

Example test_nostutter_1: nostutter [3;1;4;1;5;6].
Admitted.

Example test_nostutter_2:  nostutter (@nil nat).
Admitted.

Example test_nostutter_3:  nostutter [5].
Admitted.

Example test_nostutter_4:      not (nostutter [3;1;1;4]).
Admitted.

Definition manual_grade_for_nostutter : option (nat*string) := None.

Definition manual_grade_for_filter_challenge : option (nat*string) := None.

Definition manual_grade_for_pal_pal_app_rev_pal_rev : option (nat*string) := None.

Definition manual_grade_for_NoDup_disjoint_etc : option (nat*string) := None.

Lemma in_split : forall (X:Type) (x:X) (l:list X),
In x l ->
exists l1 l2, l = l1 ++ x :: l2.
Proof. hammer_hook "IndProp" "IndProp.in_split".
Admitted.

Inductive repeats {X:Type} : list X -> Prop :=

.

Theorem pigeonhole_principle: forall (X:Type) (l1  l2:list X),
excluded_middle ->
(forall x, In x l1 -> In x l2) ->
length l2 < length l1 ->
repeats l1.
Proof. hammer_hook "IndProp" "IndProp.pigeonhole_principle".
intros X l1. induction l1 as [|x l1' IHl1'].
Admitted.

Definition manual_grade_for_check_repeats : option (nat*string) := None.

Require Export Coq.Strings.Ascii.

Definition string := list ascii.

Lemma provable_equiv_true : forall (P : Prop), P -> (P <-> True).
Proof. hammer_hook "IndProp" "IndProp.provable_equiv_true".
intros.
split.
- intros. constructor.
- intros _. apply H.
Qed.

Lemma not_equiv_false : forall (P : Prop), ~P -> (P <-> False).
Proof. hammer_hook "IndProp" "IndProp.not_equiv_false".
intros.
split.
- apply H.
- intros. destruct H0.
Qed.

Lemma null_matches_none : forall (s : string), (s =~ EmptySet) <-> False.
Proof. hammer_hook "IndProp" "IndProp.null_matches_none".
intros.
apply not_equiv_false.
unfold not. intros. inversion H.
Qed.

Lemma empty_matches_eps : forall (s : string), s =~ EmptyStr <-> s = [ ].
Proof. hammer_hook "IndProp" "IndProp.empty_matches_eps".
split.
- intros. inversion H. reflexivity.
- intros. rewrite H. apply MEmpty.
Qed.

Lemma empty_nomatch_ne : forall (a : ascii) s, (a :: s =~ EmptyStr) <-> False.
Proof. hammer_hook "IndProp" "IndProp.empty_nomatch_ne".
intros.
apply not_equiv_false.
unfold not. intros. inversion H.
Qed.

Lemma char_nomatch_char :
forall (a b : ascii) s, b <> a -> (b :: s =~ Char a <-> False).
Proof. hammer_hook "IndProp" "IndProp.char_nomatch_char".
intros.
apply not_equiv_false.
unfold not.
intros.
apply H.
inversion H0.
reflexivity.
Qed.

Lemma char_eps_suffix : forall (a : ascii) s, a :: s =~ Char a <-> s = [ ].
Proof. hammer_hook "IndProp" "IndProp.char_eps_suffix".
split.
- intros. inversion H. reflexivity.
- intros. rewrite H. apply MChar.
Qed.

Lemma app_exists : forall (s : string) re0 re1,
s =~ App re0 re1 <->
exists s0 s1, s = s0 ++ s1 /\ s0 =~ re0 /\ s1 =~ re1.
Proof. hammer_hook "IndProp" "IndProp.app_exists".
intros.
split.
- intros. inversion H. exists s1, s2. split.
* reflexivity.
* split. apply H3. apply H4.
- intros [ s0 [ s1 [ Happ [ Hmat0 Hmat1 ] ] ] ].
rewrite Happ. apply (MApp s0 _ s1 _ Hmat0 Hmat1).
Qed.

Lemma app_ne : forall (a : ascii) s re0 re1,
a :: s =~ (App re0 re1) <->
([ ] =~ re0 /\ a :: s =~ re1) \/
exists s0 s1, s = s0 ++ s1 /\ a :: s0 =~ re0 /\ s1 =~ re1.
Proof. hammer_hook "IndProp" "IndProp.app_ne".
Admitted.

Lemma union_disj : forall (s : string) re0 re1,
s =~ Union re0 re1 <-> s =~ re0 \/ s =~ re1.
Proof. hammer_hook "IndProp" "IndProp.union_disj".
intros. split.
- intros. inversion H.
+ left. apply H2.
+ right. apply H1.
- intros [ H | H ].
+ apply MUnionL. apply H.
+ apply MUnionR. apply H.
Qed.

Lemma star_ne : forall (a : ascii) s re,
a :: s =~ Star re <->
exists s0 s1, s = s0 ++ s1 /\ a :: s0 =~ re /\ s1 =~ Star re.
Proof. hammer_hook "IndProp" "IndProp.star_ne".
Admitted.

Definition refl_matches_eps m :=
forall re : @reg_exp ascii, reflect ([ ] =~ re) (m re).

Fixpoint match_eps (re: @reg_exp ascii) : bool
. Admitted.

Lemma match_eps_refl : refl_matches_eps match_eps.
Proof. hammer_hook "IndProp" "IndProp.match_eps_refl".
Admitted.

Definition is_der re (a : ascii) re' :=
forall s, a :: s =~ re <-> s =~ re'.

Definition derives d := forall a re, is_der re a (d a re).

Fixpoint derive (a : ascii) (re : @reg_exp ascii) : @reg_exp ascii
. Admitted.

Example c := ascii_of_nat 99.
Example d := ascii_of_nat 100.

Example test_der0 : match_eps (derive c (EmptySet)) = false.
Proof. hammer_hook "IndProp" "IndProp.test_der0".
Admitted.

Example test_der1 : match_eps (derive c (Char c)) = true.
Proof. hammer_hook "IndProp" "IndProp.test_der1".
Admitted.

Example test_der2 : match_eps (derive c (Char d)) = false.
Proof. hammer_hook "IndProp" "IndProp.test_der2".
Admitted.

Example test_der3 : match_eps (derive c (App (Char c) EmptyStr)) = true.
Proof. hammer_hook "IndProp" "IndProp.test_der3".
Admitted.

Example test_der4 : match_eps (derive c (App EmptyStr (Char c))) = true.
Proof. hammer_hook "IndProp" "IndProp.test_der4".
Admitted.

Example test_der5 : match_eps (derive c (Star (Char c))) = true.
Proof. hammer_hook "IndProp" "IndProp.test_der5".
Admitted.

Example test_der6 :
match_eps (derive d (derive c (App (Char c) (Char d)))) = true.
Proof. hammer_hook "IndProp" "IndProp.test_der6".
Admitted.

Example test_der7 :
match_eps (derive d (derive c (App (Char d) (Char c)))) = false.
Proof. hammer_hook "IndProp" "IndProp.test_der7".
Admitted.

Lemma derive_corr : derives derive.
Proof. hammer_hook "IndProp" "IndProp.derive_corr".
Admitted.

Definition matches_regex m : Prop :=
forall (s : string) re, reflect (s =~ re) (m s re).

Fixpoint regex_match (s : string) (re : @reg_exp ascii) : bool
. Admitted.

Theorem regex_refl : matches_regex regex_match.
Proof. hammer_hook "IndProp" "IndProp.regex_refl".
Admitted.


Require Import Relations.

(* Basic definitions and properties for relations, and relation equivalence *)
Definition rel_eq (A : Type) (R R' : relation A):= forall (x y : A), R x y <-> R' x y.

Lemma rel_eq_eq : forall (A :Type) (R : relation A), rel_eq A R R.
intros. intros x y. split; auto.
Qed.

Lemma rel_eq_fun : forall (A : Type) (R R': relation A), rel_eq A R R' -> rel_eq A R (fun x y => R' x y).
intros. intros x y. split;apply H.
Qed.

Definition rel_comp (A : Type) (R R' : relation A) : relation A := fun x y => exists z, R x z /\ R' z y.

Lemma rel_eq_comp : forall (A : Type) (R R' R0 R0' : relation A), rel_eq A R R0 -> rel_eq A R' R0' -> rel_eq A (rel_comp A R R') (rel_comp A R0 R0').
intros A R1 R2 R1' R2' re re'. intros x y. split; intro rc; induction rc as [z s].
+ exists z. split; [apply re|apply re']; apply s.
+ exists z. split; [apply re|apply re']; apply s.
Qed.

Lemma rel_eq_sym : forall (A : Type) R R', rel_eq A R R' -> rel_eq A R' R.
intros. intros x y. split; apply H.
Qed.

(* Diagrams over relations: usefull for defining and reasoning about (strong or weak) bisimulations and bisimilarities *)
Section Diagrams.
Variable X : Type.
Variable R : relation X.
Variable T1 : relation X.
Variable T2 : relation X.
Variable R' : relation X.

Definition diagram := forall (x y z : X), R x y -> T1 x z -> exists z', T2 y z' /\ R' z z'.

End Diagrams.

Lemma diag_comp_trans : forall (A : Type) (R T T': relation A), diagram A R T T' R -> diagram A R (clos_trans A T) (clos_trans A T') R.
intros A R T T' diag.
intros x y z r tr.
revert r; revert y.
induction tr as [x z  t|x x' x'']; intros y r.
+ edestruct diag as [z' s]; try eassumption.
  exists z'.
  split; [constructor|]; apply s.
+ destruct (IHtr1 y r) as [y' hy'].
  destruct (IHtr2 y') as [y'' hy'']; [apply hy'|].
  exists y''.
  split; [|apply hy''].
  apply t_trans with y'.
  apply hy'. apply hy''.
Qed.

Lemma diag_comp_rt : forall (A : Type) (R T T': relation A), diagram A R T T' R -> diagram A R (clos_refl_trans A T) (clos_refl_trans A T') R.
intros A R T T' diag.
intros x y z r tr.
revert r; revert y.
induction tr as [x z t| |x x' x'']; intros y r.
+ edestruct diag as [z' s]; try eassumption.
  exists z'.
  split; [constructor|]; apply s.
+ exists y. split; [|assumption]. apply rt_refl.
+ destruct (IHtr1 y r) as [y' hy'].
  destruct (IHtr2 y') as [y'' hy'']; [apply hy'|].
  exists y''.
  split; [|apply hy''].
  apply rt_trans with y'.
  apply hy'. apply hy''.
Qed.

Lemma diag_compose : forall (A : Type) (R T1 T2 R' T1' T2' R'' : relation A),
 diagram A R T1 T2 R' -> diagram A R' T1' T2' R''
 -> diagram A R (rel_comp A T1 T1') (rel_comp A T2 T2') R''.
intros A R T1 T2 R' T1' T2' R'' d1 d2.
intros x y z r rc.
destruct rc as [x' s]; destruct s as [t1 t1'].
destruct (d1 x y x' r t1) as [y' s]; destruct s as [t2 r'].
destruct (d2 x' y' z r' t1') as [y'' s]; destruct s as [t2' r''].
exists y''; split; [|apply r''].
exists y'. split; assumption.
Qed.

Section RevDiagrams.
Variable X : Type.
Variable R : relation X.
Variable T1 : relation X.
Variable T2 : relation X.
Variable R' : relation X.
Definition rev_diagram := diagram X (transp X R) T1 T2 (transp X R').

End RevDiagrams.

Arguments diagram [_] _ _ _ _.
Arguments rev_diagram [_] _ _ _ _.

Section SymDiagrams.
Variable X : Type.
Variable R : relation X.
Variable T1 : relation X.
Variable T2 : relation X.
Variable R' : relation X.
Definition sym_diagram := diagram R T1 T2 R' /\ rev_diagram R T1 T2 R'.
End SymDiagrams.

Arguments sym_diagram [_] _ _ _ _.

(* Basic properties of diagrams and relations closures *)

Lemma equiv_diag : forall (A : Type) (R1 T1 T2 R2 R1' T1' T2' R2' : relation A), rel_eq A R1 R1' -> rel_eq A T1 T1' -> rel_eq A T2 T2' -> rel_eq A R2 R2' -> diagram R1 T1 T2 R2 -> diagram R1' T1' T2' R2'.
intros. intros x y z h h'. destruct (H3 x y z). apply H. apply h. apply H0. apply h'. exists x0. split.
apply H1. apply H4. apply H2. apply H4. Qed.

Lemma trans_trans_eq : forall (A : Type) (R : relation A), rel_eq A (clos_trans A R) (clos_trans A (clos_trans A R)).
intros. intros x y. split; intro h.
+ constructor; assumption.
+ induction h.
  - apply H.
  - eapply t_trans; eassumption.
Qed.

Lemma trans_trans_eq2 : forall (A : Type) (R : relation A), rel_eq A (clos_trans A (clos_trans A R)) (clos_trans A R).
intros. intros x y. split; intro h.
+ induction h.
  - apply H.
  - eapply t_trans; eassumption.
+ constructor; assumption.
Qed.

Lemma trans_trans_refl_eq2 : forall (A : Type) (R : relation A), rel_eq A (clos_trans A (clos_refl_trans A R)) (clos_refl_trans A R).
intros. intros x y. split; intro h.
+ induction h.
  - induction H. constructor; apply H. apply rt_refl. eapply rt_trans. apply IHclos_refl_trans1. apply IHclos_refl_trans2.
  - eapply rt_trans; eassumption.
+ induction h.
  - constructor. constructor. assumption.
  - apply t_step. apply rt_refl.
  - eapply t_trans; eassumption.
Qed.

Lemma trans_refl_trans_refl_eq2 : forall (A : Type) (R : relation A), rel_eq A (clos_refl_trans A (clos_refl_trans A R)) (clos_refl_trans A R).
intros. intros x y. split; intro h.
+ induction h.
  - induction H. constructor; apply H. apply rt_refl. eapply rt_trans. apply IHclos_refl_trans1. apply IHclos_refl_trans2.
  - apply rt_refl.
  - eapply rt_trans; eassumption.
+ induction h.
  - constructor. constructor. assumption.
  - apply rt_step. apply rt_refl.
  - eapply rt_trans; eassumption.
Qed.

Lemma weaker_refl_trans : forall (A : Type) (R R' : relation A), (forall x y, R x y -> R' x y) -> forall x y, clos_refl_trans A R x y -> clos_refl_trans A R' x y.
intros A R R' h x y h'.
induction h' as [x y h' | | ].
+ constructor. apply (h x y h').
+ eapply rt_refl.
+ eapply rt_trans with y; assumption.
Qed.


Require Import PeanoNat.
Require Import List.
Require Import Coq.omega.Omega.
Require Import FiatHelpers.

Section ListHelpers.
  Lemma nth_default_0: forall A: Type, forall a b : A, forall l: list A,
        nth_default b (a::l) 0 = a.
  Proof.
    intros a l.
    reflexivity.
  Qed.

  Lemma nth_default_nil: forall A: Type, forall b : A, forall i,
          nth_default b nil i = b.
  Proof.
    intros A0. intros b. intros i.
    unfold nth_default.
    unfold nth_error.
    destruct i.
    - reflexivity.
    - reflexivity.
  Qed.

  Lemma nth_default_S: forall A: Type, forall a b : A, forall l: list A, forall i,
            nth_default b (a :: l) (S i) = nth_default b l i.
  Proof.
    intros A0 a b l i.
    unfold nth_default.
    unfold nth_error.
    reflexivity.
  Qed.

  Lemma nth_default_map : forall A B X d d0 i, forall f: A -> B,
        f (d) = d0 -> nth_default d0 (map f X) i =  f (nth_default d X i).
  Proof.
    intros A B X.
    induction X as [| v X IHX].
    - intros d d0 i0 f H. simpl. rewrite nth_default_nil. rewrite nth_default_nil. rewrite H. reflexivity.
    - intros d d0 i0 f H. destruct i0.
      + rewrite nth_default_0. simpl. rewrite nth_default_0. reflexivity.
      + rewrite nth_default_S. simpl. rewrite nth_default_S. apply IHX.
        apply H.
  Qed.

  Lemma nth_default_map_in_range : forall A B X d d0 i, forall f: A -> B,
        i < length X -> nth_default d0 (map f X) i =  f (nth_default d X i).
  Proof.
    intros A B X.
    induction X as [| v X IHX].
    - intros d d0 i0 f H. inversion H.
    - intros d d0 i0 f H. destruct i0.
      + rewrite nth_default_0. simpl. rewrite nth_default_0. reflexivity.
      + rewrite nth_default_S. simpl. rewrite nth_default_S. apply IHX.
        simpl in H. omega.
  Qed.
End ListHelpers.

Ltac elim_bool:=
  repeat match goal with
         | [ |- context [Nat.eqb ?x ?y]] => let eq := fresh "eq" in destruct (x =? y) eqn: eq
         | [H: ?x =? ?y = false |- _] => apply Nat.eqb_neq in H
         | [H: ?x =? ?y = true |- _] => apply Nat.eqb_eq in H
         | [H: ?x <? ?y = true |- _] => apply Nat.ltb_lt in H
         | [H: ?x <? ?y = false |- _] => apply Nat.ltb_ge in H
         | [H: ?x <=? ?y = true |- _] => apply Nat.leb_le in H
         | [H: ?x <=? ?y = false |- _] => apply Nat.leb_gt in H
         end.

Ltac is_variable A :=
  match goal with
  | [ B :_ |- _] =>
    let eq := fresh "eq" in
    assert (eq: A = B) by auto; clear eq
  end.

Ltac is_constant a :=
  let a := (eval compute in a) in
  assert (a = a) by
      (clear;
       lazymatch goal with
       | [ H: _ |- _ ] => fail "NC"
       | _ => idtac
       end;
       reflexivity).

Ltac is_function a :=
  let b := type of (a) in
  match b with
  | ?A -> ?B => idtac
  end.

Ltac separable a :=
  tryif (is_constant a) then fail 0
  else tryif (is_variable a) then fail 0
    else tryif (is_function a) then fail 0
      else idtac.

Ltac reveal_body_evar :=
  match goal with
  | [ H := ?x : methodType _ _ _ |- _ ] => is_evar x; progress unfold H
                                                             (* | [ H := ?x : constructorType _ _ |- _ ] => is_evar x; progress unfold H *)
  end.

Ltac cleanup :=
  repeat match goal with
         | [ H: _ /\ _ |- _ ] => destruct H
         | _ => progress subst
         | _ => progress (cbv iota)
         | _ => progress simpl
         | _ => simplify with monad laws
         end.