Require Export Poly.

Theorem silly1:
  forall (n m o p : nat),
    n = m -> [n;o] = [n;p] -> [m;o] = [m;p].
Proof.
  intros n m o p.
  intros eq1.
  intros eq2.
  rewrite <- eq1.
  apply eq2.
Qed.

Theorem silly2:
  forall (n m o p : nat),
    n = m ->
    (forall (q r :nat), q = r -> [q;o] = [r;p]) ->
    [n;o] = [m;p].
Proof.
  intros m n o p.
  intros eq1.
  intros eq2.
  apply eq2.
  apply eq1.
Qed.

Theorem silly2a:
  forall n m : nat,
    (n,n) = (m,m) ->
    (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
    [n] = [m].
Proof.
  intros n m.
  intros eq1 eq2.
  apply eq2.
  apply eq1.
Qed.

Theorem silly_ex:
  (forall n, evenb n = true -> oddb (S n) = true) ->
  evenb 3 = true ->
  oddb 4 = true.
Proof.
  intros eq1.
  intros eq2.
  apply eq1.
  apply eq2.
Qed.

Theorem silly3_firsttry:
  forall (n : nat),
    true = beq_nat n 5 -> beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  simpl.
  (* Here we cannot use apply directly *)
Abort.

Theorem silly3_firsttry:
  forall (n : nat),
    true = beq_nat n 5 -> beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  symmetry.
  simpl.
  apply H.
Qed.

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

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

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

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

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

Theorem eq_add_S:
  forall n m : nat,
    S n = S m -> n = m.
Proof.
  intros n m.
  intros eq.
  inversion eq.
  reflexivity.
Qed.

Theorem silly4:
  forall n m : nat,
    [n] = [m] -> n = m.
Proof.
  intros n m.
  intros H.
  inversion H.
  reflexivity.
Qed.

Theorem silly5:
  forall n m o : nat,
    [n;m] = [o;o] -> [n] = [m].
Proof.
  intros n m o.
  intros H.
  inversion H.
  reflexivity.
Qed.

Theorem sillyex1:
  forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = z :: j ->
    y :: l = x :: j ->
    x = y.
Proof.
  intros X x y z l j.
  intros eq1 eq2.
  inversion eq2.
  reflexivity.
Qed.

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

Theorem silly7:
  forall n m : nat,
    false = true -> [n] = [m].
Proof.
  intros n m H.
  inversion H.
Qed.

Example sillyex2:
  forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] ->
    y :: l = z :: j ->
    x = z.
Proof.
  intros X x y z l j.
  intros eq1 eq2.
  inversion eq1.
Qed.

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

Theorem beq_nat_0_l:
  forall n,
    beq_nat 0 n = true -> n = 0.
