(** * Bohm Trees *)

Require Import Coq.Logic.Classical_Pred_Set.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Equality.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Logic.Decidable.
Require Import Coq.Bool.Bool.
Require Import InformationOrdering.
Require Import Nontermination.
Require Export Compile.

(* TODO prove reflexive, transitive, etc. *)

(* ------------------------------------------------------------------------ *)
(** ** Bohm trees as normal forms *)

(** Bohm trees generalize the normal forms of pure lambda-calculus,
    where the language is extended by
    terms [BOT] and [TOP],
    reduction rules [BOT x -beta-> BOT] and [TOP x -beta-> TOP],
    and approximation rules [x -pi-> BOT] and [TOP -pi-> x].

    In the lambda-join-calculus, we also have
    terms [JOIN x y],
    a reduction rule [JOIN x y * z -beta-> JOIN (x * z) (y * z)],
    and three approximation rules:
    [z -pi-> x -> z -pi-> y -> z -pi-> JOIN x y]
    (or equivalently [x -pi-> JOIN x x]),
    [JOIN x y -pi-> x], and
    [JOIN x y -pi-> y].
    *)

Inductive normal {Var : Set} : Term Var -> Prop :=
  | normal_top : normal TOP
  | normal_bot : normal BOT
  | normal_join x y : normal x -> normal y -> normal (x || y)
  | normal_rand x y : normal x -> normal y -> normal (x (+) y)
  | normal_lambda x : @normal (option Var) x -> normal (LAMBDA x)
  | normal_inert x : inert x -> normal x
with inert {Var : Set} : Term Var -> Prop :=
  | inert_var v : inert (VAR v)
  | inert_app x y : inert x -> normal y -> inert (x * y).
Hint Constructors normal inert.

Lemma inert_normal (Var : Set) (x : Term Var) : inert x -> normal x.
Proof.
  intro H; induction H; eauto.
Qed.
Hint Resolve inert_normal.

Fixpoint normal_protect (Var : Set) (x : Term Var) (n : normal x) {struct n} :
  normal (term_protect x)
with inert_protect (Var : Set) (x : Term Var) (i : inert x) {struct i} :
  inert (term_protect x).
Proof.
  - induction n; unfold term_protect; simpl; fold (@term_protect Var); auto.
    + admit.  (* TODO use an option_map lemma or sth *)
  - induction i; unfold term_protect; simpl; fold (@term_protect Var); auto.
Admitted.
Hint Resolve normal_protect inert_protect.

Fixpoint is_normal {Var : Set} (w : Term Var) {struct w} : bool :=
  match w with
  | TOP => true
  | BOT => true
  | x || y => andb (is_normal x) (is_normal y)
  | x (+) y => andb (is_normal x) (is_normal y)
  | x * y => andb (is_inert x) (is_normal y)
  | term_var v => true
  | term_lambda x => is_normal x
  end
with is_inert {Var : Set} (w : Term Var) {struct w} : bool :=
  match w with
  | x * y => andb (is_inert x) (is_normal y)
  | term_var v => true
  | _ => false
  end.

Lemma is_inert_is_normal {Var : Set} (x : Term Var) :
  is_inert x = true -> is_normal x = true.
Proof.
  induction x; simpl; auto; intro H; inversion H.
Qed.

Fixpoint normal_is_normal {Var : Set} (x : Term Var) :
  normal x -> is_normal x = true
with inert_is_inert {Var : Set} (x : Term Var) :
  inert x -> is_inert x = true.
Proof.
  - clear normal_is_normal.
    intro H; induction H; simpl; auto.
    + rewrite IHnormal1, IHnormal2; simpl; auto.
    + rewrite IHnormal1, IHnormal2; simpl; auto.
    + apply is_inert_is_normal; apply inert_is_inert; auto.
  - clear inert_is_inert.
    intro H; induction H; simpl; auto.
    rewrite IHinert; simpl.
    auto using normal_is_normal.
Admitted.

Fixpoint normal_is_normal' {Var : Set} (x : Term Var) :
  is_normal x = true -> normal x
with inert_is_inert' {Var : Set} (x : Term Var) :
  is_inert x = true -> inert x.
