(* This file contains boolean functions corresponding to the different predicates
   commonly used in reasoning about sets. These boolean functions are connected to
   the corresponding predicates using the reflection lemmas (similar to ssreflect).
   The type of elements in the set (or lists) are from eqType.

  Following are the boolean functions and their corresponding predicated

  Propositions                        Boolean functions      Connecting Lemma
  In a l                       <->    memb a l                membP
  IN a b l                     <->    memb2 a b l             memb2p
  NoDup l                      <->    noDup l                nodupP
  Empty l                      <->    is_empty l             emptyP
  Subset s s'                  <->    subset s s'            subsetP
  Equal s s'                   <->    equal s s'             equalP
  Exists P l                   <->    existsb f l            ExistsP
  exists x, (In x l /\ P x)    <->    existsb f l            existsP
  exists x, (In x l /\ f x)    <->    existsb f l            existsbP
  Forall P l                   <->    forallb f l            ForallP
  forall x, (In x l -> P x)    <->    forallb f l            forallP
  forall x, (In x l -> f x)    <->    forallb f l            forallbP

  We also define index function (idx a l), which returns the location of an element
  a in the list l.

  forall_em_exists f: (forall x, In x l -> f x) \/ (exists x, In x l /\ ~ f x).
  exists_em_forall f: (exists x, In x l /\ f x) \/ (forall x, In x l -> ~ f x).

  Definition forall_xyb g l := forallb (fun x => (forallb ( fun y=> g x y) l)) l.
  Definition forall_yxb g l := forallb (fun y => (forallb ( fun x=> g x y) l)) l.

  forall_xyP g l: reflect (forall x y, In x l-> In y l-> g x y) (forall_xyb g l).
  forall_yxP g l: reflect (forall x y, In x l-> In y l-> g x y) (forall_yxb g l).

   ------------*)

From Coq Require Export ssreflect  ssrbool Lists.List.
Require Export SetSpecs GenReflect DecType.
Set Implicit Arguments.

Section SetReflections.
Context { A:eqType }. (* to declare A as implicit for all functions in this section *)
Lemma decA: forall x y:A, {x=y}+{x<>y}.
Proof. eauto. Qed.

  (*--------- set_mem (boolean function)  and its specification ---------*)
  Fixpoint memb (a:A)(l: list A){struct l}: bool:=
    match l with
    | nil =>false
    | a1::l1 => (a== a1) ||  memb a l1
    end.

  (* fix In (a : A) (l : list A) {struct l} : Prop :=
  match l with
  | nil => False
  | b :: m => b = a \/ In a m
  end *)

  Lemma set_memb_correct1: forall (a:A)(l:list A), memb a l -> In a l.
  Proof. { intros a l. induction l.
         { simpl;auto. }
         { simpl.  move /orP. intro H; destruct H.
           move /eqP in H;symmetry in H; left;auto.
           right; auto.  } } Qed.
  Lemma set_memb_correct2: forall (a:A)(l:list A), In a l ->  memb a l.
  Proof. { intros a l. induction l.
         { simpl;auto. }
         { simpl.  intro H. apply /orP. destruct H.
           left; apply /eqP; symmetry; auto.
           right; auto.  } } Qed.

  Lemma membP a l: reflect (In a l) (memb  a l).
  Proof. apply reflect_intro. split.
         apply set_memb_correct2. apply set_memb_correct1. Qed.

  Hint Resolve membP : core.
  Hint Immediate set_memb_correct1 set_memb_correct2: core.

  Lemma memb_prop1 (a:A)(l s: list A): l [<=] s -> In a l -> memb a l = memb a s.
  Proof. intros H H1. assert (H2: In a s); auto. Qed.
  Lemma memb_prop2 (a:A)(l s: list A): l [<=] s -> ~ In a s -> memb a l = memb a s.
  Proof. intros H H1. assert (H2: ~ In a l); auto. Qed.
  Lemma memb_prop3 (a:A)(l s: list A): l [=] s -> memb a l = memb a s.
  Proof. { intro h. destruct h as [h1 h2]. cut (In a l \/ ~ In a l).
         intro h3.  destruct h3 as [h3 | h3].
         apply memb_prop1;auto. apply memb_prop2;auto.
         eapply reflect_EM;auto. } Qed.

  Hint Resolve memb_prop1 memb_prop2 memb_prop3: core.

Lemma In_EM: forall (a:A) (x: list A), In a x \/ ~ In a x.
Proof. eauto.  Qed.

Definition IN := fun (x:A)(y:A)(l:list A) => In x l /\ In y l.
Definition memb2 x y l := memb  x l && memb y l.

Lemma memb2P a b x : reflect (IN a b x) (memb2 a b x).
Proof. { apply reflect_intro. split.
       { unfold IN; unfold memb2. intro H; destruct H.
         apply /andP. split; apply /membP; auto. }
       { unfold IN; unfold memb2. move /andP.
         intro H; split; apply /membP; tauto. } } Qed.

Lemma memb2_comute (x y: A)(l: list A): memb2 x y l = memb2 y x l.
Proof. unfold memb2. case (memb  x l);case (memb y l); simpl;auto. Qed.

Hint Resolve memb2P: core.
Lemma IN_EM: forall (a b:A)(x:list A), IN a b x \/ ~ IN a b x.
Proof.  eauto. Qed.

Lemma memb_prop4 (x y: A)(l s: list A): l [=] s -> memb2 x y l = memb2 x y s.
Proof. intro h. assert (h1: s [=] l). auto. unfold memb2.
       replace (memb x s) with (memb x l). replace (memb y s) with (memb y l).
       auto. all: auto. Qed.
Lemma memb2_elim (x y: A)(l: list A): memb2 x y l = false -> (~ In x l \/ ~ In y l).
Proof. { intro h7. unfold memb2 in h7.
       destruct (memb x l) eqn:h7x; destruct (memb y l) eqn:h7y; simpl in h7;
           move /membP in h7x; move /membP in h7y.
       inversion h7. right;auto. all: left;auto. } Qed.

(*---------- noDup  (boolean function) and its specification ---------*)
Fixpoint noDup (x: list A): bool:=
  match x with
    |nil => true
    |h :: x1 => if memb h x1 then false else noDup x1
  end.
Lemma NoDup_iff_noDup l: NoDup l <-> noDup l.
Proof. { split.
       { induction l.  auto.
       intro H; inversion H;  simpl.
       replace (memb a l) with false; auto. }
       { induction l. constructor.
       simpl. case (memb a l) eqn: H1. discriminate.  intro H2.
       constructor. move /membP.  rewrite H1.  auto. tauto. }  } Qed.
Lemma noDup_intro l: NoDup l -> noDup l.
Proof. apply NoDup_iff_noDup. Qed.
Lemma noDup_elim l: noDup l -> NoDup l.
Proof. apply NoDup_iff_noDup. Qed.

Hint Immediate noDup_elim noDup_intro: core.

Lemma nodupP l: reflect (NoDup l) (noDup l).
Proof. {cut (NoDup l <-> noDup l). eauto. apply NoDup_iff_noDup. } Qed.

Hint Resolve nodupP : core.

Lemma NoDup_EM: forall l:list A, NoDup l \/ ~ NoDup l.
Proof. eauto. Qed.
Lemma NoDup_dec: forall l:list A, {NoDup l} + { ~ NoDup l}.
Proof. eauto. Qed.

Lemma nodup_spec: forall l:list A, NoDup (nodup decA l).
Proof. intros. eapply NoDup_nodup. Qed.

(*---------- is_empty (boolean function) and its specification -----------------*)
Definition is_empty (x:list A) : bool := match x with
                                 | nil => true
                                 | _ => false
                                      end.

Lemma emptyP l : reflect (Empty l) (is_empty l).
Proof. { destruct l eqn:H. simpl.  constructor. unfold Empty; auto.
       simpl. constructor. unfold Empty.  intro H1. specialize (H1 e).
       apply H1. auto.  } Qed.
Hint Resolve emptyP : core.
Lemma Empty_EM (l:list A): Empty l \/ ~ Empty l.
  Proof. solve_EM. Qed.
Lemma Empty_dec (l: list A): {Empty l} + {~Empty l}.
Proof. solve_dec. Qed.
Lemma empty_intro l : Empty l -> is_empty l.
Proof. move /emptyP. auto. Qed.
Lemma empty_elim l: is_empty l -> Empty l.
Proof. move /emptyP. auto. Qed.

Hint Immediate empty_elim empty_intro: core.

