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

(** Another familiar enumerated type: *)

Inductive bool : Type :=
  | true
  | false.

(** Booleans are also available from Coq's standard library, but
    in this course we'll define everything from scratch, just to see
    how it's done. *)
Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

(** Note the syntax for defining multi-argument
    functions ([andb] and [orb]).  *)
Example test_orb1:  (orb true  false) = true.
Proof. simpl. reflexivity.  Qed.
Example test_orb2:  (orb false false) = false.
Proof. simpl. reflexivity.  Qed.
Example test_orb3:  (orb false true)  = true.
Proof. simpl. reflexivity.  Qed.
Example test_orb4:  (orb true  true)  = true.
Proof. simpl. reflexivity.  Qed.

(** We can define new symbolic notations for existing definitions. *)

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5:  false || false || true = true.
Proof. simpl. reflexivity. Qed.

(** We can also write these function using Coq's "if" expressions.  *)

Definition negb' (b:bool) : bool :=
  if b then false
  else true.

Definition andb' (b1:bool) (b2:bool) : bool :=
  if b1 then b2
  else false.

Definition orb' (b1:bool) (b2:bool) : bool :=
  if b1 then true
  else b2.

(** **** Exercise: 1 star, standard (nandb)
    The command [Admitted] can be used as a placeholder for an
    incomplete proof.  We use it in exercises to indicate the parts
    that we're leaving for you -- i.e., your job is to replace
    [Admitted]s with real proofs.
    Remove "[Admitted.]" and complete the definition of the following
    function; then make sure that the [Example] assertions below can
    each be verified by Coq.  (I.e., fill in each proof, following the
    model of the [orb] tests above, and make sure Coq accepts it.) The
    function should return [true] if either or both of its inputs are
    [false].
    Hint: if [simpl] will not simplify the goal in your proof, it's
    probably because you defined [nandb] without using a [match]
    expression. Try a different definition of [nandb], or just
    skip over [simpl] and go directly to [reflexivity]. We'll
    explain this phenomenon later in the chapter. *)

Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | false => true
  | true =>
    match b2 with
    | true => false
    | false => true
    end
  end.

Example test_nandb1:               (nandb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb2:               (nandb false false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb3:               (nandb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb4:               (nandb true true) = false.
Proof. simpl. reflexivity. Qed.
(** [] *)

(** Most exercises are omitted from the "terse" version of the
    notes used in lecture.
    The "full" version contains both the assigned reading and all the
    exercises for your homework assignment. *)


From AG Require Export Basics.

Check bin_to_nat. (*Export works*)

Definition  add_0_r : forall  n:nat, n + 0 = n.
intro n. induction n  as [| n' IH].
  - reflexivity.
  - simpl. rewrite IH. reflexivity.
Defined.

Definition  minus_n_n : forall  n, minus n n = 0.
  intro n. induction n as [| n' IH].
  - simpl. reflexivity.
  - simpl. apply IH.
Defined.

Definition mul_0_r : forall n : nat, n * 0 = 0.
  intro n. induction n as [| n' IH].
  - simpl. reflexivity.
  - simpl. apply IH.
Defined.

Definition plus_n_Sm : forall n m : nat, S (n + m) = n + (S m).
  intros n m. induction n as [| n' IH].
  - simpl. reflexivity.
  - simpl. rewrite IH. reflexivity.
Defined.

Definition add_comm : forall n m : nat, n + m = m + n.
  intros n m. induction m as [|m IHm].
  - simpl. rewrite (add_0_r n). reflexivity.
  - simpl. rewrite <-  plus_n_Sm. rewrite IHm. reflexivity.
Defined.

Definition add_assoc : forall  n m p : nat,  n + (m + p) = (n + m) + p.
  intros n m p. induction n as [|n IHn].
  - simpl. reflexivity.
  - simpl. rewrite IHn. reflexivity.
Defined.

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

Definition double_plus : forall n, double n = n + n.
  intro n. induction n as [| n IHn].
  - simpl. reflexivity.
  -  simpl. rewrite IHn. Search plus. rewrite plus_n_Sm. reflexivity.
Defined.

Definition even_S : forall n : nat, even (S n) = negb (even n).
  intro n. induction n as [|n IHn].
  - simpl. reflexivity.
  - rewrite ->  IHn. simpl. Search negb. rewrite negb_involutive. reflexivity.
Defined.

Definition plus_rearrange : forall n m p q : nat, (n + m) + (p + q) = (m + n) + (p + q).
  intros n m p q. assert (H_comm : n + m = m + n).
  {rewrite add_comm. reflexivity. }(*Note: Assertions are non-transparent*)
  rewrite H_comm. reflexivity.
Defined.

(*Exercises*)

Definition add_shuffle3 : forall n m p : nat, n + (m+p) = m + (n + p).
  intros n m p. destruct n as [| n Sn].
  - simpl. reflexivity.
  - Search plus. rewrite plus_Sn_m. rewrite plus_Sn_m. rewrite <-  plus_n_Sm. rewrite add_assoc. rewrite  (add_comm n m). rewrite add_assoc. reflexivity.
Defined.

Definition mul_comm : forall n m : nat, n * m = m * n.
  intros n m. induction n as [| n IHn].
  - simpl. Search mult. rewrite <- mult_n_O. reflexivity.
  - simpl. Search mult. rewrite <-  mult_n_Sm. rewrite IHn. rewrite add_comm. reflexivity.
Defined.

Check leb.

Definition leb_refl : forall n : nat, (n <=? n) = true.
  intro n. induction  n.
  - simpl. reflexivity.
  - simpl. assumption.
Defined.

Definition zero_neqb_S : forall n : nat, 0 =? (S n) = false.
  intro n. simpl. reflexivity.
Defined.

Definition andb_false_r : forall b : bool, andb b false = false.
  intro b. destruct b as [].
  - simpl. reflexivity.
  - simpl. reflexivity.
Defined.

Definition plus_leb_compat_1 : forall n m p : nat, n <=? m = true -> (p + n) <=? (p + m) = true.
  intros n m p q. induction p as [| p IHp].
  - simpl. assumption.
  - simpl. assumption.
Defined.

Definition S_neqb_0 : forall n : nat, (S n) =? 0 = false.
  intro n. destruct n.
  - simpl. reflexivity.
  - simpl. reflexivity.
Defined.

Definition mult_1_1 : forall n : nat, 1 * n = n.
  intro n. rewrite mul_comm. Search mult. rewrite mult_n_1. reflexivity.
Defined.

Definition all3_spec : forall b c : bool,
    orb (andb b c) (orb (negb b) (negb c)) = true.
  intros b c. destruct b.
  - simpl. destruct c.
    + simpl. reflexivity.
    + simpl. reflexivity.
  - simpl. reflexivity.
Defined.

Definition mult_plus_distr_r : forall n m p : nat, (n + m) * p = (n * p) + (m * p).
  intros n m p. induction n.
  - simpl. reflexivity.
  - simpl. rewrite IHn. rewrite add_assoc. reflexivity.
Defined.

Definition mult_assoc : forall n m p : nat,
    n * (m * p) = (n * m) * p.
  intros n m p. induction n.
  - simpl. reflexivity.
  - simpl. rewrite mult_plus_distr_r. rewrite IHn. reflexivity.
Defined.

Definition eqb_refl : forall n : nat, (n =? n) = true.
  intro n. induction n.
  - simpl. reflexivity.
  - simpl. assumption.
Defined.

(*"Replace" tactic*)

Definition bin_to_nat_pres_incr : forall x : bin, bin_to_nat (incr x) = S (bin_to_nat x).
  intro x. induction x.
  - simpl. reflexivity.
  - simpl. rewrite add_0_r. rewrite plus_n_Sm. rewrite <- plus_n_Sm. rewrite <- plus_n_Sm. rewrite add_0_r. reflexivity.
  - simpl. rewrite_all add_0_r. rewrite <- plus_n_Sm. rewrite add_0_r. rewrite plus_n_Sm. rewrite IHx. rewrite <- plus_n_Sm. rewrite <-  (plus_n_Sm (bin_to_nat x) (bin_to_nat x)). reflexivity.
Defined.

Fixpoint nat_to_bin (n : nat) : bin :=
  match n with
  | 0 => Z
  | S n => incr (nat_to_bin n)
                end.

Definition nat_bin_nat : forall n, bin_to_nat (nat_to_bin n) = n.
  intro n. induction n.
  - simpl. reflexivity.
  - simpl. Search bin. rewrite bin_to_nat_pres_incr. rewrite IHn. reflexivity.
Defined.


Print bool.

Print bool_rect.
Print bool_ind.
Print bool_rec.

Definition match_true := match true with true => false | false => true end.

Check match_true.
Eval compute in match_true.

Definition nat_of_bool := bool_rec (fun _ => nat) 1 0.

Check (nat_of_bool : bool -> nat).

Eval compute in (nat_of_bool false).

Definition dep_of_bool := bool_rec (fun b => match b with true => nat | false => bool end) 1 true.

Check (dep_of_bool : forall b, match b with true => nat | false => bool end).

Eval compute in (dep_of_bool false).

Definition dep_of_bool2 b : match b with true => nat | false => bool end :=
  match b with
      true => 1
    | false => true
  end.

Goal dep_of_bool = dep_of_bool2.
reflexivity.
Qed.

Check dep_of_bool2.

Require Import ssreflect ssrfun ssrbool.

Print andb.
Print negb.
Print orb.

Goal forall a b : bool, ~~ (a && b) = (~~ a) || (~~ b).
by case; case.
Qed.

Require Import eqtype ssrnat.

Lemma ifP_example : forall n : nat, odd (if odd n then n else n.+1).
Proof.
move=> n.
case: ifP.
  done.
move=> Hn.
rewrite -addn1.
rewrite odd_add.
by rewrite Hn.
Qed.

Check ifP.
(* forall (A : Type) (b : bool) (vT vF : A),
       if_spec b vT vF (b = false) b (if b then vT else vF) *)
Print if_spec.
(* CoInductive if_spec (A : Type) (b : bool) (vT vF : A)
            (not_b : Prop) : bool -> A -> Set :=
    IfSpecTrue : b -> if_spec b vT vF not_b true vT
  | IfSpecFalse : not_b -> if_spec b vT vF not_b false vF
*)
(*
upon case analysis, match (a subterm in) the goal with
"(if b then vT else vF)" and generate to goals:
1. b is replaced with true, b is pushed on the stack
1. b is replaced with false, not_b is pushed on the stack
*)

Lemma boolP_example : forall n : nat, n * n - 1 < n ^ n.
Proof.
move=> n.
case: (boolP (n == O)).
  move/eqP.
  move=> ->.
  rewrite expn0.
  rewrite muln0.
  rewrite sub0n.
  done.
move=> n0.
case: (boolP (n == 1)).
  move/eqP.
  move=> ->.
  rewrite expn1.
  rewrite muln1.
  by rewrite subnn.
move=> n1.
have [m Hm] : exists m, n = m.+2.
  case: n n0 n1 => //.
  case=> // n _ _.
  by exists n.
rewrite Hm.
rewrite expnS.
rewrite expnS.
rewrite mulnA.
rewrite subn1.
rewrite prednK; last first.
  by rewrite muln_gt0.
rewrite leq_pmulr //.
by rewrite expn_gt0.
Qed.

Check boolP.
(* forall b1 : bool, alt_spec b1 b1 b1 *)
Check (boolP (0 == 1)).
(* alt_spec (0 == 1) (0 == 1) (0 == 1) *)
Check alt_spec.
Print alt_spec.
(* two combinations possible:
   P b true
   P b false
   upon case analysis, there are two branches:
   - "(0 == 1)" is replaced by true and the hypothesis "(0 == 1) (= true)" is pushed
   - "(0 == 1)" is replaced by false and the hypothesis "~~ (0 == 1)" = "(0 != 1)" is pushed
*)


Require Import Arith.Le.

Print ex.

(*
Inductive ex (a : Type) (P : a -> Prop) : Prop :=
| ex_intro : forall x : a, P x -> exists y, P y
*)

Inductive ex2 (a:Type) (P:a -> Prop) : Prop :=
| ex2_intro : forall (x:a), P x -> ex2 a P
.

Arguments ex2 {a} _.
Arguments ex2_intro {a} {P} _ _.

(* there exists n:nat, n + 3 = 5 *)
Lemma test1 : ex2 (fun (n:nat) => n + 3 = 5).
Proof. apply ex2_intro with 2. reflexivity. Qed.

Check ex2_intro.

Lemma test2 : ex2 (fun (n:nat) => n + 3 = 5).
Proof. apply (ex2_intro 2). reflexivity. Qed.

Lemma exist1 : exists (n:nat), n + 3 = 5.
Proof. exists 2. reflexivity. Qed.

Lemma exist2 : forall (n m:nat), (exists (p:nat), n + p = m) -> n <= m.
Proof.
    intros n m [p H]. revert p n m H. induction p as [|p IH]; intros n m.
    - intros H. rewrite <- plus_n_O in H. rewrite H. constructor.
    - intros H. apply le_trans with (S n).
        + constructor. constructor.
        + apply IH. simpl. rewrite <- plus_n_Sm in H. assumption.
Qed.


(* Exercise 74 *)

Require Import BenB.

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

(* A universal statement does not carry existential import,
   but if we know the domain is not empty, then we can
   prove that universal predication implies singular
   predication of a property P *)

Hypothesis Domain : exists x1 : D, exists x2 : D, exists x3 : D,
  forall x : D, (x = x1 \/ x = x2 \/ x = x3).

Theorem exercise_074 : (forall x : D, P x) -> (exists x : D, P x).
Proof.
exi_e (exists x1 : D, exists x2 : D, exists x3 : D,
  forall x : D, (x = x1 \/ x = x2 \/ x = x3)) a a1.
  hyp Domain.
exi_e (exists x2 : D, exists x3 : D,
  forall x : D, (x = a \/ x = x2 \/ x = x3)) b a2.
hyp a1.
exi_e (exists x3 : D,
  forall x : D, (x = a \/ x = b \/ x = x3)) c a3.
hyp a2.
imp_i a4.
exi_i a.
all_e (forall x:D, P x) a.
hyp a4.
Qed.


Require Export case.
Require String.
(* Software Foundations Chapter 8 : Logic in Coq *)

(**************************************************
 Exercise: 1 star, optional (proj2)
**************************************************)
Theorem proj2 : forall P Q : Prop,
                  P /\ Q -> Q.
Proof.
  intros P Q E.
  inversion E as [p q].
  apply q.
Qed.

(**************************************************
Exercise: 2 stars (and_assoc)
In the following proof, notice how the nested pattern in the inversion breaks the hypothesis H : P ∧ (Q ∧ R) down into HP: P, HQ : Q, and HR : R. Finish the proof from there:
**************************************************)
Theorem and_assoc : forall P Q R : Prop,
                      P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R H.
  inversion H as [HP [HQ HR]].
  split. split. apply HP. apply HQ. apply HR.
Qed.

(**************************************************
Exercise: 2 stars (even__ev)
Now we can prove the other direction of the equivalence of even and ev, which we left hanging in chapter Prop. Notice that the left-hand conjunct here is the statement we are actually interested in; the right-hand conjunct is needed in order to make the induction hypothesis strong enough that we can carry out the reasoning in the inductive step. (To see why this is needed, try proving the left conjunct by itself and observe where things get stuck.)
**************************************************)
Inductive ev : nat -> Prop :=
  ev_0 : ev 0
| ev_SS : forall n, ev n -> ev (S (S n)).

Fixpoint evenb n : bool :=
  match n with
    | O => true
    | S O => false
    | S (S n) => evenb n
  end.

Definition even n : Prop := evenb n = true.

Theorem even__ev : forall n : nat,
                     (even n -> ev n) /\ (even (S n) -> ev (S n)).
Proof.
  intros n.
  induction n as [|nn].
  split.
  intro H. apply ev_0.
  intro H. inversion H.
  inversion IHnn as [E1 E2].
  split.
  apply E2.
  intro H.
  unfold even in H. simpl in H.
  apply ev_SS.
  generalize H.
  unfold even in E1.
  apply E1.
Qed.

(**************************************************
  Exercise: 1 star, optional (iff_properties)
  Using the above proof that ↔ is symmetric (iff_sym) as a guide, prove that it is also reflexive and transitive.
**************************************************)
Theorem iff_refl : forall P : Prop,
                     P <-> P.
Proof.
  intros P. split.
  intro H. apply H.
  intro H. apply H.
Qed.

Theorem iff_trans : forall P Q R : Prop,
                      (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros P Q R HPQ HQR.
  inversion HPQ as [HP2Q HQ2P]. inversion HQR as [HQ2R HR2Q].
  split.
  intro HP.
  apply HQ2R in HP2Q. apply HP2Q. apply HP.
  intro HR.
  apply HQ2P in HR2Q. apply HR2Q. apply HR.
Qed.

(**************************************************
  Exercise: 2 stars (or_distributes_over_and_2)
 **************************************************)
Theorem or_distributes_over_and_2 : forall P Q R : Prop,
                                      (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
  intros P Q R H.
  inversion H as [[HP1 | HQ ] [HP2 | HR]].
  left. apply HP1. left. apply HP1. left. apply HP2.
  right. split. apply HQ. apply HR.
Qed.

(**************************************************
 Exercise: 1 star, optional (or_distributes_over_and)
 **************************************************)
Theorem or_distributes_over_and : forall P Q R : Prop,
                                    P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. split.
  intro H. split.
  inversion H as [HP | [HQ  HR]].
  left. apply HP. right. apply HQ.
  inversion H as [HP | [HQ HR]].
  left. apply HP. right. apply HR.
  intro H.
  inversion H as [[HP1 | HQ] [HP2 | HR]].
  left. apply HP1. left. apply HP1. left. apply HP2.
  right. split. apply HQ. apply HR.
Qed.

(**************************************************
 Exercise: 2 stars, optional (bool_prop)
 **************************************************)
Theorem andb_false : forall b c,
                       andb b c = false -> b = false \/ c = false.
Proof.
  intros b c H.
  destruct b. destruct c.
  simpl in H. left. apply H.
  simpl in H. right. apply H.
  destruct c.
  simpl in H. left. apply H.
  simpl in H. left. apply H.
Qed.

Theorem orb_prop : forall b c,
                     orb b c = true -> b = true \/ c = true.
Proof.
  intros b c H.
  destruct b. destruct c.
  simpl in H. left. apply H.
  simpl in H. left. apply H.
  destruct c.
  simpl in H. right. apply H.
  simpl in H. right. apply H.
Qed.

Theorem orb_false_elim : forall b c,
                           orb b c = false -> b = false /\ c = false.
Proof.
  intros b c H.
  split.
  destruct b. simpl in H. apply H.
  destruct c. simpl in H. inversion H.
  apply H.
  destruct b. inversion H.
  simpl in H. apply H.
Qed.

(**************************************************
 Exercise: 2 stars, advanced (True)
 Define True as another inductively defined proposition. (The intution is that True should be a proposition for which it is trivial to give evidence.)
 **************************************************)
Inductive True : Prop :=
| triv : True.

(*** Check this constructor ***)
Theorem check_true : forall A, A -> True.
Proof.
  intros A H.
  apply triv.
 Qed.

(**************************************************
 Exercise: 2 stars, advanced (double_neg_inf)
 Write an informal proof of double_neg:
 **************************************************)
Theorem double_neg_inf : forall P : Prop,
                           P -> ~~P.
Proof.
  intros P H1.
  unfold not. intro H2.
  apply H2 in H1.
  inversion H1.
Qed.
(**
Theorem: P implies ~~P, for any proposition P.
Proof: Let P be some proposition. First consider ~P. This is equivalent to the statement that
the proposition P implies the proposition False. Now consider ~~P. This states the if ~P holds, then we can
derive False. Therefore, the statement we are really trying to prove is P -> (P -> False) -> False. Assume P and P -> False. From these two assumptions we can derive False and use this evidence to complete the proof.
**)

(***
Theorem double_neg_imp : forall P : Prop,
                           ~~ P -> P.
Proof.
  unfold not.
  intros P H.
  (no evidence to say anything else)
***)

(**************************************************
  Exercise: 2 stars (contrapositive)
 **************************************************)

Theorem contrapositive : forall P Q : Prop,
                           (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q E1.
  unfold not.
  intros E2 E3.
  apply E1 in E3.
  apply E2 in E3.
  apply E3.
Qed.

(**************************************************
 Exercise: 1 star (not_both_true_and_false)
 **************************************************)
Theorem not_both_true_and_false : forall P : Prop,
                                    ~ (P /\ ~P).
Proof.
  intros P. unfold not.
  intros H.
  inversion H as [P' P'False].
  apply P'False in P'.
  apply P'.
Qed.

(**************************************************
 Exercise: 1 star, advanced (informal_not_PNP)
 Write an informal proof (in English) of the proposition ∀ P : Prop, ~(P ∧ ~P).
**************************************************)
(** Proof:
 Let ~(P /\ ~P) be represented instead as P /\ (P -> False) -> False. Assume the premises: P /\ (P -> False). Using the left side of the conjunction (P) as evidence for the right (P -> False), we derive False. Use this derivation as evidence for the goal.
**)

(**************************************************
 Exercise: 1 star (ev_not_ev_S)

 Theorem five_not_even confirms the unsurprising fact that five is not an even number. Prove this more interesting fact:
 **************************************************)
Theorem ev_not_ev_S : forall n,
                        ev n -> ~ ev (S n).
Proof.
  unfold not. intros n H. induction H. (* not n! *)
  intro E. inversion E.
  intro E. inversion E as [|nn HevS1 Hnh].
  apply IHev in HevS1. inversion HevS1.
Qed.

(**
Note that some theorems that are true in classical logic are not provable in Coq's (constructive) logic. E.g., let's look at how this proof gets stuck...
**)

Theorem classic_double_neg : forall P : Prop,
                               ~~P -> P.
Proof.
  (* WORKED IN CLASS *)
  intros P H. unfold not in H.
  (* But now what? There is no way to "invent" evidence for ~P
     from evidence for P. *)
  Abort.

(***************************************************
 Exercise: 5 stars, advanced, optional (classical_axioms)

 For those who like a challenge, here is an exercise taken from the Coq'Art book (p. 123). The following five statements are often considered as characterizations of classical logic (as opposed to constructive logic, which is what is "built in" to Coq). We can't prove them in Coq, but we can consistently add any one of them as an unproven axiom if we wish to work in classical logic. Prove that these five propositions are equivalent.
**************************************************)
Theorem ex_falso_quot_liblet : forall P : Prop,
                                 False -> P.
Proof. intros P H. inversion H. Qed.

Definition peirce := forall P Q: Prop,
                       ((P -> Q) -> P) -> P.
Definition classic := forall P:Prop,
                        ~~P -> P.
Definition excluded_middle := forall P:Prop,
                                P \/ ~P.
Definition de_morgan_not_and_not := forall P Q:Prop,
                                      ~(~P /\ ~Q) -> P \/ Q.
Definition implies_to_or := forall P Q : Prop,
                              (P -> Q) -> (~P \/ Q).

Theorem classic_peirce : classic <-> peirce.
Proof.
  split. unfold classic. unfold peirce.
  intros classic P Q.
  intro H1. apply classic.
  unfold not. intro notP. apply notP. apply H1.
  intro H2. apply classic. unfold not.
  intro notQ. apply notP in H2.
  apply H2.
  unfold classic. unfold peirce.
  intros peirce P notnotP.
  unfold not in notnotP.
  apply peirce with (P:=P) (Q:=False).
  intro H1.
  apply ex_falso_quot_liblet.
  apply notnotP.
  apply H1.
Qed.

Theorem peirce_de_morgan_not_and_not : peirce <-> de_morgan_not_and_not.
Proof.
  split. unfold peirce. unfold de_morgan_not_and_not.
  intros peirce P Q H1.
  unfold not in H1.
  apply peirce with (Q:=False). intros H2.
  left. apply peirce with (Q:=False). intros H3.
  apply ex_falso_quot_liblet.
  apply H2. right. apply peirce with (Q:=False). intros H4.
  apply ex_falso_quot_liblet.

Theorem excluded_middle_implies_to_or : implies_to_or <-> excluded_middle.
Proof.
  split. unfold excluded_middle. unfold implies_to_or.
  intros ex_mid.
(*  apply or_introl with (A:=Q->R) (B:=(Q->R) -> False) in H1. *)
Admitted.

Theorem imples_to_or_de_morgan_not_and_not : implies_to_or <-> de_morgan_not_and_not.
Proof.
  split. unfold implies_to_or. unfold de_morgan_not_and_not.
  intros implies_to_or P Q H1.
Admitted.

(* Theorem peirce_excluded_middle : peirce <-> excluded_middle. *)
(* Proof.  *)
(*   split. unfold peirce. unfold excluded_middle. *)
(*   intros peirce P. *)
(*   left. *)
(*   apply peirce with (P:=P) (Q:=False). *)
(*   intro notP. *)
(*   apply ex_falso_quot_liblet. *)
(*   generalize notP. *)

(*   apply peirce with (P:=False) (Q:=P). *)
(*   intro H. *)

(* Theorem classic_excluded_middle : classic <-> excluded_middle. *)
(* Proof.  *)
(*   split. unfold classic. unfold excluded_middle. *)
(*   intros classic P. *)
(*   left.  *)
(*   apply classic. *)
(*   intro notP. *)
(*   apply notP. *)

(**************************************************
 Exercise: 2 stars (false_beq_nat)
**************************************************)
Fixpoint beq_nat n m :=
  match (n, m) with
    | (O, O) => true
    | (O, _) | (_, O) => false
    | (S nn, S mm) => beq_nat nn mm
  end.

Theorem false_beq_nat : forall n m : nat,
                          n <> m ->
                          beq_nat n m = false.
Proof.
  intros n m H.
  unfold not in H.
  generalize dependent n.
  induction m as [|mm].
  intros n H.
  destruct n.
  simpl. apply ex_falso_quot_liblet. apply H. reflexivity.
  simpl. reflexivity.
  intros n. destruct n as [|nn].
  intros H. simpl. reflexivity.
  simpl. intro H. apply IHmm. intro E.
  apply H. SearchAbout S.
  apply eq_S. apply E.
Qed.

(**************************************************
Exercise: 2 stars, optional (beq_nat_false)
**************************************************)
Theorem beq_nat_false :  forall n m,
                           beq_nat n m = false -> n <> m.
Proof.
  intros n.
  unfold not.
  induction n as [|nn].
  destruct m as [|mm].
  simpl. intro H. inversion H.
  simpl. intro H1. intro H2. inversion H2.
  destruct m as [|mm].
  simpl. intros H1 H2. inversion H2.
  simpl. intros H1 H2. apply eq_add_S in H2.
  generalize H2. generalize H1. apply IHnn.
Qed.

(**************************************************
Exercise: 2 stars, optional (ble_nat_false)
**************************************************)
Fixpoint ble_nat (n:nat) (m:nat) := match (n, m) with
                                      | (O, _) => true
                                      | (S _, O) => false
                                      | (S nn, S mm) => ble_nat nn mm
                                    end.

Theorem ble_nat_false : forall n m,
                          ble_nat n m = false -> ~(n <= m).
Proof.
  intros n. induction n as [|nn].
  intros m H E.
  destruct m as [|mm].
  simpl in H. inversion H.
  simpl in H. inversion H.
  intros m E. destruct m as [|mm].
  unfold not. intro EE. inversion EE.
  simpl in E. unfold not. intro EE.
  simpl in EE. apply Le.le_S_n in EE.
  generalize dependent EE.
  generalize dependent E.
  apply IHnn.
Qed.

(**************************************************
Exercise: 1 star (dist_not_exists)
Prove that "P holds for all x" implies "there is no x for which P does not hold."
**************************************************)
Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
                            (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros X P H1 H2.
  inversion H2.
  unfold not in H.
  apply H.
  apply H1.
Qed.

(**************************************************
Exercise: 3 stars, optional (not_exists_dist)
(The other direction of this theorem requires the classical "law of the excluded middle".)
**************************************************)
Theorem not_exists_dist : excluded_middle ->
                          forall (X:Type) (P : X -> Prop),
                            ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  intros ex_mid X P.
  unfold excluded_middle in ex_mid.
  intros H x. unfold not in H.

  Admitted.

(**************************************************
Exercise: 2 stars (dist_exists_or)
Prove that existential quantification distributes over disjunction.
**************************************************)
Theorem dist_exists_or : forall (X:Type)
                                (P Q : X -> Prop),
                           (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros X P Q.
  split.
  intros H1. inversion H1.
  inversion H as [HL|HR].
  left. exists x. apply HL.
  right. exists x. apply HR.
  intros H. inversion H as [HL|HR].
  inversion HL.
  exists x.
  left. apply H0.
  inversion HR.
  exists x.
  right.
  apply H0.
Qed.

(**************************************************
Exercise: 2 stars (leibniz_equality)
The inductive definitions of equality corresponds to Leibniz equality: what we mean when we say "x and y are equal" is that every property on P that is true of x is also true of y.
**************************************************)
Lemma leibniz_equality : forall (X : Type) (x y: X),
                           x = y -> forall P : X -> Prop, P x -> P y.
Proof.
  intros X x y H P E.
  rewrite -> H in E.
  apply E.
Qed.

(**************************************************
Exercise: 1 star (override_shadow')
**************************************************)
Theorem eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
Proof.
  intros n.
  induction n as [|nn].
  destruct m as [|mm].
  left. reflexivity.
  right. intros H. inversion H.
  intros m. destruct m as [|mm].
  right. intros H. inversion H.
  destruct IHnn with (m:=mm) as [eq|neq].
  left. apply f_equal. apply eq.
  right. intros H. inversion H. generalize H1. apply neq.
Qed.

Definition override' {X: Type} (f: nat -> X) (k:nat) (x:X) : nat -> X:=
  fun (k':nat) => if eq_nat_dec k k' then x else f k'.

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 (eq_nat_dec k1 k2) as [E1|E2].
  reflexivity. reflexivity.
Qed.

(**************************************************
Exercise: 1 star, optional (dist_and_or_eq_implies_and)
**************************************************)
Lemma dist_and_or_eq_implies_and : forall P Q R,
                                     P /\ (Q \/ R) /\ Q = R -> P\/ Q.
Proof.
  intros P Q R H.
  inversion H.
  left. apply H0.
Qed.

(**************************************************
Exercise: 3 stars (all_forallb)
Inductively define a property all of lists, parameterized by a type X and a property P : X → Prop, such that all X P l asserts that P is true for every element of the list l.
**************************************************)

Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Inductive all (X : Type) (P : X -> Prop) : list X -> Prop :=
| empty : all X P []
| rest_true : forall x l, P x -> all X P l -> all X P (x::l).

(** Recall the function forallb, from the exercise forall_exists_challenge in chapter Poly: **)

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
    | nil => true
    | cons x l' => andb (test x) (forallb test l')
  end.

(* Using the property all, write down a specification for forallb, and prove that it satisfies the specification. Try to make your specification as precise as possible.
Are there any important properties of the function forallb which are not captured by your specification? *)

(* FILL IN HERE *)

(**************************************************
Exercise: 4 stars, advanced (filter_challenge)
One of the main purposes of Coq is to prove that programs match their specifications. To this end, let's prove that our definition of filter matches a specification. Here is the specification, written out informally in English.
Suppose we have a set X, a function test: X→bool, and a list l of type list X. Suppose further that l is an "in-order merge" of two lists, l1 and l2, such that every item in l1 satisfies test and no item in l2 satisfies test. Then filter test l = l1.
A list l is an "in-order merge" of l1 and l2 if it contains all the same elements as l1 and l2, in the same order as l1 and l2, but possibly interleaved. For example,
    [1,4,6,2,3]
is an in-order merge of
    [1,6,2]
and
    [4,3].
Your job is to translate this specification into a Coq theorem and prove it. (Hint: You'll need to begin by defining what it means for one list to be a merge of two others. Do this with an inductive relation, not a Fixpoint.)
**************************************************)

(**************************************************
Exercise: 5 stars, advanced, optional (filter_challenge_2)
A different way to formally characterize the behavior of filter goes like this: Among all subsequences of l with the property that test evaluates to true on all their members, filter test l is the longest. Express this claim formally and prove it.
**************************************************)

(**************************************************
Exercise: 4 stars, advanced (no_repeats)
The following inductively defined proposition...
**************************************************)
Inductive appears_in {X:Type} (a:X) : list X -> Prop :=
  | ai_here : forall l, appears_in a (a::l)
  | ai_later : forall b l, appears_in a l -> appears_in a (b::l).

(* ...gives us a precise way of saying that a value a appears at least once as a member of a list l.
Here's a pair of warm-ups about appears_in. *)

Lemma appears_in_app : forall (X:Type) (xs ys : list X) (x:X),
     appears_in x (xs ++ ys) -> appears_in x xs ∨ appears_in x ys.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma app_appears_in : forall (X:Type) (xs ys : list X) (x:X),
     appears_in x xs ∨ appears_in x ys -> appears_in x (xs ++ ys).
Proof.
  (* FILL IN HERE *) Admitted.

(* Now use appears_in to define a proposition disjoint X l1 l2, which should be provable exactly when l1 and l2 are lists (with elements of type X) that have no elements in common. *)

(* FILL IN HERE *)

(* Next, use appears_in to define an inductive proposition no_repeats X l, which should be provable exactly when l is a list (with elements of type X) where every member is different from every other. For example, no_repeats nat [1,2,3,4] and no_repeats bool [] should be provable, while no_repeats nat [1,2,1] and no_repeats bool [true,true] should not be. *)

(* FILL IN HERE *)

(* Finally, state and prove one or more interesting theorems relating disjoint, no_repeats and ++ (list append). *)

(* FILL IN HERE *)

(**************************************************
Exercise: 3 stars (nostutter)
Formulating inductive definitions of predicates is an important skill you'll need in this course. Try to solve this exercise without any help at all (except from your study group partner, if you have one).
We say that a list of numbers "stutters" if it repeats the same number consecutively. The predicate "nostutter mylist" means that mylist does not stutter. Formulate an inductive definition for nostutter. (This is different from the no_repeats predicate in the exercise above; the sequence 1,4,1 repeats but does not stutter.)
**************************************************)
Inductive nostutter: list nat -> Prop :=
 (* FILL IN HERE *)
.

(* Make sure each of these tests succeeds, but you are free to change the proof if the given one doesn't work for you. Your definition might be different from mine and still correct, in which case the examples might need a different proof.
The suggested proofs for the examples (in comments) use a number of tactics we haven't talked about, to try to make them robust with respect to different possible ways of defining nostutter. You should be able to just uncomment and use them as-is, but if you prefer you can also prove each example with more basic tactics. *)

Example test_nostutter_1: nostutter [3;1;4;1;5;6].
(* FILL IN HERE *) Admitted.
(*
  Proof. repeat constructor; apply beq_nat_false; auto. Qed.
*)

Example test_nostutter_2: nostutter [].
(* FILL IN HERE *) Admitted.
(*
  Proof. repeat constructor; apply beq_nat_false; auto. Qed.
*)

Example test_nostutter_3: nostutter [5].
(* FILL IN HERE *) Admitted.
(*
  Proof. repeat constructor; apply beq_nat_false; auto. Qed.
*)

Example test_nostutter_4: not (nostutter [3;1;1;4]).
(* FILL IN HERE *) Admitted.
(*
  Proof. intro.
  repeat match goal with
    h: nostutter _ |- _ => inversion h; clear h; subst
  end.
  contradiction H1; auto. Qed.
*)

(**************************************************
Exercise: 4 stars, advanced (pigeonhole principle)
The "pigeonhole principle" states a basic fact about counting: if you distribute more than n items into n pigeonholes, some pigeonhole must contain at least two items. As is often the case, this apparently trivial fact about numbers requires non-trivial machinery to prove, but we now have enough...
First a pair of useful lemmas (we already proved these for lists of naturals, but not for arbitrary lists).
**************************************************)
Lemma app_length : ∀(X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma appears_in_app_split : ∀(X:Type) (x:X) (l:list X),
  appears_in x l →
  ∃l1, ∃l2, l = l1 ++ (x::l2).
Proof.
  (* FILL IN HERE *) Admitted.

(* Now define a predicate repeats (analogous to no_repeats in the exercise above), such that repeats X l asserts that l contains at least one repeated element (of type X). *)

Inductive repeats {X:Type} : list X → Prop :=
  (* FILL IN HERE *)
.

(* Now here's a way to formalize the pigeonhole principle. List l2 represents a list of pigeonhole labels, and list l1 represents an assignment of items to labels: if there are more items than labels, at least two items must have the same label. You will almost certainly need to use the excluded_middle hypothesis. *)

Theorem pigeonhole_principle: ∀(X:Type) (l1 l2:list X),
  excluded_middle →
  (∀x, appears_in x l1 → appears_in x l2) →
  length l2 < length l1 →
  repeats l1.
Proof. intros X l1. induction l1.
  (* FILL IN HERE *) Admitted.


(*** Logical conjunction ***)
Variables A B C : Prop.

(* Comutatividade *)
Lemma and_commutativity : A /\ B -> B /\ A.
Proof.
  intro Hab.
  destruct Hab as [Ha Hb].
  split.
  +
    assumption.
  +
    assumption.
Qed.

(* Associatividade *)
Lemma and_associativity : A /\ (B /\ C) -> (A /\ B) /\ C.
Proof.
  intro Habc.
  destruct Habc as [Ha [Hb Hc]].
  split.
  +
    split.
    *
      assumption.
    *
      assumption.
  +
    assumption.
Qed.

(* Leis de De Morgan *)
Lemma and_de_morgan : ~A /\ ~B -> ~(A \/ B).
Proof.
  intros NHab DHab.
  destruct NHab as [NHa NHb].
  destruct DHab as [Ha|Hb].
  apply NHa.
  exact Ha.
  apply NHb.
  exact Hb.
Qed.

(* A contradição é sempre falsa *)
Lemma and_contradiction_always_false : A /\ ~A -> False.
Proof.
  intro CHa.
  destruct CHa as [Ha NHa].
  apply NHa.
  exact Ha.
Qed.

(* A verdade é o elemento neutro da conjunção *)
Lemma and_truth_neutral_element : A /\ True -> A.
Proof.
  intro CHa.
  destruct CHa as [Ha true].
  exact Ha.
Qed.

(* A falsidade é o elemento absorvente da conjunção *)
Lemma and_false_absorbent_element : A /\ False -> False.
Proof.
  intro CHa.
  destruct CHa as [Ha false].
  exact false.
Qed.

(* Distributividade em relação à disjunção lógica *)
Lemma and_distributivity_disjunction : A /\ (B \/ C) -> (A /\ B) \/ (A /\ C).
Proof.
  intro Habc.
  destruct Habc as [Ha [Hb|Hc]].
  +
    split.
  intro.
  intro.
  intro.
Qed.


(*
   Functional Programming 2018
   Term project
   Artihmetic expression decompiler

   Christoffer Müller Madsen and
   Jon Michael Aanes

   December 2018
 *)

Require Import List Coq.Arith.Arith Coq.Arith.EqNat Bool.
Import ListNotations.

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

Module Main.

(** * Syntax *)

(** ** Expression language *)

(** The expression language considered in this project is very
    simple. It can describe arithmetics on natural numbers with a select
    set of unary and binary operations. The operations defined for the
    basic version of the language were the unary operations successor
    and predecessor, and the binary operations addition and
    multiplication.

    Since then, we have added subtraction and conditional expressions.

    We define the expression language inductively. *)

Inductive unop :=
  | OSucc : unop
  | OPred : unop.

Inductive binop :=
  | OPlus : binop
  | OMult : binop
  | OMinus : binop.

Inductive exp :=
  | ENat   : nat   -> exp
  | EUnOp  : unop  -> exp -> exp
  | EBinOp : binop -> exp -> exp -> exp
  | EIf    : exp   -> exp -> exp -> exp.

(** ** Stack machine language *)

(** The stack machine language considered is similarly simple. It
    supports pushing natural numbers to the stack and performing unary
    and binary operations on these. The instructions are in reverse
    Polish notation. *)

Inductive instruction :=
  | IPush   : nat   -> instruction
  | IUnOp   : unop  -> instruction
  | IBinOp  : binop -> instruction
  | IChoose : instruction.

(** We define the type [stack] to lighten the syntactical weight of the
    Coq code. *)

Definition stack := list nat.
Definition program := list instruction.

(* ================================================================= *)
(** * Expression evaluation *)

(** We define the function [eval] to give semantics to expressions. *)

Definition eval_unop (op : unop) (v : nat) : nat :=
  match op with
    | OSucc => S v
    | OPred => pred v
  end.

Definition eval_binop (op : binop) (v1 v2 : nat) : nat :=
  match op with
    | OPlus => v1 + v2
    | OMult => v1 * v2
    | OMinus => v1 - v2
  end.

Fixpoint eval (e : exp) : nat :=
  match e with
    | ENat   n          => n
    | EUnOp  op   e     => eval_unop op (eval e)
    | EBinOp op   e1 e2 => eval_binop op (eval e1) (eval e2)
    | EIf    cond e1 e2 => if eval cond then eval e2 else eval e1
  end.

(** We test the [eval] function  *)

Example eval_1 : eval (EBinOp OMult (ENat 4) (ENat 3)) = 12.
Proof. simpl. reflexivity. Qed.

Example eval_2 : eval (ENat 4) = 4.
Proof. simpl. reflexivity. Qed.

Example eval_3 : eval (EUnOp OSucc (ENat 4)) = 5.
Proof. simpl. reflexivity. Qed.

Example eval_4 : eval (EUnOp OPred (ENat 4)) = 3.
Proof. simpl. reflexivity. Qed.

Example eval_5 : eval (EBinOp OPlus (EUnOp OPred (ENat 0)) (EUnOp OSucc (EBinOp OMult (ENat 5) (ENat 3)))) = 16.
Proof. simpl. reflexivity. Qed.

Example eval_6 : eval (EBinOp OMinus (ENat 4) (ENat 3)) = 1.
Proof. simpl. reflexivity. Qed.

Example eval_7 : eval (EBinOp OMinus (ENat 3) (ENat 4)) = 0.
Proof. simpl. reflexivity. Qed.

Example eval_if_1 : eval (EIf (ENat 0) (ENat 1) (ENat 2)) = 2.
Proof. simpl. reflexivity. Qed.

Example eval_if_2 : eval (EIf (ENat 3) (ENat 1) (ENat 2)) = 1.
Proof. simpl. reflexivity. Qed.

Example eval_if_3 : eval (EIf (EBinOp OMult (ENat 4) (ENat 3)) (ENat 1) (ENat 2)) = 1.
Proof. simpl. reflexivity. Qed.

(** It seems to work.  *)

(* ================================================================= *)
(** * Stack machine *)

(** ** General stack machine  *)

(** We observed that the virtual machine and decompiler were nearly
    equivalent in implementation.  For this reason, we generalised the
    shared parts.  The record type [stack_machine_functions] specifies
    the semantics of the general stack machine.

    The function [exp_to_elem] is not used in the actual implementation
    of the stack machine; its purpose is solely to signify what the
    equivalent of running the stack machine on an input would
    be. Running the stack machine on a compiled expression [e] should be
    equivalent to evaluating [exp_to_elem e]. We provide a proof for
    this later.

    The [props] element is a proof that applying [exp_to_elem] on an
    expression is equivalent to running the stack machine with the
    functions specified in the record.

    This will become more clear as you read along. *)

Definition exp_to_elem_props
           {A : Type}
           (exp_to_elem : exp -> A)
           exp_to_elem_push
           exp_to_elem_unop
           exp_to_elem_binop
           exp_to_elem_if : Prop :=

  (forall (n : nat),
      exp_to_elem (ENat n) = exp_to_elem_push n) /\

  (forall (e : exp) (op : unop),
      exp_to_elem (EUnOp op e) = exp_to_elem_unop op (exp_to_elem e)) /\

  (forall (e1 e2 : exp) (op : binop),
      exp_to_elem (EBinOp op e1 e2) = exp_to_elem_binop op (exp_to_elem e1) (exp_to_elem e2)) /\

  (forall (cond e1 e2 : exp),
      exp_to_elem (EIf cond e1 e2) =
      exp_to_elem_if (exp_to_elem cond) (exp_to_elem e2) (exp_to_elem e1)).

Record stack_machine_functions {A : Type} :=
  {
    constr_push  : nat -> A;
    constr_unop  : unop -> A -> A;
    constr_binop : binop -> A -> A -> A;
    constr_if    : A -> A -> A -> A;
    exp_to_elem  : exp -> A;
      }.

(** For later use: A proof tactic to unpack the propositions from a
    record of type [stack_machine_functions] into the local proof
    context.  *)

(** We define a function to execute a single step of the stack
    machine. It takes as input a [stack_machine_functions] and a single
    instruction and outputs a correspondingly updated stack.
*)

Definition stack_machine_state_transition
           {A: Type}
           (funcs: stack_machine_functions)
           (insn: instruction)
           (s: list A) : option (list A) :=

  match insn, s with
    | IPush n, s'
      => Some ((constr_push funcs n) :: s')

    | IUnOp op, x :: s'
      => Some ((constr_unop funcs op x) :: s')

    | IBinOp op, y :: x :: s'
      => Some ((constr_binop funcs op x y) :: s')

    | IChoose, cond :: v2 :: v1 :: s'
      => Some ((constr_if funcs cond v1 v2) :: s')

    | _, _ => None
  end.

(** We can now define the general stack machine as the recursive
    application of [stack_machine_state_transition] on a [program],
    returning the final stack when all instructions have been
    executed. *)

Fixpoint stack_machine {A : Type} (funcs : stack_machine_functions) (insns : program) (s : list A) : option (list A) :=
  match insns with
    | insn :: insns' => match stack_machine_state_transition funcs insn s with
                          | Some s' => stack_machine funcs insns' s'
                          | _       => None
                        end
    | [] => Some s
  end.

(** ** Virtual machine  *)

(** We can now begin defining the specialisation of the general stack
    machine to be used as the virtual machine.

    First, look at [vm_functions], which specifies the functions used
    for the virtual machine. The proof needed to specify the record is
    provided as [vm_functions_props].

    [exp_to_elem] is set to be the [eval] function, signifying that
    running the virtual machine on a compiled expression is equivalent
    to evaluating the expression using [eval]. *)

Lemma vm_functions_props : exp_to_elem_props eval id eval_unop eval_binop (fun (cond v1 v2 : nat) => (if cond then v1 else v2)).
Proof.
  unfold exp_to_elem_props. auto.
Qed.

Definition vm_functions :=
  {|
    constr_push  := fun (n : nat) => n;
    constr_unop  := eval_unop;
    constr_binop := eval_binop;
    constr_if    := fun (cond v1 v2 : nat) => (if cond then v1 else v2);
    exp_to_elem  := eval;
  |}.

(** The main virtual machine function [vm] can now be defined succinctly
    in terms of [stack_machine]. *)

Definition vm (insns : program) : option nat :=
  match stack_machine vm_functions insns nil with
    | Some (x :: _) => Some x
    | _ => None
  end.

(** We test the [vm] function *)

Example vm_test_1 : vm [IPush 2] = Some 2.
Proof. simpl. reflexivity. Qed.

Example vm_test_2 : vm [IPush 2 ; IPush 3] = Some 3.
Proof. simpl. reflexivity. Qed.

Example vm_test_3 : vm [IPush 2 ; IPush 3 ; IBinOp OPlus] = Some 5.
Proof. simpl. reflexivity. Qed.

Example vm_test_4 : vm [IPush 4 ; IPush 2 ; IPush 3 ; IBinOp OPlus ; IBinOp OMult] = Some 20.
Proof. simpl. reflexivity. Qed.

Example vm_test_5 : vm [IPush 4 ; IPush 2 ; IPush 3 ; IBinOp OPlus ; IBinOp OMult ; IUnOp OSucc] = Some 21.
Proof. simpl. reflexivity. Qed.

Example vm_test_6 : vm [IPush 4 ; IPush 2 ; IPush 3 ; IUnOp OPred ; IBinOp OPlus ; IBinOp OMult ; IUnOp OSucc] = Some 17.
Proof. simpl. reflexivity. Qed.

Example vm_test_7 : vm [] = None.
Proof. simpl. reflexivity. Qed.

Example vm_test_8 : vm [IUnOp OSucc] = None.
Proof. simpl. reflexivity. Qed.

Example vm_test_9 : vm [IPush 2 ; IBinOp OPlus] = None.
Proof. simpl. reflexivity. Qed.

Example vm_test_10 : vm [IPush 4 ; IPush 1 ; IBinOp OMinus] = Some 3.
Proof. simpl. reflexivity. Qed.

Example vm_test_11 : vm [IPush 1 ; IPush 4 ; IBinOp OMinus] = Some 0.
Proof. simpl. reflexivity. Qed.

Example vm_test_choose_1 : vm [ IPush 4 ; IPush 1 ; IPush 0 ; IChoose ] = Some 4.
Proof. simpl. reflexivity. Qed.

Example vm_test_choose_2 : vm [ IPush 4 ; IPush 2 ; IPush 1 ; IChoose ] = Some 2.
Proof. simpl. reflexivity. Qed.

Example vm_test_choose_3 : vm ([IPush 4 ; IPush 2 ; IPush 3 ; IBinOp OPlus ; IBinOp OMult] ++ [IPush 2 ; IPush 3 ; IBinOp OPlus] ++ [IPush 4 ; IPush 2 ; IPush 3 ; IUnOp OPred ; IBinOp OPlus ; IBinOp OMult ; IUnOp OSucc] ++ [IChoose]) = Some 5.
Proof. simpl. reflexivity. Qed.

(** It seems to work. *)

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

(** We give a functional definition of the compiler for the stack
    machine, which is fairly trivial.  *)

Fixpoint compile (e : exp) : program :=
  match e with
    | ENat   n          => [ IPush n ]
    | EUnOp  op e       => compile e ++ [ IUnOp op ]
    | EBinOp op e1 e2   => compile e1 ++ compile e2 ++ [ IBinOp op ]
    | EIf    cond e1 e2 => compile e2 ++ compile e1 ++ compile cond ++ [ IChoose ]
  end.

Example compile_test_1 : compile (ENat 3) = [ IPush 3 ].
Proof. simpl. reflexivity. Qed.

Example compile_test_2 : compile (EBinOp OPlus (ENat 3) (ENat 4)) = [ IPush 3 ; IPush 4 ; IBinOp OPlus ].
Proof. simpl. reflexivity. Qed.

Example compile_test_3 : compile (EBinOp OPlus (EUnOp OSucc (ENat 3)) (ENat 4)) = [ IPush 3 ; IUnOp OSucc ; IPush 4 ; IBinOp OPlus ].
Proof. simpl. reflexivity. Qed.

Example compile_test_4 : compile (EBinOp OMult (EUnOp OPred (ENat 3)) (ENat 4)) = [ IPush 3 ; IUnOp OPred ; IPush 4 ; IBinOp OMult ].
Proof. simpl. reflexivity. Qed.

Example compile_test_5 : compile (EBinOp OMult (EUnOp OPred (EUnOp OSucc (ENat 3))) (ENat 4)) = [ IPush 3 ; IUnOp OSucc ; IUnOp OPred ; IPush 4 ; IBinOp OMult ].
Proof. simpl. reflexivity. Qed.

Example compile_test_if_1 : compile (EBinOp OPlus
                                            (EIf (EUnOp OSucc (ENat 0))
                                                 (EUnOp OPred (ENat 2))
                                                 (EUnOp OSucc (ENat 4)))
                                            (ENat 41))
                            = [ IPush 4 ; IUnOp OSucc ; IPush 2 ; IUnOp OPred ; IPush 0 ; IUnOp OSucc ; IChoose ; IPush 41 ; IBinOp OPlus ].
Proof. simpl. reflexivity. Qed.

(* ================================================================= *)
(** * Correctness of virtual machine and compiler *)

(** We previously postulated that running the virtual machine on a
    compiled expression is equivalent to applying [eval] to that
    expression.

    In this section, we prove that this proposition holds. *)

(** ** QuickChick intermezzo *)

(** Before giving a formal proof of the proposition, we see if
    QuickChick can find a counter-example. *)

(** The proposition is posed as *)

(* Definition vm_correct_prop (e : exp) := vm (compile e) = Some (eval e)?. *)

(** Before we can check the propositions, we need to do some plumbing
    for QuickChick. *)

(** Deriving the [Show] typeclass for the inductive datatypes is
    necessary for QuickChick usage. *)

(* Derive Show for unop.
Derive Show for binop.
Derive Show for exp.

(** Equality of two expressions is easily decidable, it is trivially
    proved by [dec_eq].  *)

Instance eq_dec_exp (exp1 exp2 : exp) : Dec (exp1 = exp2) := {}.
Proof. dec_eq. Defined.

 *)
(** Next, we implement a function for generating expressions with some
    notion of size. We generate expressions in a straight-forward
    recursive way. *)

(* Fixpoint genSizedexp (size : nat) : G exp :=
  match size with
    | O => (n <- choose (1, 40) ;;
            ret (ENat n))
    | S size' =>
      freq [ (1, (n <- choose (1, 40) ;;
                  ret (ENat n))) ;
             (size, e <- genSizedexp size' ;;
                    op <- (elems [ OSucc ; OPred ]) ;;
                    ret (EUnOp op e)) ;
             (size, e1 <- genSizedexp size' ;;
                    e2 <- genSizedexp size' ;;
                    op <- (elems [ OPlus ; OMult ; OMinus ]) ;;
                   ret (EBinOp op e1 e2)) ;
             (size, e1 <- genSizedexp size' ;;
                    e2 <- genSizedexp size' ;;
                    e3 <- genSizedexp size' ;;
                    ret (EIf e1 e2 e3))]
  end.
 *)
(** We also need to implement a shrinker for expressions. We shrink by
    either
    - shrinking an expression to one of its parts, i.e. shrinking a
      binary operation to one of the expressions it operates on, or
    - mapping an expression to an expression of the same types, with one
      of its parts shrunk, i.e. shrinking a binary operation to the same
      binary operation, with one of the expressions it operates on being
      shrunk.  *)
(*
Fixpoint shrinkExp (e : exp) : list exp :=
  match e with
    | ENat v => map (fun n => ENat n) (shrink v)
    | EUnOp op e1 => e1 :: shrinkExp e1
    | EBinOp op e1 e2 =>
      [e1 ; e2]
        ++ map (fun e' => EBinOp op e' e2) (shrinkExp e1)
        ++ map (fun e' => EBinOp op e1 e') (shrinkExp e2)
    | EIf cond e1 e2 =>
      [e1 ; e2]
        ++ map (fun cond' => EIf cond' e1 e2) (shrinkExp cond)
        ++ map (fun e' => EIf cond e' e2) (shrinkExp e1)
        ++ map (fun e' => EIf cond e1 e') (shrinkExp e2)
  end.
 *)
(** Now that we have done the necessary plumbing, we can check the proposition. *)

(* QuickChick (forAllShrink (genSizedexp 2) shrinkExp vm_correct_prop).
 *)
(**
    +++ Passed 10000 tests (0 discards)

    It seems to work!
*)

(** ** A formal proof  *)

(** We now give a formal proof of the same proposition.

    In order to give the proof, we need a few lemmas stating properties
    about the virtual stack machine. We state these propositions as
    properties of the general stack machine in order to be able to
    re-use the propositions for later proofs.
 *)

(** The stack machine should have the transitive property,
    i.e. evaluating a list of instructions combined from two sublists
    should be the same as evaluating the two sublists sequentially. *)

Lemma stack_machine_trans : forall (A : Type) funcs insns1 insns2 s s',
    @stack_machine A funcs insns1 s = Some s' ->
    stack_machine funcs (insns1 ++ insns2) s =
    stack_machine funcs (insns2) s'.

(** The proof is by induction over the first list of instructions. *)

Proof.
  intros A funcs insns1.
  induction insns1; intros insns2 s s' H1.

  (** The case of the empty list of instructions is trivial; the stack
      remains the same.  *)

  - inversion H1. reflexivity.

  (** The induction case requires a bit more work. Here, we do case
      analysis on the type of the instruction at the head of the
      list. *)

  - rewrite <- app_comm_cons.
    destruct a;

      (** In the [INat] case the induction hypothesis and the assumption
          easily proves the proposition. *)

      apply IHinsns1, H1 ||

      (** The cases of [IUnOp], [IBinOp], and [IChoose] require a bit more work.

          We destruct the stack. The stack cannot be empty. These cases
          are solved by [inversion]. In the [cons] case, we apply the
          induction hypothesis after which the proofs is finalised by
          the anitial assumption.

          [IUnOp] requires a single pass of the stack destruction,
          [IBinOp] requires two, and [IChoose] requires three. *)

      (repeat (destruct s; inversion H1; try apply IHinsns1, H1)).

    (** And we are done! *)

Qed.

(** Evaluating a list of instructions, where the prefix of the list is a
    compiled expression should be equivalent to evaluting the rest of
    the list of instructions with the value of the expression on top of
    the original stack.

    The proof is by induction on [e]. The [props] entry of the
    [stack_machine_functions] can be used in all cases to rewriting the
    terms. Rewriting with the induction hypotheses then solves each case.
 *)

(* Lemma stack_machine_compile : forall {A : Type} (funcs : stack_machine_functions)
                                     (e : exp) (insns : program) (s : list A),
    @stack_machine A funcs (compile e ++ insns) s =
    stack_machine funcs insns ((exp_to_elem funcs e) :: s).
Proof.
  intros A funcs e.
  UnpackFunctionPropositions funcs.
  induction e; (intros insns s; apply stack_machine_trans; simpl).
  - rewrite H_push. reflexivity.
  - rewrite H_unop, IHe. reflexivity.
  - rewrite H_binop, IHe1, IHe2. reflexivity.
  - rewrite H_if, IHe3, IHe2, IHe1. reflexivity.
Qed. *)

(** We now prove a general version of the main proposition of this
    section.

    The proof is by case analysis of the expression [e]. All cases can
    be solved by rewriting a number of times with
    [stack_machine_compile] and the propositions given by the
    [stack_machine_functions] record.

    Rewriting with [stack_machine_compile] is equivalent to stepping the
    stack machine through a complete expression. The [props] in the
    [stack_machine_functions] record gives us the properties needed to
    do this. *)

(* Lemma stack_machine_correct : forall {A : Type} (funcs : stack_machine_functions) (e : exp),
    @stack_machine A funcs (compile e) [] = Some [(exp_to_elem funcs) e].
Proof.
  intros A funcs e.
  UnpackFunctionPropositions funcs.
  destruct e; simpl; repeat rewrite stack_machine_compile; simpl; congruence.
Qed. *)

(** The final proposition of this section follows as a specialisation of
    the general lemma above: the composition of [vm] and [compile] are
    equivalent to [eval] for all expressions. *)
(*
Theorem vm_correct : forall e,
    vm (compile e) = Some (eval e).
Proof.
  intros e.
  unfold vm.
  rewrite stack_machine_correct.
  reflexivity.
Qed. *)

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

(** With the interpreter, compiler and virtual machine defined and proved
    correct, we now begin the work on the decompiler. *)

(** As with the virtual machine, we use the general stack machine as the
    foundation of the decompiler. The [exp_to_elem] function is [id]:
    compiling an expression and executing the result with the decompiler
    should be equivalent to the original expression. *)

Lemma decompile_functions_props : exp_to_elem_props id ENat EUnOp EBinOp (fun (cond e1 e2 : exp) => EIf cond e2 e1).
Proof.
  unfold exp_to_elem_props. auto.
Qed.

Definition decompile_functions :=
  {|
    constr_push  := ENat;
    constr_unop  := EUnOp;
    constr_binop := EBinOp;
    constr_if    := fun (cond e1 e2 : exp) => EIf cond e2 e1;
    exp_to_elem  := id;

  |}.

Definition decompile (insns : program) : option exp :=
    match stack_machine decompile_functions insns [] with
      | Some [res] => Some res
      | _ => None
    end.

(** We test the decompiler with some simple tests. *)

Example decompile_test_1 : decompile [IPush 42] =
                           Some (ENat 42).
Proof. simpl. reflexivity. Qed.

Example decompile_test_2
  : decompile [ IPush 2 ; IPush 40 ; IBinOp OPlus ] =
    Some (EBinOp OPlus (ENat 2) (ENat 40)).
Proof. simpl. reflexivity. Qed.

Example decompile_test_3
  : decompile [ IPush 1 ; IUnOp OSucc ; IPush 40 ; IBinOp OPlus ] =
    Some (EBinOp OPlus (EUnOp OSucc (ENat 1)) (ENat 40)).
Proof. simpl. reflexivity. Qed.

Example decompile_test_if_1
  : decompile [ IPush 4 ; IUnOp OSucc ; IPush 2 ; IUnOp OPred ; IPush 0 ; IUnOp OSucc ; IChoose ; IPush 41 ; IBinOp OPlus ] =
    Some ((EBinOp OPlus
            (EIf (EUnOp OSucc (ENat 0))
                 (EUnOp OPred (ENat 2))
                 (EUnOp OSucc (ENat 4)))
            (ENat 41))).
Proof. simpl. reflexivity. Qed.

(** It seems to work. *)

(** ** Left-inverse *)

(** We want the decompiler to be the left-inverse of the compiler,
    i.e. decompiling any compiled expression should yield a result equal
    to the original expression. *)

(** *** QuickChick intermezzo  *)

(** Before we give a formal proof of the proposition, we use QuickChick
    to check for counter-examples.

    We state the proposition: *)

(* Definition decompile_correct_prop (e : exp) := decompile (compile e) = (Some e)?.

(** And check it with QuickChick:  *)

QuickChick (forAllShrink (genSizedexp 2) shrinkExp vm_correct_prop).
 *)
(**
    +++ Passed 10000 tests (0 discards)

    It seems to work!
*)

(** *** A formal proof  *)

(** Proving that the result of decompiling any compiled expression is
    the original expression is closely related to the proposition
    [vm_correct] made for the virtual machine. Again, the proof follows
    from the more general proposition [stack_machine_correct]. *)
(*
Lemma decompile_correct : forall e,
    decompile (compile e) = Some e.
Proof.
  intros e.
  unfold decompile.
  rewrite stack_machine_correct.
  reflexivity.
Qed. *)

(** ** Right-inverse  *)

(** The decompiler should be the right-inverse of the compiler,
    i.e. compiling the result of any decompiled [program] should yield
    an identical [program]. *)

(** *** QuickChick intermezzo  *)

(** Again, we would like to check for counter-examples before proving
    the proposition formally. In order to use QuickChick for this, we
    need to do a bit of plumbing. *)

(** As with the [exp] type, we need to derive the [Show] typeclass for
    [instruction] and derive decidability of equality between two
    elements of this type. *)
(*
Derive Show for instruction. *)

(* Instance eq_dec_insns (insns1 insns2 : list instruction) : Dec (insns1 = insns2) := {}.
Proof. dec_eq. Defined.

(** We implement an instruction generator that generates programs
    guaranteed to not fail with a stack underflow. We do this by
    conditioning the generation of instructions based on the current
    size of the stack, e.g. if the stack size is lower than 2,
    generating a binary operation would cause a stack underflow; thus,
    we do not allow generation that instruction in this specific case.
*)

Fixpoint genSizedinsns_helper (size : nat) (s : nat) (insns : list instruction) :=
  match size with
    | O => ret insns
    | S size' =>
      freq [ (if (s = 1)? then 1 else 0, ret insns) ;
             (size,
               (n <- choose (1, 40) ;;
                (genSizedinsns_helper size' (s + 1) (IPush n :: insns)))) ;
             (if (s >= 1)? then 1 else 0,
               (op <- (elems [ OSucc ; OPred ]) ;;
               (genSizedinsns_helper size' s (IUnOp op :: insns)))) ;
             (if (s >= 2)? then 1 else 0,
               (op <- (elems [ OPlus ; OMult ; OMinus ]) ;;
               (genSizedinsns_helper size' (s - 1) (IBinOp op :: insns)))) ;
             (if (s >= 3)? then 1 else 0,
               (genSizedinsns_helper size' (s - 2) (IChoose :: insns)))
           ]
  end.

Fixpoint genSizedinsns (size : nat) : G (list instruction) :=
  rev_insns <- (genSizedinsns_helper size 0 []) ;;
  ret (rev rev_insns).

(** Not all programs generated by the generator can be decompiled
    successfully by [decompile]---some programs would decompile to more
    than one expression, which we disallow in the [decompile]
    function. To accomodate this, we state a predicate for successful
    decompilation using the [decompile] function.

    (Note: The predicate is a QuickChick Checker, since it returns a
    boolean as opposed to a Prop.)

 *)*)

Definition decompiles (insns : list instruction) :=
  match decompile insns with
    | Some _ => true
    | None => false
  end.

(** We are now able to state the proposition we want to check: the
    successful decompilation of a program implies that compiling the result
    of this is equal to the original program. *)

(* Definition compile_decompile_test (ins : list instruction) :=
  (decompiles ins) ==> match (decompile ins) with
                         | Some e => (compile e = ins)?
                         | None => false
                       end.
 *)
(** We check the proposition *)

(* QuickChick (forAll (genSizedinsns 5) compile_decompile_test). *)

(** and get

    +++ Passed 10000 tests (10547 discards)

    The proposition seems to hold. The discards come from generated
    programs that were discarded because they did not satisfy the
    [decompiles] predicate.
*)

(** *** An attempt at a formal proof *)

(** Compared to the proof of the left-inverse property, the formal proof
    of the right-inverse property is more difficult.

    (Note: We do not succeed in proving the proposition stated. We have
    kept the proof attempts in the document to illustrate our work and
    the thoughts made during this.)

    We try to prove the proposition by induction on [e]: *)
(*
Theorem compile_decompile : forall insns e,
    decompile insns = Some e -> compile e = insns.
Proof.
  intros. generalize dependent insns. induction e; intros insns H.
  - simpl. destruct insns.
    + inversion H.
    + destruct i.
      * destruct insns.
      * inversion H. reflexivity.
        -- destruct i.
           ++ destruct insns.
              ** inversion H.
              ** (* ? *)

(** At this point in the proof, we are stuck. We can keep on alternating
    between destructing [insns] and [i]. In the cases where [insns] is
    [nil], we can use inversion to prove the subgoals:

        H : decompile [IPush n0; IPush n1] = Some (ENat n)

    is obviously not a valid hypothesis. However, in the case where
    [insns] contains an instruction [i], we need to destruct this.  This
    cycle can keep on ad infinitum.

    The main issue with this approach for the proof is that the
    [decompile] function can not yield an answer until it has walked
    fully through the list, e.g. a single [IPush] instruction in the
    head of the list does not indicate that the decompiled expression
    should be a [ENat]; it might as well be that a [IUnOp] instruction
    follows, and the correct decompilation should be a [EUnOp] with an
    [ENat] as sub-expression.

    The logical way of getting around this problem would be by induction
    over the list of instructions. We abort the proof, and try this
    approach instead.  *)
Abort. *)

Theorem compile_decompile : forall insns e,
    decompile insns = Some e -> compile e = insns.
Proof.
  intro insns. induction insns; intros.
  - inversion H.
  - unfold decompile in H. destruct a. simpl in H.

(** It seems that we are stuck yet again. Being able to decompile a
    single instruction could help us progress in the proof. The
    [decompile] function is implemented using [stack_machine], which
    operates in single steps on the list of instructions. This is,
    however, not what we need. Decompiling a single instruction is not
    enough to uniquely determine the expression being decompiled.

    Let us abort this proof for now. *)
Abort.

(* ================================================================= *)
(** *** Inductive relations  *)

(** In an attempt to attack the proof of the right-inverse property of
    the decompiler from another angle, we define the compiler as an
    inductive relation between expressions and programs. *)

Inductive compileR : exp -> program -> Prop :=
  | C_ENat : forall (n : nat),
      compileR (ENat n) [IPush n]

  | C_EUnOp : forall (op : unop) (e : exp) (insns : program),
      compileR e insns
      -> compileR (EUnOp op e) (insns ++ [IUnOp op])

  | C_EBinOp : forall (op : binop) (e1 e2 : exp) (insns1 insns2 : program),
      compileR e1 insns1
      -> compileR e2 insns2
      -> compileR (EBinOp op e1 e2) (insns1 ++ insns2 ++ [IBinOp op])

  | C_EIf : forall (cond e1 e2 : exp) (cond_insns insns1 insns2 : program),
      compileR e1 insns1
      -> compileR e2 insns2
      -> compileR cond cond_insns
      -> compileR (EIf cond e1 e2) (insns2 ++ insns1 ++ cond_insns ++ [ IChoose ]).

(** A pair of an expression and a program should satisfy this relation
    iff the applying [compile] to the expression yields the program. *)

Lemma compile_iff_compileR : forall e insns,
    compileR e insns <-> compile e = insns.
Proof.
  intros e insns.
  split; intro H.
  - induction H; subst; reflexivity.
  - generalize dependent insns.
    induction e; intros insns H; subst; constructor; auto.
Qed.

(** Note that the inductive relation also describes decompilation of
    programs. *)

Definition decompileR (insns : program) (e : exp) : Prop :=
  compileR e insns.

(** This definition leads to [compileR] being equivalent to [decompileR]
    (with swapped arguments). *)

Lemma compileR_iff_decompileR : forall ins e,
    compileR e ins <-> decompileR ins e.
Proof.
  unfold decompileR.
  intros. reflexivity.
Qed.

(** We now want to prove that decompilation of a program [insns]
    yielding some expression [e] implies that [insns] and [e] satisfy
    the [decompileR] relation. Having this lemma at our hands would
    allow us to prove the [compile_decompile] lemma that we struggled
    with earlier.  *)

Lemma decompile_implies_decompileR : forall e insns,
   decompile insns = Some e -> decompileR insns e.
Proof.
  intros e insns. generalize dependent e. induction insns; intros.
  - inversion H.
  - destruct a.
    (** We are back in the same situation as before. Stuck, yet again. *)
Abort.

(** We abort the quest of proving the right-inverse property. It seems
    to be possible, but we need to know more of the properties of the
    [decompile] function in order to progress in these proofs.  *)

(* ================================================================= *)
(** * Eval not unique  *)

(** In this section, we show that for all expressions, there exists a
    different expression which evaluates to the same value. This makes
    it impossible to prove a right-hand version of [vm_correct], as
    opposed to [compile_decompile], which is the right-hand version of
    [decompile_correct].

    To prove this, we need to state a lemma to help us: *)

Lemma binop_cannot_contain_self : forall e e' op, e <> EBinOp op e' e.
  unfold not.
  induction e; intros; inversion H.
  - subst. apply IHe2 in H3. apply H3.
Qed.

(** We now formally state and prove the [eval_not_unique]
    proposition. *)

Lemma eval_not_unique : forall e1, exists e2, eval e1 = eval e2 /\ ~(e1 = e2).
Proof.
  intros e1.
  unfold not.
  destruct e1 eqn:He1; simpl; exists (EBinOp OPlus (ENat 0) e1);
    subst; split; simpl; (reflexivity || intros H; inversion H).
  - subst. apply binop_cannot_contain_self in H3. apply H3.
Qed.

End Main.

(* ================================================================= *)
(** * Adding a no-op instruction *)

(** In this last section, we show that adding a no-op instruction to the
    instruction set invalidates the right-inverse property of
    [decompile] for [compile]. We do this by reimplementing the compiler
    and decompiler and checking the right-inverse proposition with
    QuickChick, which should find a fairly trivial counter-example.

    Illustrating this requires duplicating a fair amount of code. We
    have added comments to show when new code is added.

*)

Module Nop.

  Inductive unop :=
    | OSucc : unop
    | OPred : unop.

  Inductive binop :=
    | OPlus : binop
    | OMult : binop
    | OMinus : binop.

  Inductive exp :=
    | ENat   : nat   -> exp
    | EUnOp  : unop  -> exp -> exp
    | EBinOp : binop -> exp -> exp -> exp
    | EIf    : exp   -> exp -> exp -> exp.

  Inductive instruction :=
  | IPush   : nat   -> instruction
  | IUnOp   : unop  -> instruction
  | IBinOp  : binop -> instruction
  | IChoose : instruction

  (** We add the IDont instruction. *)
  | IDont : instruction.

  Definition program := list instruction.
(*   Derive Show for unop.
  Derive Show for binop.
  Derive Show for exp.
 *)
  (* The compiler remains unchanged from the main program. There is no
     case where the compiler outputs an [IDont] instruction. This is an
     important point to note. *)
  Fixpoint compile (e : exp) : program :=
    match e with
    | ENat   n          => [ IPush n ]
    | EUnOp  op e       => compile e ++ [ IUnOp op ]
    | EBinOp op e1 e2   => compile e1 ++ compile e2 ++ [ IBinOp op ]
    | EIf    cond e1 e2 => compile e2 ++ compile e1 ++ compile cond ++ [ IChoose ]
    end.

  Definition exp_to_elem_props
             {A : Type}
             (exp_to_elem : exp -> A)
             exp_to_elem_push
             exp_to_elem_unop
             exp_to_elem_binop
             exp_to_elem_if : Prop :=

    (forall (n : nat),
        exp_to_elem (ENat n) = exp_to_elem_push n) /\

    (forall (e : exp) (op : unop),
        exp_to_elem (EUnOp op e) = exp_to_elem_unop op (exp_to_elem e)) /\

    (forall (e1 e2 : exp) (op : binop),
        exp_to_elem (EBinOp op e1 e2) = exp_to_elem_binop op (exp_to_elem e1) (exp_to_elem e2)) /\

    (forall (cond e1 e2 : exp),
        exp_to_elem (EIf cond e1 e2) =
        exp_to_elem_if (exp_to_elem cond) (exp_to_elem e2) (exp_to_elem e1)).

  Record stack_machine_functions {A : Type} :=
    {
      constr_push  : nat -> A;
      constr_unop  : unop -> A -> A;
      constr_binop : binop -> A -> A -> A;
      constr_if    : A -> A -> A -> A;
      exp_to_elem  : exp -> A;
      props        : @exp_to_elem_props A exp_to_elem constr_push constr_unop constr_binop constr_if
    }.

  Definition stack_machine_state_transition
             {A: Type}
             (funcs: stack_machine_functions)
             (insn: instruction)
             (s: list A) : option (list A) :=

    match insn, s with
    | IPush n, s'
      => Some ((constr_push funcs n) :: s')

    | IUnOp op, x :: s'
      => Some ((constr_unop funcs op x) :: s')

    | IBinOp op, y :: x :: s'
      => Some ((constr_binop funcs op x y) :: s')

    | IChoose, cond :: v2 :: v1 :: s'
      => Some ((constr_if funcs cond v1 v2) :: s')

    (** We add a new case to handle the [IDont] instruction by making no
       changes to the stack.  *)
    | IDont, s' => Some s'

    | _, _ => None
    end.

  Fixpoint stack_machine {A : Type} (funcs : stack_machine_functions) (insns : program) (s : list A) : option (list A) :=
    match insns with
    | insn :: insns' => match stack_machine_state_transition funcs insn s with
                        | Some s' => stack_machine funcs insns' s'
                        | _       => None
                        end
    | [] => Some s
    end.

  Lemma decompile_functions_props : exp_to_elem_props id ENat EUnOp EBinOp (fun (cond e1 e2 : exp) => EIf cond e2 e1).
  Proof.
    unfold exp_to_elem_props. auto.
  Qed.

  Definition decompile_functions :=
    {|
      constr_push  := ENat;
      constr_unop  := EUnOp;
      constr_binop := EBinOp;
      constr_if    := fun (cond e1 e2 : exp) => EIf cond e2 e1;
      exp_to_elem  := id;
      props        := decompile_functions_props;
    |}.

  Definition decompile (insns : program) : option exp :=
    match stack_machine decompile_functions insns [] with
    | Some [res] => Some res
    | _ => None
    end.

(*   Derive Show for instruction. *)
(*
  Fixpoint genSizedinsns_helper (size : nat) (s : nat) (insns : list instruction) :=
    match size with
    | O => ret insns
    | S size' =>
      freq [ (if (s = 1)? then 1 else 0, ret insns) ;
               (size,
                (n <- choose (1, 40) ;;
                   (genSizedinsns_helper size' (s + 1) (IPush n :: insns)))) ;
               (if (s >= 1)? then 1 else 0,
                (op <- (elems [ OSucc ; OPred ]) ;;
                    (genSizedinsns_helper size' s (IUnOp op :: insns)))) ;
               (if (s >= 2)? then 1 else 0,
                (op <- (elems [ OPlus ; OMult ; OMinus ]) ;;
                    (genSizedinsns_helper size' (s - 1) (IBinOp op :: insns)))) ;
               (if (s >= 3)? then 1 else 0,
                (genSizedinsns_helper size' (s - 2) (IChoose :: insns))) ;
               (** We add a case to generate the [IDont] instruction *)
               (size, genSizedinsns_helper size' s (IDont :: insns))
           ]
    end.

  Fixpoint genSizedinsns (size : nat) : G (list instruction) :=
    rev_insns <- (genSizedinsns_helper size 0 []) ;;
              ret (rev rev_insns).
 *)
  Definition decompiles (insns : list instruction) :=
    match decompile insns with
    | Some _ => true
    | None => false
    end.

(*   Instance eq_dec_insns (insns1 insns2 : list instruction) : Dec (insns1 = insns2) := {}.
  Proof. dec_eq. Defined.
 *)
  (** We state the right-inverse proposition again for use with
      QuickChick.  *)

(*   Definition compile_decompile_test (ins : list instruction) :=
    (decompiles ins) ==> match (decompile ins) with
                         | Some e => (compile e = ins)?
                         | None => false
                         end.
 *)
  (** Checking should result in an error as soon as a program contains
      the [IDont] instruction.  *)

(*   QuickChick (forAll (genSizedinsns 5) compile_decompile_test). *)

  (** QuickChick returns the expected results:

   > [IDont; IDont; IPush 20; IDont; IDont]

   > Failed after 1 tests and 0 shrinks. (0 discards)

   The right-inverse property does not hold.
  *)

  (** The reasoning behind the right-inverse property not holding for
      this language (with the added no-op) is that that there is no way
      of producing an [IDont] instruction from the compiler. Decompiling
      an expression simply ignores [IDont] instructions, causing there
      to be multiple programs decompiling to the same
      expression. Decompiling a program containing [IDont] instructions
      and compiling it imediately afterwards should yield the same
      program with the [IDont] instructions removed.

*)

End Nop.

From Coq Require Import Extraction.
From Coq Require Import List.
Declare ML Module "coq_spec".
From Hammer Require Import Hammer.
From Hammer Require Import Reconstr.
Add LoadPath "~/Documents/cpdt/src" as Cpdt.
Require Import Cpdt.CpdtTactics.

Extract Inductive bool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ].
Extract Inductive option => "Prelude.Maybe" [ "Prelude.Just" "Prelude.Nothing" ].
Extract Inductive unit => "()" [ "()" ].
Extract Inductive list => "([])" [ "([])" "(:)" ].
Extract Inductive prod => "(,)" [ "(,)" ].

Extract Inductive sumbool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ].
Extract Inductive sumor => "Prelude.Maybe" [ "Prelude.Just" "Prelude.Nothing" ].
Extract Inductive sum => "Prelude.Either" [ "Prelude.Left" "Prelude.Right" ].

Extract Inlined Constant andb => "(Prelude.&&)".
Extract Inlined Constant orb => "(Prelude.||)".
Extract Inlined Constant negb => "(Prelude.not)".
Extract Inlined Constant app => "(Prelude.++)".

(* DiscoverLemmas "DecompilerTest" Main.stack_machine_functions Main.eval  Main.compile . *)

(** END OF DOCUMENT. *)

(* Local Variables: *)
(* fill-column: 72 *)
(* End: *)


Require Import Arith.

Fixpoint sum_odd (n : nat) : nat :=
  match n with
  | O => O
  | S m => 1 + m + m +sum_odd m
  end.

Goal forall n, sum_odd n = n * n.
Proof.
  induction n.
  simpl.
  reflexivity.
  simpl.
  f_equal.
  rewrite IHn.
  ring.
Qed.

Require Import Lists.List.

Fixpoint sum (xs : list nat) : nat :=
  match xs with
  | nil => 0
  | x :: xs => x + sum xs
  end.

Theorem Pigeon_Hole_Principle :
  forall (xs : list nat), length xs < sum xs -> (exists x, 1 < x /\ In x xs).
Proof.
  intros.
  induction xs.
  contradict H.
  simpl.
  apply Lt.lt_irrefl.
  simpl in H.


Add LoadPath "C:\Users\Jonathan\source\repos\PLT-Coq\Software Foundations\Logical Foundations".
Require Export Induction.

Module NatList.

Inductive natprod : Type :=
  | pair : nat -> nat -> natprod.

Check (pair 3 5).

Definition fst (p: natprod) : nat :=
  match p with
  | pair x y => x
end.

Definition snd (p: natprod) : nat :=
  match p with
  | pair x y => y
end.

Compute (fst (pair 3 5)).

Notation "( x , y )" := (pair x y).

Compute (fst (3,5)).

Definition fst' (p: natprod) : nat :=
  match p with
  | (x,y) => x
end.

Definition snd' (p: natprod) : nat :=
  match p with
  | (x,y) => y
end.

Definition swap_pair (p: natprod) : natprod :=
  match p with
  | (x, y) => (y,x)
end.

Theorem surjective_pairing' : forall (n m : nat),
  (n, m) = (fst (n, m), snd (n, m)).
Proof.
  reflexivity.
Qed.

Theorem surjective_pairing_stuck: forall (p: natprod),
  p = (fst p, snd p).
Proof.
  simpl.
Abort.

Theorem surjective_pairing : forall (p: natprod),
  p = (fst p, snd p).
Proof.
  intros [n m].
  simpl.
  reflexivity.
Qed.

(* Exercise snd_fst_is_swap *)

Theorem snd_fst_is_swap : forall (p: natprod),
 (snd p, fst p) = swap_pair p.
Proof.
  intros [n m].
  simpl.
  reflexivity.
Qed.

(* Exercise fst_swap_is_snd *)

Theorem fst_swap_is_snd : forall (p: natprod),
  fst(swap_pair p ) = snd p.
Proof.
  intros [n m].
  simpl.
  reflexivity.
Qed.

(* Lists of Numbers *)

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

Definition mylist :=  cons 1 (cons 2 (cons 3 nil)).

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

Fixpoint repeat (n count: nat) : natlist :=
  match count with
  | O => nil
  | S count' => n :: (repeat n count')
end.

Fixpoint length (l: natlist) : nat :=
  match l with
  | nil => 0
  | h :: t => S (length t)
end.

Fixpoint app (l_1 l_2 : natlist) : natlist :=
  match l_1 with
  | nil => l_2
  | h :: t => h :: (app t l_2)
end.

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity. Qed.
Example test_app2 : nil ++ [4;5] = [4;5].
Proof. reflexivity. Qed.
Example test_app3 : [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity. Qed.

Definition hd (default: nat) (l : natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
end.

Definition tl (l: natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
end.

Example test_hd1 : hd 0 [1;2;3] = 1.
Proof. reflexivity. Qed.
Example test_hd2 : hd 0 [] = 0.
Proof. reflexivity. Qed.
Example test_tl : tl [1;2;3] = [2;3].
Proof. reflexivity. Qed.

(* Exercise list_funs *)

Fixpoint nonzeros (l : natlist) : natlist :=
  match l with
  | nil => nil
  | 0 :: t => nonzeros t
  | h :: t => h :: (nonzeros t)
end.

Example test_nonzeros : nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. reflexivity. Qed.

Fixpoint oddmembers (l : natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => match (evenb h) with
              | true => oddmembers t
              | false => h :: oddmembers t
              end
end.

Example test_oddmembers : oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof. reflexivity. Qed.

Definition countoddmembers (l: natlist) : nat := length (oddmembers l).

Example test_coundoddmembers1 : countoddmembers [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.

Example test_countoddmembers2: countoddmembers [0;2;4] = 0.
Proof. reflexivity. Qed.

Example test_countmembers3: countoddmembers nil = 0.
Proof. reflexivity. Qed.

(* Exercise alternate *)
Fixpoint alternate (l_1 l_2 : natlist) : natlist :=
  match l_1 with
  | nil => l_2
  | h_1 :: t_1 => match l_2 with
              | nil => h_1 :: t_1
              | h_2 :: t_2 => h_1 :: h_2 :: (alternate t_1 t_2)
              end
end.

Example test_alternate1: alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof. reflexivity. Qed.
Example test_alternate2: alternate [1] [4;5;6] = [1;4;5;6].
Proof. reflexivity. Qed.
Example test_alternate3 : alternate [1;2;3] [4] = [1;4;2;3].
Proof. reflexivity. Qed.
Example test_alternate4: alternate [] [20;30] = [20;30].
Proof. reflexivity. Qed.

Definition bag := natlist.

(* Exercise bag_functions *)

Fixpoint count (v: nat) (s:bag) : nat :=
  match s with
  | nil => 0
  | h :: t => match (beq_nat v h) with
              | true => 1 + (count v t)
              | false => 0 + (count v t)
  end
end.

Example test_count1 : count 1 [1;2;3;1;4;1] = 3.
Proof. reflexivity. Qed.
Example test_count2 : count 6 [1;2;3;1;4;1] = 0.
Proof. reflexivity. Qed.

Definition sum : bag -> bag -> bag := app.

Example test_sum1 : count 1 (sum [1;2;3] [1;4;1]) = 3.
Proof. reflexivity. Qed.

Definition add (v: nat) (s: bag) : bag := v :: s.

Example test_add1 : count 1 (add 1 [1;4;1]) = 3.
Proof. reflexivity. Qed.

Example test_add2 : count 5 (add 1 [1;4;1]) = 0.
Proof. reflexivity. Qed.

Definition member (v: nat) (s: bag) : bool := blt_nat 0 (count v s).

Example test_member : member 1 [1;4;1] = true.
Proof. reflexivity. Qed.

Example test_member2 : member 2 [1;4;1] = false.
Proof. reflexivity. Qed.

(* Exercise bag_more_functions *)

Fixpoint remove_one (v : nat) (s : bag) : bag :=
  match s with
  | nil => nil
  | h :: t => match (beq_nat h v) with
              | true => t
              | false => h :: (remove_one v t)
  end
end.

Example test_remove_one1: count 5 (remove_one 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_one2 : count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_one3 : count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.

Example test_remove_one4 : count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
Proof. reflexivity. Qed.

Fixpoint remove_all (v: nat) (s: bag) : bag :=
  match s with
  | nil => nil
  | h :: t => match (beq_nat h v) with
              | true => remove_all v t
              | false => h :: remove_all v t
  end
end.

Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.

Example test_remove_all4 : count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
Proof. reflexivity. Qed.

Fixpoint subset (s_1: bag) (s_2: bag) : bool :=
  match s_1 with
  | nil => true
  | h :: t => andb (member h s_2) (subset t (remove_one h s_2))
end.

Example test_subset1: subset [1;2] [2;1;4;1] = true.
Proof. reflexivity. Qed.

Example test_subset2: subset [1;2;2] [2;1;4;1] = false.
Proof. reflexivity. Qed.

(* Reasoning about lists *)

Theorem nil_app : forall l:natlist, [] ++ l = l.
Proof. reflexivity. Qed.

Theorem tl_length_pred : forall l: natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  - reflexivity.
  - reflexivity. Qed.

(* Induction on lists *)

Theorem app_assoc : forall l_1 l_2 l_3 : natlist,
  (l_1 ++ l_2) ++ l_3 = l_1 ++ (l_2 ++ l_3).
Proof.
  intros l_1 l_2 l_3. induction l_1 as [| n l' IHl1'].
  - reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity.
Qed.

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => rev t ++ [h]
end.

Example test_rev1 : rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.

Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.

Theorem rev_length_firsttry : forall l: natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - reflexivity.
  - simpl. rewrite <- IHl'.
Abort.

Theorem app_length : forall l_1 l_2 : natlist,
  length (l_1 ++ l_2) = (length l_1) + (length l_2).
Proof.
  intros l_1 l_2. induction l_1 as [| n l_1 IHl'].
  - reflexivity.
  - simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem rev_length : forall l: natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - reflexivity.
  - simpl. rewrite -> app_length, plus_comm.
    simpl. rewrite -> IHl'. reflexivity.
Qed.

(* Exercise list_exercises *)

Theorem app_nil_r : forall l : natlist, l ++ [] = l.
Proof.
  induction l.
  - reflexivity.
  - intros. simpl. rewrite -> IHl. reflexivity.
Qed.

Theorem rev_app_distr:  forall l_1 l_2 : natlist,
  rev (l_1 ++ l_2 ) = rev l_2 ++ rev l_1.
Proof.
  induction l_1.
  - intros.
    rewrite nil_app.
    simpl.
    rewrite app_nil_r.
    reflexivity.
  - intros.
    simpl.
    rewrite IHl_1.
    rewrite app_assoc.
    reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  induction l as [| n l' IHl'].
  - reflexivity.
  - simpl. rewrite rev_app_distr. rewrite IHl'. reflexivity.
Qed.

Theorem app_assoc4 : forall l_1 l_2 l_3 l_4 : natlist,
  l_1 ++ (l_2 ++ (l_3 ++ l_4)) = ((l_1 ++ l_2) ++ l_3) ++ l_4.
Proof.
  intros. rewrite -> app_assoc. rewrite -> app_assoc. reflexivity.
Qed.

Lemma nonzeros_app : forall l_1 l_2 : natlist,
  nonzeros (l_1 ++ l_2) = (nonzeros l_1) ++ (nonzeros l_2).
Proof.
  intros. induction l_1 as [| n l_1' IHl1'].
  + reflexivity.
  + destruct n as [| n'].
    - simpl. rewrite -> IHl1'. reflexivity.
    - simpl. rewrite -> IHl1'. reflexivity.
Qed.

(* Exercises beq_natlist *)
Fixpoint beq_natlist (l_1 l_2 : natlist) : bool :=
  match l_1 with
  | [] => beq_nat (length l_2) 0
  | h_1 :: t_1 => match l_2 with
                  | [] => false
                  | h_2 :: t_2 => match beq_nat h_1 h_2 with
                                  | true => beq_natlist t_1 t_2
                                  | false => false
                  end
  end
end.

Example test_beq_natlist : (beq_natlist nil nil = true).
Proof. reflexivity. Qed.

Example test_beq_natlist2 : beq_natlist [1;2;3] [1;2;3] = true.
Proof. reflexivity. Qed.

Example test_beq_natlist3: beq_natlist [1;2;3] [1;2;4] = false.
Proof. reflexivity. Qed.

Theorem beq_nat_refl: forall n, beq_nat n n = true.
Proof.
  induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem beq_natlist_refl : forall l: natlist,
  true = beq_natlist l l.
Proof.
  induction l as [|n' l' IHl'].
  + reflexivity.
  + simpl. rewrite -> beq_nat_refl. rewrite -> IHl'. reflexivity.
Qed.

(* Exercise  count_member_nonzero *)
Theorem count_member_nonzero : forall (s: bag),
  leb 1 (count 1 (1 :: s)) = true.
Proof.
  intros. reflexivity.
Qed.

Theorem ble_n_Sn: forall n : nat,
  leb n (S n) = true.
Proof.
  intros n. induction n as [| n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite IHn'. reflexivity.
Qed.

Theorem remove_does_not_increase_count : forall (s: bag),
  leb (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  induction s as [|n s' IHs'].
  - reflexivity.
  - induction n as [|n' IHn'].
    + simpl. rewrite -> ble_n_Sn. reflexivity.
    + simpl. rewrite -> IHs'. reflexivity.
Qed.

Theorem rev_injective : forall (l_1 l_2 : natlist),
  rev l_1 = rev l_2 -> l_1 = l_2.
Proof.
  intros.
  rewrite <- rev_involutive.
  rewrite <- H.
  rewrite -> rev_involutive.
  reflexivity.
Qed.

Fixpoint nth_bad (l: natlist) (n: nat) : nat :=
  match l with
  | nil => 42
  | a :: l' => match beq_nat n 0 with
                | true => a
                | false => nth_bad l' (pred n)
  end
end.

Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

Fixpoint nth_error (l: natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => match beq_nat n O with
                | true => Some a
                | false => nth_error l' (pred n)
  end
end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.

Example test_nth_error2: nth_error [4;5;6;7] 3 = Some 7.
Proof. reflexivity. Qed.

Example test_nth_error3 : nth_error [4;5;6;7] 9 = None.
Proof. reflexivity. Qed.

Fixpoint nth_error' (l: natlist) (n : nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => if beq_nat n O then Some a else nth_error' l' (pred n)
end.

Definition option_elim (d: nat) (o : natoption) : nat :=
  match o with
  | Some n' => n'
  | None => d
end.

(* Exercise hd_error *)

Definition hd_error (l : natlist): natoption :=
  match l with
  | [] => None
  | a :: t' => Some a
end.

Example test_hd_error1: hd_error [] = None.
Proof. reflexivity. Qed.

Example test_hd_error2 : hd_error [1] = Some 1.
Proof. reflexivity. Qed.

Example test_hd_error3 : hd_error [5;6] = Some 5.
Proof. reflexivity. Qed.

(* Exercise option_elim_hd *)

Theorem option_elim_hd : forall (l: natlist) (default: nat),
  hd default l = option_elim default (hd_error l).
Proof.
  induction l as [| n l' IHl'].
  - reflexivity.
  - reflexivity.
Qed.

(* Partial Maps *)

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id (x_1 x_2 : id) :=
  match x_1, x_2 with
  | Id n_1, Id n_2 => beq_nat n_1 n_2
end.

Theorem beq_id_refl : forall x, true = beq_id x x.
Proof.
  destruct x.
  simpl.
  rewrite beq_nat_refl.
  reflexivity.
Qed.
End NatList.
Module PartialMap.
Export NatList.

Inductive partial_map : Type :=
  | empty : partial_map
  | record : id -> nat -> partial_map -> partial_map.

Definition update (d: partial_map) (x: id) (value : nat) : partial_map :=
  record x value d.

Fixpoint find (x: id) (d : partial_map) : natoption :=
  match d with
  | empty => None
  | record y v d' => if beq_id x y
                      then Some v
                      else find x d'
end.

(* Exercise update_eq *)

Theorem update_eq : forall (d: partial_map) (x : id) (v: nat),
  find x (update d x v) = Some v.
Proof.
  intros.
  simpl.
  rewrite <- beq_id_refl.
  reflexivity.
Qed.

(* Exercise udpate_neq *)

Theorem update_neq : forall (d: partial_map) (x y : id) (o : nat),
  beq_id x y = false -> find x (update d y o) = find x d.
Proof.
  intros.
  simpl.
  rewrite -> H.
  reflexivity.
Qed.
End PartialMap.


(**
Coq/SSReflect/MathComp による定理証明

3.15 コマンド Record, Canonical
======
2018_04_22 @suharahiromichi
 *)

From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Print All.

(**
# 3.15.1 コマンド Record - Magma マグマ の定義
*)

(**
## 例1: 集合Mと、M上の二項演算*の組 [(M, * )] Magma の形式化
*)
Record magma : Type :=                      (* 型クラス *)
  Magma {
      carrier : Type;
      operator : carrier -> carrier -> carrier
    }.

Check magma : Type.
Check Magma : forall carrier : Type, (carrier -> carrier -> carrier) -> magma.

(** ****************** *)
(** Magma [(Prop, /\)] *)
(** ****************** *)
Check and.                             (* Prop -> Prop -> Prop *)
Definition prop_and_magma := @Magma Prop and. (* 型インスタンス *)

Print prop_and_magma.
(** [{| carrier := Prop; operator := and |} : magma] *)
Compute carrier prop_and_magma.      (* 台 Prop を取り出す。 *)
Compute @operator prop_and_magma.    (* オペレータ and を取り出す。 *)

Lemma PropMagmaFalse (x y : carrier prop_and_magma) :
  operator x False -> y.
Proof.
  rewrite /=; by case.
Qed.

Lemma PropMagmaFalse'' (x y : carrier prop_and_magma) :
  @operator prop_and_magma x False -> y.
Proof.
  rewrite /=; by case.
Qed.

(** 同じことを Magma を使わずに定義する。 *)
Lemma PropFalse (x y : Prop) : and x False -> y.
Proof.
    by case.
Qed.

(** **************** *)
(** Magma [(nat, +)] *)
(** **************** *)
Definition nat_plus_magma := @Magma nat plus. (* 型インスタンス *)

Print nat_plus_magma.
(** [{| carrier := nat; operator := Init.Nat.add |} : magma] *)
Compute carrier nat_plus_magma.     (* 台 nat を取り出す。 *)
Compute @operator nat_plus_magma.   (* オペレータ plus を取り出す。 *)

Lemma NatMagmaPlus (x y : carrier nat_plus_magma) :
  operator x y = x + y.
Proof.
  rewrite /=; by [].
Qed.

Lemma NatMagmaPlus'' (x y : carrier nat_plus_magma) :
  @operator nat_plus_magma x y = x + y.
Proof.
  rewrite /=; by [].
Qed.

(** 同じことを Magma を使わずに定義する。 *)
Lemma NatPlus (x y : nat) :
  plus x y = x + y.
Proof.
  done.
Qed.

(**
## 例2: 代数構造の階層、半群の例
*)
Record semigroup : Type :=                  (* 型クラス *)
  Semigroup {
      scarrier : magma;
      assoc : forall a b c : carrier scarrier,
          operator a (operator b c)
          = operator (operator a b) c
    }.
(**
carrier の型引数が省略されている。
[[
      assoc : forall a b c : carrier scarrier,
          @operator scarrier a (@operator scarrier b c)
          = @operator scarrier (@operator scarrier a b) c
]]
*)

(** *************** *)
(** 半群 [(nat, +)] *)
(** *************** *)
Check addnA : associative addn.
Check addnA 1 2 3 : 1 + (2 + 3) = 1 + 2 + 3.

Definition nat_plus_semigroup := @Semigroup nat_plus_magma addnA. (* 型インスタンス *)

Print nat_plus_semigroup.
(** [{| scarrier := nat_plus_magma; assoc := addnA |}] *)

(**
# 3.15.2 コマンド Canonical
*)

Canonical nat_plus_magma.
Print Canonical Projections.                (* カノニカルの表示 *)
(** [nat <- carrier ( nat_plus_magma )]  *)

Lemma NatMagmaPlus' (x y : nat) :
  operator x y = x + y.
Proof.
  rewrite /=; by [].
Qed.

(* ********* *)

Canonical nat_plus_semigroup.
Print Canonical Projections.                (* カノニカルの表示 *)
(** [nat_plus_magma <- scarrier ( nat_plus_semigroup )] *)

Notation "a ^^ b" := (@operator _ a b) (at level 30, right associativity).
(** 次でも同じ： *)
(** [Notation "a ^^ b" := (operator a b) (at level 30, right associativity).] *)

(** [Canonical nat_plus_magma]  がなくても良い例  *)
(** [Canonical nat_plus_semigroup] がなくても良い例  *)
Section TEST1.
  Variable a b : carrier nat_plus_magma.

  Check @operator nat_plus_magma :
    carrier nat_plus_magma -> carrier nat_plus_magma -> carrier nat_plus_magma.
  Check @operator nat_plus_magma a b : carrier nat_plus_magma.
  Check a ^^ b : carrier nat_plus_magma.

  Lemma natPlusExample1 (x y z : carrier nat_plus_magma) :
    x ^^ (y ^^ z) = (x ^^ y) ^^ z.
  Proof.
      by rewrite (@assoc nat_plus_semigroup).
  Qed.
End TEST1.

(** [Canonical nat_plus_magma] は必要。 *)
(** [Canonical nat_plus_semigroup] がなくても良い例  *)
Section TEST2.
  Variable a b : nat.

  Check @operator nat_plus_magma :
    carrier nat_plus_magma -> carrier nat_plus_magma -> carrier nat_plus_magma.
  Compute carrier nat_plus_magma.           (* nat *)
  Check @operator nat_plus_magma : nat -> nat -> nat.
  Check @operator nat_plus_magma a b : carrier nat_plus_magma.

  Check operator a b : carrier nat_plus_magma. (* canonical 宣言が必要 *)
  Check a ^^ b  : carrier nat_plus_magma.

  Check @operator nat_plus_magma a b : nat.
  Check operator a b : nat.
  Check a ^^ b  : nat.

  Lemma natPlusExample2 (x y z : nat) :
    x ^^ (y ^^ z) = (x ^^ y) ^^ z.
  Proof.
      by rewrite (@assoc nat_plus_semigroup).
  Qed.
End TEST2.

(** [Canonical nat_plus_magma] は必要。 *)
(** [Canonical nat_plus_semigroup]  は必要。 *)
Lemma natPlusExample3 (x y z : nat) :
  x ^^ (y ^^ z) = (x ^^ y) ^^ z.
Proof.
    by rewrite assoc.
Qed.

(**
# 補足
*)

(** ****************** *)
(** Magma [(Prop, /\)] *)
(** ****************** *)

(**
既存の [^] の定義により、Propに対する演算ができない（？）ので、
全体に対して [^^] を使うようにした。
 *)

(** [Canonical prop_and_magma] がなくても良い例  *)
Lemma PropMagmaFalse1 (x y : carrier prop_and_magma) :
  x ^^ False -> y.
Proof.
  rewrite /=; by case.
Qed.

(* ********* *)
(* ********* *)

Canonical prop_and_magma.
Print Canonical Projections.                (* カノニカルの表示 *)
(** [Prop <- carrier ( prop_and_magma )] *)

Lemma PropMagmaFalse2' (x y : Prop) :
  operator x False -> y.
Proof.
  rewrite /=; by case.
Qed.

(** [Canonical prop_and_magma] が必要 *)
Lemma PropMagmaFalse2 (x y : Prop) :
  x ^^ False -> y.
Proof.
  rewrite /=; by case.
Qed.

(** END *)