Proof.
  - clear normal_is_normal'.
    dependent induction x; simpl; intros; eauto.
    + case_eq (is_normal x1); intro H1; rewrite H1 in H; simpl in H.
      apply normal_join; [apply IHx1 | apply IHx2]; auto.
      inversion H.
    + case_eq (is_normal x1); intro H1; rewrite H1 in H; simpl in H.
      apply normal_rand; [apply IHx1 | apply IHx2]; auto.
      inversion H.
  - clear inert_is_inert'.
    dependent induction x; simpl; intros; eauto; try inversion H.
    case_eq (is_inert x1); intro H2; rewrite H2 in H; simpl in H.
    apply inert_app; [apply IHx1 | try apply normal_is_normal']; auto.
    inversion H.
Admitted.

Lemma normal_is_normal_true {Var : Set} (x : Term Var) :
  normal x <-> is_normal x = true.
Proof.
  split; [apply normal_is_normal | apply normal_is_normal'].
Qed.

Lemma normal_is_normal_false {Var : Set} (x : Term Var) :
 ~ normal x <-> is_normal x = false.
Proof.
  case_eq (is_normal x); intros H; split; intro H'; auto.
  - rewrite normal_is_normal_true in H'; contradiction.
  - inversion H'.
  - rewrite normal_is_normal_true, H; auto.
Qed.

Ltac case_normal x :=
  let Hnx := fresh "Hn" x in
  case_eq (is_normal x);
  intro Hnx;
  [ rewrite <- normal_is_normal_true in Hnx
  | rewrite <- normal_is_normal_false in Hnx].

Lemma normal_decidable {Var : Set} (x : Term Var) : decidable (normal x).
Proof.
  unfold decidable; rewrite normal_is_normal_true; decide equality.
Qed.
Hint Resolve normal_decidable.

Ltac solve_normal :=
  match goal with
  | _ : _ |- normal _ => apply normal_is_normal_true; simpl; auto
  end.

Lemma normal_i (Var : Set) : normal (DeBruijn.I : Term Var).
Proof.
  solve_normal.
Qed.
Hint Resolve normal_i.

Lemma normal_k (Var : Set) : normal (DeBruijn.K : Term Var).
Proof.
  solve_normal.
Qed.
Hint Resolve normal_k.

Lemma normal_b (Var : Set) : normal (DeBruijn.B : Term Var).
Proof.
  solve_normal.
Qed.
Hint Resolve normal_b.

Lemma normal_c (Var : Set) : normal (DeBruijn.C : Term Var).
Proof.
  solve_normal.
Qed.
Hint Resolve normal_c.

Lemma normal_s (Var : Set) : normal (DeBruijn.S : Term Var).
Proof.
  solve_normal.
Qed.
Hint Resolve normal_s.

Lemma normal_j (Var : Set) : normal (DeBruijn.J : Term Var).
Proof.
  solve_normal.
Qed.
Hint Resolve normal_j.

Lemma normal_r (Var : Set) : normal (DeBruijn.R : Term Var).
Proof.
  solve_normal.
Qed.
Hint Resolve normal_r.

(** Bohm trees are normal forms WRT the following notion of reduction. *)

Inductive reduce {Var : Set} : relation (Term Var) :=
  | reduce_refl x : reduce x x
  | reduce_trans x y z : reduce x y -> reduce y z -> reduce x z
  | reduce_join_left x x' y : reduce x x' -> reduce (x || y) (x' || y)
  | reduce_join_right x y y' : reduce y y' -> reduce (x || y) (x || y')
  | reduce_rand_left x x' y : reduce x x' -> reduce (x (+) y) (x' (+) y)
  | reduce_rand_right x y y' : reduce y y' -> reduce (x (+) y) (x (+) y')
  | reduce_app_left x x' y : reduce x x' -> reduce (x * y) (x' * y)
  | reduce_app_right x y y' : reduce y y' -> reduce (x * y) (x * y')
  | reduce_lambda x x' :
      @reduce (option Var) x x' -> reduce (LAMBDA x) (LAMBDA x')
  | reduce_top y : reduce (TOP * y) TOP
  | reduce_bot y : reduce (BOT * y) BOT
  | reduce_join_app x y z : reduce ((x || y) * z) (x * z || y * z)
  | reduce_rand_app x y z : reduce ((x (+) y) * z) (x * z (+) y * z)
  | reduce_lambda_app x y : reduce (term_lambda x * y) (lambda_app_sub x y).
Hint Constructors reduce.

Hint Rewrite
  @reduce_bot @reduce_join_app @reduce_rand_app @reduce_lambda_app
  : term_simpl.

Ltac term_simpl := autorewrite with term_simpl using simpl.

Instance reduce_reflexive (Var : Set) : Reflexive (@reduce Var) :=
  reduce_refl.

Instance reduce_transitive (Var : Set) : Transitive (@reduce Var) :=
  reduce_trans.

Instance term_join_proper_reduce (Var : Set) :
  Proper (reduce ==> reduce ==> reduce) (@term_join Var).
Proof.
  intros x x' xx' y y' yy'; transitivity (x' || y);
  [apply reduce_join_left | apply reduce_join_right]; assumption.
Qed.

Instance term_rand_proper_reduce (Var : Set) :
  Proper (reduce ==> reduce ==> reduce) (@term_rand Var).
Proof.
  intros x x' xx' y y' yy'; transitivity (x' (+) y);
  [apply reduce_rand_left | apply reduce_rand_right]; assumption.
Qed.

Instance term_app_proper_reduce (Var : Set) :
  Proper (reduce ==> reduce ==> reduce) (@term_app Var).
Proof.
  intros x x' xx' y y' yy'; transitivity (x' * y);
  [apply reduce_app_left | apply reduce_app_right]; assumption.
Qed.

Instance term_lambda_proper_reduce (Var : Set) :
  Proper (reduce ==> reduce) (@term_lambda Var) := reduce_lambda.

Instance reduce_eq_subrelation (Var : Set) : subrelation reduce (@term_eq Var).
Proof.
  unfold term_eq; intros x y xy; induction xy; simpl; auto.
  - transitivity (compile y); assumption.
  - rewrite IHxy; auto.
  - code_simpl; auto.
  - code_simpl; auto.
  - rewrite compile_lambda_app; auto.
Qed.

Fixpoint try_reduce_step {Var : Set} (x : Term Var) : option (Term Var) :=
  match x with
  | TOP * y => Some TOP
  | BOT * y => Some BOT
  | (x1 || x2) * y => Some (x1 * y || x2 * y)
  | (x1 (+) x2) * y => Some (x1 * y (+) x2 * y)
  | term_lambda x1 * x2 => Some (lambda_app_sub x1 x2)
  | l * r =>
      match try_reduce_step l with
      | Some l' => Some (l' * r)
      | None =>
          match try_reduce_step r with
          | Some r' => Some (l * r')
          | None => None
          end
      end
  | (l || r) =>
      match try_reduce_step l with
      | Some l' => Some (l' || r)
      | None =>
          match try_reduce_step r with
          | Some r' => Some (l || r')
          | None => None
          end
      end
  | l (+) r =>
      match try_reduce_step l with
      | Some l' => Some (l' (+) r)
      | None =>
          match try_reduce_step r with
          | Some r' => Some (l (+) r')
          | None => None
          end
      end
  | term_lambda y =>
      match try_reduce_step y with
      | Some y' => Some (LAMBDA y')
      | None => None
      end
  | _ => None
  end.

Section try_reduce_step_reduce.
  Local Ltac case_reduce x H :=
    let x' := fresh x "'" in
    let eq := fresh "E" x in
    case_eq (try_reduce_step x); [intros x' eq | intro eq];
    rewrite eq in H; simpl in H; auto.

  Lemma try_reduce_step_reduce (Var : Set) (x : Term Var) :
    match try_reduce_step x with
    | None => True
    | Some x' => reduce x x'
    end.
  Proof.
    induction x; simpl; auto.
    - case_reduce x1 IHx1; case_reduce x2 IHx2.
    - case_reduce x1 IHx1; case_reduce x2 IHx2.
    - case_reduce x1 IHx1;
      case_eq x1; intros; simpl; auto.
      + rewrite <- H; rewrite IHx1; reflexivity.
      + rewrite <- H; rewrite IHx1; reflexivity.
      + case_reduce x2 IHx2.
      + case_reduce x2 IHx2.
    - case_reduce x IHx.
  Qed.
End try_reduce_step_reduce.

Fixpoint is_irreducible {Var : Set} (x : Term Var) : bool :=
  match x with
  | TOP * _ => false
  | BOT * _ => false
  | (_ || _) * _ => false
  | (_ (+) _) * _ => false
  | term_lambda x1 * x2 => false
  | l * r => andb (is_irreducible l) (is_irreducible r)
  | l || r => andb (is_irreducible l) (is_irreducible r)
  | l (+) r => andb (is_irreducible l) (is_irreducible r)
  | term_lambda x1 => is_irreducible x1
  | _ => true
  end.

Definition is_none {a : Set} (x : option a) : bool :=
  match x with
  | None => true
  | Some _ => false
  end.

Section try_reduce_step_is_irreducible.
  Local Ltac case_some x H :=
    let x' := fresh x "'" in
    let Hx' := fresh x "'" in
    intros x' Hx';
    rewrite Hx' in H; simpl in H; rewrite H;
    simpl.

  Local Ltac case_none x H :=
    let Hx' := fresh x "'" in
    intro Hx';
    rewrite Hx' in H; simpl in H; rewrite H;
    simpl.

  Local Ltac cases_option x IHx :=
    case_eq (try_reduce_step x); [case_some x IHx | case_none x IHx].

  Local Ltac cases_option2 x1 x2 IHx1 IHx2 :=
    cases_option x1 IHx1;
    [ case x1; auto
    | cases_option x2 IHx2; case x1; auto
    ].

  Lemma try_reduce_step_is_irreducible {Var : Set} (x : Term Var) :
    is_irreducible x = is_none (try_reduce_step x).
  Proof.
    induction x; simpl; auto.
    - cases_option2 x1 x2 IHx1 IHx2.
    - cases_option2 x1 x2 IHx1 IHx2.
    - cases_option2 x1 x2 IHx1 IHx2.
    - cases_option x IHx; auto.
  Qed.
End try_reduce_step_is_irreducible.

Theorem is_irreducible_is_normal {Var : Set} (x : Term Var) :
  is_irreducible x = is_normal x.
Proof.
  induction x; simpl; auto.
  - rewrite IHx1; rewrite IHx2; clear IHx1 IHx2; revert x2.
    induction x1; simpl; auto.
  - rewrite IHx1; rewrite IHx2; clear IHx1 IHx2; simpl.
    case (is_normal x1); case (is_normal x2); simpl; reflexivity.
  - rewrite IHx1; rewrite IHx2; clear IHx1 IHx2; simpl.
    induction x1; auto.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Decidable properties of Bohm trees *)

Fixpoint normal_conv {Var : Set} (x : Term Var) : bool :=
  match x with
  | TOP => true
  | BOT => false
  | (x1 || x2) => orb (normal_conv x1) (normal_conv x2)
  | x1 (+) x2 => andb (normal_conv x1) (normal_conv x2)
  | x1 * x2 => normal_conv x1  (* assumes x is normal *)
  | term_lambda x => normal_conv x
  | term_var v => true
  end.

Lemma term_conv_normal_conv (Var : Set) (x : Term Var) :
  term_conv x <-> normal_conv x = true.
Proof.
Admitted.

Lemma term_conv_normal_conv' {Var : Set} (x : Term Var) :
 ~ term_conv x <-> normal_conv x = false.
Proof.
  case_eq (normal_conv x); intros H; split; intro H'; auto.
  - rewrite term_conv_normal_conv in H'; contradiction.
  - inversion H'.
  - rewrite term_conv_normal_conv, H; auto.
Qed.

Ltac case_normal_conv x :=
  let Hcx := fresh "Hc" x in
  case_eq (normal_conv x);
  intro Hcx;
  [ rewrite <- term_conv_normal_conv in Hcx
  | rewrite <- term_conv_normal_conv' in Hcx].

Lemma normal_conv_decidable (Var : Set) (x : Term Var) :
  normal x -> decidable (term_conv x).
Proof.
  unfold decidable; rewrite term_conv_normal_conv; decide equality.
Qed.
Hint Resolve normal_conv_decidable.

Definition normal_conv' {Var : Set} (x : Term Var) :
  normal x -> {term_conv x} + {~ term_conv x}.
Proof.
  intro Hn; case_normal_conv x; auto.
Defined.

Definition try_decide_conv {Var : Set} (x : Term Var) :
  {term_conv x} + {~ term_conv x} + {~normal x}.
Proof.
  case_normal x; [case_normal_conv x|]; auto.
Defined.

Fixpoint normal_pconv {Var : Set} (x : Term Var) : dyadic.
Admitted.

(* This uses beta-eta discrimination; do BTs have eta normal forms? *)
Fixpoint normal_is_le {Var : Set} (x y : Term Var) : bool.
Admitted.

Lemma normal_is_le_correct (Var : Set) (x y : Term Var) :
  normal x -> normal y ->
  if normal_is_le x y then x [= y else ~ x [= y.
Admitted.

Definition normal_is_le' {Var : Set} (x y : Term Var) :
  normal x -> normal y -> {x [= y} + {~ x [= y}.
Proof.
  intros Hnx Hny; set (H := normal_is_le_correct Var x y Hnx Hny).
  case_eq (normal_is_le x y); intro eq; rewrite eq in H; simpl in H;
  [apply left | apply right]; assumption.
Defined.

Definition normal_le {Var : Set} : relation (Term Var) :=
  fun x y => normal_is_le x y = true.

Lemma normal_is_le_le (Var : Set) (x y : Term Var) :
  normal x -> normal y -> (x [= y <-> normal_is_le x y = true).
Proof.
Admitted.

Lemma normal_is_le_le' {Var : Set} (x y : Term Var) :
  normal x -> normal y -> (~ x [= y <-> normal_is_le x y = false).
Proof.
  case_eq (normal_is_le x y); intros H; split; intro H'; auto.
  - rewrite normal_is_le_le in H'; auto; contradiction.
  - inversion H'.
  - rewrite normal_is_le_le, H; auto.
Qed.

Ltac case_normal_le x y :=
  let Hxy := fresh "H" x y in
  case_eq (normal_le x y);
  intro Hxy;
  [ rewrite <- normal_is_le_le in Hxy
  | rewrite <- normal_is_le_le' in Hxy].

Lemma normal_le_decidable (Var : Set) (x y : Term Var) :
  normal x -> normal y -> decidable (x [= y).
Proof.
  intros; unfold decidable; rewrite normal_is_le_le; auto; decide equality.
Qed.
Hint Resolve normal_le_decidable.

Definition try_decide_le (x y : ClosedTerm) :
  {x [= y} + {~ x [= y} + {~normal x \/ ~normal y}.
Proof.
  case_normal x; case_normal y; auto.
  apply inleft; apply normal_is_le'; auto.
Defined.

(* ------------------------------------------------------------------------ *)
(** ** Theorems about bohm trees and order *)

(** The [normal_dense] theorem motivates where to allow [JOIN] and [RAND]
    in Bohm trees.
    Whereas \cite{obermeyer2009automated} restricts [JOIN] and [RAND] to
    the argument of an [inert] variable,
    we here allow them at the top level
    to allow finite joins of dyadic mixtures.

    Question:
    Should [JOIN] and [RAND] be restricted to be inside lambda abstractions
    so as to force compatibility among proofs of repair and raise theorems?
    Consider the example

      \x y z. x <TOP> BOT (+) x BOT <TOP>

    What are the proof terms?
    *)

Theorem normal_dense {Var : Set} (x y : Term Var) :
  (forall x', normal x' -> x' [= x -> x' [= y) -> x [= y.
Proof.
Admitted.

(** Classically we can provide normal witnesses of non-ordering. *)

Lemma impl_not_impl_not (a b : Prop) : (~ b -> ~ a) <-> (a -> b).
Proof.
  apply contrapositive; apply classic.
Qed.

Corollary nle_normal_witness {Var : Set} (x y : Term Var) :
  ~ x [= y ->
  exists x', normal x' /\ x' [= x /\
  ~ x' [= y.
Proof.
  intro Hxy.
  set (H := normal_dense x y); apply impl_not_impl_not in H; auto.
  apply not_all_ex_not in H; destruct H as [x' H]; exists x'.
  repeat split; auto.
  - apply not_imply_elim in H; assumption.
  - apply not_imply_elim2 in H; apply not_imply_elim in H; assumption.
Qed.


Require Import List.
Import ListNotations.
Require Import Classes.EquivDec.
Require Import Coq.Program.Program.
Require Import Bool.
Require Import ListSet.

(*leave the type inference at maximum level in Coq, not being necessary to declare the type*)
(*of parameters of functions, as seen in https://coq.inria.fr/cocorico/CoqNewbieQuestions  *)

Set Implicit Arguments.
(*Coq will try to infer at maximum level the arguments' types *)
Set Maximal Implicit Insertion.

(* First, some library helper functions and notations. *)
(* https://coq.inria.fr/distrib/current/refman/Reference-Manual023.html#hevea_command261/ *)
(*Instance: in this case, the Instance keyword creates a instance of the EqDec class,i.e, *)
(*creates an instance of an equality relation for the type option A (A: Type)             *)
(*Program : gives a way to write programs as if they were written in a regular functional *)
(*programming language, such as Haskell, using the Coq proof apparatus to generate a sound*)
(*program from the specification given.                                                   *)

(*eq: equality relation, it is an inductive proposition that gives the notion of equality *)
(*between 2 elements of the same type. It is in Coq.Init.Logic.                           *)

Obligation Tactic := unfold complement, equiv ; program_simpl.
(*needed tactic, so the obligations generated by Program to deal with the proof of the sound*)
(*ness is solved automatically by the Program keyword.                                     *)

Program Instance option_eqdec A `(EqDec A eq) : EqDec (option A) eq :=
{
  equiv_dec x y :=
    match x, y with
      | Some a, Some b => if a == b then in_left else in_right
      | None, None => in_left
      | Some _, None | None, Some _ => in_right
    end
 }.
(* Equality decidion procedure for pairs *)
Program Instance pair_eqdec A B `(EqDec A eq) `(EqDec B eq) : EqDec (A * B) eq :=
{
  equiv_dec x y :=
    match x,y with
      | pair a b, pair c d => if (a == c) then
                              if (b == d) then in_left else in_right
                              else in_right
    end
}.
Definition filterMap {A B} (f : A -> option B) : list A -> list B :=
  fix rec (l : list A) : list B :=
    match l with
    | [] => []
    | x :: l => match f x with
               | None => rec l
               | Some y => y :: rec l
               end
    end.

Definition add_list_to_set {A} `{EqDec A eq} : list A -> set A :=
  fix rec l :=
    match l with
    | [] => []
    | a::t => set_add equiv_dec (a) (rec t)
  end.

(* We define a function that computes the powerset of a set *)
Fixpoint powerset {A} (l:set A) : set (set A) :=
match l with
  | [] => [[]]
  | a::t => concat (map (fun f => [a::f;f]) (powerset t))
end.

(* Returns true if all elements of s1 is in s2 *)
Fixpoint s1_in_s2 {A} `{EqDec A eq} (s1 s2 : set A) :=
  match s1 with
    | [] => true
    | a::t => set_mem equiv_dec a s2 && s1_in_s2 t s2
  end.

Fixpoint set_eq {A} `{EqDec A eq} (s1 s2 : set A) :=
  if (length s1 == length s2) then
      if (s1_in_s2 s1 s2) then
          if (s1_in_s2 s2 s1) then true else false
      else false
  else false.

Notation "x |> f" := (f x) (left associativity, at level 69, only parsing).

(* A type representing valid right-hand sides of left-regular grammar rules.
   The original email used a much looser representation of rules, which did not
   separate the LHS from the RHS, and which did not enforce regularity. By
   restricting the representation, we make it easier to write a parser. *)
Module rhs.
  (*RHS: Right Hand Side: How right linear regular grammar should behave:its rules should  *)
  (*be A -> a, A -> a B or A -> e, where A and B denotes nonterminal symbols and a denotes.*)
  (* a terminal symbol.                                                                    *)

  Inductive t T NT :=
  | Empty : t T NT
  | Single : T -> t T NT
  | Continue : T -> NT -> t T NT.
  (* Coq will infer the type of the arguments of the constructors of the RHS type, as seen in *)
  (*https://coq.inria.fr/distrib/current/refman/Reference-Manual004.html#hevea_command59      *)
  (* so we don't have to worry about expliciting the types every now and then. *)

  Arguments Empty {_} {_}.
  Arguments Single {_} {_} _.
  Arguments Continue {_} {_} _ _.
  (*the function below checks whether a rule is empty or not, given the terminal and nonterminal    *)
  (*and the RHS of a rule, returns true if this RHS is Empty, otherwise, returns false        *)
  Definition isEmpty (T NT : Type) (rhs : rhs.t T NT) : bool :=
    match rhs with
    | Empty => true
    | _ => false
    end.

  Module exports.
    Notation Empty := Empty.
    Notation Single := Single.
    Notation Continue := Continue.
  End exports.
End rhs.
Import rhs.exports.

(* A helper to give us the notion of equality over RHS *)
Program Instance rhs_eqdec A B `(EqDec A eq) `(EqDec B eq) : EqDec (rhs.t A B) eq :=
{
  equiv_dec x y :=
    match x,y with
      | Empty, Empty => in_left
      | Single a, Single b => if a == b then in_left else in_right
      | Continue a nt, Continue b nt' => if a == b then
                                         if nt == nt' then in_left else in_right
                                      else in_right
      | Empty, Single _ => in_right
      | Empty, Continue _ _ => in_right
      | Single _, Empty => in_right
      | Single _, Continue _ _ => in_right
      | Continue _ _, Empty => in_right
      | Continue _ _, Single _ => in_right
    end
}.

Module reg_grammar.
  Section reg_grammar.
    Variable T NT: Type.
    Context  `{EqDec T eq} `{EqDec NT eq}.
    (*When using this, it is possible to use the notion of equality between elements of type*)
    (* T and NT                                                                             *)
    Record g : Type:= {
      start_symbol: NT;
      rules : set (NT * rhs.t T NT);
      terminal_symbols : set T;
      nonterminal_symbols : set NT
    }.

    (* Note that the terminal symbols and nonterminal symbols are sets implemented as lists *)
    (* It fails if the user provides directly to the record a list with repeated symbols    *)
    Definition build_grammar (nt: NT) rules alphabet nonterminal: g :={|
      start_symbol := nt;
      rules := add_list_to_set (rules);
      terminal_symbols := add_list_to_set (alphabet) ;
      nonterminal_symbols := add_list_to_set (nonterminal) |}.

  (* Next, we're going to write a function [parse] that decides whether a string
     is in the language represented by the grammar. The parser keeps track of
     the set of nonterminal symbols it's currently in, with the additonal
     special symbol None representing "end of string when the last rule applied
     had RHS [Single]". *)

  (* It may help to scroll down to the function [parse] first, and read
     backwards up to here. *)

  (* Given the RHS of a rule and a terminal, decides whether the RHS can be used. *)
  (* In others words, given a RHS of a rule and a terminal symbol, it checks how, if it *)
  (* can be used, the RHS will be used.                                            *)
  Definition step_rhs (t : T) (rhs : rhs.t T NT) : list (option NT) :=
    match rhs with
    | Empty => []
    | Single t' => if t == t' then [None] else []
    | Continue t' nt => if t == t' then [Some nt] else []
    end.

  (* Finds all the productions for a given nonterminal. *)
  (*Note: this list will never be empty, if the nt symbol belongs to the grammar   *)
  Definition getRHS `{EqDec NT eq}
           (nt : NT) : set (NT * rhs.t T NT) ->
                       set (rhs.t T NT) :=
    filterMap (fun rule => let '(nt', rhs) := rule in
                        if nt == nt' then Some rhs else None).

  (* Given a nonterminal [nt], applies all possible rules,applying step_rhs on the             *)
  (* list of nonterminal symbols obtained by applying getRHS nt with the rules of the grammar  *)

  Definition step_nt (rules : set(NT * rhs.t T NT)) (t : T) (nt : NT) : set (option NT) :=
    rules |> getRHS nt  |> flat_map (step_rhs t).

  (* Given a *list* of nonterminals, takes all possible next steps. *)
  (*map: returns 1 value for each application of the function for each element of the list. *)
  (*flat_map: returns 0 or more values for each application of the function in each list element.*)
  (*if applyable *)
  Definition step (rules : set (NT * rhs.t T NT)) (t : T) (acc : set NT) : set (option NT) :=
    acc |> flat_map (step_nt rules t) |> nodup equiv_dec .

  (* The main parser loop. Repeatedly steps the current set of states using
     terminals from the string. *)
  Definition parse' (rules : set (NT * rhs.t T NT))
           : list T -> set (option NT) -> set (option NT) :=
    fix rec l acc :=
      match l with
      | [] => acc
      | t :: l =>
    (*filtermap id : acc gets the elements of t::l. *)
        acc |> filterMap id
            |> step rules t
            |> rec l
      end.
  (* Checks to see if the current state represents an accepting state.  In this
     representataion of state, a state is accepting if it contains [None] or if
     it contains [Some nt] and there is a rule [(nt, Empty)].  *)
  Definition is_final (rules : set (NT * rhs.t T NT)) (l : set (option NT)) : bool :=
  (*existsb: boolean exists, chech whether a condition can
   be met by any of the elements in l*)
  (*This function is in Coq.Lists, where o is an element of the list l.*)
  (* Note that the order of the elements in this list does not affect the result,*)
  (* because for all elements of the list it is checked whether a state is final *)
  (*according to the rules.                                                      *)
    existsb (fun o => match o with
                   | None => true
                   | Some nt => getRHS nt rules |> existsb rhs.isEmpty
                   end)
            l.
  (* Top-level parse function. Calls [parse'] with the initial symbol and checks
     to see whether the resulting state is accepting. *)
  Definition parse (grammar : reg_grammar.g) (l : list T): bool :=
    [Some (start_symbol grammar)] |> parse' (rules grammar) l |> is_final (rules grammar).

  (*Returns the final derivation state of the grammar *)
  Definition parse_aux (grammar: reg_grammar.g) (l:list T) :=
   [Some (start_symbol grammar)] |> parse' (rules grammar) l.

  End reg_grammar.
End reg_grammar.

(* Nondeterministic finite automata *)
Module nfa.
  Section nfa.
    Variable (A ST : Type).
    Context  `{EqDec ST eq} `{EqDec A eq}.

    Record t := NFA {
      initial_state : ST;
      is_final : ST -> bool;
      next : A -> ST -> set ST;
      states: set ST;
      alphabet: set A
   }.
    (* run' is the function that does the verification steps of the automata, applying     *)
    (* the transition functions in the list of terminal symbols, returning a state, which  *)
    (* can be final or not.                                                                *)

    Definition step (nfa:t) (states : set ST) (t:A) : list ST :=
      states |> flat_map (next nfa t).

    (* Since a NFA can have multiple paths for a single run, we have to check them all. *)
    Definition run' (m: t)
           : list A -> set ST -> set ST :=
    fix rec l acc :=
      match l with
      | [] => acc
      | t :: l => step m acc t
               |> rec l
      end.
    (* The acceptance criteria is sliglty modified : since we can reach more than one state *)
    (* while going through a word, we have to check whether the nfa can be at (at least) one*)
    (* final state. The verify_final_state function goes though a list of possible states   *)
    (* and checks if one of them is a final state. The run function will go through a word, *)
    (* returning true iff the nfa reached a final state, otherwise it returns false.        *)

    Definition verify_final_state' (m:t) (states: set ST) :=
      existsb (fun x => is_final m x) states.

    (* We call the above function to check whether the run in the nfa returns true or false. *)
    Definition run (m : t) (l : list A) : bool :=
     verify_final_state' m ((run' (m) l  ([initial_state m]))).
    Definition run2 (m :t) (l : list A) : set ST :=
      nodup equiv_dec (run' (m) l  ([initial_state m])).

    (* The path function returns all the states the automata have been while consuming the *)
    (* word given to be checked whether it is recognizable by the automata or not.         *)
    Definition get_trace (m:t) : list A -> list ST -> list (list ST) -> list (list ST):=
      fix rec l acc res :=
        match l with
        | [] => res
        | t::l => (res ++ ([step m acc t |> nodup equiv_dec])) |> rec l (step m acc t)
        end.

    Definition path (m:t) (l:list A) : list (set ST) :=
      get_trace m l [initial_state m] [[initial_state m]].

  Fixpoint create_continue_rule_from_list (s:ST) (ls:set ST) (a:A) :=
    match ls with
    | [] => []
    | x::t => set_add equiv_dec (s,Continue a x) (create_continue_rule_from_list s t a)
    end.

  (*The next 3 functions returns all states acessible from a given state of the NFA *)
  (* TODO prove this in the .PDF                                                    *)
  Fixpoint expand_a_state (m:t) (s:ST) (l: list A) :=
  match l with
  | [] => []
  | a::t => set_union equiv_dec (nfa.next m a s) (expand_a_state m s t)
  end.

  Program Fixpoint bounded_search (m:t) (n:nat) (x y: ST) :=
  match n with
  | O => if x == y then true else false
  | S k => if x == y then true else
            existsb (fun x => bounded_search m k x y)
                    (expand_a_state m x (nfa.alphabet m))
  end.

  Fixpoint get_all_reachable_states_from_a_state (m:t) (state:ST) (s: set ST): set ST :=
  match s with
  | [] => []
  | a::t => if (bounded_search m (length(nfa.states m)) (state) a)
            then set_add equiv_dec (a) (get_all_reachable_states_from_a_state m state t)
            else get_all_reachable_states_from_a_state m state t
  end.

  Definition get_all_related_states (m:t) (state:ST) :=
    get_all_reachable_states_from_a_state m state (nfa.states m).

  (* We can build a regular grammar from a NFA: *)

  (* Gets all possible nonempty rules from every transition from the NFA *)
  Definition get_every_state (m:t) (s: ST) : set A -> set (ST * rhs.t A ST) :=
    fix rec l :=
      match l with
      | [] => []
      | a::t => set_union equiv_dec (
                match (nfa.next m a s) with
                | [] => []
                | b::y => (create_continue_rule_from_list (s) (nfa.next m a s) (a))
                end)
    (rec t)
    end.

  (* Gets all rules from all states of the NFA *)
  Fixpoint get_all_rules (m:t) (s: set ST) (l: set A):
  set (ST * rhs.t A ST):=
  match s with
    | [] => []
    | a::x =>  set_union equiv_dec (get_every_state m a l)
               (get_all_rules m x l)
  end.
  (*Creates empty rule from a set of states, getting all final states of the *)
  (* NFA and then creating rules of the kind A -> e                          *)
  Fixpoint create_empty_rules (m:t) (ls:set ST) :
  set (ST * rhs.t A ST) :=
    match ls with
    | [] => []
    | x::t => if (nfa.is_final m x) then
              set_add equiv_dec (x,Empty) (create_empty_rules m t)
              else (create_empty_rules m t)
    end.

  (* For every state that is final, we create a rule of the kind (A,Empty) *)
  Fixpoint get_empty_rules (m:t) (s: ST) (l2: list A): set (ST * rhs.t A ST) :=
  match l2 with
  | [] => []
  | a::x => set_union equiv_dec (create_empty_rules m ((nfa.next m a s)))
            (get_empty_rules m s x)
  end.
  (* Gets all empty rules of the resulting grammar for all nonterminals*)
  Fixpoint add_empty_rules (m:t) (l1: list ST) (l2: list A)
  : set (ST * rhs.t A ST) :=
  match l1 with
  | [] => []
  | a::t => set_union equiv_dec (get_empty_rules m a l2) (add_empty_rules m t l2)
  end.
  (* Function that gets both all possible derivation rules from the NFA *)
  Definition nfa_transitions_to_grammar_rules (m:t) (l1:list ST) (l2:list A) :=
   set_union equiv_dec
  (get_all_rules m l1 l2) (add_empty_rules m l1 l2).

  (* To create a regular grammar from a NFA, one may call the above function: *)
  Definition build_grammar_from_nfa (m:t) :=
    reg_grammar.build_grammar (nfa.initial_state m)
    (nfa_transitions_to_grammar_rules m (nfa.states m) (nfa.alphabet m))
    (nfa.alphabet m) (nfa.states m).

  End nfa.
End nfa.

(* From a regular grammar we can build a NFA that recgonizes the same language *)
Module grammar_to_nfa.
  Section grammar_to_nfa.

  Variables T NT: Type.
  Context `{EqDec T eq} `{EqDec NT eq}.
  Variable g : reg_grammar.g T NT.
  Definition state : Type := option NT.
  Definition init := Some (reg_grammar.start_symbol g).

  Definition final (s : state) : bool :=
    match s with
      | None => true
      | Some nt => reg_grammar.getRHS nt (reg_grammar.rules g) |> existsb rhs.isEmpty
    end.
  Definition next (t : T) (s:state) : list state :=
      (* filtermap com step_nt e [s]. *)
      (*reg_grammar.step_nt (reg_grammar.rules g) t s. *)
    reg_grammar.step (reg_grammar.rules g) t (filterMap id [s]).

  (* Gets all states from the set of nonterminal symbols *)
  (* The resulting states in the NFA are the nonterminal symbols of the grammar *)
  Fixpoint get_all_nt (nt: list (NT)) : list (option NT) :=
  match nt with
  | [] => []
  | a::t => [Some a] ++ get_all_nt t
  end |> nodup equiv_dec.

  (* Adds None as a valid final state if there is a rule of the kind
    (A,Single x) in the grammar's rules set. *)
  Definition build_nfa_from_grammar :=
  if (existsb (fun x => match x with
                        | pair A B => match B with
                                      | Single x => true
                                      | _ => false
                                      end
                        end) (reg_grammar.rules g ))
  then nfa.NFA (init) (final) (next)
  (set_add equiv_dec (None)
  (get_all_nt (reg_grammar.nonterminal_symbols g)))
  (reg_grammar.terminal_symbols g)
  else nfa.NFA (init) (final) (next) (get_all_nt (reg_grammar.nonterminal_symbols g))
  (reg_grammar.terminal_symbols g).

  Lemma grammar_to_nfa_sound_aux : forall s, forall a, nfa.step build_nfa_from_grammar s a =
    reg_grammar.step (reg_grammar.rules g) a (filterMap id s).
  Proof. induction s.
  - unfold reg_grammar.step. simpl. auto.
  - intros. simpl. destruct a. simpl. destruct build_nfa_from_grammar. Admitted.
  Lemma same_initial_state :  Some (reg_grammar.start_symbol g) =
  nfa.initial_state (build_nfa_from_grammar).
  Proof.  unfold build_nfa_from_grammar. destruct existsb;reflexivity.
  Qed.
  Check nfa.next build_nfa_from_grammar.
  Check reg_grammar.step.
  Definition grammar_to_nfa_aux : forall l, forall s,
  reg_grammar.is_final (reg_grammar.rules g)
    (reg_grammar.parse' (reg_grammar.rules g) l
      s) =
  nfa.verify_final_state' build_nfa_from_grammar
    (nfa.run' build_nfa_from_grammar l
      s).
  Proof.
  induction l.
  destruct s.
  - simpl. reflexivity.
  - simpl. unfold build_nfa_from_grammar.
    + destruct existsb;reflexivity;simpl;reflexivity.
  - simpl. intros. rewrite IHl. rewrite grammar_to_nfa_sound_aux. reflexivity.
  Qed.

  (*lemma : dfa.is_final m (dfa.run' (dfa.next m) l (s)) =
  nfa.verify_final_state' (dfa.dfa_to_nfa) (nfa.run' (dfa.dfa_to_nfa) l [s]).*)
  (*is_final m (run' (next m) l (next m s a)) =
nfa.verify_final_state' dfa_to_nfa (nfa.run' dfa_to_nfa l [next m s a])
*)

  Definition grammar_to_nfa_sound : forall l,
  reg_grammar.parse g l = nfa.run (build_nfa_from_grammar) l.
  Proof.
  unfold reg_grammar.parse. unfold nfa.run. rewrite same_initial_state.
  induction l.
  - simpl. unfold build_nfa_from_grammar. destruct existsb;reflexivity.
  - apply grammar_to_nfa_aux. Qed.

  End grammar_to_nfa.
End grammar_to_nfa.

Module nfa_epsilon_transitions.

  (* We define an inductive type for the transitions of the NFA with epsilon transitions *)
  Inductive ep_trans S A :=
  (* the incoming state is defined in the next function *)
  | Epsilon : S -> ep_trans S A
  | Goes :  A -> S -> ep_trans S A.

  (*Where Epsilon is the epsilon transitions and Goes the other transitions of the NFA*)
  Arguments Epsilon {_} {_} _.
  Arguments Goes {_} {_} _ _.
  Module exports.
      Notation Epsilon := Epsilon.
      Notation Goes := Goes.
  End exports.
End nfa_epsilon_transitions.

(* A equality decision procedure for the types of the transitions of the NFA with *)
(* epsilon transitions                                                            *)
Import nfa_epsilon_transitions.exports.
Program Instance ep_trans_eqdec S A `(EqDec S eq) `(EqDec A eq) :
EqDec (nfa_epsilon_transitions.ep_trans S A) eq :=
{
  equiv_dec x y :=
    match x, y with
    | Epsilon x, Epsilon y => if x == y then in_left else in_right
    | Goes a b , Goes c d => if a == c then
                                if b == d then in_left else in_right
                             else in_right
    | Epsilon x, Goes y z | Goes y z, Epsilon x => in_right
    end
}.

Module nfa_epsilon.
  Section nfa_epsilon.
  Variables A ST: Type.
  Context `{EqDec ST eq} `{EqDec A eq}.

  (* We define an NFA with epsilon transitions as the same record of a NFA, only with *)
  (* the transition relation prepared to include epsilon transitions *)
  Record t := NFA_e {
    initial_state : ST;
    is_final : ST -> bool;
    next : ST -> set (nfa_epsilon_transitions.ep_trans ST A);
    states : set ST;
    alphabet : set A
  }.
  (* Obligation Tactic := intros. *)
  (* idea: each state has a set of (possible) transitions *)
  (* from epsilons we calculate the epsilon closure *)
  (* the other ones are normal transitions of a NFA *)
  (* we get all resulting states w
   epsilon transitions from one given state *)
  (* Program fixpoint? *)
  (* Obligation Tactic := compute. *)
  Program Fixpoint next_state_w_e
  (t: set (nfa_epsilon_transitions.ep_trans ST A)) : set ST :=
  match t with
  | [] => []
  | a::y =>
            match a with
            | Epsilon x => set_add equiv_dec (x) (next_state_w_e y)
            | _ => next_state_w_e y
            end
  end.

  (*get all transitions of a given set of states that are not epsilon transitions *)
  Fixpoint get_goes_transitions
  (t: set (nfa_epsilon_transitions.ep_trans ST A))  :=
  match t with
  | [] => []
  | a::f => match a with
            | Goes x y => set_add equiv_dec (Goes x y) (get_goes_transitions f)
            | Epsilon x => (get_goes_transitions f)
            end
  end.

  (* idea: extract a NFA with no epsilon transitions from one with epsilon transitions,*)
  (* storing all transitions in an intermediate set *)
  (*Creates pair of transitions (S, transition) where S is the state where the *)
  (* transition is "leaving"                                                   *)

  Context `{EqDec (nfa_epsilon_transitions.ep_trans A ST) eq}.
  Fixpoint create_transition (x:ST) (s:set (nfa_epsilon_transitions.ep_trans ST A))
  :=
  match s with
  | [] => []
  | a::t => set_add equiv_dec ((x,a)) (create_transition x t)
  end.

  (* Let us define a NFA with epsilon transitions: *)
  Variable m: nfa_epsilon.t.

  (* Then we have to apply this condition to every state in the NFA: *)
  (* We define a search procedure that reaches all states of the NFA: *)
  Fixpoint bounded_search (n:nat) (x y: ST) :=
  match n with
  | O => if x == y then true else false
  | S k => if x == y then true else
            existsb (fun x => bounded_search k x y)
                    (next_state_w_e (nfa_epsilon.next m x))
  end.

  Fixpoint get_all_reachable_states_w_e (x:ST) (s: set ST): set ST :=
  match s with
  | [] => []
  | a::t => if (bounded_search (length(nfa_epsilon.states m))(x) a)
               then set_add equiv_dec (a) (get_all_reachable_states_w_e x t)
            else get_all_reachable_states_w_e x t
  end.

  (* Calculates the epsilon closure of a given state *)
  Definition epsilon_clos (x:ST) := get_all_reachable_states_w_e x
                          (nfa_epsilon.states m).
  (* Gets all transitions that aren't epsilon transitions from the neighborhood  *)
  (* of a state                                                                  *)
  Definition next_from_state (x: ST) := get_goes_transitions (nfa_epsilon.next m x).

  (* Gets all transitions that aren't epsilon transitions from a set of *)
  (* states                                                             *)
  Definition next_from_states (s: set ST) :=
    flat_map (next_from_state) s.

  (* To make a run on a nfa with epsilon transitions, we first convert    *)
  (* it to a conventional NFA : By calculating the epsilon closure of a   *)
  (* state, we remove the epsilon transitions of the NFA                  *)
  (* This function calculates the epsilon closure for all states in a set *)
  (* of states                                                            *)
  (* With the epsilon closure of a state, we can extract the next from the NFA:*)
  Fixpoint next_from_epsilon_clos (x:set ST) :=
  match x with
  | [] => []
  | a::t => set_union equiv_dec
            (epsilon_clos a |> next_from_states |> create_transition a)
            (next_from_epsilon_clos t)
  end.

  (* To make a run on a nfa with epsilon transitions, we first convert    *)
  (* it to a conventional NFA : By calculating the epsilon closure of a   *)
  (* state, we remove the epsilon transitions of the NFA appyling the algo*)
  (* rithm of converting a NFA with epsilon transitions to a "normal" NFA   *)

  (* This function calculates the epsilon closure and extracs all transitions:   *)
  (* defined for a given symbol of the NFA's alphabet for every state in the     *)
  (* NFA's set of states                                                         *)
  (* Definition next_nfa := next_from_epsilon_clos (nfa_epsilon.states m).       *)
  Definition next_nfa := Eval vm_compute in (next_from_epsilon_clos (nfa_epsilon.states m)).

  (* The next step is to retrieve from the "next_nfa" function all states *)
  (* that has s as the outgoing state with a                              *)
  (* The next function retrieves those states                             *)
  Fixpoint step (s:ST) (a:A)
  (x:set (ST * nfa_epsilon_transitions.ep_trans ST A)) :=
  match x with
  | [] => []
  | l::l' => match l with
             | (k,o) => if s == k then
                        match o with
                        | Goes i j => if i == a then set_add equiv_dec (j)
                                                (step s a l')
                                                else (step s a l')
                        | _ =>  (step s a l')
                        end
                        else  (step s a l')
             end
  end.

  Check step.
  (* Therefore, the function below converts the transitions to a NFA with no  *)
  (* epsilon rules                                                            *)
  Definition step_nfa (a:A) (s:ST) : set ST :=
    step s a next_nfa.

  (* Now one can create a NFA without epsilon transitions from a NFA with *)
  (* epsilon transitions                                                  *)

  Definition nfa_e_to_nfa := nfa.NFA (nfa_epsilon.initial_state m)
  (nfa_epsilon.is_final m) (step_nfa) (nfa_epsilon.states m) (nfa_epsilon.alphabet m).

  End nfa_epsilon.
End nfa_epsilon.

(*Equality decision procedure of elements of the type of the transitions of a epsilon NFA *)
Program Instance eptrans_eqdec A B `(EqDec A eq) `(EqDec B eq) :
 EqDec (nfa_epsilon_transitions.ep_trans A B) eq :=
{
  equiv_dec x y :=
    match x,y with
      |Goes a b, Goes c d => if a == c then
                                if b == d then in_left
                                else in_right
                             else in_right
      | Epsilon x, Epsilon b => if x == b then in_left else in_right
      | Goes a b, Epsilon z | Epsilon z, Goes a b => in_right
    end
}.

Module dfa.
  Section dfa.
    Variables S A: Type.
    Context  `{EqDec S eq} `{EqDec A eq}.

    Record t := DFA {
      initial_state : S;
      is_final : S -> bool;
      next : S -> A -> S;
      states: set S;
      alphabet: set A
    }.

    (*run' is the function that does the verification steps of the automata, applying     *)
    (*the transition functions in the list of terminal symbols, returning a state, which can*)
    (*be final or not.                                                                    *)
    (*acc is a accumulator, a variable that stores the result of the processing upon each ele-*)
    (* ment of the list of terminal symbols. In this case, it receives the result of applying a*)
    (*transition function for each of the elements of the list (if possible). using the fold_left iterator*)

    Definition run' (step: S -> A -> S) (l : list A) (acc : S) : S :=
      fold_left step l acc.
    Definition run (m : t) (l : list A) : bool :=
      is_final m (run' (next m) l (initial_state m)).
    Definition run2 (m :t) (l : list A) : S :=
      run' (next m) l  (initial_state m).

    Definition get_trace (m:t) : list A ->  S -> list S -> list S:=
      fix rec l s res :=
        match l with
        | [] => res
        | t::l => (res ++ [next m s t]) |> rec l (next m s t)
        end.
    Definition path (m:t) (l:list A) : list S :=
      get_trace m l (initial_state m) [initial_state m] (*|> nodup equiv_dec*).

  (* Building a grammar from a DFA. *)

  (* Gets all derivation rules from a given state *)
  Fixpoint get_transitions_from_a_state (m:t) (s: S) (l2: set A):
  set (S * rhs.t A S):=
  match l2 with
    | [] => []
    | a::x =>  set_add equiv_dec ((s, Continue a (dfa.next m s a)))
               (get_transitions_from_a_state m s x)
  end.
  (* Gets all nonempty derivation rules from all states of the automaton *)
  Fixpoint add_rules (m:t) (l1: set S) (l2: set A)
  : set (S * rhs.t A S) :=
  match l1 with
  | [] => []
  | a::t => set_union equiv_dec
            (get_transitions_from_a_state m a l2)(add_rules m t l2)
  end.

  (* Gets all empty rules of the resulting grammar for a given nonterminal *)
  Fixpoint get_empty_rules (m:t) (s: S) (l2: set A): set (S * rhs.t A S) :=
  match l2 with
  | [] => []
  | a::x => if (is_final m (dfa.next m s a)) then
            set_add equiv_dec ((dfa.next m s a, Empty)) (get_empty_rules m s x)
            else get_empty_rules m s x
  end.

  (* Gets all empty rules of the resulting grammar for all nonterminals*)
  Fixpoint add_empty_rules (m:t) (l1: set S) (l2: set A)
  : set (S * rhs.t A S) :=
  match l1 with
  | [] => []
  | a::t => set_union equiv_dec (get_empty_rules m a l2) (add_empty_rules m t l2)
  end.

  Definition dfa_transitions_to_grammar_rules (m:t) (l1:set S) (l2:set A) :=
   set_union equiv_dec
  (add_rules m l1 l2) (add_empty_rules m l1 l2) .

  Definition dfa_to_regular_grammar (m:t): reg_grammar.g A S :=
    reg_grammar.build_grammar (initial_state m)
    (dfa_transitions_to_grammar_rules m (dfa.states m) (dfa.alphabet m))
    (dfa.alphabet m) (dfa.states m).

  (* We can build an NFA from a DFA. *)
  Variable m : t.
  (* The first step is to rewrite the next function of the DFA as the same way it behaves for the NFA*)
  Definition nfa_step(t:A) (s:S) :=
    [dfa.next m s t].

  Definition dfa_to_nfa := nfa.NFA (dfa.initial_state m) (dfa.is_final m)
  (nfa_step) (dfa.states m) (dfa.alphabet m).

  (* We can also build a regular grammar from a DFA: *)
  (* Verifying if the DFA is a minimal DFA.                                   *)
  (* idea: a DFA is minimal iff there is no equivalent transition             *)
  (* The first step is to check whether a pair of states is equivalent:       *)
  Program Fixpoint check_pair_states (m:t) (s1: S) (s2: S) (l: set A) : bool :=
    match l with
    | [] => true
    | a::t => if (((dfa.next m s1 a) == (dfa.next m s2 a)))
              then check_pair_states m s1 s2 t
              else false
    end.
  Check check_pair_states.

  Fixpoint check_a_pair_states (m:t) (s1: S) (s2: list S) (l:list A) : bool :=
    match s2 with
    | [] => false
    | b::y => if s1 <> b then
                   if (check_pair_states m s1 b l == false)
                   then check_a_pair_states m s1 y l
                   else true
              else check_a_pair_states m s1 y l
    end.

  (* Then we can check for all states of the automaton if there is no equivale-*)
  (* nt state in the automaton.                                                *)
  Definition has_equivalent_states (m:t): set S -> set S -> set A -> bool :=
    fix rec s1 s2 l :=
      match s1 with
      | [] => false
      | a::t => check_a_pair_states m (a) s2 l || rec t s2 l
    end.

  Definition is_minimal (m:t) :=
    negb (has_equivalent_states  m (dfa.states m) (dfa.states m) (dfa.alphabet m)).

  (* We can also return the pair of states that are equivalent *)
  Fixpoint get_equivalent_states (m:t) (s1: S) (s2: set S) (l:set A) : set (S * S) :=
    match s2 with
    | [] => []
    | b::y => if s1 <> b then
                   if (check_pair_states m s1 b l == true)
                   then set_add equiv_dec ((s1,b)) (get_equivalent_states m s1 y l)
                   else get_equivalent_states m s1 y l
              else get_equivalent_states m s1 y l
    end.

  Definition get_all_equivalent_states (m:t): set S -> set S -> set A -> set (S * S) :=
    fix rec s1 s2 l :=
      match s1,s2 with
      | [],[] => []
      | a::t,x::y => set_union equiv_dec (get_equivalent_states m (a) s2 l)
                    (rec t y l)
      | _,_ => []
    end.

  (* Top level function that returns pairs of equivalent states *)
  Definition check_equivalent_states (m:t) :=
    get_all_equivalent_states m (dfa.states m) (dfa.states m) (dfa.alphabet m).

  End dfa.
End dfa.

Module nfa_to_dfa.
  Section nfa_to_dfa.

  Variables A ST : Type.
  Context `{EqDec A eq} `{EqDec ST eq}.
  Variable m: nfa.t A ST.

  (* We implement the conversion of NFA to DFA using the powerset construction          *)
  (* algorith on the fly. Then, a state in the DFA is built according to the algorithm. *)
  Definition state := set ST.
  (*The initial state of the DFA is the same of the NFA. *)
  Definition init : state := [nfa.initial_state m].
  (*The final states of the DFA will be the states that were built from at least*)
  (* one final state of the NFA                                                 *)
  Definition final (s : state) : bool :=
    nfa.verify_final_state' (m) s.
  Definition dfa_alphabet := nfa.alphabet m.
  Definition dfa_next (s:state) (a:A) : state := nfa.step m s a.

  (* Gets all next states from a given state *)
  Fixpoint list_states (s:state) (l: set A) :  set state :=
    match l with
    | [] => []
    | a::t => if (dfa_next s a <> []) then
              set_add equiv_dec (dfa_next s a) (list_states s t)
              else list_states s t
    end.

  (* We compute the powerset of the states of the NFA : *)
  Definition power_states := powerset (nfa.states m).

  (* And we want only the states in the powerset that are reachable from the *)
  (* initial state:                                                          *)
  Fixpoint bounded_search (n:nat) (x y: state) :=
  match n with
  | O => set_eq x y
  | S k => if (set_eq x y) then true else
            existsb (fun x => bounded_search k x y) (list_states x (nfa.alphabet m))
  end.

  Fixpoint get_all_reachable_states (s: set state): set state :=
  match s with
  | [] => []
  | a::t => if (bounded_search (length(nfa.states m)) ([nfa.initial_state m]) a)
            then set_add equiv_dec (a) (get_all_reachable_states t)
            else get_all_reachable_states t
  end.

  (* The resulting set of states are all states within the powerset that are *)
  (* reachable from the initial state of the DFA                             *)
  Definition dfa_states := get_all_reachable_states (power_states).
  Definition build_dfa_from_nfa := dfa.DFA (init) (final) (dfa_next) (dfa_states)
    (dfa_alphabet).

  End nfa_to_dfa.
End nfa_to_dfa.

(* We can also explicitly construct a DFA corresponding to the grammar. In fact, all
   the hard work was already done in our grammar parser. *)
Module powerset_construction.
  Section powerset_construction.

    Variable T NT : Type.
    Context `{EqDec T eq} `{EqDec NT eq}.
    (*a valid regular grammar shall follow the rules of g, where T and NT are, respectively, *)
    (* the terminal and nonterminal symbols.                                                 *)
    Variable g : reg_grammar.g T NT.
    Definition state : Type := set (option NT).
    (* The automata's inital state is the same as the start symbol of the grammar.           *)

    Definition init : state := [Some (reg_grammar.start_symbol g)].
    (*The same goes to a final state in the automaton. *)
    Definition is_final (s : state) : bool :=
      reg_grammar.is_final (reg_grammar.rules g) s.
    Definition next (s : state) (t : T) : state :=
      reg_grammar.step (reg_grammar.rules g) t (filterMap id s).

    Definition alphabet := (reg_grammar.terminal_symbols g).

    (*Gets nonterminal symbols and converts them to the same type of the states of the resulting  *)
    Fixpoint nt_to_state (l : set NT) : set (option NT) :=
    match l with
      | [] => []
      | a::t => set_add equiv_dec (Some a) (nt_to_state t)
    end.

    Definition states :=
      if (existsb (fun x => match x with
                          | pair A B => match B with
                                        | Single x => true
                                        | _ => false
                                        end
                          end) (reg_grammar.rules g ))
    then set_add equiv_dec (None) (nt_to_state (reg_grammar.nonterminal_symbols g))
    else (nt_to_state (reg_grammar.nonterminal_symbols g)).

    (* Again, We compute the powerset of the states of the NFA (created "on the fly" from the grammar: *)
    Definition power_states := powerset states.

    (* Gets all reachable states from the state s *)
    Fixpoint list_states (s:state) (l: set T) :  set state :=
      match l with
      | [] => []
      | a::t => if (next s a <> []) then
                set_add equiv_dec (next s a) (list_states s t)
                else list_states s t
      end.

    (* And we want only the states in the powerset that are reachable from the *)
    (* initial state:                                                          *)
    Fixpoint bounded_search (n:nat) (x y: state) :=
    match n with
    | O => if set_eq x y then true else false
    | S k => if set_eq x y then true else
              existsb (fun x => bounded_search k x y) (list_states x (reg_grammar.terminal_symbols g))
    end.

    Fixpoint get_all_reachable_states (s: set state): set state :=
    match s with
    | [] => []
    | a::t => if (bounded_search (length (reg_grammar.nonterminal_symbols g))
                  ([Some (reg_grammar.start_symbol g)]) a)
              then set_add equiv_dec (a) (get_all_reachable_states t)
              else get_all_reachable_states t
    end.

   Definition build_dfa :=
   dfa.DFA (init) (is_final) (next)
   (get_all_reachable_states (power_states))
    (reg_grammar.terminal_symbols g).

  End powerset_construction.
End powerset_construction.

Require Export List.
Export ListNotations.
Require Export Classes.EquivDec.
Require Export Coq.Program.Program.
Require Export Bool.
Require Export ListSet.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Export Ensembles.

Section Ensembles_facts.
  Variable U : Type.

  Lemma Extension : forall B C:Ensemble U, B = C -> Same_set U B C.
  Proof.
    intros B C H'; rewrite H'; auto with sets.
  Qed.

  Lemma Noone_in_empty : forall x:U, ~ In U (Empty_set U) x.
  Proof.
    red in |- *; destruct 1.
  Qed.

  Lemma Included_Empty : forall A:Ensemble U, Included U (Empty_set U) A.
  Proof.
    intro; red in |- *.
    intros x H; elim (Noone_in_empty x); auto with sets.
  Qed.

  Lemma Add_intro1 :
    forall (A:Ensemble U) (x y:U), In U A y -> In U (Add U A x) y.
  Proof.
    unfold Add at 1 in |- *; auto with sets.
  Qed.

  Lemma Add_intro2 : forall (A:Ensemble U) (x:U), In U (Add U A x) x.
  Proof.
    unfold Add at 1 in |- *; auto with sets.
  Qed.

  Lemma Inhabited_add : forall (A:Ensemble U) (x:U), Inhabited U (Add U A x).
  Proof.
    intros A x.
    apply Inhabited_intro with (x := x); auto using Add_intro2 with sets.
  Qed.

  Lemma Inhabited_not_empty :
    forall X:Ensemble U, Inhabited U X -> X <> Empty_set U.
  Proof.
    intros X H'; elim H'.
    intros x H'0; red in |- *; intro H'1.
    absurd (In U X x); auto with sets.
    rewrite H'1; auto using Noone_in_empty with sets.
  Qed.

  Lemma Add_not_Empty : forall (A:Ensemble U) (x:U), Add U A x <> Empty_set U.
  Proof.
    intros A x; apply Inhabited_not_empty; apply Inhabited_add.
  Qed.

  Lemma not_Empty_Add : forall (A:Ensemble U) (x:U), Empty_set U <> Add U A x.
  Proof.
    intros; red in |- *; intro H; generalize (Add_not_Empty A x); auto with sets.
  Qed.

  Lemma Singleton_inv : forall x y:U, In U (Singleton U x) y -> x = y.
  Proof.
    intros x y H'; elim H'; trivial with sets.
  Qed.

  Lemma Singleton_intro : forall x y:U, x = y -> In U (Singleton U x) y.
  Proof.
    intros x y H'; rewrite H'; trivial with sets.
  Qed.

  Lemma Union_inv :
    forall (B C:Ensemble U) (x:U), In U (Union U B C) x -> In U B x \/ In U C x.
  Proof.
    intros B C x H'; elim H'; auto with sets.
  Qed.

  Lemma Add_inv :
    forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y.
  Proof.
    intros A x y H'; induction H'.
      left; assumption.
      right; apply Singleton_inv; assumption.
  Qed.

  Lemma Intersection_inv :
    forall (B C:Ensemble U) (x:U),
      In U (Intersection U B C) x -> In U B x /\ In U C x.
  Proof.
    intros B C x H'; elim H'; auto with sets.
  Qed.

  Lemma Couple_inv : forall x y z:U, In U (Couple U x y) z -> z = x \/ z = y.
  Proof.
    intros x y z H'; elim H'; auto with sets.
  Qed.

  Lemma Setminus_intro :
    forall (A B:Ensemble U) (x:U),
      In U A x -> ~ In U B x -> In U (Setminus U A B) x.
  Proof.
    unfold Setminus at 1 in |- *; red in |- *; auto with sets.
  Qed.

  Lemma Strict_Included_intro :
    forall X Y:Ensemble U, Included U X Y /\ X <> Y -> Strict_Included U X Y.
  Proof.
    auto with sets.
  Qed.

  Lemma Strict_Included_strict : forall X:Ensemble U, ~ Strict_Included U X X.
  Proof.
    intro X; red in |- *; intro H'; elim H'.
    intros H'0 H'1; elim H'1; auto with sets.
  Qed.

End Ensembles_facts.

Hint Resolve Singleton_inv Singleton_intro Add_intro1 Add_intro2
  Intersection_inv Couple_inv Setminus_intro Strict_Included_intro
  Strict_Included_strict Noone_in_empty Inhabited_not_empty Add_not_Empty
  not_Empty_Add Inhabited_add Included_Empty: sets v62.


(* In this file, we show the equivalence between the Skolemized
   and existentially quantified presentations of ZF.
 *)

Require Import basic.
Require Export ZFdef.
Require Import Sublogic.

Module Skolem (Z : IZF_R_Ex_sig CoqSublogicThms) <: IZF_R_sig CoqSublogicThms.

Instance Zsetoid: Equivalence Z.eq_set.
Proof.
split; red; intros; rewrite Z.eq_set_ax in *; intros.
 reflexivity.
 symmetry; trivial.
 transitivity (Z.in_set x0 y); trivial.
Qed.

Instance Zin_morph : Proper (Z.eq_set ==> Z.eq_set ==> iff) Z.in_set.
Proof.
do 3 red; intros.
rewrite Z.eq_set_ax in H0.
split; intros.
 rewrite <- H0.
 apply Z.in_reg with x; trivial.

 rewrite H0.
 symmetry in H.
 apply Z.in_reg with y; trivial.
Qed.

Definition set :=
  { f : Z.set -> Prop |
    (exists u, f u) /\
    (forall a a', f a -> f a' -> Z.eq_set a a') }.

Lemma set_intro : forall (f:Z.set->Prop) (P:set->Prop),
  (exists u, f u) ->
  (forall a a', f a -> f a' -> Z.eq_set a a') ->
  (forall Hex Huniq, P (exist _ f (conj Hex Huniq))) ->
  sig P.
intros.
exists (exist (fun _ => _ /\ _) f (conj H H0)); trivial. (* regression of unification *)
(*exists (exist _ f (conj H H0)); trivial.*)
Qed.

Inductive in_set_ (x y:set) : Prop :=
 InSet
  (_:exists2 x', proj1_sig x x' &
     exists2 y', proj1_sig y y' & Z.in_set x' y').

Definition in_set := in_set_.

Lemma in_set_elim : forall x y, in_set x y <->
  exists2 x', proj1_sig x x' &
  exists2 y', proj1_sig y y' & Z.in_set x' y'.
split; intros.
 destruct H; trivial.
 constructor; trivial.
Qed.

Notation "x ∈ y" := (in_set x y).

Definition eq_set a b := forall x, x ∈ a <-> x ∈ b.

Notation "x == y" := (eq_set x y).

Lemma eq_set_ax : forall a b, a == b <-> (forall x, x ∈ a <-> x ∈ b).
reflexivity.
Qed.

Instance eq_setoid: Equivalence eq_set.
Proof.
split; do 2 red; intros.
 reflexivity.
 symmetry; trivial.
 transitivity (x0 ∈ y); trivial.
Qed.

Lemma In_intro: forall x y: set,
  (forall x' y', proj1_sig x x' -> proj1_sig y y' -> Z.in_set x' y') ->
  x ∈ y.
intros.
destruct (proj2_sig x).
destruct H0.
destruct (proj2_sig y).
destruct H2.
constructor.
exists x0; trivial.
exists x1; auto.
Qed.

Definition Z2set (x:Z.set) : set.
exists (fun a => Z.eq_set a x).
split.
 exists x; reflexivity.
 intros; transitivity x; trivial.
 symmetry; trivial.
Defined.

Lemma Z2set_surj : forall x, exists y, x == Z2set y.
intros.
destruct (proj2_sig x).
destruct H.
exists x0.
split; intros.
 rewrite in_set_elim in H1.
 destruct H1.
 destruct H2.
 constructor.
 exists x2; trivial.
 exists x3; trivial.
 simpl; auto.

 rewrite in_set_elim in H1.
 destruct H1.
 destruct H2.
 constructor.
 exists x2; trivial.
 simpl in H2.
 exists x0; trivial.
 rewrite <- H2; trivial.
Qed.

Lemma Eq_proj : forall (x:set) x', proj1_sig x x' -> x == Z2set x'.
intros.
destruct (proj2_sig x).
clear H0.
split; intros.
 rewrite in_set_elim in H0.
 destruct H0.
 destruct H2.
 constructor.
 exists x1; simpl; trivial.
 exists x2; auto.

 rewrite in_set_elim in H0.
 destruct H0; simpl in *.
 destruct H2.
 constructor.
 exists x1; simpl; trivial.
 exists x'; trivial.
 rewrite <- H2; trivial.
Qed.

Lemma inZ_in : forall a b, Z.in_set a b -> Z2set a ∈ Z2set b.
unfold Z2set, in_set; simpl.
intros.
constructor; simpl.
exists a; try reflexivity.
exists b; try reflexivity; trivial.
Qed.

Lemma in_inZ : forall a b, Z2set a ∈ Z2set b -> Z.in_set a b.
intros.
rewrite in_set_elim in H.
destruct H.
destruct H0.
unfold Z2set in *; simpl in *.
apply Z.in_reg with x; trivial.
rewrite <- H0; auto.
Qed.

Lemma in_equiv a b : in_set (Z2set a) (Z2set b) <-> Z.in_set a b.
split; intros.
 apply in_inZ; trivial.
 apply inZ_in; trivial.
Qed.

Lemma eq_Zeq : forall x y, Z2set x == Z2set y -> Z.eq_set x y.
intros.
rewrite Z.eq_set_ax; split; intros.
 apply in_inZ.
 apply (proj1 (H (Z2set x0))).
 apply inZ_in; trivial.

 apply in_inZ.
 apply (proj2 (H (Z2set x0))).
 apply inZ_in; trivial.
Qed.

Lemma Zeq_eq : forall x y, Z.eq_set x y -> Z2set x == Z2set y.
intros.
split; intros.
 rewrite in_set_elim in H0.
 destruct H0.
 destruct H1.
 simpl in H1.
 constructor.
 exists x1; trivial.
 exists x2; trivial.
 simpl.
 transitivity x; trivial.

 rewrite in_set_elim in H0.
 destruct H0.
 destruct H1.
 simpl in H1.
 constructor.
 exists x1; trivial.
 exists x2; trivial.
 simpl.
 transitivity y; trivial.
 symmetry; trivial.
Qed.

Lemma eq_equiv x y : Z2set x == Z2set y <-> Z.eq_set x y.
split; intros.
 apply eq_Zeq; trivial.
 apply Zeq_eq; trivial.
Qed.

Instance Z2set_morph : Proper (Z.eq_set ==> eq_set) Z2set.
exact Zeq_eq.
Qed.

Lemma in_reg : forall a a' b, a == a' -> a ∈ b -> a' ∈ b.
intros.
rewrite in_set_elim in H0.
destruct H0 as (a0,eq_a,(b0,eq_b,in_ab)).
destruct (proj2_sig a') as ((a'0, eq_a'),_).
constructor.
exists a'0; trivial.
exists b0; trivial.
apply Z.in_reg with a0; trivial.
apply eq_Zeq.
rewrite <- (Eq_proj _ _ eq_a).
rewrite <- (Eq_proj _ _ eq_a').
trivial.
Qed.

Instance in_morph : Proper (eq_set ==> eq_set ==> iff) in_set.
Proof.
unfold eq_set in |- *; split; intros.
 apply in_reg with x; auto.
 elim (H0 x); auto.

 apply in_reg with y; auto.
  symmetry  in |- *; auto.
  elim (H0 y); auto.
Qed.

(* empty set *)

Lemma empty_sig : { empty | forall x, ~ x ∈ empty }.
apply set_intro with (fun x:Z.set => forall y, ~ Z.in_set y x); intros.
 apply Z.empty_ex.

 rewrite Z.eq_set_ax; split; intros.
  elim H with x; trivial.
  elim H0 with x; trivial.

 red; intros.
 rewrite in_set_elim in H.
 destruct H; simpl in *.
 destruct H0.
 elim H0 with x0; trivial.
Qed.

Definition empty := proj1_sig empty_sig.
Lemma empty_ax: forall x, ~ x ∈ empty.
Proof proj2_sig empty_sig.

(* pair *)

Lemma pair_sig : forall a b,
  { pair | forall x, x ∈ pair <-> (x == a \/ x == b) }.
intros a b.
apply set_intro with
  (fun x => forall y, y ∈ Z2set x <-> y == a \/ y == b); intros.
 elim (Z2set_surj a); intros.
 elim (Z2set_surj b); intros.
 elim Z.pair_ex with x x0; intros.
 exists x1; intros.
 elim (Z2set_surj y); intros.
 rewrite H2.
 transitivity (Z.in_set x2 x1).
  split; intros; first [apply inZ_in|apply in_inZ]; trivial.
  apply iff_trans with (1:=H1 x2).
  rewrite H.
  rewrite H0.
  setoid_replace (Z.eq_set x2 x) with (Z2set x2 == Z2set x).
  setoid_replace (Z.eq_set x2 x0) with (Z2set x2 == Z2set x0).
  reflexivity.
  split; intros; first [apply Zeq_eq|apply eq_Zeq]; trivial.
  split; intros; first [apply Zeq_eq|apply eq_Zeq]; trivial.

 intros; rewrite Z.eq_set_ax; intros.
 transitivity (Z2set x ∈ Z2set a0).
  split; intros; first [apply inZ_in|apply in_inZ]; trivial.
  transitivity (Z2set x == a \/ Z2set x == b); auto.
  symmetry.
  transitivity (Z2set x ∈ Z2set a'); trivial.
  split; intros; first [apply inZ_in|apply in_inZ]; trivial.

 split; intros.
  rewrite in_set_elim in H.
  destruct H; simpl in *.
  destruct H0.
  apply (proj1 (H0 x)).
  constructor.
  exists x0; trivial; simpl.
  exists x1; trivial; reflexivity.

  apply In_intro; simpl; intros.
  apply in_inZ.
  rewrite <- (Eq_proj _ _ H0).
  apply (proj2 (H1 x)); trivial.
Qed.

Definition pair a b := proj1_sig (pair_sig a b).
Lemma pair_ax: forall a b x, x ∈ pair a b <-> (x == a \/ x == b).
Proof fun a b => proj2_sig (pair_sig a b).

(* union *)

Lemma union_sig: forall a,
  { union | forall x, x ∈ union <-> (exists2 y, x ∈ y & y ∈ a) }.
intro a.
apply set_intro with
 (fun x => forall z,
  Z.in_set z x <-> exists2 y, Z.in_set z y & Z2set y ∈ a); intros.
 elim (Z2set_surj a); intros.
 elim (Z.union_ex x); intros.
 exists x0.
 intros.
 apply iff_trans with (1:=H0 z).
 split; intros.
  destruct H1.
  exists x1; trivial.
  rewrite H; apply inZ_in; trivial.

  destruct H1.
  exists x1; trivial.
  apply in_inZ; rewrite <- H; trivial.

 rewrite Z.eq_set_ax; intros.
 apply iff_trans with (1:=H x).
 symmetry; trivial.

split; intros.
 rewrite in_set_elim in H.
 destruct H; simpl in *.
 destruct H0.
 elim (proj1 (H0 _) H1); intros.
 exists (Z2set x2); trivial.
 rewrite (Eq_proj  _ _ H).
 apply inZ_in; trivial.

 destruct H.
 apply In_intro; simpl; intros.
 apply (proj2 (H2 x')).
 elim (Z2set_surj x0); intros.
 exists x1.
  apply in_inZ.
  rewrite <- H3; rewrite <- (Eq_proj _ _ H1); trivial.

  rewrite <- H3; trivial.
Qed.

Definition union a := proj1_sig (union_sig a).
Lemma union_ax: forall a x,
  x ∈ union a <-> (exists2 y, x ∈ y & y ∈ a).
Proof fun a => proj2_sig (union_sig a).

(* subset *)

Lemma subset_sig: forall a P,
  { subset | forall x, x ∈ subset <->
             (x ∈ a /\ exists2 x', x==x' & P x') }.
intros a P.
apply set_intro with
  (fun x => forall y, y ∈ Z2set x <->
    (y ∈ a /\ exists2 y', y==y' & P y')); intros.
 elim (Z2set_surj a); intros.
 elim Z.subset_ex with
   x (fun z => exists2 z', z' == Z2set z & P z'); intros.
 exists x0; intros.
 elim (Z2set_surj y); intros.
 rewrite H1.
 transitivity (Z.in_set x1 x0).
  split; intros; first [apply inZ_in|apply in_inZ]; trivial.
  apply iff_trans with (1:=H0 x1).
  rewrite H.
  apply and_iff_morphism.
   split; intros; first [apply inZ_in|apply in_inZ]; trivial.

   split; destruct 1.
    destruct H3.
    exists x3; trivial.
    rewrite H1; rewrite H3; apply Zeq_eq; trivial.

    exists x1;[reflexivity|].
    exists x2; trivial.
    rewrite <- H1; symmetry; trivial.

 apply eq_Zeq.
 rewrite eq_set_ax; intros.
 rewrite H.
 rewrite H0.
 reflexivity.

 split; intros.
  rewrite in_set_elim in H.
  destruct H; simpl in *.
  destruct H0.
  apply (proj1 (H0 x)).
  constructor.
  exists x0; trivial; simpl.
  exists x1; trivial; reflexivity.

  apply In_intro; simpl; intros.
  apply in_inZ.
  rewrite <- (Eq_proj _ _ H0).
  apply (proj2 (H1 x)); trivial.
Qed.

Definition subset a P := proj1_sig (subset_sig a P).
Lemma subset_ax : forall a P x,
    x ∈ subset a P <-> (x ∈ a /\ exists2 x', x==x' & P x').
Proof fun a P => proj2_sig (subset_sig a P).

(* power set *)

Lemma power_sig: forall a,
  { power | forall x, x ∈ power <-> (forall y, y ∈ x -> y ∈ a) }.
intro a.
apply set_intro with
 (fun x => forall z,
  Z.in_set z x <-> (forall y, Z.in_set y z -> Z2set y ∈ a)); intros.
 elim (Z2set_surj a); intros.
 elim (Z.power_ex x); intros.
 exists x0; intros.
 apply iff_trans with (1:= H0 z).
 split; intros.
  rewrite H; apply inZ_in; auto.
  apply in_inZ; rewrite <- H; auto.

 rewrite Z.eq_set_ax; intros.
 apply iff_trans with (1:=H x).
 symmetry; trivial.

split; intros.
 rewrite in_set_elim in H.
 destruct H; simpl in *.
 destruct H1.
 elim (Z2set_surj y); intros.
 rewrite H3.
 apply (proj1 (H1 _) H2).
 apply in_inZ; rewrite <- H3; rewrite <- (Eq_proj _ _ H); trivial.

 apply In_intro; simpl; intros.
 apply (proj2 (H1 x')).
 intros.
 apply H.
 rewrite (Eq_proj _ _ H0); apply inZ_in; trivial.
Qed.

Definition power a := proj1_sig (power_sig a).
Lemma power_ax:
  forall a x, x ∈ power a <-> (forall y, y ∈ x -> y ∈ a).
Proof fun a => proj2_sig (power_sig a).

(* uchoice *)

Definition uchoice_pred (P:set->Prop) :=
  (forall x x', x == x' -> P x -> P x') /\
  (exists x, P x) /\
  (forall x x', P x -> P x' -> x == x').

Definition uchoice (P : set -> Prop) (Hp : uchoice_pred P) : set.
exists (fun z => P (Z2set z)).
destruct Hp.
destruct H0.
split; intros.
 destruct H0.
 destruct (Z2set_surj x).
 exists x0; apply H with x; trivial.

 apply eq_Zeq.
 auto.
Defined.

Lemma uchoice_ax : forall P h x,
  (x ∈ uchoice P h <-> exists2 z, P z & x ∈ z).
split; intros.
 destruct H.
 destruct H.
 destruct H0.
 simpl in H0.
 exists (Z2set x1); trivial.
 apply In_intro; intros.
 simpl in H3.
 rewrite H3.
 destruct (proj2_sig x).
 rewrite (H5 x' x0); trivial.

 destruct H.
 destruct H0.
 destruct H0.
 destruct H1.
 constructor.
 exists x1; trivial.
 simpl.
 exists x2; trivial.
 apply (proj1 h x0); trivial.
 apply Eq_proj; trivial.
Qed.

Lemma uchoice_morph_raw : forall (P1 P2:set->Prop) h1 h2,
  (forall x x', x == x' -> (P1 x <-> P2 x')) ->
  uchoice P1 h1 == uchoice P2 h2.
intros.
apply eq_set_ax; intros.
rewrite uchoice_ax.
rewrite uchoice_ax.
apply ex2_morph; red; intros.
 apply H; reflexivity.

 reflexivity.
Qed.

Instance uchoice_pred_morph : Proper ((eq_set ==> iff) ==> iff) uchoice_pred.
apply morph_impl_iff1; auto with *.
do 3 red; intros.
destruct H0 as (?,(?,?)); split;[|split]; intros.
 assert (x x0).
  revert H4; apply H; auto with *.
 revert H5; apply H; trivial.

 destruct H1; exists x0.
 revert H1; apply H; auto with *.

 apply H2; [revert H3|revert H4]; apply H; auto with *.
Qed.

Lemma uchoice_ext : forall (P:set->Prop) h x, P x -> x == uchoice P h.
intros.
apply eq_set_ax;intros.
rewrite uchoice_ax.
split; intros.
 exists x; trivial.

 destruct H0.
 destruct h.
 destruct H3.
 rewrite (H4 x x1); auto.
Qed.

Lemma uchoice_def : forall P h, P (uchoice P h).
intros.
destruct h.
destruct a.
destruct e.
apply p with x; trivial.
apply uchoice_ext; trivial.
Qed.

(* replacement *)

Definition funDom (R:set -> set -> Prop) x :=
  forall x' y y', R x y -> R x' y' -> x == x' -> y == y'.
Definition downR (R:set -> set -> Prop) x' y' :=
  exists2 x, x == Z2set x' /\ funDom R x & exists2 y, y == Z2set y' & R x y.

Lemma downR_morph : Proper
  ((eq_set ==> eq_set ==> iff) ==> Z.eq_set ==> Z.eq_set ==> iff) downR.
do 4 red; intros.
unfold downR.
apply Zeq_eq in H0.
apply Zeq_eq in H1.
apply ex2_morph; red; intros.
 apply and_iff_morphism.
  rewrite H0; reflexivity.

  unfold funDom.
  split; intros.
   rewrite <- (fun e1 => H a a e1 y2 y2) in H3; auto with *.
   rewrite <- (fun e1 => H x' x' e1 y' y') in H4; eauto with *.

   rewrite (fun e1 => H a a e1 y2 y2) in H3; auto with *.
   rewrite (fun e1 => H x' x' e1 y' y') in H4; eauto with *.

 apply ex2_morph; red; intros.
  rewrite H1; reflexivity.
  apply H; reflexivity.
Qed.

Lemma downRm : forall R x x' y y',
  Z.eq_set x x' ->
  Z.eq_set y y' ->
  downR R x y ->
  downR R x' y'.
intros.
destruct H1 as (xx,(eqx,fdomx), (yy,eqy,rel)).
exists xx.
 split; trivial.
 rewrite eqx.
 rewrite eq_equiv; trivial.
exists yy; trivial.
rewrite eqy.
rewrite eq_equiv; trivial.
Qed.

Lemma downR_fun : forall R x y y',
  downR R x y ->
  downR R x y' ->
  Z.eq_set y y'.
intros.
destruct H as (xx,(eqx,fdomx), (yy,eqy,rel)).
destruct H0 as (xx',(eqx',_), (yy',eqy',rel')).
apply eq_Zeq.
rewrite <- eqy; rewrite <- eqy'.
red in fdomx.
apply fdomx with xx'; trivial.
rewrite eqx; rewrite eqx'.
reflexivity.
Qed.

Lemma repl0 : forall (a:set) (R:set->set->Prop), set.
intros a R.
exists
 (fun a' => forall x,
  Z.in_set x a' <-> exists2 y, Z2set y ∈ a & downR R y x).
split; intros.
 destruct (Z2set_surj a).
 assert (R'm := fun x0 x' y y' (_:Z.in_set x0 x) => downRm R x0 x' y y').
 assert (R'fun := fun x0 y y' (_:Z.in_set x0 x) => downR_fun R x0 y y').
 destruct (Z.repl_ex x (downR R) R'm R'fun); intros.
 exists x0; intros.
 rewrite H0.
 apply ex2_morph; red; intros.
 2:reflexivity.
 split; intros.
  rewrite H.
  apply inZ_in; trivial.

  apply in_inZ.
  rewrite <- H; trivial.

 rewrite Z.eq_set_ax; intros.
 rewrite H.
 rewrite H0.
 reflexivity.
Defined.

Definition incl_set x y := forall z, z ∈ x -> z ∈ y.

Lemma repl0_mono :
  Proper (incl_set ==> (eq_set ==> eq_set ==> iff) ==> incl_set) repl0.
do 4 red; simpl; intros.
rewrite in_set_elim in *.
destruct H1.
destruct H2.
simpl in *; intros.
destruct (Z2set_surj y).
assert (R'm := fun x x' y y' (_:Z.in_set x x3) => downRm y0 x x' y y').
assert (R'fun := fun x y y' (_:Z.in_set x x3) => downR_fun y0 x y y').
destruct (Z.repl_ex x3 (downR y0) R'm R'fun).
exists x1; trivial.
exists x4; trivial.
 intro; rewrite H5.
 apply ex2_morph; red; intros; auto with *.
 rewrite H4.
 symmetry; apply in_equiv.

 rewrite H5.
 rewrite H2 in H3.
 clear x2 H1 H2 x4 H5.
 destruct H3.
 exists x2.
  apply H in H1.
  rewrite H4 in H1; rewrite in_equiv in H1; trivial.

  revert H2; apply iff_impl; apply downR_morph; auto with *.
Qed.

Lemma repl_sig :
  { repl |
    Proper (incl_set ==> (eq_set ==> eq_set ==> iff) ==> incl_set) repl /\
    forall a (R:set->set->Prop),
    (forall x x' y y', x ∈ a -> x == x' -> y == y' -> R x y -> R x' y') ->
    (forall x y y', x ∈ a -> R x y -> R x y' -> y == y') ->
    forall x, x ∈ repl a R <-> exists2 y, y ∈ a & R y x }.
exists repl0; split.
 exact repl0_mono.
split; intros.
 rewrite in_set_elim in H1.
 destruct H1.
 destruct H2; simpl in *.
 rewrite H2 in H3.
 destruct H3.
 destruct H4.
 destruct H5.
 destruct H4.
 exists x3.
  rewrite H4; trivial.
 revert H6; apply H; auto with *.
  rewrite H4; trivial.

  apply Eq_proj in H1.
  rewrite H1; trivial.

 destruct H1.
 apply In_intro; simpl; intros.
 rewrite H4; clear H4.
 destruct (Z2set_surj x0).
 exists x1.
  rewrite <- H4; trivial.
 exists x0.
  split; intros; eauto.
  red; intros.
  apply H0 with x0; trivial.
  revert H6; apply H; auto with *.
  rewrite <- H7; trivial.

  exists x; trivial.
  apply Eq_proj; trivial.
Defined.

Definition repl := proj1_sig repl_sig.
Lemma repl_mono :
  Proper (incl_set ==> (eq_set ==> eq_set ==> iff) ==> incl_set) repl.
Proof (proj1 (proj2_sig repl_sig)).
Lemma repl_ax:
    forall a (R:set->set->Prop),
    (forall x x' y y', x ∈ a -> x == x' -> y == y' -> R x y -> R x' y') ->
    (forall x y y', x ∈ a -> R x y -> R x y' -> y == y') ->
    forall x, x ∈ repl a R <-> exists2 y, y ∈ a & R y x.
Proof proj2 (proj2_sig repl_sig).

(* infinite set (natural numbers) *)

Definition Nat x :=
  forall (P:set),
  empty ∈ P ->
  (forall x, x ∈ P -> union (pair x (pair x x)) ∈ P) ->
  x ∈ P.

Instance Nat_morph : Proper (eq_set ==> iff) Nat.
unfold Nat; split; intros.
 rewrite <- H; apply H0; trivial.
 rewrite H; apply H0; trivial.
Qed.

Lemma Nat_S : forall x,
  Nat x -> Nat (union (pair x (pair x x))).
unfold Nat; intros; auto.
Qed.

Definition infinite_sig :
  { infty | empty ∈ infty /\
      forall x, x ∈ infty -> union (pair x (pair x x)) ∈ infty }.
apply set_intro with
  (fun x => forall y, Z.in_set y x <-> Nat (Z2set y)); intros.
 elim Z.infinity_ex; intros.
 elim Z.repl_ex with x (fun x' y' => Z.eq_set x' y' /\ Nat (Z2set y')); intros.
  exists x0; intros.
  rewrite H1.
  split; intros.
   destruct H2.
   destruct H.
   destruct H3; trivial.

   exists y.
    red in H2.
    apply in_inZ.
    apply H2; intros.
     destruct H.
     apply inZ_in in H3.
     apply in_reg with (Z2set x1); trivial.
     split; intros.
      destruct (Z2set_surj x2).
      rewrite H5 in H4; apply in_inZ in H4.
      elim H with x3; trivial.

      elim empty_ax with x2; trivial.

     destruct (Z2set_surj x1).
     rewrite H4 in H3; apply in_inZ in H3.
     apply H0 in H3.
     destruct H3.
     apply in_reg with (Z2set x3).
     2:apply inZ_in; trivial.
     split; simpl; intros.
      rewrite union_ax.
      destruct (Z2set_surj x4).
      rewrite H7 in H6; apply in_inZ in H6; rewrite H3 in H6.
      destruct H6.
       exists (pair x1 x1).
        rewrite pair_ax; left.
        rewrite H7; rewrite H4; apply Zeq_eq; trivial.

        rewrite pair_ax; right; reflexivity.

       exists x1.
        rewrite H7; rewrite H4; apply inZ_in; trivial.

        rewrite pair_ax; left; reflexivity.

      destruct (Z2set_surj x4).
      rewrite H7; apply inZ_in.
      rewrite H3.
      rewrite H7 in H6; clear x4 H7.
      rewrite union_ax in H6.
      destruct H6.
      rewrite pair_ax in H7; destruct H7.
       right; apply in_inZ.
       rewrite <- H4; rewrite <- H7; trivial.

       rewrite H7 in H6; clear x4 H7.
       left; apply eq_Zeq.
       rewrite <- H4.
       rewrite pair_ax in H6; destruct H6; trivial.

    split; auto with *.

  rewrite <- H2; rewrite <- H3; trivial.

  destruct H2; destruct H3.
  rewrite <- H2; trivial.

 rewrite Z.eq_set_ax; split; intros.
  rewrite H0; rewrite H in H1; trivial.

  rewrite H; rewrite H0 in H1; trivial.

split; intros.
 apply In_intro; simpl; unfold Nat; intros.
 apply (proj2 (H0 x')); intros.
 apply in_reg with empty; trivial.
 split; intros.
  elim empty_ax with x; trivial.

  elim (Z2set_surj x); intros.
 apply Eq_proj in H.
 rewrite <- H in H3.
 elim empty_ax with (1:=H3).

 rewrite in_set_elim in H.
 destruct H; simpl in *.
 destruct H0.
 apply In_intro; simpl; intros.
 apply (proj2 (H3 x')).
 setoid_replace (Z2set x') with (union (pair x (pair x x))).
  apply Nat_S.
  rewrite (Eq_proj _ _ H).
  apply (proj1 (H0 x0)); trivial.

  split; intros.
   elim (Z2set_surj x2); intros.
   rewrite H5 in H4 |- *; clear H5 x2.
   apply Eq_proj in H2.
   rewrite <- H2 in H4; trivial.

   elim (Z2set_surj x2); intros.
   rewrite H5 in H4 |- *; clear H5 x2.
   apply Eq_proj in H2.
   rewrite <- H2; trivial.
Qed.
Definition infinite := proj1_sig infinite_sig.
Lemma infinity_ax1: empty ∈ infinite.
Proof proj1 (proj2_sig infinite_sig).

Lemma infinity_ax2: forall x,
  x ∈ infinite -> union (pair x (pair x x)) ∈ infinite.
Proof proj2 (proj2_sig infinite_sig).

(* well-founded induction *)

Lemma wf_ax : forall (P:set->Prop),
  (forall x, (forall y, y ∈ x -> P y) -> P x) ->
  forall x, P x.
intros P H x.
cut (forall xs (x:set), x == Z2set xs -> P x).
 intros.
 destruct (Z2set_surj x).
 eauto.
clear x.
intros xs; elim xs using Z.wf_ax; intros; trivial.
apply H; intros.
elim (Z2set_surj y); intros.
rewrite H1,H3 in H2.
apply in_inZ in H2; eauto.
Qed.

(* Proving that collection can be skolemized in classical ZF:
   we need excluded-middle to prove coll_ax_uniq (see EnsEm)
 *)

Section Collection.

(* A predicate transformer that is true for the least element of
   the Veblen hierarchy that satisfies the input predicate. If there
   is no unique solution, the returned predicate is empty. No
   excluded-middle needed here.
 *)
Hypothesis lst_rk : (Z.set->Prop) -> Z.set -> Prop.
Hypothesis lst_rk_morph : forall (P P':Z.set->Prop),
  (forall x x', Z.eq_set x x' -> (P x <-> P' x')) ->
  forall y y', Z.eq_set y y' -> lst_rk P y -> lst_rk P' y'.
Hypothesis lst_incl : forall P y, lst_rk P y -> P y.
Hypothesis lst_fun : forall P y y', lst_rk P y -> lst_rk P y' -> Z.eq_set y y'.

(* The modification of the collection axiom that return the least Veblen universe
   that collects all the images of A. This can exist only when the Veblen hierarchy
   is totally ordered, which requires excluded-middle. See EnsEm for the
   construction.
 *)
Hypothesis coll_ax_uniq : forall A (R:Z.set->Z.set->Prop),
    (forall x x' y y', Z.in_set x A -> Z.eq_set x x' -> Z.eq_set y y' ->
     R x y -> R x' y') ->
    exists B, lst_rk(fun B =>
      forall x, Z.in_set x A ->
      (exists y, R x y) ->
      exists2 y, Z.in_set y B & R x y) B.
(* We could also try to prove that B grows when A and R do. *)

Lemma coll_sig : forall A (R:set->set->Prop),
  {coll| Proper (eq_set==>eq_set==>iff) R ->
     forall x, x ∈ A -> (exists y, R x y) ->
     exists2 y, y ∈ coll & R x y }.
intros A R.
pose (R' x y := exists2 x', Z2set x == x' & exists2 y', Z2set y == y' & R x' y').
assert (R'm : forall x x' y y', Z.eq_set x x' -> Z.eq_set y y' ->
     R' x y -> R' x' y').
 destruct 3 as (x'',?,(y'',?,?)).
 exists x'';[|exists y'';trivial].
  transitivity (Z2set x); trivial.
  apply Zeq_eq.
  symmetry; trivial.

  transitivity (Z2set y); trivial.
  apply Zeq_eq.
  symmetry; trivial.
apply set_intro with
  (lst_rk(fun B => exists2 A', Z2set A' == A & forall x, Z.in_set x A' ->
      (exists y, R' x y) ->
      exists2 y, Z.in_set y B & R' x y)); intros.
 destruct (Z2set_surj A) as (A',e).
 destruct coll_ax_uniq with A' R' as (B,HB); eauto.
 exists B.
 revert HB; apply lst_rk_morph; auto with *.
 intros.
 split; intros.
  exists A'; intros; auto with *.
  destruct H0 with x0 as (y,?,?); trivial.
  exists y; trivial.
  revert H3; apply Zin_morph; auto with *.

  destruct H0 as (A'',e',?).
  rewrite e in e'.
  apply eq_Zeq in e'.
  rewrite <- e' in H1.
  destruct H0 with x0 as (y,?,?); trivial.
  exists y; trivial.
  revert H3; apply Zin_morph; auto with *.

 apply lst_fun with (1:=H) (2:=H0).

 destruct Hex as (B,HB).
 assert (Bok := lst_incl _ _ HB).
 destruct Bok as (A',eA,Bok).
 destruct (Z2set_surj x) as (x',ex).
 destruct Bok with x' as (y,?,?).
  apply in_inZ.
  rewrite eA; rewrite <- ex; trivial.

  destruct H1 as (y,Rxy).
  destruct (Z2set_surj y) as (y',ey).
  exists y'; exists x; [|exists y]; auto with *.

  exists (Z2set y).
   apply In_intro; simpl; intros.
   specialize Huniq with (1:=HB) (2:=H5).
   rewrite <- Huniq.
   rewrite H4; trivial.

   destruct H3 as (x'',?,(y',?,?)).
   revert H5; apply H; trivial.
   rewrite ex; rewrite <- H3; auto with *.
Qed.

Definition coll A R := proj1_sig (coll_sig A R).
Lemma coll_ax : forall A (R:set->set->Prop),
  Proper (eq_set==>eq_set==>iff) R ->
  forall x, x ∈ A -> (exists y, R x y) ->
  exists2 y, y ∈ coll A R & R x y.
Proof (fun A R => proj2_sig (coll_sig A R)).

End Collection.

End Skolem.


From Hammer Require Import Hammer.

Require Import Coq.Program.Basics.
Require Export FunctionalExtensionality.

Open Scope program_scope.

Lemma compose_id_left : forall A B (f : A -> B), id ∘ f = f.
Proof. hammer_hook "Combinators" "Combinators.compose_id_left".
intros.
unfold id, compose.
symmetry. apply eta_expansion.
Qed.

Lemma compose_id_right : forall A B (f : A -> B), f ∘ id = f.
Proof. hammer_hook "Combinators" "Combinators.compose_id_right".
intros.
unfold id, compose.
symmetry ; apply eta_expansion.
Qed.

Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D),
h ∘ g ∘ f = h ∘ (g ∘ f).
Proof. hammer_hook "Combinators" "Combinators.compose_assoc".
intros.
reflexivity.
Qed.

Hint Rewrite @compose_id_left @compose_id_right : core.
Hint Rewrite <- @compose_assoc : core.

Lemma flip_flip : forall A B C, @flip A B C ∘ flip = id.
Proof. hammer_hook "Combinators" "Combinators.flip_flip".
unfold flip, compose.
intros.
extensionality x ; extensionality y ; extensionality z.
reflexivity.
Qed.

Lemma prod_uncurry_curry : forall A B C, @prod_uncurry A B C ∘ prod_curry = id.
Proof. hammer_hook "Combinators" "Combinators.prod_uncurry_curry".
simpl ; intros.
unfold prod_uncurry, prod_curry, compose.
extensionality x ; extensionality y ; extensionality z.
reflexivity.
Qed.

Lemma prod_curry_uncurry : forall A B C, @prod_curry A B C ∘ prod_uncurry = id.
Proof. hammer_hook "Combinators" "Combinators.prod_curry_uncurry".
simpl ; intros.
unfold prod_uncurry, prod_curry, compose.
extensionality x ; extensionality p.
destruct p ; simpl ; reflexivity.
Qed.