(*----------- subset (boolean function) and its specification--------------------*)
Fixpoint subset (s s': list A): bool:=
  match s with
  |nil => true
  | a1 :: s1=> memb a1 s' && subset s1 s'
  end.

Lemma subsetP s s': reflect (Subset s s') (subset s s').
Proof. { induction s. simpl. constructor. intro. intros  H. absurd (In a nil); auto.
       apply reflect_intro. split.
       { intro H.  cut (In a s' /\ Subset s s'). Focus 2. split; eauto. simpl.
         intro H1; destruct H1 as [H1 H2].
         apply /andP. split. apply /membP;auto. apply /IHs;auto.  }
       { simpl.  move /andP. intro H; destruct H as [H1 H2]. unfold Subset.
         intros a0 H3. cut (a0= a \/ In a0 s). intro H4; destruct H4 as [H4 | H5].
         rewrite H4. apply /membP;auto. cut (Subset s s'). intro H6. auto. apply /IHs;auto.
         eauto.   }  } Qed.

Hint Resolve subsetP: core.
Lemma Subset_EM (s s': list A): Subset s s' \/ ~ Subset s s'.
Proof. solve_EM. Qed.
Lemma Subset_dec (s s': list A): {Subset s s'} + {~ Subset s s'}.
Proof. solve_dec. Qed.

Lemma subset_intro s s': Subset s s' -> subset s s'.
Proof. move /subsetP. auto. Qed.
Lemma subset_elim s s': subset s s' -> Subset s s'.
Proof. move /subsetP. auto. Qed.

Hint Immediate subset_intro subset_elim: core.

(*----------- equal (boolean function) and its specifications--------------------*)
Definition equal (s s':list A): bool:= subset s s' && subset s' s.
Lemma equalP s s': reflect (Equal s s') (equal s s').
Proof. { apply reflect_intro.  split.
       { intro H. cut (Subset s s'/\ Subset s' s).
       Focus 2. auto. intro H1. unfold equal.
       apply /andP. split; apply /subsetP; tauto. }
       { unfold equal. move /andP. intro H. apply Equal_intro; apply /subsetP; tauto. }
       } Qed.

Hint Resolve equalP: core.
Lemma Equal_EM (s s': list A): Equal s s' \/ ~ Equal s s'.
Proof. solve_EM. Qed.
Lemma Equal_dec (s s': list A): {Equal s s'} + {~ Equal s s'}.
Proof. solve_dec. Qed.

Lemma equal_intro s s': Equal s s' -> equal s s'.
Proof. move /equalP. auto. Qed.
Lemma equal_elim s s': equal s s' -> Equal s s'.
Proof. move /equalP. auto. Qed.

Hint Immediate equal_elim equal_intro: core.

(*----------- existsb (boolean function) and its specifications-------------------*)

  (* fix existsb (l : list A) : bool :=
  match l with
  | nil => false
  | a :: l0 => f a || existsb l0
  end *)

  (* Inductive Exists (A : Type) (P : A -> Prop) : list A -> Prop :=
    Exists_cons_hd : forall (x : A) (l : list A), P x -> Exists P (x :: l)
  | Exists_cons_tl : forall (x : A) (l : list A), Exists P l -> Exists P (x :: l) *)

  Lemma ExistsP P f l: (forall x:A, reflect (P x) (f x) ) -> reflect (Exists P l) (existsb f l).
  Proof.  { intro H. eapply reflect_intro.
         induction l. simpl. constructor; intro H1; inversion H1.
         split.
         { intro H1.  inversion H1. simpl. apply /orP; left; apply /H;auto.
           simpl. apply /orP; right; apply /IHl; auto. }
         { simpl. move /orP. intro H1; destruct H1 as [H1| H2]. constructor. apply /H; auto.
           eapply Exists_cons_tl. apply /IHl; auto.  } } Qed.

  Hint Resolve ExistsP: core.

  (* Exists_dec
     : forall (A : Type) (P : A -> Prop) (l : list A),
       (forall x : A, {P x} + {~ P x}) -> {Exists P l} + {~ Exists P l} *)

   Lemma Exists_EM P l:(forall x:A, P x \/ ~ P x )-> Exists P l \/ ~ Exists P l.
  Proof. { intros H. induction l. right. intro H1.  inversion H1.
         cut( P a \/ ~ P a).  intro Ha. cut (Exists P l \/ ~ Exists P l). intro Hl.
         { destruct Ha as [Ha1 | Ha2]; destruct Hl as [Hl1 | Hl2].
           left. constructor;auto. left; constructor;auto.
           left.  apply Exists_cons_tl;auto.
           right. intro H1. inversion H1. all:contradiction. }
         all: auto.  } Qed.

  (* Exists_exists
     : forall (A : Type) (P : A -> Prop) (l : list A),
       Exists P l <-> (exists x : A, In x l /\ P x) *)

  Lemma existsP P f l: (forall x:A, reflect (P x)(f x))-> reflect (exists x, In x l /\ P x)(existsb f l).
  Proof. { intro H. eapply iffP with (P:= Exists P l). eapply ExistsP. apply H.
           all: apply Exists_exists. } Qed.
  Hint Resolve existsP: core.
  Lemma existsbP (f:A->bool) l: reflect (exists x, In x l /\ f x)(existsb f l).
  Proof. apply existsP. intros. apply idP. Qed.

  Lemma exists_dec P l:
    (forall x:A, {P x} + {~ P x})-> { (exists x, In x l /\ P x) } + { ~ exists x, In x l /\ P x}.
  Proof. { intros. cut({Exists P l}+{ ~ Exists P l}). intro H;destruct H as [Hl |Hr].
         left. apply Exists_exists;auto.
         right;intro H1; apply Hr; apply Exists_exists;auto.
         eapply Exists_dec;auto.  } Qed.

  Lemma exists_EM P l:
     (forall x:A, P x \/ ~ P x) ->  (exists x, In x l /\ P x) \/  ~ (exists x, In x l /\ P x) .
  Proof. { intro H. cut(Exists P l \/ ~ Exists P l).
         intro H1; destruct H1 as [H1l| H1r]. left. eapply Exists_exists;auto.
         right; intro H2;apply H1r; apply Exists_exists;auto. eapply Exists_EM;auto. } Qed.

(*----------- forallb ( boolean function) and its specifications----------------- *)

 (* fix forallb (l : list A) : bool :=
    match l with
     | nil => true
     | a :: l0 => f a && forallb l0
    end *)

 (* Inductive Forall (A : Type) (P : A -> Prop) : list A -> Prop :=
    Forall_nil : Forall P nil
  | Forall_cons : forall (x : A) (l : list A), P x -> Forall P l -> Forall P (x :: l) *)

 Lemma ForallP P f l: (forall x:A, reflect (P x) (f x) ) -> reflect (Forall P l) (forallb f l).
 Proof.   { intro H. eapply reflect_intro.
         induction l. simpl. constructor; intro H1; inversion H1; auto.
         split.
         { intro H1.  inversion H1. simpl. apply /andP. split.  apply /H;auto.
           apply /IHl; auto. }
         { simpl. move /andP. intro H1; destruct H1 as [H1 H2]. constructor. apply /H; auto.
           apply /IHl; auto. } } Qed.

 Hint Resolve ForallP: core.
 Lemma Forall_EM P l:(forall x:A, P x \/ ~ P x ) -> Forall P l \/ ~ Forall P l.
 Proof.  { intros H. induction l. left. constructor.
         cut( P a \/ ~ P a).  intro Ha. cut (Forall P l \/ ~ Forall P l). intro Hl.
         { destruct Ha as [Ha1 | Ha2]; destruct Hl as [Hl1 | Hl2].
           left. constructor;auto.
           right; intro H1;apply Hl2; inversion H1;auto.
           right; intro H1; apply Ha2; inversion H1; auto.
           right. intro H1. apply Ha2. inversion H1;auto.  }
         all: auto.  } Qed.
 Lemma forallP P f l: (forall x:A, reflect (P x) (f x) ) -> reflect (forall x, In x l -> P x) (forallb f l).
 Proof. { intro H. eapply iffP with (P:= Forall P l). eapply ForallP. apply H.
          all: apply Forall_forall. } Qed.

 Lemma forallbP (f: A->bool) (l: list A): reflect (forall x:A, In x l -> (f x)) (forallb f l).
 Proof. apply forallP. intros. apply idP. Qed.

 Lemma forall_dec P  l:
   (forall x:A, {P x} + { ~ P x}) -> { (forall x, In x l -> P x) } + { ~ forall x, In x l -> P x}.
 Proof. { intros. cut({Forall P l} + {~ Forall P l}).
          intro H;destruct H as [Hl |Hr].
          left. apply Forall_forall;auto.
          right;intro H1; apply Hr; apply Forall_forall;auto.
          eapply Forall_dec; auto.  } Qed.
 Lemma forall_EM P l:
   (forall x:A, P x \/ ~ P x )->  (forall x, In x l -> P x)  \/  ~ (forall x, In x l -> P x).
 Proof. { intros H. cut(Forall P l \/ ~ Forall P l).
          intro H1; destruct H1 as [H1l| H1r]. left. eapply Forall_forall;auto.
          right; intro H2;apply H1r; apply Forall_forall;auto. eapply Forall_EM;auto. } Qed.

 Lemma forall_exists_EM P l:
   (forall x:A, P x \/ ~ P x) -> (forall x, In x l -> P x) \/ (exists x, In x l /\ ~ P x).
 Proof. { intros. cut(Forall P l \/ ~ Forall P l).
        Focus 2. eapply Forall_EM. auto.
        intro H1; destruct H1 as [Hl | Hr].
        left. apply Forall_forall. auto. right.
        cut(Exists (fun x : A => ~ P x) l). eapply Exists_exists.
        apply Exists_Forall_neg. all:auto. } Qed.
 Lemma exists_forall_EM P l:
   (forall x:A, P x \/ ~ P x)-> (exists x, In x l /\ P x) \/ (forall x, In x l ->  ~ P x).
   Proof.  { intros. cut(Exists P l \/ ~ Exists P l).
        Focus 2. eapply Exists_EM. auto.
        intro H1; destruct H1 as [Hl | Hr].
        left. apply Exists_exists. auto. right.
        cut(Forall (fun x : A => ~ P x) l). eapply Forall_forall.
        apply Forall_Exists_neg. all:auto. } Qed.
   Lemma forall_em_exists (f: A-> bool) (l: list A): (forall x, In x l -> f x) \/ (exists x, In x l /\ ~ f x).
   Proof. apply forall_exists_EM; intro x;destruct (f x); auto. Qed.
   Lemma exists_em_forall (f: A-> bool) (l: list A): (exists x, In x l /\ f x) \/ (forall x, In x l ->  ~ f x).
   Proof. apply exists_forall_EM; intro x; destruct (f x); auto. Qed.

End SetReflections.

Hint Resolve membP memb2P nodupP emptyP subsetP equalP
     existsP existsbP ExistsP ForallP forallP forallbP memb2_comute: core.
Hint Resolve forall_exists_EM exists_forall_EM: core.
Hint Resolve forall_em_exists exists_em_forall: core.

Hint Immediate set_memb_correct1 set_memb_correct2  memb2_elim: core.
Hint Resolve memb_prop1 memb_prop2 memb_prop3 memb_prop4: core.
Hint Immediate noDup_elim noDup_intro: core.
Hint Immediate empty_elim empty_intro: core.
Hint Immediate subset_intro subset_elim: core.
Hint Immediate equal_elim equal_intro: core.

Section MoreReflection.
  Context { A:eqType }.

  Definition forall_xyb (g:A->A->bool)(l:list A):=  (forallb (fun x=> (forallb (fun y => g x y) l )) l).
  Definition forall_yxb (g:A->A->bool)(l:list A) :=  (forallb (fun y=> (forallb (fun x => g x y) l )) l).

  Lemma forall_xyP (g:A->A->bool) (l:list A):
    reflect (forall x y, In x l-> In y l-> g x y)  (forall_xyb g l).
  Proof. eapply iffP with (P:= (forall x, In x l -> (forall y, In y l -> g x y))).
         unfold forall_xyb; auto. all: auto. Qed.
  Lemma forall_yxP (g:A->A->bool) (l:list A):
    reflect (forall x y, In x l-> In y l-> g x y)  (forall_yxb g l).
  Proof. eapply iffP with (P:= (forall y, In y l -> (forall x, In x l -> g x y))).
         unfold forall_yxb; auto. all: auto. Qed.

End MoreReflection.

Hint Resolve forall_xyP forall_yxP: core.


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

Print ev.

Check ev_SS.

Theorem ev_4 : ev 4.
Proof.
  apply ev_SS. apply ev_SS. apply ev_0. Qed.

Print ev_4.

Check (ev_SS 2 (ev_SS 0 ev_0)).

Theorem ev_4' : ev 4.
Proof.
  apply (ev_SS 2 (ev_SS 0 ev_0)).
Qed.

Theorem ev_4'' : ev 4.
Proof.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_0.
  Show Proof.
Qed.

Definition ev_4''' : ev 4 :=
  ev_SS 2 (ev_SS 0 ev_0).

Print ev_4.

Print ev_4'.

Print ev_4''.

Print ev_4'''.

Theorem ev_8 : ev 8.
Proof.
  repeat apply ev_SS. apply ev_0.
Qed.

Definition ev_8' : ev 8 :=
  ev_SS 6 (ev_SS 4 (ev_SS 2 (ev_SS 0 ev_0))).

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n H. simpl.
  apply ev_SS.
  apply ev_SS.
  apply H.
Qed.

Definition ev_plus4' : forall n, ev n -> ev (4 + n) :=
  fun (n : nat) => fun (H : ev n) =>
    ev_SS (S (S n)) (ev_SS n H).

Definition ev_plus4'' (n : nat) (H : ev n)
  : ev (4 + n) :=
  ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4''.

Definition ev_plus2 : Prop :=
  forall n, forall (E : ev n), ev (n + 2).

Definition ev_plus2' : Prop :=
  forall n, forall (_ : ev n), ev (n + 2).

Definition ev_plus2'' : Prop :=
  forall n, ev n -> ev (n + 2).

Definition add1 : nat -> nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n.
Defined.

Print add1.

Compute add1 2.

Module Props.

Module And.

Inductive and (P Q : Prop) : Prop :=
  | conj : P -> Q -> and P Q.

End And.

Print prod.

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

Definition and_comm'_aux P Q (H : P /\ Q) :=
  match H with
  | conj HP HQ => conj HQ HP
  end.

Definition and_comm' P Q : P /\ Q <-> Q /\ P :=
  conj (and_comm'_aux P Q) (and_comm'_aux Q P).

Definition conj_fact_aux P R (H : P /\ R) :=
  match H with
  | conj HP HQ => conj HP HQ
  end.

Definition conj_fact :
  forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
  fun P => fun Q => fun R => fun PQ => fun QR =>
   match PQ with
   | conj P Q => match QR with
                  | conj Q R => conj P R
                  end
   end.

Module Or.

Inductive or (P Q : Prop) : Prop :=
  | or_introl : P -> or P Q
  | or_intror : Q -> or P Q.

End Or.

Definition or_comm : forall P Q, P \/ Q -> Q \/ P :=
  fun _ => fun _ => fun PQ =>
      match PQ with
      | or_introl P => or_intror P
      | or_intror Q => or_introl Q
      end.

Module Ex.

Inductive ex { A : Type } (P : A -> Prop) : Prop :=
  | ex_intro : forall x : A, P x -> ex P.

End Ex.

Check ex (fun n => ev n).

Definition some_nat_is_even : exists n, ev n :=
  ex_intro ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

Definition ex_ev_Sn : ex (fun n => ev (S n)) :=
  ex_intro (fun n => ev (S n)) 1 (ev_SS 0 ev_0).

Inductive True : Prop :=
  | I : True.

Inductive False : Prop :=.

End Props.

Module MyEquality.

Inductive eq { X : Type } : X -> X -> Prop :=
  | eq_refl : forall x, eq x x.

Notation "x = y" := (eq x y)
                    (at level 70, no associativity)
                    : type_scope.

Lemma four : 2 + 2 = 1 + 3.
Proof.
  apply eq_refl.
Qed.

Definition four' : 2 + 2 = 1 + 3 :=
  eq_refl 4.

Definition singleton : forall (X : Type) (x : X),
  [] ++ [x] = x :: [] :=
  fun (X : Type) (x : X) => eq_refl [x].

End MyEquality.

Lemma equality__leibniz_equality :
  forall (X : Type) (x y : X),
  x = y -> forall P : X -> Prop, P x -> P y.
Proof.
  intros X x y H1 P H2. rewrite -> H1 in H2.
  apply H2.
Qed.


Require Export ZArith.
Require Export Arith.
Require Import Lia.

Fixpoint check_range (v:Z)(r:nat)(sr:Z){struct r} : bool :=
  match r with
    O => true
  | S r' =>
    match (v mod sr)%Z with
      Z0 => false
    | _ => check_range v r' (Z.pred sr)
    end
  end.

Definition check_primality (n:nat) :=
  check_range (Z_of_nat n)(pred (pred n))(Z_of_nat (pred n)).

Theorem verif_divide :
    forall m p:nat, 0 < m -> 0 < p ->
    (exists q:nat, m = q*p) -> (Z_of_nat m mod Z_of_nat p = 0)%Z.
Proof.
 intros m p Hltm Hltp (q, Heq); rewrite Heq.
 rewrite inj_mult.
 replace (Z_of_nat q * Z_of_nat p)%Z with (0 + Z_of_nat q * Z_of_nat p)%Z;
    try ring.
 rewrite Z_mod_plus; auto.
 lia.
Qed.

Theorem divisor_smaller :
    forall m p:nat, 0 < m -> forall q:nat, m = q*p -> q <= m.
Proof.
 intros m p Hlt; case p.
 -  intros q Heq; rewrite Heq in Hlt; rewrite mult_comm in Hlt.
     elim (lt_irrefl 0);exact Hlt.
 -  intros p' q; case q.
    +  intros Heq; rewrite Heq in Hlt.
       elim (lt_irrefl _ Hlt).
    + intros q' Heq; rewrite Heq.
      rewrite mult_comm; simpl; auto with arith.
Qed.

Theorem Zabs_nat_0 : forall x:Z, Z.abs_nat x = 0 -> (x = 0)%Z.
Proof.
 intros x; case x.
 -  simpl; auto.
 -  intros p Heq; elim (lt_irrefl 0).
    pattern 0 at 2; rewrite <- Heq.
    simpl; apply lt_O_nat_of_P.
 -  intros p Heq; elim (lt_irrefl 0).
    pattern 0 at 2; rewrite <- Heq.
    simpl; apply lt_O_nat_of_P.
Qed.

Theorem Z_to_nat_and_back :
 forall x:Z, (0 <= x)%Z -> (Z.of_nat (Z.abs_nat x))=x.
Proof.
 intros x; case x.
 - reflexivity.
 -  intros p Hd; elim p.
   +  unfold Z.abs_nat; intros p' Hrec; rewrite nat_of_P_xI.
      rewrite inj_S,  inj_mult,  Zpos_xI.
      unfold Z.succ; rewrite Hrec;  simpl; auto.
   +  unfold Z.abs_nat; intros p' Hrec; rewrite nat_of_P_xO.
      rewrite inj_mult,  Zpos_xO.
      unfold Z.succ; rewrite Hrec; simpl; auto.
   +  simpl; auto.

 -  intros p' Hd; elim Hd;auto.
Qed.

Theorem  check_range_correct :
  forall (v:Z)(r:nat)(rz:Z),
  (0 < v)%Z -> Z_of_nat (S r) = rz -> check_range v r rz = true ->
  ~(exists k:nat, k <= S r /\ k <> 1 /\
                       (exists q:nat, Z.abs_nat v = q*k)).
Proof.
 intros v r; elim r.
 -  intros rz Hlt H1 H2 Hex; case Hex; intros k; case k.
   +  intros (Hle, (Hne1, (q, Heq))).
      rewrite mult_comm in Heq; simpl in Heq.
      rewrite (Zabs_nat_0 _ Heq) in Hlt.
      elim (Z.lt_irrefl 0); assumption.

   + intros k' (Hle, (Hne1, (q, Heq))).
     inversion Hle.
     *  assert (H':k'=0) by  assumption.
        rewrite H' in Hne1; elim Hne1;auto.
     *  assert (H': S k' <= 0) by  assumption.
        inversion H'.

 -  intros r' Hrec rz Hlt H1 H2 Hex; case Hex; intros k; case k.
    intros (Hle, (Hne1, (q, Heq))).
    rewrite mult_comm in Heq; simpl in Heq.
    rewrite (Zabs_nat_0 _ Heq) in Hlt.
    elim (Z.lt_irrefl 0); assumption.
    intros k' (Hle, (Hne1, (q, Heq))).
    inversion Hle.
    rewrite <- H1 in H2.
    rewrite <- (Z_to_nat_and_back v) in H2.
    assert (Hmod:(Z.of_nat (Z.abs_nat v) mod Z.of_nat (S (S r')) = 0)%Z).
    +  apply verif_divide.
       replace 0 with (Z.abs_nat 0%Z).
       apply Zabs_nat_lt.
       lia.
       simpl; auto.
       auto with arith.
       exists q.
       assert (H': k' = S r') by  assumption.
       rewrite <- H'.
       assumption.
    +  unfold check_range in H2.
       rewrite Hmod in H2.
       discriminate H2.
      + lia.
      + unfold check_range in H2; fold check_range in H2.
        case_eq ((v mod rz)%Z).
        *  intros Heqmod; rewrite Heqmod in H2; discriminate H2.
        *  intros pmod Heqmod; rewrite Heqmod in H2;  elim (Hrec (Z.pred rz) Hlt).
           rewrite <- H1; repeat rewrite inj_S;  rewrite <- Zpred_succ; auto.
          assumption.
          exists (S k'); repeat split;auto.
          exists q; assumption.

        * intros p Hmod; elim (Z_mod_lt v rz).
          rewrite Hmod; unfold Z.le; simpl; intros Hle'; elim Hle';auto.
          rewrite <- H1; rewrite inj_S; unfold Z.succ;
            generalize (Zle_0_nat (S r')).
          intros; lia.
Qed.

Theorem nat_of_P_Psucc :
 forall p:positive, nat_of_P (Pos.succ p) = S (nat_of_P p).
Proof.
 intros p; elim p.
 - simpl; intros p'; rewrite nat_of_P_xO.
   intros Heq; rewrite Heq.
   rewrite nat_of_P_xI; ring.
- intros p' Heq; simpl; rewrite nat_of_P_xI; rewrite nat_of_P_xO;auto.
-  auto.
Qed.

Theorem nat_to_Z_and_back:
 forall n:nat, Z.abs_nat (Z_of_nat n) = n.
Proof.
 intros n; elim n.
 -  auto.
 - intros n'; simpl; case n'.
  +  simpl; auto.
  +  intros n''; simpl; rewrite nat_of_P_Psucc; intros Heq; rewrite Heq; auto.
Qed.

Theorem check_correct :
  forall p:nat, 0 < p -> check_primality p = true ->
  ~(exists k:nat, k <> 1 /\ k <> p /\ (exists q:nat, p = q*k)).
Proof.
 unfold lt; intros p Hle; elim Hle.
 -  intros Hcp (k, (Hne1, (Hne1bis, (q, Heq)))); rewrite mult_comm in Heq.
    assert (Hle' : k < 1).
    +  elim (le_lt_or_eq k 1); try(intuition; fail).
       apply divisor_smaller with (2:= Heq); auto.
    +  case_eq k.
       *  intros Heq'; rewrite Heq' in Heq; simpl in Heq; discriminate Heq.
       *  intros; lia.
 -  intros p' Hlep' Hrec; unfold check_primality.
    assert (H':(exists p'':nat, p' = (S p''))).
   +  inversion Hlep'.
      *     exists 0; auto.
      *  eapply ex_intro;eauto.
   +  elim H'; intros p'' Hp''; rewrite Hp''.
      repeat rewrite <- pred_Sn.
      intros Hcr Hex;  elim check_range_correct with (3:= Hcr).
     *  rewrite inj_S; generalize (Zle_0_nat (S p'')).
        intros; lia.
     *  auto.
     *  elim Hex; intros k (Hne1, (HneSSp'', (q, Heq))); exists k.
       split.
       assert (HkleSSp'': k <= S (S p'')).
       apply (divisor_smaller (S (S p'')) q); auto with arith.
       rewrite mult_comm; assumption.
       lia.
       split.
       assumption.
       exists q; now  rewrite nat_to_Z_and_back.
Qed.


From Hammer Require Import Hammer.

Require Import List Compare_dec EqNat Decidable ListDec. Require Fin.
Set Implicit Arguments.

Definition Injective {A B} (f : A->B) :=
forall x y, f x = f y -> x = y.

Definition Surjective {A B} (f : A->B) :=
forall y, exists x, f x = y.

Definition Bijective {A B} (f : A->B) :=
exists g:B->A, (forall x, g (f x) = x) /\ (forall y, f (g y) = y).

Definition Full {A:Type} (l:list A) := forall a:A, In a l.
Definition Finite (A:Type) := exists (l:list A), Full l.

Definition Listing {A:Type} (l:list A) := NoDup l /\ Full l.
Definition Finite' (A:Type) := exists (l:list A), Listing l.

Lemma Finite_alt A (d:decidable_eq A) : Finite A <-> Finite' A.
Proof. hammer_hook "FinFun" "FinFun.Finite_alt".
split.
- intros (l,F). destruct (uniquify d l) as (l' & N & I).
exists l'. split; trivial.
intros x. apply I, F.
- intros (l & _ & F). now exists l.
Qed.

Lemma Injective_map_NoDup A B (f:A->B) (l:list A) :
Injective f -> NoDup l -> NoDup (map f l).
Proof. hammer_hook "FinFun" "FinFun.Injective_map_NoDup".
intros Ij. induction 1 as [|x l X N IH]; simpl; constructor; trivial.
rewrite in_map_iff. intros (y & E & Y). apply Ij in E. now subst.
Qed.

Lemma Injective_list_carac A B (d:decidable_eq A)(f:A->B) :
Injective f <-> (forall l, NoDup l -> NoDup (map f l)).
Proof. hammer_hook "FinFun" "FinFun.Injective_list_carac".
split.
- intros. now apply Injective_map_NoDup.
- intros H x y E.
destruct (d x y); trivial.
assert (N : NoDup (x::y::nil)).
{ repeat constructor; simpl; intuition. }
specialize (H _ N). simpl in H. rewrite E in H.
inversion_clear H; simpl in *; intuition.
Qed.

Lemma Injective_carac A B (l:list A) : Listing l ->
forall (f:A->B), Injective f <-> NoDup (map f l).
Proof. hammer_hook "FinFun" "FinFun.Injective_carac".
intros L f. split.
- intros Ij. apply Injective_map_NoDup; trivial. apply L.
- intros N x y E.
assert (X : In x l) by apply L.
assert (Y : In y l) by apply L.
apply In_nth_error in X. destruct X as (i,X).
apply In_nth_error in Y. destruct Y as (j,Y).
assert (X' := map_nth_error f _ _ X).
assert (Y' := map_nth_error f _ _ Y).
assert (i = j).
{ rewrite NoDup_nth_error in N. apply N.
- rewrite <- nth_error_Some. now rewrite X'.
- rewrite X', Y'. now f_equal. }
subst j. rewrite Y in X. now injection X.
Qed.

Lemma Surjective_list_carac A B (f:A->B):
Surjective f <-> (forall lB, exists lA, incl lB (map f lA)).
Proof. hammer_hook "FinFun" "FinFun.Surjective_list_carac".
split.
- intros Su.
induction lB as [|b lB IH].
+ now exists nil.
+ destruct (Su b) as (a,E).
destruct IH as (lA,IC).
exists (a::lA). simpl. rewrite E.
intros x [X|X]; simpl; intuition.
- intros H y.
destruct (H (y::nil)) as (lA,IC).
assert (IN : In y (map f lA)) by (apply (IC y); now left).
rewrite in_map_iff in IN. destruct IN as (x & E & _).
now exists x.
Qed.

Lemma Surjective_carac A B : Finite B -> decidable_eq B ->
forall f:A->B, Surjective f <-> (exists lA, Listing (map f lA)).
Proof. hammer_hook "FinFun" "FinFun.Surjective_carac".
intros (lB,FB) d. split.
- rewrite Surjective_list_carac.
intros Su. destruct (Su lB) as (lA,IC).
destruct (uniquify_map d f lA) as (lA' & N & IC').
exists lA'. split; trivial.
intro x. apply IC', IC, FB.
- intros (lA & N & FA) y.
generalize (FA y). rewrite in_map_iff. intros (x & E & _).
now exists x.
Qed.

Lemma Endo_Injective_Surjective :
forall A, Finite A -> decidable_eq A ->
forall f:A->A, Injective f <-> Surjective f.
Proof. hammer_hook "FinFun" "FinFun.Endo_Injective_Surjective".
intros A F d f. rewrite (Surjective_carac F d). split.
- apply (Finite_alt d) in F. destruct F as (l,L).
rewrite (Injective_carac L); intros.
exists l; split; trivial.
destruct L as (N,F).
assert (I : incl l (map f l)).
{ apply NoDup_length_incl; trivial.
- now rewrite map_length.
- intros x _. apply F. }
intros x. apply I, F.
- clear F d. intros (l,L).
assert (N : NoDup l). { apply (NoDup_map_inv f), L. }
assert (I : incl (map f l) l).
{ apply NoDup_length_incl; trivial.
- now rewrite map_length.
- intros x _. apply L. }
assert (L' : Listing l).
{ split; trivial.
intro x. apply I, L. }
apply (Injective_carac L'), L.
Qed.

Definition EqDec (A:Type) := forall x y:A, {x=y}+{x<>y}.

Lemma Finite_Empty_or_not A :
Finite A -> (A->False) \/ exists a:A,True.
Proof. hammer_hook "FinFun" "FinFun.Finite_Empty_or_not".
intros (l,F).
destruct l.
- left; exact F.
- right; now exists a.
Qed.

Lemma Surjective_inverse :
forall A B, Finite A -> EqDec B ->
forall f:A->B, Surjective f ->
exists g:B->A, forall x, f (g x) = x.
Proof. hammer_hook "FinFun" "FinFun.Surjective_inverse".
intros A B F d f Su.
destruct (Finite_Empty_or_not F) as [noA | (a,_)].
-
assert (noB : B -> False). { intros y. now destruct (Su y). }
exists (fun y => False_rect _ (noB y)).
intro y. destruct (noB y).
-
destruct F as (l,F).
set (h := fun x k => if d (f k) x then true else false).
set (get := fun o => match o with Some y => y | None => a end).
exists (fun x => get (List.find (h x) l)).
intros x.
case_eq (find (h x) l); simpl; clear get; [intros y H|intros H].
* apply find_some in H. destruct H as (_,H). unfold h in H.
now destruct (d (f y) x) in H.
* exfalso.
destruct (Su x) as (y & Y).
generalize (find_none _ l H y (F y)).
unfold h. now destruct (d (f y) x).
Qed.

Lemma Injective_Surjective_Bijective :
forall A B, Finite A -> EqDec B ->
forall f:A->B, Injective f -> Surjective f -> Bijective f.
Proof. hammer_hook "FinFun" "FinFun.Injective_Surjective_Bijective".
intros A B F d f Ij Su.
destruct (Surjective_inverse F d Su) as (g, E).
exists g. split; trivial.
intros y. apply Ij. now rewrite E.
Qed.

Lemma Fin_Finite n : Finite (Fin.t n).
Proof. hammer_hook "FinFun" "FinFun.Fin_Finite".
induction n.
- exists nil.
red;inversion a.
- destruct IHn as (l,Hl).
exists (Fin.F1 :: map Fin.FS l).
intros a. revert n a l Hl.
refine (@Fin.caseS _ _ _); intros.
+ now left.
+ right. now apply in_map.
Qed.

Definition bFun n (f:nat->nat) := forall x, x < n -> f x < n.

Definition bInjective n (f:nat->nat) :=
forall x y, x < n -> y < n -> f x = f y -> x = y.

Definition bSurjective n (f:nat->nat) :=
forall y, y < n -> exists x, x < n /\ f x = y.

Module Fin2Restrict.

Notation n2f := Fin.of_nat_lt.
Definition f2n {n} (x:Fin.t n) := proj1_sig (Fin.to_nat x).
Definition f2n_ok n (x:Fin.t n) : f2n x < n := proj2_sig (Fin.to_nat x).
Definition n2f_f2n : forall n x, n2f (f2n_ok x) = x := @Fin.of_nat_to_nat_inv.
Definition f2n_n2f x n h : f2n (n2f h) = x := f_equal (@proj1_sig _ _) (@Fin.to_nat_of_nat x n h).
Definition n2f_ext : forall x n h h', n2f h = n2f h' := @Fin.of_nat_ext.
Definition f2n_inj : forall n x y, f2n x = f2n y -> x = y := @Fin.to_nat_inj.

Definition extend n (f:Fin.t n -> Fin.t n) : (nat->nat) :=
fun x =>
match le_lt_dec n x with
| left _ => 0
| right h => f2n (f (n2f h))
end.

Definition restrict n (f:nat->nat)(hf : bFun n f) : (Fin.t n -> Fin.t n) :=
fun x => let (x',h) := Fin.to_nat x in n2f (hf _ h).

Ltac break_dec H :=
let H' := fresh "H" in
destruct le_lt_dec as [H'|H'];
[elim (Lt.le_not_lt _ _ H' H)
|try rewrite (n2f_ext H' H) in *; try clear H'].

Lemma extend_ok n f : bFun n (@extend n f).
Proof. hammer_hook "FinFun" "FinFun.Fin2Restrict.extend_ok".
intros x h. unfold extend. break_dec h. apply f2n_ok.
Qed.

Lemma extend_f2n n f (x:Fin.t n) : extend f (f2n x) = f2n (f x).
Proof. hammer_hook "FinFun" "FinFun.Fin2Restrict.extend_f2n".
generalize (n2f_f2n x). unfold extend, f2n, f2n_ok.
destruct (Fin.to_nat x) as (x',h); simpl.
break_dec h.
now intros ->.
Qed.

Lemma extend_n2f n f x (h:x<n) : n2f (extend_ok f h) = f (n2f h).
Proof. hammer_hook "FinFun" "FinFun.Fin2Restrict.extend_n2f".
generalize (extend_ok f h). unfold extend in *. break_dec h. intros h'.
rewrite <- n2f_f2n. now apply n2f_ext.
Qed.

Lemma restrict_f2n n f hf (x:Fin.t n) :
f2n (@restrict n f hf x) = f (f2n x).
Proof. hammer_hook "FinFun" "FinFun.Fin2Restrict.restrict_f2n".
unfold restrict, f2n. destruct (Fin.to_nat x) as (x',h); simpl.
apply f2n_n2f.
Qed.

Lemma restrict_n2f n f hf x (h:x<n) :
@restrict n f hf (n2f h) = n2f (hf _ h).
Proof. hammer_hook "FinFun" "FinFun.Fin2Restrict.restrict_n2f".
unfold restrict. generalize (f2n_n2f h). unfold f2n.
destruct (Fin.to_nat (n2f h)) as (x',h'); simpl. intros ->.
now apply n2f_ext.
Qed.

Lemma extend_surjective n f :
bSurjective n (@extend n f) <-> Surjective f.
Proof. hammer_hook "FinFun" "FinFun.Fin2Restrict.extend_surjective".
split.
- intros hf y.
destruct (hf _ (f2n_ok y)) as (x & h & Eq).
exists (n2f h).
apply f2n_inj. now rewrite <- Eq, <- extend_f2n, f2n_n2f.
- intros hf y hy.
destruct (hf (n2f hy)) as (x,Eq).
exists (f2n x).
split.
+ apply f2n_ok.
+ rewrite extend_f2n, Eq. apply f2n_n2f.
Qed.

Lemma extend_injective n f :
bInjective n (@extend n f) <-> Injective f.
Proof. hammer_hook "FinFun" "FinFun.Fin2Restrict.extend_injective".
split.
- intros hf x y Eq.
apply f2n_inj. apply hf; try apply f2n_ok.
now rewrite 2 extend_f2n, Eq.
- intros hf x y hx hy Eq.
rewrite <- (f2n_n2f hx), <- (f2n_n2f hy). f_equal.
apply hf.
rewrite <- 2 extend_n2f.
generalize (extend_ok f hx) (extend_ok f hy).
rewrite Eq. apply n2f_ext.
Qed.

Lemma restrict_surjective n f h :
Surjective (@restrict n f h) <-> bSurjective n f.
Proof. hammer_hook "FinFun" "FinFun.Fin2Restrict.restrict_surjective".
split.
- intros hf y hy.
destruct (hf (n2f hy)) as (x,Eq).
exists (f2n x).
split.
+ apply f2n_ok.
+ rewrite <- (restrict_f2n h), Eq. apply f2n_n2f.
- intros hf y.
destruct (hf _ (f2n_ok y)) as (x & hx & Eq).
exists (n2f hx).
apply f2n_inj. now rewrite restrict_f2n, f2n_n2f.
Qed.

Lemma restrict_injective n f h :
Injective (@restrict n f h) <-> bInjective n f.
Proof. hammer_hook "FinFun" "FinFun.Fin2Restrict.restrict_injective".
split.
- intros hf x y hx hy Eq.
rewrite <- (f2n_n2f hx), <- (f2n_n2f hy). f_equal.
apply hf.
rewrite 2 restrict_n2f.
generalize (h x hx) (h y hy).
rewrite Eq. apply n2f_ext.
- intros hf x y Eq.
apply f2n_inj. apply hf; try apply f2n_ok.
now rewrite <- 2 (restrict_f2n h), Eq.
Qed.

End Fin2Restrict.
Import Fin2Restrict.

Lemma bInjective_bSurjective n (f:nat->nat) :
bFun n f -> (bInjective n f <-> bSurjective n f).
Proof. hammer_hook "FinFun" "FinFun.bInjective_bSurjective".
intros h.
rewrite <- (restrict_injective h), <- (restrict_surjective h).
apply Endo_Injective_Surjective.
- apply Fin_Finite.
- intros x y. destruct (Fin.eq_dec x y); [left|right]; trivial.
Qed.

Lemma bSurjective_bBijective n (f:nat->nat) :
bFun n f -> bSurjective n f ->
exists g, bFun n g /\ forall x, x < n -> g (f x) = x /\ f (g x) = x.
Proof. hammer_hook "FinFun" "FinFun.bSurjective_bBijective".
intro hf.
rewrite <- (restrict_surjective hf). intros Su.
assert (Ij : Injective (restrict hf)).
{ apply Endo_Injective_Surjective; trivial.
- apply Fin_Finite.
- intros x y. destruct (Fin.eq_dec x y); [left|right]; trivial. }
assert (Bi : Bijective (restrict hf)).
{ apply Injective_Surjective_Bijective; trivial.
- apply Fin_Finite.
- exact Fin.eq_dec. }
destruct Bi as (g & Hg & Hg').
exists (extend g).
split.
- apply extend_ok.
- intros x Hx. split.
+ now rewrite <- (f2n_n2f Hx), <- (restrict_f2n hf), extend_f2n, Hg.
+ now rewrite <- (f2n_n2f Hx), extend_f2n, <- (restrict_f2n hf), Hg'.
Qed.


Require Import Coq.Program.Program Coq.Program.Equality.

Goal forall (H: forall n m : nat, n = m -> n = 0) x, x = tt.
intros.
dependent destruction x.
reflexivity.
Qed.

Variable A : Set.

Inductive vector : nat -> Type := vnil : vector 0 | vcons : A -> forall {n}, vector n -> vector (S n).

Goal forall n, forall v : vector (S n), vector n.
Proof.
  intros n H.
  dependent destruction H.
  assumption.
Qed.

Require Import ProofIrrelevance.

Goal forall n, forall v : vector (S n), exists v' : vector n, exists a : A, v = vcons a v'.
Proof.
  intros n v.
  dependent destruction v.
  exists v ; exists a.
  reflexivity.
Qed.

(* Extraction Unnamed_thm. *)

Inductive type : Type :=
| base : type
| arrow : type -> type -> type.

Notation " t --> t' " := (arrow t t') (at level 20, t' at next level).

Inductive ctx : Type :=
| empty : ctx
| snoc : ctx -> type -> ctx.

Bind Scope context_scope with ctx.
Delimit Scope context_scope with ctx.

Arguments snoc _%context_scope.

Notation " Γ , τ " := (snoc Γ τ) (at level 25, τ at next level, left associativity) : context_scope.

Fixpoint conc (Δ Γ : ctx) : ctx :=
  match Δ with
    | empty => Γ
    | snoc Δ' x => snoc (conc Δ' Γ) x
  end.

Notation " Γ  ; Δ " := (conc Δ Γ) (at level 25, left associativity) : context_scope.

Reserved Notation " Γ ⊢ τ " (at level 30, no associativity).

Generalizable All Variables.

Inductive term : ctx -> type -> Type :=
| ax : `(Γ, τ ⊢ τ)
| weak : `{Γ ⊢ τ -> Γ, τ' ⊢ τ}
| abs : `{Γ, τ ⊢ τ' -> Γ ⊢ τ --> τ'}
| app : `{Γ ⊢ τ --> τ' -> Γ ⊢ τ -> Γ ⊢ τ'}

where " Γ ⊢ τ " := (term Γ τ) : type_scope.

Hint Constructors term : lambda.

Local Open Scope context_scope.

Ltac eqns := subst ; reverse ; simplify_dep_elim ; simplify_IH_hyps.

Lemma weakening : forall Γ Δ τ, Γ ; Δ ⊢ τ ->
  forall τ', Γ , τ' ; Δ ⊢ τ.
Proof with simpl in * ; eqns ; eauto with lambda.
  intros Γ Δ τ H.

  dependent induction H.

  destruct Δ as [|Δ τ'']...

  destruct Δ as [|Δ τ'']...

  destruct Δ as [|Δ τ'']...
    apply abs.
    specialize (IHterm Γ (Δ, τ'', τ))...

  intro. eapply app...
Defined.

Lemma weakening_ctx : forall Γ Δ τ, Γ ; Δ ⊢ τ ->
  forall Δ', Γ ; Δ' ; Δ ⊢ τ.
Proof with simpl in * ; eqns ; eauto with lambda.
  intros Γ Δ τ H.

  dependent induction H.

  destruct Δ as [|Δ τ'']...
  induction Δ'...

  destruct Δ as [|Δ τ'']...
  induction Δ'...

  destruct Δ as [|Δ τ'']...
    apply abs.
    specialize (IHterm Γ (empty, τ))...

    apply abs.
    specialize (IHterm Γ (Δ, τ'', τ))...

  intro. eapply app...
Defined.

Lemma exchange : forall Γ Δ α β τ, term (Γ, α, β ; Δ) τ -> term (Γ, β, α ; Δ) τ.
Proof with simpl in * ; eqns ; eauto.
  intros until 1.
  dependent induction H.

  destruct Δ ; eqns.
    apply weak ; apply ax.

    apply ax.

  destruct Δ...
    pose (weakening Γ (empty, α))...

    apply weak...

  apply abs...
    specialize (IHterm Γ (Δ, τ))...

  eapply app...
Defined.

(** Example by Andrew Kenedy, uses simplification of the first component of dependent pairs. *)

Set Implicit Arguments.

Inductive Ty :=
 | Nat : Ty
 | Prod : Ty -> Ty -> Ty.

Inductive Exp : Ty -> Type :=
| Const : nat -> Exp Nat
| Pair : forall t1 t2, Exp t1 -> Exp t2 -> Exp (Prod t1 t2)
| Fst : forall t1 t2, Exp (Prod t1 t2) -> Exp t1.

Inductive Ev : forall t, Exp t -> Exp t -> Prop :=
| EvConst   : forall n, Ev (Const n) (Const n)
| EvPair    : forall t1 t2 (e1:Exp t1) (e2:Exp t2) e1' e2',
               Ev e1 e1' -> Ev e2 e2' -> Ev (Pair e1 e2) (Pair e1' e2')
| EvFst     : forall t1 t2 (e:Exp (Prod t1 t2)) e1 e2,
               Ev e (Pair e1 e2) ->
               Ev (Fst e) e1.

Lemma EvFst_inversion : forall t1 t2 (e:Exp (Prod t1 t2)) e1, Ev (Fst e) e1 -> exists e2, Ev e (Pair e1 e2).
intros t1 t2 e e1 ev. dependent destruction ev. exists e2 ; assumption.
Qed.


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

Require Setoid.

Section plus_minus_mult.

  Print nat.

  Check 1.

  Reserved Notation "a ⊕ b" (at level 50, left associativity).
  Reserved Notation "a ⊖ b" (at level 50, left associativity).
  Reserved Notation "a ⊗ b" (at level 40, left associativity).

  (* We redefine plus as myplus denote with ⊕ to
     avoid the conflicts with the Init module
     that contains parts of the Arith library

     Notice that we import the inductive definition of nat

   *)

  Print nat.

  Fixpoint myplus (a b : nat) { struct a } :=
    match a with
      | 0   => b
      | S a' => S (a' ⊕ b)
    end
  where "a ⊕ b" := (myplus a b).

  Print myplus.

  (* 0, 1, 2 is a notation of S (S ... O)
     in particular, 0 is identical to O
   *)

  Fact plus_0_l n : 0 ⊕ n = n.
  Proof.
    simpl.
    trivial.
  Qed.

  Fact plus_1_l n : 1 ⊕ n = S n.
  Proof.
    simpl.
    trivial.
  Qed.

  Fact plus_0_r n : n ⊕ 0 = n.
  Proof.
    simpl.
    induction n.
    + simpl; trivial.
    + simpl.
      f_equal.
      exact IHn.
  Qed.

  Fact plus_a_Sb a b : a ⊕ S b = S (a ⊕ b).
  Proof. (* induction a; simpl; f_equal; trivial. *)
    induction a as [ | a IHa ].
    + simpl; trivial.
    + simpl; f_equal; assumption.
  Qed.

  Hint Resolve plus_0_r plus_a_Sb : core.

  Fact plus_comm a b : a ⊕ b = b ⊕ a.
  Proof.
    induction a as [ | a IHa ].
    + simpl; trivial. (* using Hint plus_0_r *)
    + simpl.
      rewrite IHa.
      trivial.
  Qed.

  Fact plus_assoc a b c : (a ⊕ b) ⊕ c = a ⊕ (b ⊕ c).
  Proof. (* induction a; simpl; f_equal; trivial. *)
    induction a as [ | a IHa ].
    + simpl; trivial.
    + simpl; f_equal.
      trivial.
  Qed.

  Fixpoint myminus (a b : nat) { struct a } :=
    match a, b with
      | 0, _     => 0
      | S a, 0   => S a
      | S a, S b => a ⊖ b
    end
  where "a ⊖ b" := (myminus a b).

  Print myminus.

  Fact minus_0 a : a ⊖ 0 = a.
  Proof. (* induction a; simpl; trivial. *)
    induction a as [ | a IHa ].
    + simpl; trivial.
    + simpl; trivial.
  Qed.

  Hint Resolve minus_0 : core.

  Fact plus_minus a b : (a ⊕ b) ⊖ a = b.
  Proof.
    induction a as [ | a IHa ].
    + simpl; trivial.
    + simpl; trivial.
  Qed.

  Fact minus_diag a : a ⊖ a = 0.
  Proof.
    rewrite <- (plus_minus a 0).
    f_equal.
    trivial.
  Qed.

  Hint Resolve minus_diag : core.

  (* a ⊖ b ⊕ b <> a *)

  Eval compute in 1 ⊖ 3 ⊕ 3.

  Fact minus_plus_assoc a b c : a ⊖ b ⊖ c = a ⊖ (b ⊕ c).
  Proof.
    (* induction a as [ | a IHa ].
    + simpl; trivial.
    + simpl.
      destruct b; simpl.
      * trivial.
      *
      destruct c; auto. FAIL *)

  (*  revert b; induction a; simpl; trivial; intros []; simpl; trivial. *)
    revert b.
    induction a as [ | a IHa ].
    + intros b.
      simpl; trivial.
    + intros [ | b ].
      * simpl.
        trivial.
      * simpl.
        apply IHa.
  Qed.

  Fact minus_eq a b : a = b <-> (a ⊖ b = 0 /\ b ⊖ a = 0).
  Proof.
    split.
    + (* intros E; split; rewrite E, minus_diag; reflexivity. *)
      (* intros E; rewrite -> E; clear E. *)
      intros ->; auto.
    + intros [ H1 H2 ].
      revert a b H1 H2.
      induction a.
      * simpl.
        intros b.
        rewrite minus_0.
        auto.
      * simpl.
        intros [ | b ].
        - trivial.
        - simpl.
          intros.
          f_equal.
          apply IHa; trivial.
  Qed.

  Fact plus_cancel_l a b c : a ⊕ b = a ⊕ c -> b = c.
  Proof.
    intros E.
    apply f_equal with (f := fun x => x ⊖ a) in E.
    rewrite !plus_minus in E.
    trivial.
  Qed.

  Fact plus_cancel_r a b c : a ⊕ c = b ⊕ c -> a = b.
  Proof.
    rewrite !(plus_comm _ c).
    apply plus_cancel_l.
  Qed.

  Fact discriminate n : S n = O -> False.
  Proof.
    (* discriminate. *)
    intros H.
    set (f n := match n with 0 => False | S  _ => True end).
    change (f 0).
    rewrite <- H.
    simpl.
    trivial.
  Qed.

  Fact plus_eq_0 a b : a ⊕ b = 0 <-> a = 0 /\ b = 0.
  Proof.
    split.
    + destruct a.
      * simpl.
        intros ->; auto.
      * simpl.
        intros C.
        exfalso.
        discriminate.
    + intros (-> & ->).
      trivial.
  Qed.

  Fixpoint mymult a b :=
    match a with
      | 0   => 0
      | S a => b ⊕ a ⊗ b
    end
  where "a ⊗ b" := (mymult a b).

  Fact mult_0_l b : 0 ⊗ b = 0.
  Proof.
    reflexivity.
  Qed.

  Fact mult_0_r a : a ⊗ 0 = 0.
  Proof.
    induction a as [ | a IHa ].
    + trivial.
    + unfold mymult; fold mymult.
      simpl; trivial.
  Qed.

  Hint Resolve plus_comm mult_0_r : core.

  Fact mult_a_Sb a b : a ⊗ S b = a ⊕ a ⊗ b.
  Proof.
    induction a as [ | a IHa ].
    + simpl; trivial.
    + simpl.
      f_equal.
      rewrite IHa.
      (* generalize (a ⊗ b); intros c. *)
      Check plus_assoc.
      rewrite <- !plus_assoc.
      f_equal.
      apply plus_comm.
  Qed.

  Fact mult_comm a b : a ⊗ b = b ⊗ a.
  Proof.
    induction a as [ | a IHa ].
    + simpl; auto.
    + simpl.
      rewrite mult_a_Sb.
      f_equal; trivial.
  Qed.

  Fact plus_mult_distr_l a b c : (a ⊕ b) ⊗ c = a ⊗ c ⊕ b ⊗ c.
  Proof.
    induction a as [ | a IHa ]; simpl; trivial.
    rewrite IHa, plus_assoc; trivial.
  Qed.

  Hint Resolve plus_mult_distr_l : core.

  Fact plus_mult_distr_r a b c : c ⊗ (a ⊕ b)  = c ⊗ a ⊕ c ⊗ b.
  Proof.
  Admitted.

  Fact mult_assoc a b c : a ⊗ b ⊗ c = a ⊗ (b ⊗ c).
  Proof.
    induction a as [ | a IHa ]; simpl; trivial.
  Admitted.

  Fact mult_1_l a : 1 ⊗ a = a.
  Proof.
  Admitted.

  Hint Resolve mult_1_l : core.

  Fact mult_1_r a : a ⊗ 1 = a.
  Proof.
  Admitted.

  Hint Resolve mult_1_r : core.

  Fact mult_minus a b c : a ⊗ (b ⊖ c) = a ⊗ b ⊖ a ⊗ c.
  Proof.
    rewrite !(mult_comm a).
    revert c; induction b as [ | b IHb ]; intros c.
  Admitted.

  Fact mult_eq_0 a b : a ⊗ b = 0 <-> a = 0 \/ b = 0.
  Proof.
  Admitted.

  Fact mult_cancel_0 a b c : a ⊗ b = a ⊗ c -> a = 0 \/ b = c.
  Proof.
    intros E.
    rewrite minus_eq in E.
    rewrite <- !mult_minus in E.
    rewrite !mult_eq_0 in E.
    rewrite (minus_eq b c).
    destruct E as [ [] [] ]; auto.
  Qed.

  Fact mult_cancel_l a b c : S a ⊗ b = S a ⊗ c -> b = c.
  Proof.
    intros E.
    apply mult_cancel_0 in E.
    destruct E; trivial.
    discriminate.
  Qed.

  Fact mult_cancel_r a b c : a ⊗ S c = b ⊗ S c -> a = b.
  Proof.
    rewrite !(mult_comm _ (S _)).
    apply mult_cancel_l.
  Qed.

End plus_minus_mult.

Require Import Arith Lia Ring Omega. (* In day to day practice with nat, Z *)

Fact test (a b c : nat) : a <= b -> a+b <= b*3.
Proof. lia. Qed.


From Hammer Require Import Hammer.

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

Check nat_ind.

Theorem mult_0_r' : forall n:nat,
n * 0 = 0.
Proof. hammer_hook "IndPrinciples" "IndPrinciples.mult_0_r'".
apply nat_ind.
-  reflexivity.
-  simpl. intros n' IHn'. rewrite -> IHn'.
reflexivity.  Qed.

Theorem plus_one_r' : forall n:nat,
n + 1 = S n.
Proof. hammer_hook "IndPrinciples" "IndPrinciples.plus_one_r'".
Admitted.

Inductive yesno : Type :=
| yes
| no.

Check yesno_ind.

Inductive rgb : Type :=
| red
| green
| blue.
Check rgb_ind.

Inductive natlist : Type :=
| nnil
| ncons (n : nat) (l : natlist).

Check natlist_ind.

Inductive natlist1 : Type :=
| nnil1
| nsnoc1 (l : natlist1) (n : nat).

Inductive byntree : Type :=
| bempty
| bleaf (yn : yesno)
| nbranch (yn : yesno) (t1 t2 : byntree).

Inductive ExSet : Type :=

.

Inductive tree (X:Type) : Type :=
| leaf (x : X)
| node (t1 t2 : tree X).
Check tree_ind.

Inductive foo' (X:Type) : Type :=
| C1 (l : list X) (f : foo' X)
| C2.

Definition P_m0r (n:nat) : Prop :=
n * 0 = 0.

Definition P_m0r' : nat->Prop :=
fun n => n * 0 = 0.

Theorem mult_0_r'' : forall n:nat,
P_m0r n.
Proof. hammer_hook "IndPrinciples" "IndPrinciples.mult_0_r''".
apply nat_ind.
-  reflexivity.
-

intros n IHn.
unfold P_m0r in IHn. unfold P_m0r. simpl. apply IHn. Qed.

Theorem plus_assoc' : forall n m p : nat,
n + (m + p) = (n + m) + p.
Proof. hammer_hook "IndPrinciples" "IndPrinciples.plus_assoc'".

intros n m p.

induction n as [| n'].
-  reflexivity.
-

simpl. rewrite -> IHn'. reflexivity.  Qed.

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

Theorem plus_comm'' : forall n m : nat,
n + m = m + n.
Proof. hammer_hook "IndPrinciples" "IndPrinciples.plus_comm''".

induction m as [| m'].
-  simpl. rewrite <- plus_n_O. reflexivity.
-  simpl. rewrite <- IHm'.
rewrite <- plus_n_Sm. reflexivity.  Qed.

Check even_ind.

Theorem ev_ev' : forall n, even n -> even' n.
Proof. hammer_hook "IndPrinciples" "IndPrinciples.ev_ev'".
apply even_ind.
-
apply even'_0.
-
intros m Hm IH.
apply (even'_sum 2 m).
+ apply even'_2.
+ apply IH.
Qed.

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

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

Check le_ind.


(* Copyright (c) 2008-2012, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import Arith List.

Require Import Cpdt.CpdtTactics.

Set Implicit Arguments.
Set Asymmetric Patterns.
(* end hide *)

(** %\chapter{Dependent Data Structures}% *)

(** Our red-black tree example from the last chapter illustrated how dependent types enable static enforcement of data structure invariants.  To find interesting uses of dependent data structures, however, we need not look to the favorite examples of data structures and algorithms textbooks.  More basic examples like length-indexed and heterogeneous lists come up again and again as the building blocks of dependent programs.  There is a surprisingly large design space for this class of data structure, and we will spend this chapter exploring it. *)

Section ilist.
  Variable A : Set.

  Inductive ilist : nat -> Set :=
  | Nil : ilist 0
  | Cons : forall n, A -> ilist n -> ilist (S n).

  Inductive fin : nat -> Set :=
  | Find : forall n, fin (S n)
  | Next : forall n, fin n -> fin (S n).

  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
    | Nil =>
      fun f =>
        match f in (fin n') return (match n' with
                                    | 0 => A
                                    | _ => unit
                                    end) with
        | Find _ => tt
        | Next _ _ => tt
        end
    | Cons n1 x ls' =>
      fun f =>
        (match f in (fin n') return ((fin (pred n') -> A) -> A) with
         | Find _ => fun _ => x
         | Next _ f' => fun new_f => new_f f'
         end) (get ls')
    end.
End ilist.

Arguments Nil [A].
Arguments Find [n].

Check Cons 0 (Cons 1 (Cons 2 Nil)).

Eval simpl in get (Cons 0 (Cons 1 (Cons 2 Nil))) Find.
Eval simpl in get (Cons 0 (Cons 1 (Cons 2 Nil))) (Next Find).
Eval simpl in get (Cons 0 (Cons 1 (Cons 2 Nil))) (Next (Next Find)).

Section ilist_map.
  Variables A B : Set.

  Variable f : A -> B.

  Fixpoint ilist_map n (ls : ilist A n) : ilist B n :=
    match ls in (ilist _ n) return (ilist B n) with
    | Nil => Nil
    | Cons n x ls' => Cons (f x) (ilist_map ls')
    end.

  Theorem get_imap : forall n (ls : ilist A n) (fdx : fin n),
      get (ilist_map ls) fdx = f (get ls fdx).
    induction ls.
    -
      intros; simpl. inversion fdx.
    -
      simpl; intros; dep_destruct fdx.
      reflexivity. apply IHls.
  Qed.
End ilist_map.

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall x ls, B x -> hlist ls -> hlist (x :: ls).

  Variable elem : A.

  Inductive member : list A -> Type :=
  | HFirst : forall ls, member (elem :: ls)
  | HNext : forall x ls, member ls -> member (x :: ls).

  Fixpoint hget (ls : list A) (hls : hlist ls) : member ls -> B elem :=
    match hls with
    | HNil =>
      fun memb =>
        match memb in (member ls') return (match ls' with
                                           | nil => B elem
                                           | _ => unit
                                           end) with
        | HFirst _ => tt
        | _ => tt
        end
    | HCons _ _ val rem_ls =>
      fun memb =>
        (match memb in (member ls') return (match ls' with
                                            | nil => Empty_set
                                            | x' :: ls'' =>
                                              B x' -> (member ls'' -> B elem) -> B elem
                                            end) with
         | HFirst _ => fun x _ => x
         | HNext _ _ memb' => fun _ recur => recur memb'
         end) val (hget rem_ls)
    end.
End hlist.

Arguments HNil [A B].
Arguments HCons [A B x ls] _ _.

Arguments HFirst [A elem ls].
Arguments HNext [A elem x ls] _.

Definition someTypes : list Set := nat :: bool :: nil.

Example someValues : hlist (fun T : Set =>  T) someTypes :=
  HCons 5 (HCons true HNil).

Eval simpl in (hget someValues HFirst).

Eval simpl in (hget someValues (HNext HFirst)).

Example somePairs : hlist (fun T : Set => T * T)%type someTypes :=
  HCons (1, 2) (HCons (true, false) HNil).

(** ** A Lambda Calculus Interpreter *)

(** Heterogeneous lists are very useful in implementing %\index{interpreters}%interpreters for functional programming languages.  Using the types and operations we have already defined, it is trivial to write an interpreter for simply typed lambda calculus%\index{lambda calculus}%.  Our interpreter can alternatively be thought of as a denotational semantics (but worry not if you are not familiar with such terminology from semantics).

   We start with an algebraic datatype for types. *)

Inductive type : Set :=
| Unit : type
| Arrow : type -> type -> type.

(** Now we can define a type family for expressions.  An [exp ts t] will stand for an expression that has type [t] and whose free variables have types in the list [ts].  We effectively use the de Bruijn index variable representation%~\cite{DeBruijn}%.  Variables are represented as [member] values; that is, a variable is more or less a constructive proof that a particular type is found in the type environment. *)

Inductive exp : list type -> type -> Set :=
| Const : forall ts, exp ts Unit
(* begin thide *)
| Var : forall ts t, member t ts -> exp ts t
| App : forall ts dom ran, exp ts (Arrow dom ran) -> exp ts dom -> exp ts ran
| Abs : forall ts dom ran, exp (dom :: ts) ran -> exp ts (Arrow dom ran).
(* end thide *)

Arguments Const [ts].

(** We write a simple recursive function to translate [type]s into [Set]s. *)

Fixpoint typeDenote (t : type) : Set :=
  match t with
    | Unit => unit
    | Arrow t1 t2 => typeDenote t1 -> typeDenote t2
  end.

(** Now it is straightforward to write an expression interpreter.  The type of the function, [expDenote], tells us that we translate expressions into functions from properly typed environments to final values.  An environment for a free variable list [ts] is simply an [hlist typeDenote ts].  That is, for each free variable, the heterogeneous list that is the environment must have a value of the variable's associated type.  We use [hget] to implement the [Var] case, and we use [HCons] to extend the environment in the [Abs] case. *)

(* EX: Define an interpreter for [exp]s. *)

(* begin thide *)
Fixpoint expDenote ts t (e : exp ts t) : hlist typeDenote ts -> typeDenote t :=
  match e with
    | Const _ => fun _ => tt

    | Var _ _ mem => fun s => hget s mem
    | App _ _ _ e1 e2 => fun s => (expDenote e1 s) (expDenote e2 s)
    | Abs _ _ _ e' => fun s => fun x => expDenote e' (HCons x s)
  end.

(** Like for previous examples, our interpreter is easy to run with [simpl]. *)

Eval simpl in expDenote Const HNil.
(** %\vspace{-.15in}% [[
    = tt
     : typeDenote Unit
]]
*)

Eval simpl in expDenote (Abs (dom := Unit) (Var HFirst)) HNil.
(** %\vspace{-.15in}% [[
     = fun x : unit => x
     : typeDenote (Arrow Unit Unit)
]]
*)

Eval simpl in expDenote (Abs (dom := Unit)
  (Abs (dom := Unit) (Var (HNext HFirst)))) HNil.
(** %\vspace{-.15in}% [[
     = fun x _ : unit => x
     : typeDenote (Arrow Unit (Arrow Unit Unit))
]]
*)

Eval simpl in expDenote (Abs (dom := Unit) (Abs (dom := Unit) (Var HFirst))) HNil.
(** %\vspace{-.15in}% [[
     = fun _ x0 : unit => x0
     : typeDenote (Arrow Unit (Arrow Unit Unit))
]]
*)

Eval simpl in expDenote (App (Abs (Var HFirst)) Const) HNil.
(** %\vspace{-.15in}% [[
     = tt
     : typeDenote Unit
]]
*)

(* end thide *)

(** We are starting to develop the tools behind dependent typing's amazing advantage over alternative approaches in several important areas.  Here, we have implemented complete syntax, typing rules, and evaluation semantics for simply typed lambda calculus without even needing to define a syntactic substitution operation.  We did it all without a single line of proof, and our implementation is manifestly executable.  Other, more common approaches to language formalization often state and prove explicit theorems about type safety of languages.  In the above example, we got type safety, termination, and other meta-theorems for free, by reduction to CIC, which we know has those properties. *)

(** * Recursive Type Definitions *)

(** %\index{recursive type definition}%There is another style of datatype definition that leads to much simpler definitions of the [get] and [hget] definitions above.  Because Coq supports "type-level computation," we can redo our inductive definitions as _recursive_ definitions.  Here we will preface type names with the letter [f] to indicate that they are based on explicit recursive _function_ definitions. *)

(* EX: Come up with an alternate [ilist] definition that makes it easier to write [get]. *)

Section filist.
  Variable A : Set.

  Fixpoint filist (n : nat) : Set :=
    match n with
    | O => unit
    | S n' => A * (filist n')
    end %type.

  Fixpoint ffin (n : nat) : Set :=
    match n with
    | O => Empty_set
    | S n' => option (ffin n')
    end %type.

  Fixpoint fget (n : nat) : filist n -> ffin n -> A :=
    match n with
    | O => fun _ fdx => match fdx with end
    | S n' =>
      fun ls fdx =>
        match fdx with
        | Some fdx' => fget n' (snd ls) fdx'
        | None => fst ls
        end
    end.
End filist.

(** Heterogeneous lists are a little trickier to define with recursion, but we then reap similar benefits in simplicity of use. *)

(* EX: Come up with an alternate [hlist] definition that makes it easier to write [hget]. *)

Section fhlist.
  Variable A : Type.
  Variable B : A -> Type.

  Fixpoint fhlist (ls : list A) : Type :=
    match ls with
    | nil => unit
    | x :: ls' => (B x) * (fhlist ls')
    end.

  Variable elem : A.

  Fixpoint fmember (ls : list A) : Type :=
    match ls with
    | nil => Empty_set
    | x :: ls' => (x = elem) + (fmember ls')
    end.

  Fixpoint fhget (ls : list A) : fhlist ls -> fmember ls -> B elem :=
    match ls with
    | nil => fun _ fdx => match fdx with end
    | x :: ls' =>
      fun fls fdx =>
        match fdx with
        | inl eqp => match eqp with
                     | eq_refl => fst fls
                     end
        | inr fdx' => fhget ls' (snd fls) fdx'
        end
    end.
End fhlist.

Arguments fhget [A B elem ls] _ _.

(** How does one choose between the two data structure encoding strategies we have presented so far?  Before answering that question in this chapter's final section, we introduce one further approach. *)

(** * Data Structures as Index Functions *)

(** %\index{index function}%Indexed lists can be useful in defining other inductive types with constructors that take variable numbers of arguments.  In this section, we consider parameterized trees with arbitrary branching factor. *)

(* begin hide *)
Definition red_herring := O.
(* working around a bug in Coq 8.5! *)
(* end hide *)

Section tree.
  Variable A : Set.

  Inductive tree : Set :=
  | Leaf : A -> tree
  | Node : forall n, ilist tree n -> tree.
End tree.

(** Every [Node] of a [tree] has a natural number argument, which gives the number of child trees in the second argument, typed with [ilist].  We can define two operations on trees of naturals: summing their elements and incrementing their elements.  It is useful to define a generic fold function on [ilist]s first. *)

Section ifoldr.
  Variables A B : Set.
  Variable f : A -> B -> B.
  Variable i : B.

  Fixpoint ifoldr n (ls : ilist A n) : B :=
    match ls with
      | Nil => i
      | Cons _ x ls' => f x (ifoldr ls')
    end.
End ifoldr.

Fixpoint sum (t : tree nat) : nat :=
  match t with
    | Leaf n => n
    | Node _ ls => ifoldr (fun t' n => sum t' + n) O ls
  end.

Fixpoint inc (t : tree nat) : tree nat :=
  match t with
    | Leaf n => Leaf (S n)
    | Node _ ls => Node (imap inc ls)
  end.

(** Now we might like to prove that [inc] does not decrease a tree's [sum]. *)

Theorem sum_inc : forall t, sum (inc t) >= sum t.
(* begin thide *)
  induction t; crush.
  (** [[
  n : nat
  i : ilist (tree nat) n
  ============================
   ifoldr (fun (t' : tree nat) (n0 : nat) => sum t' + n0) 0 (imap inc i) >=
   ifoldr (fun (t' : tree nat) (n0 : nat) => sum t' + n0) 0 i

   ]]

   We are left with a single subgoal which does not seem provable directly.  This is the same problem that we met in Chapter 3 with other %\index{nested inductive type}%nested inductive types. *)

  Check tree_ind.
  (** %\vspace{-.15in}% [[
  tree_ind
     : forall (A : Set) (P : tree A -> Prop),
       (forall a : A, P (Leaf a)) ->
       (forall (n : nat) (i : ilist (tree A) n), P (Node i)) ->
       forall t : tree A, P t
]]

The automatically generated induction principle is too weak.  For the [Node] case, it gives us no inductive hypothesis.  We could write our own induction principle, as we did in Chapter 3, but there is an easier way, if we are willing to alter the definition of [tree]. *)

Abort.

Reset tree.
(* begin hide *)
Reset red_herring.
(* working around a bug in Coq 8.5! *)
(* end hide *)

(** First, let us try using our recursive definition of [ilist]s instead of the inductive version. *)

Section tree.
  Variable A : Set.

  (** %\vspace{-.15in}% [[
  Inductive tree : Set :=
  | Leaf : A -> tree
  | Node : forall n, filist tree n -> tree.
]]

<<
Error: Non strictly positive occurrence of "tree" in
 "forall n : nat, filist tree n -> tree"
>>

  The special-case rule for nested datatypes only works with nested uses of other inductive types, which could be replaced with uses of new mutually inductive types.  We defined [filist] recursively, so it may not be used in nested inductive definitions.

  Our final solution uses yet another of the inductive definition techniques introduced in Chapter 3, %\index{reflexive inductive type}%reflexive types.  Instead of merely using [fin] to get elements out of [ilist], we can _define_ [ilist] in terms of [fin].  For the reasons outlined above, it turns out to be easier to work with [ffin] in place of [fin]. *)

  Inductive tree : Set :=
  | Leaf : A -> tree
  | Node : forall n, (ffin n -> tree) -> tree.

  (** A [Node] is indexed by a natural number [n], and the node's [n] children are represented as a function from [ffin n] to trees, which is isomorphic to the [ilist]-based representation that we used above. *)

End tree.

Arguments Node [A n] _.

(** We can redefine [sum] and [inc] for our new [tree] type.  Again, it is useful to define a generic fold function first.  This time, it takes in a function whose domain is some [ffin] type, and it folds another function over the results of calling the first function at every possible [ffin] value. *)

Section rifoldr.
  Variables A B : Set.
  Variable f : A -> B -> B.
  Variable i : B.

  Fixpoint rifoldr (n : nat) : (ffin n -> A) -> B :=
    match n with
      | O => fun _ => i
      | S n' => fun get => f (get None) (rifoldr n' (fun idx => get (Some idx)))
    end.
End rifoldr.

Arguments rifoldr [A B] f i [n] _.

Fixpoint sum (t : tree nat) : nat :=
  match t with
    | Leaf n => n
    | Node _ f => rifoldr plus O (fun idx => sum (f idx))
  end.

Fixpoint inc (t : tree nat) : tree nat :=
  match t with
    | Leaf n => Leaf (S n)
    | Node _ f => Node (fun idx => inc (f idx))
  end.

(** Now we are ready to prove the theorem where we got stuck before.  We will not need to define any new induction principle, but it _will_ be helpful to prove some lemmas. *)

Lemma plus_ge : forall x1 y1 x2 y2,
  x1 >= x2
  -> y1 >= y2
  -> x1 + y1 >= x2 + y2.
  crush.
Qed.

Lemma sum_inc' : forall n (f1 f2 : ffin n -> nat),
  (forall idx, f1 idx >= f2 idx)
  -> rifoldr plus O f1 >= rifoldr plus O f2.
  Hint Resolve plus_ge.

  induction n; crush.
Qed.

Theorem sum_inc : forall t, sum (inc t) >= sum t.
  Hint Resolve sum_inc'.

  induction t; crush.
Qed.

(* end thide *)

(** Even if Coq would generate complete induction principles automatically for nested inductive definitions like the one we started with, there would still be advantages to using this style of reflexive encoding.  We see one of those advantages in the definition of [inc], where we did not need to use any kind of auxiliary function.  In general, reflexive encodings often admit direct implementations of operations that would require recursion if performed with more traditional inductive data structures. *)

(** ** Another Interpreter Example *)

(** We develop another example of variable-arity constructors, in the form of optimization of a small expression language with a construct like Scheme's <<cond>>.  Each of our conditional expressions takes a list of pairs of boolean tests and bodies.  The value of the conditional comes from the body of the first test in the list to evaluate to [true].  To simplify the %\index{interpreters}%interpreter we will write, we force each conditional to include a final, default case. *)

Inductive type' : Type := Nat | Bool.

Inductive exp' : type' -> Type :=
| NConst : nat -> exp' Nat
| Plus : exp' Nat -> exp' Nat -> exp' Nat
| Eq : exp' Nat -> exp' Nat -> exp' Bool

| BConst : bool -> exp' Bool
(* begin thide *)
| Cond : forall n t, (ffin n -> exp' Bool)
  -> (ffin n -> exp' t) -> exp' t -> exp' t.
(* end thide *)

(** A [Cond] is parameterized by a natural [n], which tells us how many cases this conditional has.  The test expressions are represented with a function of type [ffin n -> exp' Bool], and the bodies are represented with a function of type [ffin n -> exp' t], where [t] is the overall type.  The final [exp' t] argument is the default case.  For example, here is an expression that successively checks whether [2 + 2 = 5] (returning 0 if so) or if [1 + 1 = 2] (returning 1 if so), returning 2 otherwise. *)

Example ex1 := Cond 2
  (fun f => match f with
              | None => Eq (Plus (NConst 2) (NConst 2)) (NConst 5)
              | Some None => Eq (Plus (NConst 1) (NConst 1)) (NConst 2)
              | Some (Some v) => match v with end
            end)
  (fun f => match f with
              | None => NConst 0
              | Some None => NConst 1
              | Some (Some v) => match v with end
            end)
  (NConst 2).

(** We start implementing our interpreter with a standard type denotation function. *)

Definition type'Denote (t : type') : Set :=
  match t with
    | Nat => nat
    | Bool => bool
  end.

(** To implement the expression interpreter, it is useful to have the following function that implements the functionality of [Cond] without involving any syntax. *)

(* begin thide *)
Section cond.
  Variable A : Set.
  Variable default : A.

  Fixpoint cond (n : nat) : (ffin n -> bool) -> (ffin n -> A) -> A :=
    match n with
      | O => fun _ _ => default
      | S n' => fun tests bodies =>
        if tests None
          then bodies None
          else cond n'
            (fun idx => tests (Some idx))
            (fun idx => bodies (Some idx))
    end.
End cond.

Arguments cond [A] default [n] _ _.
(* end thide *)

(** Now the expression interpreter is straightforward to write. *)

(* begin thide *)
Fixpoint exp'Denote t (e : exp' t) : type'Denote t :=
  match e with
    | NConst n => n
    | Plus e1 e2 => exp'Denote e1 + exp'Denote e2
    | Eq e1 e2 =>
      if eq_nat_dec (exp'Denote e1) (exp'Denote e2) then true else false

    | BConst b => b
    | Cond _ _ tests bodies default =>
      cond
      (exp'Denote default)
      (fun idx => exp'Denote (tests idx))
      (fun idx => exp'Denote (bodies idx))
  end.
(* begin hide *)
Reset exp'Denote.
(* end hide *)
(* end thide *)

(* begin hide *)
Fixpoint exp'Denote t (e : exp' t) : type'Denote t :=
  match e with
    | NConst n => n
    | Plus e1 e2 => exp'Denote e1 + exp'Denote e2
    | Eq e1 e2 =>
      if eq_nat_dec (exp'Denote e1) (exp'Denote e2) then true else false

    | BConst b => b
    | Cond _ _ tests bodies default =>
(* begin thide *)
      cond
      (exp'Denote default)
      (fun idx => exp'Denote (tests idx))
      (fun idx => exp'Denote (bodies idx))
(* end thide *)
  end.
(* end hide *)

(** We will implement a constant-folding function that optimizes conditionals, removing cases with known-[false] tests and cases that come after known-[true] tests.  A function [cfoldCond] implements the heart of this logic.  The convoy pattern is used again near the end of the implementation. *)

(* begin thide *)
Section cfoldCond.
  Variable t : type'.
  Variable default : exp' t.

  Fixpoint cfoldCond (n : nat)
    : (ffin n -> exp' Bool) -> (ffin n -> exp' t) -> exp' t :=
    match n with
      | O => fun _ _ => default
      | S n' => fun tests bodies =>
        match tests None return _ with
          | BConst true => bodies None
          | BConst false => cfoldCond n'
            (fun idx => tests (Some idx))
            (fun idx => bodies (Some idx))
          | _ =>
            let e := cfoldCond n'
              (fun idx => tests (Some idx))
              (fun idx => bodies (Some idx)) in
            match e in exp' t return exp' t -> exp' t with
              | Cond n _ tests' bodies' default' => fun body =>
                Cond
                (S n)
                (fun idx => match idx with
                              | None => tests None
                              | Some idx => tests' idx
                            end)
                (fun idx => match idx with
                              | None => body
                              | Some idx => bodies' idx
                            end)
                default'
              | e => fun body =>
                Cond
                1
                (fun _ => tests None)
                (fun _ => body)
                e
            end (bodies None)
        end
    end.
End cfoldCond.

Arguments cfoldCond [t] default [n] _ _.
(* end thide *)

(** Like for the interpreters, most of the action was in this helper function, and [cfold] itself is easy to write. *)

(* begin thide *)
Fixpoint cfold t (e : exp' t) : exp' t :=
  match e with
    | NConst n => NConst n
    | Plus e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' return exp' Nat with
        | NConst n1, NConst n2 => NConst (n1 + n2)
        | _, _ => Plus e1' e2'
      end
    | Eq e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' return exp' Bool with
        | NConst n1, NConst n2 => BConst (if eq_nat_dec n1 n2 then true else false)
        | _, _ => Eq e1' e2'
      end

    | BConst b => BConst b
    | Cond _ _ tests bodies default =>
      cfoldCond
      (cfold default)
      (fun idx => cfold (tests idx))
      (fun idx => cfold (bodies idx))
  end.
(* end thide *)

(* begin thide *)
(** To prove our final correctness theorem, it is useful to know that [cfoldCond] preserves expression meanings.  The following lemma formalizes that property.  The proof is a standard mostly automated one, with the only wrinkle being a guided instantiation of the quantifiers in the induction hypothesis. *)

Lemma cfoldCond_correct : forall t (default : exp' t)
  n (tests : ffin n -> exp' Bool) (bodies : ffin n -> exp' t),
  exp'Denote (cfoldCond default tests bodies)
  = exp'Denote (Cond n tests bodies default).
  induction n; crush;
    match goal with
      | [ IHn : forall tests bodies, _, tests : _ -> _, bodies : _ -> _ |- _ ] =>
        specialize (IHn (fun idx => tests (Some idx)) (fun idx => bodies (Some idx)))
    end;
    repeat (match goal with
              | [ |- context[match ?E with NConst _ => _ | _ => _ end] ] =>
                dep_destruct E
              | [ |- context[if ?B then _ else _] ] => destruct B
            end; crush).
Qed.

(** It is also useful to know that the result of a call to [cond] is not changed by substituting new tests and bodies functions, so long as the new functions have the same input-output behavior as the old.  It turns out that, in Coq, it is not possible to prove in general that functions related in this way are equal.  We treat this issue with our discussion of axioms in a later chapter.  For now, it suffices to prove that the particular function [cond] is _extensional_; that is, it is unaffected by substitution of functions with input-output equivalents. *)

Lemma cond_ext : forall (A : Set) (default : A) n (tests tests' : ffin n -> bool)
  (bodies bodies' : ffin n -> A),
  (forall idx, tests idx = tests' idx)
  -> (forall idx, bodies idx = bodies' idx)
  -> cond default tests bodies
  = cond default tests' bodies'.
  induction n; crush;
    match goal with
      | [ |- context[if ?E then _ else _] ] => destruct E
    end; crush.
Qed.

(** Now the final theorem is easy to prove. *)
(* end thide *)

Theorem cfold_correct : forall t (e : exp' t),
  exp'Denote (cfold e) = exp'Denote e.
(* begin thide *)
  Hint Rewrite cfoldCond_correct.
  Hint Resolve cond_ext.

  induction e; crush;
    repeat (match goal with
              | [ |- context[cfold ?E] ] => dep_destruct (cfold E)
            end; crush).
Qed.
(* end thide *)

(** We add our two lemmas as hints and perform standard automation with pattern-matching of subterms to destruct. *)

(** * Choosing Between Representations *)

(** It is not always clear which of these representation techniques to apply in a particular situation, but I will try to summarize the pros and cons of each.

   Inductive types are often the most pleasant to work with, after someone has spent the time implementing some basic library functions for them, using fancy [match] annotations.  Many aspects of Coq's logic and tactic support are specialized to deal with inductive types, and you may miss out if you use alternate encodings.

   Recursive types usually involve much less initial effort, but they can be less convenient to use with proof automation.  For instance, the [simpl] tactic (which is among the ingredients in [crush]) will sometimes be overzealous in simplifying uses of functions over recursive types.  Consider a call [get l f], where variable [l] has type [filist A (S n)].  The type of [l] would be simplified to an explicit pair type.  In a proof involving many recursive types, this kind of unhelpful "simplification" can lead to rapid bloat in the sizes of subgoals.  Even worse, it can prevent syntactic pattern-matching, like in cases where [filist] is expected but a pair type is found in the "simplified" version.  The same problem applies to applications of recursive functions to values in recursive types: the recursive function call may "simplify" when the top-level structure of the type index but not the recursive value is known, because such functions are generally defined by recursion on the index, not the value.

   Another disadvantage of recursive types is that they only apply to type families whose indices determine their "skeletons."  This is not true for all data structures; a good counterexample comes from the richly typed programming language syntax types we have used several times so far.  The fact that a piece of syntax has type [Nat] tells us nothing about the tree structure of that syntax.

   Finally, Coq type inference can be more helpful in constructing values in inductive types.  Application of a particular constructor of that type tells Coq what to expect from the arguments, while, for instance, forming a generic pair does not make clear an intention to interpret the value as belonging to a particular recursive type.  This downside can be mitigated to an extent by writing "constructor" functions for a recursive type, mirroring the definition of the corresponding inductive type.

   Reflexive encodings of data types are seen relatively rarely.  As our examples demonstrated, manipulating index values manually can lead to hard-to-read code.  A normal inductive type is generally easier to work with, once someone has gone through the trouble of implementing an induction principle manually with the techniques we studied in Chapter 3.  For small developments, avoiding that kind of coding can justify the use of reflexive data structures.  There are also some useful instances of %\index{co-inductive types}%co-inductive definitions with nested data structures (e.g., lists of values in the co-inductive type) that can only be deconstructed effectively with reflexive encoding of the nested structures. *)


Require Import Ltac.
(*Definitions of Logical Constants in Propect Calculus.*)
Notation "x '->' y" := (forall (_ : x), y) (at level 99, right associativity, y at level 200).
Definition False : Prop := forall x:Prop, x.
Notation "⊥" := False.
Definition not : Prop -> Prop := fun P:Prop => P->⊥.
Notation "¬ x" := (not x) (at level 75, right associativity).
Definition and : Prop->Prop->Prop := fun P Q:Prop => forall x:Prop, (P -> Q -> x) -> x.
Notation "x ∧ y" := (and x y) (at level 80, right associativity).
Theorem and_intro : forall (P Q : Prop), P -> Q -> P ∧ Q.
Proof fun _ _ p q _ f => f p q.
Notation "'andi'" := (and_intro _ _).
Theorem and_elim1 : forall (P Q:Prop) (f:P∧Q), P.
Proof fun P Q:Prop => fun f:P∧Q => f P (fun p:P => fun q:Q => p).
Notation "'ande1'" := (and_elim1 _ _).
Theorem and_elim2 : forall (P Q:Prop) (f:P∧Q), Q.
Proof fun P Q:Prop => fun f:P∧Q => f Q (fun p:P => fun q:Q => q).
Notation "'ande2'" := (and_elim2 _ _).
Definition or : Prop->Prop->Prop := fun P Q:Prop => forall x:Prop, (P->x)->(Q->x)->x.
Notation "x ∨ y" := (or x y) (at level 85, right associativity).
Theorem or_intro1 : forall P Q:Prop, P->P∨Q.
Proof fun P Q:Prop => fun p:P => fun x:Prop => fun f:P->x => fun g:Q->x => f p.
Notation "'ori1'" := (or_intro1 _ _).
Theorem or_intro2 : forall P Q:Prop, Q->P∨Q.
Proof fun P Q:Prop => fun q:Q => fun x:Prop => fun f:P->x => fun g:Q->x => g q.
Notation "'ori2'" := (or_intro2 _ _).
Definition iff : Prop->Prop->Prop := fun P Q:Prop => (P->Q)∧(Q->P).
Notation "x ⇔ y" := (iff x y) (at level 95, right associativity).
Theorem iff_intro : forall P Q:Prop, (P->Q)->(Q->P)->P⇔Q.
Proof fun P Q:Prop => fun f:P->Q => fun g:Q->P => andi f g.
Notation "'iffi'" := (iff_intro _ _).
Theorem iff_elim1 : forall P Q:Prop, P⇔Q->P->Q.
Proof fun P Q:Prop => fun f:P⇔Q => fun p:P => (ande1 f) p.
Notation "'iffe1'" := (iff_elim1 _ _).
Theorem iff_elim2 : forall P Q:Prop, P⇔Q->Q->P.
Proof fun P Q:Prop => fun f:P⇔Q => fun q:Q => (ande2 f) q.
Notation "'iffe2'" := (iff_elim2 _ _).
Definition eq (T:Type) : T->T->Prop := fun x y:T => forall P:T->Prop, P x->P y.
Notation "x = y" := (eq _ x y) (at level 70).
Notation "x ≠ y" := (¬ x = y) (at level 70).
Theorem eq_intro (T:Type) : forall x:T, x=x.
Proof fun (x:T) (P:T->Prop) (f:P x) => f.
Notation "'eqi'" := (eq_intro _).
Definition ex (T:Type) (P:T->Prop) : Prop := forall x:Prop, (forall t:T, P t->x)->x.
Notation "'∃' t ':' T ',' p" := (ex T (fun t:T => p))  (at level 200, t name, right associativity).
Theorem ex_intro (T:Type) (P:T->Prop) : forall t:T, P t->∃t:T, P t.
Proof fun t:T => fun p: P t => fun x:Prop => fun f:(forall t:T, P t->x) => f t p.
Notation "'exi'" := (ex_intro _ _).
Theorem ex_elim (T:Type) (P:T->Prop) (Q:T->Prop) : (∃t:T, P t)->(forall t:T, P t->Q t)->∃t:T, Q t.
Proof fun f:∃t:T, P t => fun g: forall t:T, P t->Q t => f (∃t:T, Q t) (fun t:T => fun h:P t => ex_intro _ _ _ (g t h)).
Notation "'exe'" := (ex_elim _ _ _).
Definition exu (T:Type) (P:T->Prop) : Prop := (∃t:T, P t)∧forall t0 t1:T, P t0->P t1->t0=t1.
Notation "'∃!' t ':' T ',' p" := (exu T (fun t:T => p))  (at level 200, t name, right associativity).
Theorem exu_intro (T:Type) (P:T->Prop) : (∃t:T, P t)->(forall t0 t1:T, P t0->P t1->t0=t1)->∃!t:T, P t.
Proof fun (h:∃t:T, P t) (h1:forall t0 t1:T, P t0->P t1->t0=t1) => andi h h1.
Notation "'exui'" := (exu_intro _ _).
Theorem exu_elim1 (T:Type) (P:T->Prop) : (∃!t:T, P t)->∃t:T, P t.
Proof fun h:∃!t:T, P t => ande1 h.
Notation "'exue1'" := (exu_elim1 _ _).
Theorem exu_elim2 (T:Type) (P:T->Prop) : (∃!t:T, P t)->forall t0 t1:T, P t0->P t1->t0=t1.
Proof fun h:∃!t:T, P t => ande2 h.
Notation "'exue2'" := (exu_elim2 _ _).
Parameter hilberts_epsilon : forall (T:Type) (P:T->Prop), (∃t:T, P t)->T.
Notation "'eps' x" := (hilberts_epsilon _ _ x) (at level 100).
Axiom definition : forall (T:Type) (P:T->Prop) (p:∃t:T, P t), P (eps p).
Notation "'def' x" := (definition _ _ x) (at level 100).