Proof.
  intros n H.
  induction n as [| n'].
  reflexivity.
  inversion H.
Qed.

Theorem beq_nat_0_r:
  forall n,
    beq_nat n 0 = true -> n = 0.
Proof.
  intros n H.
  induction n as [| n'].
  reflexivity.
  inversion H.
Qed.

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

Theorem silly3':
  forall n : nat,
    (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
    true = beq_nat n 5 ->
    true = beq_nat (S (S n)) 7.
Proof.
  intros n.
  intros eq1 eq2.
  symmetry in eq2.
  apply eq1 in eq2.
  symmetry in eq2.
  apply eq2.
Qed.

Theorem plus_n_n_O:
  forall n,
    n + n = 0 -> n = 0.
Proof.
  intros n.
  induction n as [| n'].
  simpl. reflexivity.
  intros H.
  inversion H.
Qed.

Theorem plus_n_n_injective:
  forall n m,
    n + n = m + m -> n = m.
Proof.
  intros n.
  induction n as [| n'].
  Case "n' = O".
    simpl.
    intros m H.
    symmetry in H.
    apply plus_n_n_O in H.
    symmetry.
    apply H.
  Case "n' = S n'".
    intros m.
    destruct m.
      SCase "m = O".
      intros H.
      inversion H.
      SCase "m = S m".
      simpl.
      intros H.
      inversion H.
      rewrite <- plus_n_Sm in H1.
      rewrite <- plus_n_Sm in H1.
      inversion H1.
      apply IHn' in H2.
      rewrite -> H2.
      reflexivity.
Qed.

Theorem double_injective:
  forall n m,
    double n = double m -> n = m.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = O".
    simpl.
    intros m H.
    destruct m as [| m'].
    SCase "m = O".
      reflexivity.
    SCase "m = S m'".
      inversion H.
  Case "n = S n'".
    intros m H.
    destruct m as [| m'].
      SCase "m = O".
        inversion H.
      SCase "m = S m'".
        apply f_equal.
        apply IHn'.
        inversion H.
        reflexivity.
Qed.

Theorem beq_nat_true:
  forall n m,
    beq_nat n m = true -> n = m.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = O".
    intros m H.
    destruct m as [| m'].
    SCase "m = O".
      reflexivity.
    SCase "m = S m'".
      inversion H.
  Case "n = S n'".
    intros m H.
    destruct m as [| m'].
    SCase "m = O".
      inversion H.
    SCase "m = S m'".
      apply f_equal.
      apply IHn'.
      inversion H.
      reflexivity.
Qed.

Theorem double_injective_take2_FAILED:
  forall n m,
     double n = double m -> n = m.
Proof.
  intros n m. induction m as [| m'].
  Case "m = O". simpl. intros eq. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". inversion eq.
  Case "m = S m'". intros eq. destruct n as [| n'].
    SCase "n = O". inversion eq.
    SCase "n = S n'". apply f_equal.
        (* Stuck again here, just like before. *)
Abort.

Theorem double_injective_take2:
  forall n m,
    double n = double m -> n = m.
Proof.
  intros n m.
  generalize dependent n.
  induction m as [| m'].
  Case "m = O".
    intros n H.
    destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". inversion H.
  Case "m = S m'".
    intros n H.
    destruct n as [| n'].
    SCase "n = O". inversion H.
    SCase "n = S n'".
      apply f_equal.
      apply IHm'.
      inversion H.
      reflexivity.
Qed.

Theorem length_snoc':
  forall (X : Type) (v : X) (l : list X) (n : nat),
    length l = n -> length (snoc l v) = S n.
Proof.
  intros X v l.
  induction l as [| v' l'].
  Case "l = []".
    intros n H.
    rewrite <- H.
    reflexivity.
  Case "l = v' :: l'".
    intros n H.
    simpl.
    destruct n as [| n'].
    SCase "n = O".
      inversion H.
    SCase "n = S n'".
      apply f_equal.
      apply IHl'.
      inversion H.
      reflexivity.
Qed.

Theorem index_after_last:
  forall (n : nat) (X : Type) (l : list X),
    length l = n -> index n l = None.
Proof.
  intros n X l.
  generalize dependent n.
  induction l as [| v' l'].
  Case "l = []".
    intros n H.
    simpl. reflexivity.
  Case "l = v' :: l'".
    intros n H.
    destruct n.
    SCase "n = O".
      inversion H.
    SCase "n = S n".
      simpl.
      apply IHl'.
      inversion H.
      reflexivity.
Qed.

Theorem length_snoc''':
  forall (n : nat) (X : Type) (v : X) (l : list X),
    length l = n -> length (snoc l v) = S n.
Proof.
  intros n X v l.
  generalize dependent n.
  induction l as [| v' l'].
  Case "l = []".
    intros n H.
    simpl.
    destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'".
      inversion H.
  Case "l = v' :: l'".
    intros n H.
    simpl.
    destruct n as [| n'].
    SCase "n = O".
      inversion H.
    SCase "n = S n'".
      apply f_equal.
      apply IHl'.
      inversion H.
      reflexivity.
Qed.

Theorem app_length_cons:
  forall (X : Type) (l1 l2 : list X) (x : X) (n : nat),
    length (l1 ++ (x :: l2)) = n ->
    S (length (l1 ++ l2)) = n.
Proof.
  intros X l1 l2 x.
  induction l1 as [| v' l1'].
  Case "l1 = []".
    intros n H.
    destruct n as [| n'].
    SCase "n' = O".
      inversion H.
    SCase "n' = S n'".
      simpl in H.
      simpl.
      apply H.
  Case "l1 = v' :: l1'".
    intros n H.
    destruct n as [| n'].
    SCase "n' = O".
      inversion H.
    SCase "n' = S n'".
      simpl.
      apply f_equal.
      apply IHl1'.
      inversion H.
      reflexivity.
Qed.

Theorem length_app:
  forall (X : Type) (v : X) (l1 l2 : list X),
    length (l1 ++ v :: l2) = S (length (l1 ++ l2)).
Proof.
  intros X v l1 l2.
  induction l1 as [| v' l1'].
  Case "l1 = []".
    simpl. reflexivity.
  Case "l1 = v' :: l1'".
    simpl.
    apply f_equal.
    apply IHl1'.
Qed.

Theorem app_length_twice:
  forall (X : Type) (n : nat) (l : list X),
    length l = n -> length (l ++ l) = n + n.
Proof.
  intros X n l.
  generalize dependent n.
  induction l as [| v' l'].
  Case "l = []".
    intros n H.
    destruct n as [| n'].
    SCase "n = O".
      simpl. reflexivity.
    SCase "n = S n'".
      inversion H.
  Case "l = v' :: l'".
    intros n H.
    destruct n as [| n'].
    SCase "n = O".
      inversion H.
    SCase "n = S n'".
      simpl.
      rewrite -> length_app.
      apply f_equal.
      inversion H.
      rewrite -> H1.
      apply IHl' in H1.
      rewrite -> H1.
      rewrite -> plus_n_Sm.
      reflexivity.
Qed.

Theorem double_induction:
  forall (P : nat -> nat -> Prop),
    P 0 0 ->
    (forall m, P m 0 -> P (S m) 0) ->
    (forall n, P 0 n -> P 0 (S n)) ->
    (forall m n, P m n -> P (S m) (S n)) ->
    forall m n, P m n.
Proof.
  intros P eq1 eq2 eq3 eq4 m.
  induction m as [| m'].
  Case "m = O".
    intros n.
    induction n as [| n'].
    SCase "n = O".
      apply eq1.
    SCase "n = S n'".
      apply eq3.
      apply IHn'.
  Case "m = S m'".
    intros n.
    induction n as [| n'].
    SCase "n = O".
      apply eq2.
      apply IHm'.
    SCase "n = S n'".
      apply eq4.
      apply IHm'.
Qed.

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

Theorem sillyfun_false:
  forall n : nat,
    sillyfun n = false.
Proof.
  intros n.
  unfold sillyfun.
  destruct (beq_nat n 3).
  Case "beq_nat n 3 = true".
    reflexivity.
  Case "beq_nat n 3 = false".
    destruct (beq_nat n 5).
      SCase "beq_nat n 5 = true".
        reflexivity.
      SCase "beq_nat n 5 = false".
        reflexivity.
Qed.

Theorem override_shadow:
  forall (X : Type) x1 x2 k1 k2 (f : nat -> X),
    (override (override f k1 x2) k1 x1) k2 = (override f k1 x1) k2.
Proof.
  intros X x1 x2 k1 k2 f.
  unfold override.
  destruct (beq_nat k1 k2).
  Case "beq_nat k1 k2 = true".
    reflexivity.
  Case "beq_nat k1 k2 = false".
    reflexivity.
Qed.

Theorem combine_split:
  forall X Y (l : list (X * Y)) l1 l2,
    split l = (l1, l2) -> combine l1 l2 = l.
Proof.
  intros X Y l.
  induction l as [| [x y] l'].
  Case "l = []".
    intros l1 l2 H.
    inversion H.
    reflexivity.
  Case "l = v' :: l'".
    intros l1 l2 H.
    simpl in H.
    destruct (split l') as [lx ly].
    SCase "split l' = (lx,ly)".
      inversion H.
      simpl.
      rewrite -> IHl'.
      reflexivity.
      reflexivity.
Qed.

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

Theorem sillyfun1_odd_FAILED:
  forall n : nat,
    sillyfun1 n = true ->
    oddb n = true.
Proof.
  intros n H.
  unfold sillyfun1 in H.
  destruct (beq_nat n 3).
Abort.

Theorem sillyfun1_odd:
  forall n : nat,
    sillyfun1 n = true ->
    oddb n = true.
Proof.
  intros n eq.
  unfold sillyfun1 in eq.
  destruct (beq_nat n 3) eqn:Heqe3.
    Case "e3 = true".
      apply beq_nat_true in Heqe3.
      rewrite -> Heqe3.
      reflexivity.
    Case "e3 = false".
      destruct (beq_nat n 5) eqn:Heqe5.
      SCase "e5 = true".
        apply beq_nat_true in Heqe5.
        rewrite -> Heqe5.
        reflexivity.
      SCase "e5 = false".
        inversion eq.
Qed.

Theorem bool_fn_applied_thrice:
  forall (f : bool -> bool) (b : bool),
    f (f (f b)) = f b.
Proof.
  intros f b.
  destruct (f b) eqn:H.
  Case "f b = true".
    destruct b.
    SCase "b = true".
      rewrite -> H.
      symmetry.
      rewrite -> H.
      reflexivity.
    SCase "b = false".
      destruct (f true) eqn:H'.
        rewrite -> H'.
        reflexivity.

        rewrite -> H.
        reflexivity.
  Case "f b = false".
    destruct b.
    SCase "b = true".
      destruct (f false) eqn:H'.
        symmetry.
        rewrite -> H.
        reflexivity.

        rewrite -> H'.
        reflexivity.
    SCase "b = false".
      destruct (f false) eqn:H'.
        inversion H.

        rewrite -> H'.
        reflexivity.
Qed.

Theorem override_same:
  forall (X : Type) x1 k1 k2 (f : nat -> X),
    f k1 = x1 -> (override f k1 x1) k2 = f k2.
Proof.
  intros X x1 k1 k2 f H.
  unfold override.
  destruct (beq_nat k1 k2) eqn:eq.
    apply beq_nat_true in eq.
    rewrite eq in H.
    rewrite -> H.
    reflexivity.
    reflexivity.
Qed.

Theorem beq_nat_sym:
  forall n m : nat,
    beq_nat n m = beq_nat m n.
Proof.
  intros n m.
  destruct (beq_nat n m) eqn:H.
  Case "beq_nat n m = true".
    inversion H.
    apply beq_nat_true in H.
    rewrite -> H.
    reflexivity.
  Case "beq_nat n m = false".
    destruct n.
    SCase "n = O".
      destruct m.
      SSCase "m = O".
        inversion H.
      SSCase "m = S m".
        simpl. reflexivity.
    SCase "n = S n".
      destruct m.
      SSCase "m = O".
        simpl. reflexivity.
      SSCase "m = S m".
Abort.

Theorem beq_nat_sym:
  forall n m : nat,
    beq_nat n m = beq_nat m n.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = O".
    intros m.
    destruct m.
      reflexivity.
      reflexivity.
  Case "n = S n".
    intros m.
    destruct m.
      reflexivity.
      simpl.
      rewrite -> IHn'.
      reflexivity.
Qed.


(* Hand is defined inductively *)
Inductive Hand : Set := Gu | Tyoki | Pa.

(* Check type of Hand *)
Check Hand.

(* Show definitions *)
Print Hand.
Print Hand_ind.

(* Function definition *)
Inductive win : Hand -> Hand -> Prop :=
| gu_win_tyoki : win Gu Tyoki
| tyoki_win_pa : win Tyoki Pa
| pa_win_gu : win Pa Gu.

Hint Constructors win.
(* Winning hand *)
Definition winning_hand(s:Hand) : { a | win a s }.
Proof.
induction s.
 exists Pa. apply pa_win_gu.
 exists Gu. auto.
 exists Tyoki; auto.
Defined.

(* Result = hand & proof *)
Eval compute in (winning_hand Gu).
(* Hand *)
Eval compute in (proj1_sig (winning_hand Gu)).
(* Proof *)
Eval compute in (proj2_sig (winning_hand Gu)).
(* Extract as OCaml program *)
Extraction winning_hand.

(* Winning hand is unique *)
Theorem winning_hand_unique : forall a b c,
  win a c -> win b c -> a = b.
Proof.
intros a b c Hac Hbc. induction c.
 inversion Hac. inversion Hbc. reflexivity.
 inversion Hac. inversion Hbc. auto.
 inversion Hac; inversion Hbc; auto.
Qed.

(* Import List module *)
Require Import List.

(* Show definition of list type *)
Print list.

(* Sample of list *)
Check (1::2::nil).

Check list_ind.

(* Define append function *)
Fixpoint append{A:Type}(xs ys:list A):=
match xs with
| nil => ys
| x::xs' => x::(append xs' ys)
end.

(* Evaluation *)
Eval compute in (append (1::2::nil) (3::4::nil)).

(* Definition of nat *)
Print nat.
Print plus.

(* Write your length function *)
Fixpoint len{A:Type}(xs:list A):nat :=
match xs with
| nil => 0
| _::xs' => S (len xs')
end.

(* Should be 3 *)
Eval compute in (len (1::2::3::nil)).

Theorem len_append: forall (A:Type)(xs ys:list A),
  len (append xs ys) = plus (len xs) (len ys).
Proof.
intro A.
induction xs.
 simpl.
 intro ys. auto.

 intro ys. simpl.
 erewrite IHxs.
 auto.
Qed.

Fixpoint reverse{A:Type}(xs:list A):list A :=
match xs with
| nil => nil
| x::xs' => append (reverse xs') (x::nil)
end.

(* Evaluate *)
Eval compute in (reverse (1::2::3::nil)).
(* reverse twice *)
Eval compute in (reverse (reverse (1::2::3::nil))).

Lemma append_right_nil: forall (A:Type)(xs:list A),
  append xs nil = xs.
Proof.
induction xs.
 auto.
 simpl. erewrite IHxs. auto.
Qed.

Lemma append_append : forall (A:Type)(xs ys zs:list A),
  append (append xs ys) zs = append xs (append ys zs).
Proof.
induction xs.
 simpl. intros; auto.

 simpl. intros. erewrite IHxs. auto.
Qed.

Lemma reverse_append : forall (A:Type)(xs ys:list A),
  reverse (append xs ys) = append (reverse ys) (reverse xs).
Proof.
induction xs.
 simpl. intro.
 erewrite append_right_nil. auto.

 simpl. intro ys.
 erewrite IHxs.
 erewrite append_append.
 auto.
Qed.

Theorem reverse_reverse: forall (A:Type)(xs:list A),
  reverse (reverse xs) = xs.
Proof.
induction xs.
 simpl. auto.
 simpl. erewrite reverse_append. erewrite IHxs.
 simpl. auto.
Qed.

Fixpoint rev2{A:Type}(xs ys:list A):list A :=
match xs with
| nil => ys
| x::xs' => rev2 xs' (x::ys)
end.

Lemma app_r_head: forall (A: Type)(a: A)(xs ys: list A),
  append xs (a :: ys) = append (append xs (a :: nil)) ys.
Proof.
  intros A a.
  induction xs.
    intro ys.
    simpl.
    reflexivity.

    intro ys.
    simpl.
    rewrite IHxs.
    reflexivity.
Qed.

Lemma rev2_app: forall (A: Type)(xs ys: list A),
  append (rev2 xs nil) ys = rev2 xs ys.
Proof.
  induction xs.
    simpl.
    intro ys.
    reflexivity.

    intro ys.
    simpl.
    rewrite <- (IHxs (a::ys)).
    rewrite <- (IHxs (a::nil)).
    rewrite <- app_r_head.
    reflexivity.
Qed.

Theorem rev_eq_rev2: forall (A: Type)(xs: list A),
  reverse xs = rev2 xs nil.
Proof.
  intro A.
  induction xs.
    simpl.
    reflexivity.

    simpl.
    erewrite IHxs.
    rewrite rev2_app.
    reflexivity.
Qed.


Require Import Bool Arith List CpdtTactics.
Set Implicit Arguments.

(*
Set Asymetric Patterns. (* no impact before Coq version 8.5 *)
*)

Inductive binop : Set := Plus | Times.

Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.

(*
Definition binopDenote (b : binop) : nat -> nat -> nat :=
  match b with
  | Plus => plus
  | Times => mult
  end.
*)

(*
Definition binopDenote : binop -> nat -> nat -> nat := fun (b : binop) =>
  match b with
  | Plus => plus
  | Times => mult
  end.
*)

Definition binopDenote := fun b =>
  match b with
    | Plus => plus
    | Times => mult
  end.

Fixpoint expDenote (e : exp) : nat :=
  match e with
    | Const n => n
    | Binop b e1 e2 => (binopDenote b) (expDenote e1 ) (expDenote e2 )
  end.

Definition exp1 : exp := Const 42.
Definition exp2 : exp := Binop Plus (Const 2) (Const 2).
Definition exp3 : exp := Binop Times exp2 (Const 7).

(*
Eval simpl in expDenote exp1.
Eval simpl in expDenote exp2.
Eval simpl in expDenote exp3.
*)

(*
Eval simpl in expDenote(Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7)).
*)

Inductive instr : Set :=
| iConst : nat -> instr
| iBinop : binop -> instr.

Definition prog := list instr.
Definition stack := list nat.

Definition instrDenote (i : instr) (s : stack) : option stack :=
  match i with
    | iConst n => Some (n :: s)
    | iBinop b =>
      match s with
        | arg1 :: arg2 :: s' => Some ((binopDenote b) arg1 arg2 :: s')
        | _ => None
      end
  end.

Fixpoint progDenote (p : prog) (s : stack) : option stack :=
  match p with
    | nil     => Some s
    | i :: p' =>
      match instrDenote i s with
        | None    => None
        | Some s' => progDenote p' s'
      end
    end.

Fixpoint compile (e : exp) : prog :=
  match e with
    | Const n       => iConst n :: nil
    | Binop b e1 e2 => compile e2 ++ compile e1 ++ iBinop b :: nil
  end.

(*
Eval simpl in compile exp1. (* Const 42 *)
Eval simpl in compile exp2. (* Binop Plus (Const 2) (Const 2) *)
Eval simpl in compile exp3. (* Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7) *)
*)

Definition prog1 : prog := compile exp1.
Definition prog2 : prog := compile exp2.
Definition prog3 : prog := compile exp3.

(*
Eval simpl in progDenote prog1 nil.
Eval simpl in progDenote prog2 nil.
Eval simpl in progDenote prog3 nil.
*)

Theorem compile_correct : forall e,
  progDenote (compile e) nil = Some (expDenote e :: nil).

Abort.

Lemma compile_correct' : forall e p s,
  progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).

  induction e.
  intros.
  unfold compile.
  unfold expDenote.
  unfold progDenote at 1.
  simpl.
  fold progDenote.
  reflexivity.

  intros.
  unfold compile.
  fold compile.
  unfold expDenote.
  fold expDenote.
(*
Check app_assoc_reverse.
Check app_assoc.
SearchRewrite((_++_)++_).
*)
  rewrite app_assoc_reverse.
  rewrite IHe2.
  rewrite app_assoc_reverse.
  rewrite IHe1.
  unfold progDenote at 1.
  simpl.
  fold progDenote.
  reflexivity.

Abort.

Lemma compile_correct' : forall e p s,
  progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).

  induction e; crush.
Qed.

Theorem compile_correct : forall e,
  progDenote (compile e) nil = Some (expDenote e :: nil).

  intros.

(*
Check app_nil_end.
*)
  rewrite (app_nil_end(compile e)).
  rewrite compile_correct'.
  unfold progDenote. (* actually this is optional, as reflexivity will check *)
  reflexivity.
Qed.

Inductive type : Set := Nat | Bool.

Inductive tbinop : type -> type -> type -> Set :=
| TPlus : tbinop Nat Nat Nat
| TTimes : tbinop Nat Nat Nat
| TEq : forall t, tbinop t t Bool
| TLt : tbinop Nat Nat Bool.

Inductive texp : type -> Set :=
| TNConst : nat -> texp Nat
| TBConst : bool -> texp Bool
| TBinop : forall t1 t2 t, tbinop t1 t2 t -> texp t1 -> texp t2 -> texp t.

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

Definition tbinopDenote arg1 arg2 res (b : tbinop arg1 arg2 res)
  : typeDenote arg1 -> typeDenote arg2 -> typeDenote res :=
  match b with
    | TPlus => plus
    | TTimes => mult
    | TEq Nat => beq_nat
    | TEq Bool => eqb
    | TLt => leb
  end.

Fixpoint texpDenote t (e : texp t) : typeDenote t :=
  match e with
    | TNConst n => n
    | TBConst b => b
    | TBinop _ _ _ b e1 e2 => (tbinopDenote b) (texpDenote e1) (texpDenote e2)
  end.

Definition texp1: texp Nat  := TNConst 42.
Definition texp2: texp Bool := TBConst false.
Definition texp3: texp Bool := TBConst true.
Definition texp_2p2         := TBinop TPlus (TNConst 2) (TNConst 2).
Definition texp_7           := TNConst 7.
Definition texp4: texp Nat  := TBinop TTimes texp_2p2 texp_7.
Definition texp5: texp Bool := TBinop (TEq Nat) texp_2p2 texp_7.
Definition texp6: texp Bool := TBinop TLt texp_2p2 texp_7.

(*
Eval simpl in texpDenote texp1.
Eval simpl in texpDenote texp2.
Eval simpl in texpDenote texp3.
Eval simpl in texpDenote texp4.
Eval simpl in texpDenote texp5.
Eval simpl in texpDenote texp6.
*)

Definition tstack := list type.

Inductive tinstr : tstack -> tstack -> Set :=
| TiNConst : forall s, nat -> tinstr s (Nat :: s)
| TiBConst : forall s, bool -> tinstr s (Bool :: s)
| TiBinop : forall arg1 arg2 res s, tbinop arg1 arg2 res
  -> tinstr (arg1 :: arg2 :: s) (res :: s).

Inductive tprog : tstack -> tstack -> Set :=
| TNil : forall s, tprog s s
| TCons : forall s1 s2 s3,
  tinstr s1 s2 -> tprog s2 s3 -> tprog s1 s3.

Fixpoint vstack (ts : tstack) : Set :=
  match ts with
    | nil => unit
    | t :: ts' => typeDenote t * vstack ts'
  end%type.

Definition tinstrDenote ts ts' (i : tinstr ts ts') : vstack ts -> vstack ts' :=
  match i with
    | TiNConst _ n => fun s => (n, s)
    | TiBConst _ b => fun s => (b, s)
    | TiBinop _ _ _ _ b => fun s =>
      let '(arg1, (arg2, s')) := s in
        ((tbinopDenote b) arg1 arg2, s')
  end.

Fixpoint tprogDenote ts ts' (p : tprog ts ts') : vstack ts -> vstack ts' :=
  match p with
    | TNil _ => fun s => s
    | TCons _ _ _ i p' => fun s => tprogDenote p' (tinstrDenote i s)
  end.

Fixpoint tconcat ts ts' ts''(p : tprog ts ts') : tprog ts' ts'' -> tprog ts ts'' :=
  match p with
    | TNil _ => fun p' => p'
    | TCons _ _ _ i p1 => fun p' => TCons i (tconcat p1 p')
  end.

Fixpoint tcompile t (e : texp t) (ts : tstack) : tprog ts (t :: ts) :=
  match e with
    | TNConst n => TCons (TiNConst _ n) (TNil _)
    | TBConst b => TCons (TiBConst _ b) (TNil _)
    | TBinop _ _ _ b e1 e2 => tconcat (tcompile e2 _)
      (tconcat (tcompile e1 _) (TCons (TiBinop _ b) (TNil _)))
  end.

(*
Print tcompile.

Eval simpl in tprogDenote (tcompile texp1 nil) tt.
Eval simpl in tprogDenote (tcompile texp2 nil) tt.
Eval simpl in tprogDenote (tcompile texp3 nil) tt.
Eval simpl in tprogDenote (tcompile texp4 nil) tt.
Eval simpl in tprogDenote (tcompile texp5 nil) tt.
Eval simpl in tprogDenote (tcompile texp6 nil) tt.
*)

Theorem tcompile_correct : forall t (e : texp t),
  tprogDenote (tcompile e nil) tt = (texpDenote e, tt).

Abort.

Lemma tcompile_correct' :
  forall (t : type) (e : texp t) (ts : tstack) (s : vstack ts),
    tprogDenote (tcompile e ts) s = (texpDenote e, s).

  induction e; crush.

Abort.

Lemma tconcat_correct :
  forall ts ts' ts'' (p : tprog ts ts') (p' : tprog ts' ts'') (s : vstack ts),
  tprogDenote (tconcat p p') s = tprogDenote p' (tprogDenote p s).

  induction p; crush.
Qed.

Hint Rewrite tconcat_correct.

Lemma tcompile_correct' : forall t (e : texp t) ts (s : vstack ts),
  tprogDenote (tcompile e ts) s = (texpDenote e, s).

  induction e; crush.
Qed.

Extraction tcompile.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(* Jean-Francois.Monin@lannion.cnet.fr                                      *)
(* December 1994, Coq V5.10                                                 *)
(*                                                                          *)
(****************************************************************************)
(*                                  tree.v                                  *)
(****************************************************************************)

Inductive tree : Set :=
  | leaf : nat -> tree
  | node : tree -> tree -> tree.

Section func_pred.

Variable bin : nat -> nat -> nat.

Fixpoint ext_morph (t : tree) : nat :=
  match t return nat with
  | leaf n => n
  | node t1 t2 => bin (ext_morph t1) (ext_morph t2)
  end.

Inductive Pext_morph : tree -> nat -> Prop :=
  | Pl : forall n : nat, Pext_morph (leaf n) n
  | Pn :
      forall (t1 t2 : tree) (n1 n2 : nat),
      Pext_morph t1 n1 ->
      Pext_morph t2 n2 -> Pext_morph (node t1 t2) (bin n1 n2).
Hint Resolve Pl Pn.

Theorem Pem_em : forall t : tree, Pext_morph t (ext_morph t).
simple induction t; simpl in |- *; auto.
Qed.

Theorem em_eq_Pem :
 forall (t : tree) (n : nat), n = ext_morph t -> Pext_morph t n.
intros t n Heq; rewrite Heq; apply Pem_em.
Qed.

Theorem Pem_em_eq :
 forall (t : tree) (n : nat), Pext_morph t n -> n = ext_morph t.
simple induction 1.
   auto.
   intros t1 t2 n1 n2 HPem1 Heq1 HPem2 Heq2.
      rewrite Heq1; rewrite Heq2; auto.
Qed.

End func_pred.

(* ============================== *)


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

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

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

Module Type VARIABLES.

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

Parameter var : Set.

(** This type is inhabited. *)

Parameter var_default : var.

(** Variables are ordered. *)

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

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

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

Definition vars := VarSet.S.t.

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

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

(** Variables can be enumerated *)

Parameter var_of_Z : Z -> var.
Parameter Z_of_var : var -> Z.

End VARIABLES.

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

Module Variables : VARIABLES.

Local Open Scope Z_scope.

Definition var := Z.

Definition var_default : var := 0.

Definition var_of_Z x : var := x.
Definition Z_of_var x : Z := x.

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

Module Import VarSet : FinSet with Module E := Var_as_OT :=
  Lib_FinSetImpl.Make Var_as_OT.

Local Open Scope set_scope.

Definition vars := VarSet.S.t.

Lemma max_lt_l :
  forall (x y z : Z), x <= y -> x <= Z.max y z.
Proof.
  intros.
  apply (Z.le_trans _ _ _ H).
  apply Z.le_max_l.
Qed.

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

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

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

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

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

End Variables.

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

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

Open Scope set_scope.

(** Equality on variables is decidable. *)

Module Import Var_as_OT_Facts := OrderedTypeFacts Variables.Var_as_OT.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(** Demo of pick_fresh_gen *)

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

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

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

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

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

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

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

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

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

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


(* Software Foundations *)
(* Exercice 2 stars, list_design *)

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

Notation "[]" := nil.
Notation " x :: l" := (cons x l).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Fixpoint append(l1 l2: natlist): natlist :=
match l1 with
|nil        => l2
|cons h1 t1 => h1 :: (append t1 l2)
end.

Notation "l1 ++ l2" := (append l1 l2).

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

(* Write down a non-trivial theorem involving cons (::), snoc, and app (++).
Prove it *)

Theorem list_design: forall (l1 l2: natlist)(v: nat),
  l1 ++ (cons v l2) = (snoc l1 v) ++ l2.
Proof.
    intros. induction l1 as [|h1 t1].
    simpl. reflexivity.
    simpl. rewrite IHt1. reflexivity.
Qed.


Section Vector.
  Variable A : Type.
  Variable f : A -> bool.

  Inductive Vec : nat -> Type :=
  | nil : Vec 0
  | cons : forall {n}, A -> Vec n -> Vec (S n).

  Notation "[]" := nil.
  Notation "a :: l" := (cons a l).

  Fixpoint append {n m : nat} (v : Vec n) (v0 : Vec m) : Vec (n + m) :=
    match v with
      | [] => v0
      | a::v' => a::(append v' v0)
    end.

  Fixpoint filter_length {n} (v : Vec n) : nat :=
    match v with
      | [] => O
      | a::v' =>
        if f a then S (filter_length v') else filter_length v'
    end.

  Fixpoint filter {n} (v : Vec n) : Vec (filter_length v) :=
    match v as v0 return Vec (filter_length v0)
    with
      | [] => []
      | a::v' =>
        if f a as b return Vec (if b then S (filter_length v')
                                else filter_length v')
        then a::(filter v')
        else filter v'
    end.
End Vector.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (lf2 : natural) (lf1 : natural) : natural :=
  plus y (Succ lf2).


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

(* ** Reification for bounded quantification *)

Require Import Arith Lia.

Set Implicit Arguments.

(* A nat indexed finite number of conjunctions *)

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

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

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

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

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

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

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

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

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

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

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

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

*)

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

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


(* Lemma cons_inj  :
forall x1 x2 :Type, forall l1 l2 : list Type,
 cons x1 l1 = cons x2 l2 -> x1=x2 /\ l1=l2.
Proof.
	intros.
	injection H.
	split.
	apply H1.
	apply H0.
Qed. *)

Parameter A:Type.

Definition tl (l: list A) : list A :=
	match l with
	nil => nil
	|cons _ t => t
	end
.

Definition hd (v:A) (l: list A) : A :=
	match l with
	nil =>  v
	|cons h t => h
	end
.

Lemma cons_inj  :
forall x1 x2 :A, forall l1 l2 : list A,
 cons x1 l1 = cons x2 l2 -> x1=x2 /\ l1=l2.
Proof.
	intros.
	split.
	apply f_equal with (f:= hd x1) in H.

	simpl in H.
	apply H.
	apply f_equal with (f:= tl) in H.
	simpl in H.
	apply H.
Qed.

Definition Nil (l: list A) :=
	match l with
	nil => True
	|_ => False
	end
.

Lemma cons_discr :
forall x : A, forall l : list A, nil <> cons x l.
Proof.
	intros.

	unfold not.
	intro.
	apply f_equal with (f:=Nil) in H.
	unfold Nil in H.
	rewrite <-  H.
	exact I.


(** * IndPrinciples: Induction Principles *)

(** With the Curry-Howard correspondence and its realization in Coq in
    mind, we can now take a deeper look at induction principles. *)

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

(* ################################################################# *)
(** * Basics *)

(** Every time we declare a new [Inductive] datatype, Coq
    automatically generates an _induction principle_ for this type.
    This induction principle is a theorem like any other: If [t] is
    defined inductively, the corresponding induction principle is
    called [t_ind].  Here is the one for natural numbers: *)

Check nat_ind :
  forall P : nat -> Prop,
    P 0 ->
    (forall n : nat, P n -> P (S n)) ->
    forall n : nat, P n.

(** In English: Suppose [P] is a property of natural numbers (that is,
      [P n] is a [Prop] for every [n]). To show that [P n] holds of all
      [n], it suffices to show:

      - [P] holds of [0]
      - for any [n], if [P] holds of [n], then [P] holds of [S n]. *)

(** The [induction] tactic is a straightforward wrapper that, at its
    core, simply performs [apply t_ind].  To see this more clearly,
    let's experiment with directly using [apply nat_ind], instead of
    the [induction] tactic, to carry out some proofs.  Here, for
    example, is an alternate proof of a theorem that we saw in the
    [Induction] chapter. *)

Theorem mult_0_r' : forall n:nat,
  n * 0 = 0.
Proof.
  apply nat_ind.
  - (* n = O *) reflexivity.
  - (* n = S n' *) simpl. intros n' IHn'. rewrite -> IHn'.
    reflexivity.  Qed.

(** This proof is basically the same as the earlier one, but a
    few minor differences are worth noting.

    First, in the induction step of the proof (the [S] case), we
    have to do a little bookkeeping manually (the [intros]) that
    [induction] does automatically.

    Second, we do not introduce [n] into the context before applying
    [nat_ind] -- the conclusion of [nat_ind] is a quantified formula,
    and [apply] needs this conclusion to exactly match the shape of
    the goal state, including the quantifier.  By contrast, the
    [induction] tactic works either with a variable in the context or
    a quantified variable in the goal.

    Third, we had to manually supply the name of the induction principle
    with [apply], but [induction] figures that out itself.

    These conveniences make [induction] nicer to use in practice than
    applying induction principles like [nat_ind] directly.  But it is
    important to realize that, modulo these bits of bookkeeping,
    applying [nat_ind] is what we are really doing. *)

(** **** Exercise: 2 stars, standard (plus_one_r')

    Complete this proof without using the [induction] tactic. *)

Theorem plus_one_r' : forall n:nat,
  n + 1 = S n.
Proof.
  apply nat_ind.
  - simpl. reflexivity.
  - simpl. intros n' IHn. rewrite IHn. reflexivity.
Qed.
(** [] *)

(** Coq generates induction principles for every datatype
    defined with [Inductive], including those that aren't recursive.
    Although of course we don't need the proof technique of induction
    to prove properties of non-recursive datatypes, the idea of an
    induction principle still makes sense for them: it gives a way to
    prove that a property holds for all values of the type. *)

(** These generated principles follow a similar pattern. If we
    define a type [t] with constructors [c1] ... [cn], Coq generates a
    theorem with this shape:

    t_ind : forall P : t -> Prop,
              ... case for c1 ... ->
              ... case for c2 ... -> ...
              ... case for cn ... ->
              forall n : t, P n

    The specific shape of each case depends on the arguments to the
    corresponding constructor. *)

(** Before trying to write down a general rule, let's look at
    some more examples. First, an example where the constructors take
    no arguments: *)

Inductive time : Type :=
  | day
  | night.

Check time_ind :
  forall P : time -> Prop,
    P day ->
    P night ->
    forall t : time, P t.

(** **** Exercise: 1 star, standard, optional (rgb)

    Write out the induction principle that Coq will generate for the
    following datatype.  Write down your answer on paper or type it
    into a comment, and then compare it with what Coq prints. *)

Inductive rgb : Type :=
  | red
  | green
  | blue.
Check rgb_ind.
(** [] *)

(** Here's another example, this time with one of the constructors
    taking some arguments. *)

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

Check natlist_ind :
  forall P : natlist -> Prop,
    P nnil  ->
    (forall (n : nat) (l : natlist),
        P l -> P (ncons n l)) ->
    forall l : natlist, P l.

(** In general, the automatically generated induction principle for
    inductive type [t] is formed as follows:

    - Each constructor [c] generates one case of the principle.
    - If [c] takes no arguments, that case is:

      "P holds of c"

    - If [c] takes arguments [x1:a1] ... [xn:an], that case is:

      "For all x1:a1 ... xn:an,
          if [P] holds of each of the arguments of type [t],
          then [P] holds of [c x1 ... xn]"

      But that oversimplifies a little.  An assumption about [P]
      holding of an argument [x] of type [t] actually occurs
      immediately after the quantification of [x].
*)

(** For example, suppose we had written the definition of [natlist] a little
    differently: *)

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

(** Now the induction principle case for [nsnoc1] is a bit different
    than the earlier case for [ncons]: *)

Check natlist'_ind :
  forall P : natlist' -> Prop,
    P nnil' ->
    (forall l : natlist', P l -> forall n : nat, P (nsnoc l n)) ->
    forall n : natlist', P n.

(** **** Exercise: 1 star, standard (booltree_ind)

    In the comment below, Write out the induction principle that Coq
    will generate for the following datatype. *)

Inductive booltree : Type :=
 | bt_empty
 | bt_leaf (b : bool)
 | bt_branch (b : bool) (t1 t2 : booltree).

(* FILL IN HERE:
   forall P : booltree -> Prop,
   P bt_empty ->
   (forall (b : bool), P(bt_leaf)) ->
   (forall (b : bool) (t1 : booltree), P t1 ->
   forall t2 : booltree, P t2 -> P (bt_branch b t1 t2)) ->
   forall bt : booltree, P bt
*)

(* Do not modify the following line: *)
Definition manual_grade_for_booltree_ind : option (nat*string) := None.
(** [] *)

(** **** Exercise: 1 star, standard (toy_ind)

    Here is an induction principle for a toy type:

  forall P : Toy -> Prop,
    (forall b : bool, P (con1 b)) ->
    (forall (n : nat) (t : Toy), P t -> P (con2 n t)) ->
    forall t : Toy, P t

    Give an [Inductive] definition of [Toy], such that the induction
    principle Coq generates is that given above: *)

Inductive Toy : Type :=
  | con1 (b : bool)
  | con2 (n : nat) (t: Toy).

(* Do not modify the following line: *)
Definition manual_grade_for_toy_ind : option (nat*string) := None.
(** [] *)

(* ################################################################# *)
(** * Polymorphism *)

(** What about polymorphic datatypes?

    The inductive definition of polymorphic lists

      Inductive list (X:Type) : Type :=
        | nil : list X
        | cons : X -> list X -> list X.

    is very similar to that of [natlist].  The main difference is
    that, here, the whole definition is _parameterized_ on a set [X]:
    that is, we are defining a _family_ of inductive types [list X],
    one for each [X].  (Note that, wherever [list] appears in the body
    of the declaration, it is always applied to the parameter [X].)
*)

(**  The induction principle is likewise parameterized on [X]:

      list_ind :
        forall (X : Type) (P : list X -> Prop),
           P [] ->
           (forall (x : X) (l : list X), P l -> P (x :: l)) ->
           forall l : list X, P l

    Note that the _whole_ induction principle is parameterized on
    [X].  That is, [list_ind] can be thought of as a polymorphic
    function that, when applied to a type [X], gives us back an
    induction principle specialized to the type [list X]. *)

(** **** Exercise: 1 star, standard, optional (tree)

    Write out the induction principle that Coq will generate for
   the following datatype.  Compare your answer with what Coq
   prints. *)

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

(** **** Exercise: 1 star, standard, optional (mytype)

    Find an inductive definition that gives rise to the
    following induction principle:

      mytype_ind :
        forall (X : Type) (P : mytype X -> Prop),
            (forall x : X, P (constr1 X x)) ->
            (forall n : nat, P (constr2 X n)) ->
            (forall m : mytype X, P m ->
               forall n : nat, P (constr3 X m n)) ->
            forall m : mytype X, P m
*)
(** [] *)

(** **** Exercise: 1 star, standard, optional (foo)

    Find an inductive definition that gives rise to the
    following induction principle:

      foo_ind :
        forall (X Y : Type) (P : foo X Y -> Prop),
             (forall x : X, P (bar X Y x)) ->
             (forall y : Y, P (baz X Y y)) ->
             (forall f1 : nat -> foo X Y,
               (forall n : nat, P (f1 n)) -> P (quux X Y f1)) ->
             forall f2 : foo X Y, P f2
*)
(** [] *)

(** **** Exercise: 1 star, standard, optional (foo')

    Consider the following inductive definition: *)

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

(** What induction principle will Coq generate for [foo']?  Fill
   in the blanks, then check your answer with Coq.)

     foo'_ind :
        forall (X : Type) (P : foo' X -> Prop),
              (forall (l : list X) (f : foo' X),
                    _______________________ ->
                    _______________________   ) ->
             ___________________________________________ ->
             forall f : foo' X, ________________________
*)

(** [] *)

(* ################################################################# *)
(** * Induction Hypotheses *)

(** Where does the phrase "induction hypothesis" fit into this story?

    The induction principle for numbers

       forall P : nat -> Prop,
            P 0  ->
            (forall n : nat, P n -> P (S n))  ->
            forall n : nat, P n

   is a generic statement that holds for all propositions
   [P] (or rather, strictly speaking, for all families of
   propositions [P] indexed by a number [n]).  Each time we
   use this principle, we are choosing [P] to be a particular
   expression of type [nat->Prop].

   We can make proofs by induction more explicit by giving
   this expression a name.  For example, instead of stating
   the theorem [mult_0_r] as "[forall n, n * 0 = 0]," we can
   write it as "[forall n, P_m0r n]", where [P_m0r] is defined
   as... *)

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

(** ... or equivalently: *)

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

(** Now it is easier to see where [P_m0r] appears in the proof. *)

Theorem mult_0_r'' : forall n:nat,
  P_m0r n.
Proof.
  apply nat_ind.
  - (* n = O *) reflexivity.
  - (* n = S n' *)
    (* Note the proof state at this point! *)
    intros n IHn.
    unfold P_m0r in IHn. unfold P_m0r. simpl. apply IHn. Qed.

(** This extra naming step isn't something that we do in
    normal proofs, but it is useful to do it explicitly for an example
    or two, because it allows us to see exactly what the induction
    hypothesis is.  If we prove [forall n, P_m0r n] by induction on
    [n] (using either [induction] or [apply nat_ind]), we see that the
    first subgoal requires us to prove [P_m0r 0] ("[P] holds for
    zero"), while the second subgoal requires us to prove [forall n',
    P_m0r n' -> P_m0r (S n')] (that is "[P] holds of [S n'] if it
    holds of [n']" or, more elegantly, "[P] is preserved by [S]").
    The _induction hypothesis_ is the premise of this latter
    implication -- the assumption that [P] holds of [n'], which we are
    allowed to use in proving that [P] holds for [S n']. *)

(* ################################################################# *)
(** * More on the [induction] Tactic *)

(** The [induction] tactic actually does even more low-level
    bookkeeping for us than we discussed above.

    Recall the informal statement of the induction principle for
    natural numbers:
      - If [P n] is some proposition involving a natural number n, and
        we want to show that P holds for _all_ numbers n, we can
        reason like this:
          - show that [P O] holds
          - show that, if [P n'] holds, then so does [P (S n')]
          - conclude that [P n] holds for all n.
    So, when we begin a proof with [intros n] and then [induction n],
    we are first telling Coq to consider a _particular_ [n] (by
    introducing it into the context) and then telling it to prove
    something about _all_ numbers (by using induction).
*)

(**  What Coq actually does in this situation, internally, is to
    "re-generalize" the variable we perform induction on.  For
    example, in our original proof that [plus] is associative... *)

Theorem plus_assoc' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  (* ...we first introduce all 3 variables into the context,
     which amounts to saying "Consider an arbitrary [n], [m], and
     [p]..." *)
  intros n m p.
  (* ...We now use the [induction] tactic to prove [P n] (that
     is, [n + (m + p) = (n + m) + p]) for _all_ [n],
     and hence also for the particular [n] that is in the context
     at the moment. *)
  induction n as [| n'].
  - (* n = O *) reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.  Qed.

(** It also works to apply [induction] to a variable that is
    quantified in the goal. *)

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

(** Note that [induction n] leaves [m] still bound in the goal --
    i.e., what we are proving inductively is a statement beginning
    with [forall m].

    If we do [induction] on a variable that is quantified in the goal
    _after_ some other quantifiers, the [induction] tactic will
    automatically introduce the variables bound by these quantifiers
    into the context. *)

Theorem plus_comm'' : forall n m : nat,
  n + m = m + n.
Proof.
  (* Let's do induction on [m] this time, instead of [n]... *)
  induction m as [| m']. (* [n] is already introduced into the context *)
  - (* m = O *) simpl. rewrite <- plus_n_O. reflexivity.
  - (* m = S m' *) simpl. rewrite <- IHm'.
    rewrite <- plus_n_Sm. reflexivity.  Qed.

(** **** Exercise: 1 star, standard, optional (plus_explicit_prop)

    Rewrite both [plus_assoc'] and [plus_comm'] and their proofs in
    the same style as [mult_0_r''] above -- that is, for each theorem,
    give an explicit [Definition] of the proposition being proved by
    induction, and state the theorem and proof in terms of this
    defined proposition.  *)

(* FILL IN HERE

    [] *)

(* ################################################################# *)
(** * Induction Principles for Propositions *)

(** Inductive definitions of propositions also cause Coq to generate
    induction priniciples.  For example, recall our proposition [ev],
    repeated here as [ev'']: *)

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

Check ev''_ind :
  forall P : nat -> Prop,
    P 0 ->
    (forall n : nat, ev'' n -> P n -> P (S (S n))) ->
    forall n : nat, ev'' n -> P n.

(** In English, [ev''_ind] says: Suppose [P] is a property of natural
    numbers.  To show that [P n] holds whenever [n] is even, it suffices
    to show:

      - [P] holds for [0],

      - for any [n], if [n] is even and [P] holds for [n], then [P]
        holds for [S (S n)]. *)

(** As expected, we can apply [ev''_ind] directly instead of using
    [induction].  For example, we can use it to show that [ev'] (the
    slightly awkward alternate definition of evenness that we saw in
    an exercise in the \chap{IndProp} chapter) is equivalent to the
    cleaner inductive definition [ev'']: *)

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

Theorem ev''_ev' : forall n, ev'' n -> ev' n.
Proof.
  apply ev''_ind.
  - (* ev_0 *)
    apply ev'_0.
  - (* ev_SS *)
    intros m Hm IH.
    apply (ev'_sum 2 m).
    + apply ev'_2.
    + apply IH.
Qed.

(** The precise form of an [Inductive] definition can affect the
    induction principle Coq generates. *)

Inductive le1 : nat -> nat -> Prop :=
     | le1_n : forall n, le1 n n
     | le1_S : forall n m, (le1 n m) -> (le1 n (S m)).

Notation "m <=1 n" := (le1 m n) (at level 70).

(** This definition can be streamlined a little by observing that the
    left-hand argument [n] is the same everywhere in the definition,
    so we can actually make it a "general parameter" to the whole
    definition, rather than an argument to each constructor. *)

Inductive le2 (n:nat) : nat -> Prop :=
  | le2_n : le2 n n
  | le2_S m (H : le2 n m) : le2 n (S m).

Notation "m <=2 n" := (le2 m n) (at level 70).

(** The second one is better, even though it looks less symmetric.
    Why?  Because it gives us a simpler induction principle. *)

Check le1_ind :
  forall P : nat -> nat -> Prop,
    (forall n : nat, P n n) ->
    (forall n m : nat, n <=1 m -> P n m -> P n (S m)) ->
    forall n n0 : nat, n <=1 n0 -> P n n0.

Check le2_ind :
  forall (n : nat) (P : nat -> Prop),
    P n ->
    (forall m : nat, n <=2 m -> P m -> P (S m)) ->
    forall n0 : nat, n <=2 n0 -> P n0.

(* ################################################################# *)
(** * Another Form of Induction Principles on Propositions (Optional) *)

(** The induction principle that Coq generated for [ev''] was parameterized
    on a natural number [n].  It could have additionally been parameterized
    on the evidence that [n] was even, which would have led to this
    induction principle:

    forall P : (forall n : nat, ev'' n -> Prop),
      P O ev_0 ->
      (forall (m : nat) (E : ev'' m),
        P m E -> P (S (S m)) (ev_SS m E)) ->
      forall (n : nat) (E : ev'' n), P n E
*)

(**   ... because:

     - Since [ev''] is indexed by a number [n] (every [ev''] object [E] is
       a piece of evidence that some particular number [n] is even),
       the proposition [P] is parameterized by both [n] and [E] --
       that is, the induction principle can be used to prove
       assertions involving both an even number and the evidence that
       it is even.

     - Since there are two ways of giving evidence of evenness ([even]
       has two constructors), applying the induction principle
       generates two subgoals:

         - We must prove that [P] holds for [O] and [ev_0].

         - We must prove that, whenever [m] is an even number and [E]
           is an evidence of its evenness, if [P] holds of [m] and
           [E], then it also holds of [S (S m)] and [ev_SS m E].

     - If these subgoals can be proved, then the induction principle
       tells us that [P] is true for _all_ even numbers [n] and
       evidence [E] of their evenness.

    This is more flexibility than we normally need or want: it is
    giving us a way to prove logical assertions where the assertion
    involves properties of some piece of _evidence_ of evenness, while
    all we really care about is proving properties of _numbers_ that
    are even -- we are interested in assertions about numbers, not
    about evidence.  It would therefore be more convenient to have an
    induction principle for proving propositions [P] that are
    parameterized just by [n] and whose conclusion establishes [P] for
    all even numbers [n]:

       forall P : nat -> Prop,
         ... ->
       forall n : nat,
         even n -> P n

    That is why Coq actually generates the induction principle
    [ev''_ind] that we saw before. *)

(* ################################################################# *)
(** * Formal vs. Informal Proofs by Induction *)

(** Question: What is the relation between a formal proof of a
    proposition [P] and an informal proof of the same proposition [P]?

    Answer: The latter should _teach_ the reader how to produce the
    former.

    Question: How much detail is needed??

    Unfortunately, there is no single right answer; rather, there is a
    range of choices.

    At one end of the spectrum, we can essentially give the reader the
    whole formal proof (i.e., the "informal" proof will amount to just
    transcribing the formal one into words).  This may give the reader
    the ability to reproduce the formal one for themselves, but it
    probably doesn't _teach_ them anything much.

   At the other end of the spectrum, we can say "The theorem is true
   and you can figure out why for yourself if you think about it hard
   enough."  This is also not a good teaching strategy, because often
   writing the proof requires one or more significant insights into
   the thing we're proving, and most readers will give up before they
   rediscover all the same insights as we did.

   In the middle is the golden mean -- a proof that includes all of
   the essential insights (saving the reader the hard work that we
   went through to find the proof in the first place) plus high-level
   suggestions for the more routine parts to save the reader from
   spending too much time reconstructing these (e.g., what the IH says
   and what must be shown in each case of an inductive proof), but not
   so much detail that the main ideas are obscured.

   Since we've spent much of this chapter looking "under the hood" at
   formal proofs by induction, now is a good moment to talk a little
   about _informal_ proofs by induction.

   In the real world of mathematical communication, written proofs
   range from extremely longwinded and pedantic to extremely brief and
   telegraphic.  Although the ideal is somewhere in between, while one
   is getting used to the style it is better to start out at the
   pedantic end.  Also, during the learning phase, it is probably
   helpful to have a clear standard to compare against.  With this in
   mind, we offer two templates -- one for proofs by induction over
   _data_ (i.e., where the thing we're doing induction on lives in
   [Type]) and one for proofs by induction over _evidence_ (i.e.,
   where the inductively defined thing lives in [Prop]). *)

(* ================================================================= *)
(** ** Induction Over an Inductively Defined Set *)

(** _Template_:

       - _Theorem_: <Universally quantified proposition of the form
         "For all [n:S], [P(n)]," where [S] is some inductively defined
         set.>

         _Proof_: By induction on [n].

           <one case for each constructor [c] of [S]...>

           - Suppose [n = c a1 ... ak], where <...and here we state
             the IH for each of the [a]'s that has type [S], if any>.
             We must show <...and here we restate [P(c a1 ... ak)]>.

             <go on and prove [P(n)] to finish the case...>

           - <other cases similarly...>                        []

    _Example_:

      - _Theorem_: For all sets [X], lists [l : list X], and numbers
        [n], if [length l = n] then [index (S n) l = None].

        _Proof_: By induction on [l].

        - Suppose [l = []].  We must show, for all numbers [n],
          that, if [length [] = n], then [index (S n) [] =
          None].

          This follows immediately from the definition of [index].

        - Suppose [l = x :: l'] for some [x] and [l'], where
          [length l' = n'] implies [index (S n') l' = None], for
          any number [n'].  We must show, for all [n], that, if
          [length (x::l') = n] then [index (S n) (x::l') =
          None].

          Let [n] be a number with [length l = n].  Since

            length l = length (x::l') = S (length l'),

          it suffices to show that

            index (S (length l')) l' = None.

          But this follows directly from the induction hypothesis,
          picking [n'] to be [length l'].  [] *)

(* ================================================================= *)
(** ** Induction Over an Inductively Defined Proposition *)

(** Since inductively defined proof objects are often called
    "derivation trees," this form of proof is also known as _induction
    on derivations_.

    _Template_:

       - _Theorem_: <Proposition of the form "[Q -> P]," where [Q] is
         some inductively defined proposition (more generally,
         "For all [x] [y] [z], [Q x y z -> P x y z]")>

         _Proof_: By induction on a derivation of [Q].  <Or, more
         generally, "Suppose we are given [x], [y], and [z].  We
         show that [Q x y z] implies [P x y z], by induction on a
         derivation of [Q x y z]"...>

           <one case for each constructor [c] of [Q]...>

           - Suppose the final rule used to show [Q] is [c].  Then
             <...and here we state the types of all of the [a]'s
             together with any equalities that follow from the
             definition of the constructor and the IH for each of
             the [a]'s that has type [Q], if there are any>.  We must
             show <...and here we restate [P]>.

             <go on and prove [P] to finish the case...>

           - <other cases similarly...>                        []

    _Example_

       - _Theorem_: The [<=] relation is transitive -- i.e., for all
         numbers [n], [m], and [o], if [n <= m] and [m <= o], then
         [n <= o].

         _Proof_: By induction on a derivation of [m <= o].

           - Suppose the final rule used to show [m <= o] is
             [le_n]. Then [m = o] and we must show that [n <= m],
             which is immediate by hypothesis.

           - Suppose the final rule used to show [m <= o] is
             [le_S].  Then [o = S o'] for some [o'] with [m <= o'].
             We must show that [n <= S o'].
             By induction hypothesis, [n <= o'].

             But then, by [le_S], [n <= S o'].  [] *)

(* ################################################################# *)
(** * Explicit Proof Objects for Induction (Optional) *)

(** Although tactic-based proofs are normally much easier to
    work with, the ability to write a proof term directly is sometimes
    very handy, particularly when we want Coq to do something slightly
    non-standard.  *)

(** Recall again the induction principle on naturals that Coq generates for
    us automatically from the Inductive declation for [nat]. *)

Check nat_ind :
  forall P : nat -> Prop,
    P 0 ->
    (forall n : nat, P n -> P (S n)) ->
    forall n : nat, P n.

(** There's nothing magic about this induction lemma: it's just
   another Coq lemma that requires a proof.  Coq generates the proof
   automatically too...  *)

Print nat_ind.

(** We can rewrite that more tidily as follows: *)
Fixpoint build_proof
         (P : nat -> Prop)
         (evPO : P 0)
         (evPS : forall n : nat, P n -> P (S n))
         (n : nat) : P n :=
  match n with
  | 0 => evPO
  | S k => evPS k (build_proof P evPO evPS k)
  end.

Definition nat_ind_tidy := build_proof.

(** We can read [build_proof] as follows: Suppose we have
    evidence [evPO] that [P] holds on 0, and evidence [evPS] that [forall
    n:nat, P n -> P (S n)].  Then we can prove that [P] holds of an
    arbitrary nat [n] using recursive function [build_proof], which
    pattern matches on [n]:

      - If [n] is 0, [build_proof] returns [evPO] to show that [P n]
        holds.

      - If [n] is [S k], [build_proof] applies itself recursively on
        [k] to obtain evidence that [P k] holds; then it applies
        [evPS] on that evidence to show that [P (S n)] holds. *)

(** Recursive function [build_proof] thus pattern matches against
    [n], recursing all the way down to 0, and building up a proof
    as it returns. *)

(** The actual [nat_ind] that Coq generates uses a recursive
    function [F] defined with [fix] instead of [Fixpoint]. *)

(**  We can adapt this approach to proving [nat_ind] to help prove
    _non-standard_ induction principles too.  As a motivating example,
    suppose that we want to prove the following lemma, directly
    relating the [ev] predicate we defined in [IndProp]
    to the [evenb] function defined in [Basics]. *)

Lemma evenb_ev : forall n: nat, evenb n = true -> ev'' n.
Proof.
  induction n; intros.
  - apply ev_0.
  - destruct n.
    + simpl in H. inversion H.
    + simpl in H.
      apply ev_SS.
Abort.

(** Attempts to prove this by standard induction on [n] fail in the case for
    [S (S n)],  because the induction hypothesis only tells us something about
    [S n], which is useless. There are various ways to hack around this problem;
    for example, we _can_ use ordinary induction on [n] to prove this (try it!):

    [Lemma evenb_ev' : forall n : nat,
     (evenb n = true -> ev n) /\ (evenb (S n) = true -> ev (S n))].

    But we can make a much better proof by defining and proving a
    non-standard induction principle that goes "by twos":
 *)

 Definition nat_ind2 :
    forall (P : nat -> Prop),
    P 0 ->
    P 1 ->
    (forall n : nat, P n -> P (S(S n))) ->
    forall n : nat , P n :=
       fun P => fun P0 => fun P1 => fun PSS =>
          fix f (n:nat) := match n with
                             0 => P0
                           | 1 => P1
                           | S (S n') => PSS n' (f n')
                          end.

 (** Once you get the hang of it, it is entirely straightforward to
     give an explicit proof term for induction principles like this.
     Proving this as a lemma using tactics is much less intuitive.

     The [induction ... using] tactic variant gives a convenient way to
     utilize a non-standard induction principle like this. *)

Lemma evenb_ev : forall n, evenb n = true -> ev'' n.
Proof.
 intros.
 induction n as [ | |n'] using nat_ind2.
 - apply ev_0.
 - simpl in H.
   inversion H.
 - simpl in H.
   apply ev_SS.
   apply IHn'.
   apply H.
Qed.

(* 04 Mar 2020 *)


Require Import List.
Section Last.

  Variable A : Type.
  Set Implicit Arguments.

  Inductive last (a:A) : list A -> Prop :=
  | last_hd : last a (a :: nil)
  | last_tl : forall (b:A) (l:list A), last a l -> last a (b :: l).

  #[local] Hint Constructors last : core.

  Fixpoint last_fun (l:list A) : option A :=
    match l with
    | nil => None (A:=A)
    | a :: nil => Some a
    | a :: l' => last_fun l'
    end.

  Theorem last_fun_correct :
    forall (a:A) (l:list A), last a l -> last_fun l = Some a.
  Proof.
    intros a l H; induction H as [| b l H IH].
    - reflexivity.
    -   destruct l; simpl in *.
        +  discriminate IH.
        +  assumption.
  Qed.

  Theorem last_fun_correct_R :
    forall (a:A) (l:list A), last_fun l = Some a -> last a l.
  Proof.
    intros a l ; induction l as [ |a0 l0 IHl0]; simpl.
    - discriminate.
    -  destruct l0.
       + injection 1;intros;subst a0;auto.
       +  intro e; simpl; auto.
  Qed.

  Lemma last_fun_of_cons : forall (l:list A) (a:A), last_fun (a :: l) <> None.
  Proof.
    intros l ; induction l as [| a l0].
    -  discriminate.
    - destruct l0;simpl;auto.
      + discriminate.
  Qed.

  Theorem last_fun_correct3 :
    forall l:list A, last_fun l = None -> forall b:A, ~ last b l.
  Proof.
    intro l; case l.
    - simpl; red; inversion 2.
    -  intros a l0 H;  case (last_fun_of_cons l0 a H).
  Qed.

End Last.


(** DEPRECATED?
    \o notation for composition is used in LibFixDemos
*)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Functions                                                               *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibContainer LibSet.
(* This will be Import-ed only in the relevant sections *)
From TLC Require LibList.
Generalizable Variables A.

(* ********************************************************************** *)
(** ** Indentity function *)

Definition id {A} (x : A) :=
  x.

(* ********************************************************************** *)
(** Constant functions *)

Definition const {A B} (v : B) : A -> B :=
  fun _ => v.
Definition const1 :=
  @const.
Definition const2 {A1 A2 B} (v:B) : A1->A2->B :=
  fun _ _ => v.
Definition const3 {A1 A2 A3 B} (v:B) : A1->A2->A3->B :=
  fun _ _ _ => v.
Definition const4 {A1 A2 A3 A4 B} (v:B) : A1->A2->A3->A4->B :=
  fun _ _ _ _ => v.
Definition const5 {A1 A2 A3 A4 A5 B} (v:B) : A1->A2->A3->A4->A5->B :=
  fun _ _ _ _ _ => v.

(* ********************************************************************** *)
(** Function application *)

Definition apply {A B} (f : A -> B) (x : A) :=
  f x.

Definition apply_to (A : Type) (x : A) (B : Type) (f : A -> B) :=
  f x.

(* ********************************************************************** *)
(** Function composition *)

Definition compose {A B C} (g : B -> C) (f : A -> B) :=
  fun x => g (f x).

Declare Scope fun_scope.

Notation "f1 \o f2" := (compose f1 f2)
  (at level 49, right associativity) : fun_scope.

Section Combinators.
Open Scope fun_scope.
Variables (A B C D : Type).

Lemma compose_id_l : forall (f:A->B),
  id \o f = f.
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma compose_id_r : forall (f:A->B),
  f \o id = f.
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma compose_assoc : forall (f:C->D) (g:B->C) (h:A->B),
  (f \o g) \o h = f \o (g \o h).
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma compose_eq_l : forall (f:B->C) (g1 g2:A->B),
  g1 = g2 ->
  f \o g1 = f \o g2.
Proof using. intros. subst~. Qed.

Lemma compose_eq_r : forall (f:A->B) (g1 g2:B->C),
  g1 = g2 ->
  g1 \o f = g2 \o f.
Proof using. intros. subst~. Qed.

(** Composition of [LibList.map] behaves well. **)
(* Could not be put in [LibList] because of circular dependencies. *)
Import LibList.

Lemma list_map_compose : forall A B C (f : A -> B) (g : B -> C) l,
  LibList.map g (LibList.map f l) = LibList.map (g \o f) l.
Proof using.
  introv. induction l.
   reflexivity.
   rew_listx. fequals~.
Qed.

End Combinators.

(** Tactic for simplifying function compositions *)
(* --TODO: not used; might become deprecated *)

#[global]
Hint Rewrite compose_id_l compose_id_r compose_assoc : rew_compose.
Tactic Notation "rew_compose" :=
  autorewrite with rew_compose.
Tactic Notation "rew_compose" "in" "*" :=
  autorewrite with rew_compose in *.
Tactic Notation "rew_compose" "in" hyp(H) :=
  autorewrite with rew_compose in H.

(* ********************************************************************** *)
(** ** Function update *)

(** [fupdate f a b x] is like [f] except that it returns [b] for input [a] *)

Definition fupdate A B (f : A -> B) (a : A) (b : B) : A -> B :=
  fun x => If (x = a) then b else f x.

Lemma fupdate_eq : forall A B (f:A->B) a b x,
  fupdate f a b x = If (x = a) then b else f x.
Proof using. auto. Qed.

Lemma fupdate_same : forall A B (f:A->B) a b,
  fupdate f a b a = b.
Proof using. intros. unfold fupdate. case_if*. Qed.

Lemma fupdate_neq : forall A B (f:A->B) a b x,
  x <> a ->
  fupdate f a b x = f x.
Proof using. intros. unfold fupdate. case_if*. Qed.

(* Opaque fupdate. -- could be added in the future *)

(* ********************************************************************** *)
(** ** Function image *)

Section FunctionImage.
Open Scope set_scope.
Import LibList.

Definition image A B (f : A -> B) (E : set A) : set B :=
  \set{ y | exists_ x \in E, y = f x }.

Lemma in_image_prove_eq : forall A B x (f : A -> B) (E : set A),
  x \in E -> f x \in image f E.
Proof using. introv N. unfold image. rew_set. exists* x. Qed.

Lemma in_image_prove : forall A B x y (f : A -> B) (E : set A),
  x \in E -> y = f x -> y \in image f E.
Proof using. intros. subst. applys* in_image_prove_eq. Qed.

Lemma in_image_inv : forall A B y (f : A -> B) (E : set A),
  y \in image f E -> exists x, x \in E /\ y = f x.
Proof using. introv N. unfolds image. rew_set in N. auto. Qed.

Lemma finite_image : forall A B (f : A -> B) (E : set A),
  finite E ->
  finite (image f E).
Proof using.
  introv M. lets (L&H): finite_inv_list_covers M.
  applys finite_of_list_covers (LibList.map f L). introv N.
  lets (y&Hy&Ey): in_image_inv (rm N). subst x. applys* mem_map.
Qed.

Lemma image_covariant : forall A B (f : A -> B) (E F : set A),
  E \c F ->
  image f E \c image f F.
Proof using.
  introv. do 2 rewrite incl_in_eq. introv M N.
  lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
Qed.

Lemma image_union : forall A B (f : A -> B) (E F : set A),
  image f (E \u F) = image f E \u image f F.
Proof using.
  Hint Resolve in_image_prove.
  introv. apply in_extens. intros x. iff N.
    lets (y&Hy&Ey): in_image_inv (rm N). rewrite in_union_eq in Hy.
     rewrite in_union_eq. destruct* Hy.
    rewrite in_union_eq in N. destruct N as [N|N].
      lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
       rewrite in_union_eq. eauto.
      lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
       rewrite in_union_eq. eauto.
Qed.

Lemma image_singleton : forall A B (f : A -> B) (x : A),
  image f \{x} = \{f x}.
Proof using.
  intros. apply in_extens. intros z. rewrite in_single_eq. iff N.
    lets (y&Hy&Ey): in_image_inv (rm N). rewrite in_single_eq in Hy. subst~.
    applys* in_image_prove. rewrite~ @in_single_eq. typeclass.
Qed.

End FunctionImage.

#[global]
Hint Resolve finite_image : finite.

(* ********************************************************************** *)
(** ** Function preimage *)

Section FunctionPreimage.
Open Scope set_scope.

Definition preimage A B (f : A -> B) (E : set B) : set A :=
  \set{ x | exists_ y \in E, y = f x }.

End FunctionPreimage.

(* ********************************************************************** *)
(** ** Function iteration *)

Fixpoint applyn A n (f : A -> A) x :=
  match n with
  | O => x
  | S n' => f (applyn n' f x)
  end.

Lemma applyn_fix : forall A n f (x : A),
  applyn (S n) f x = applyn n f (f x).
Proof using. introv. induction~ n. simpls. rewrite~ IHn. Qed.

Lemma applyn_comp : forall A n m f (x : A),
  applyn n f (applyn m f x) = applyn (n + m) f x.
Proof using.
  introv. gen m; induction n; introv; simpls~.
  rewrite~ IHn.
Qed.

Lemma applyn_nested : forall A n m f (x : A),
  applyn n (applyn m f) x = applyn (n * m) f x.
Proof using.
  introv. gen m. induction n; introv; simpls~.
  rewrite IHn. rewrite~ applyn_comp.
Qed.

Lemma applyn_altern : forall A B (f : A -> B) (g : B -> A) x n,
  applyn n (fun x => f (g x)) (f x) =
    f (applyn n (fun x => g (f x)) x).
Proof using. introv. gen x. induction~ n. introv. repeat rewrite applyn_fix. autos~. Qed.

Lemma applyn_ind : forall A (P : A -> Prop) (f : A -> A) x n,
  (forall x, P x -> P (f x)) ->
  P x ->
  P (applyn n f x).
Proof using. introv I. induction n; introv Hx; autos*. Qed.

(* --TODO: rename applyn to iter *)
(* --TODO: migrate iteration of functionals from LibFix to here *)