Require Import List.

Definition char := nat.
Definition string := list char.

(* regular expressions defined as an inductive type *)
Inductive Exp : Set :=
  | Lit : char -> Exp
  | And : Exp -> Exp -> Exp
  | Or  : Exp -> Exp -> Exp
  | Many: Exp -> Exp.

(* each regular expression has an associated 'language', namely a set of
strings which are 'recognized' by the regular expression. Normally, this set
of strings can easily be defined recursively. However, it is not finite in
general. Here we are attempting to define this set of strings as a type
'Language r'. So we are defining a family of types (indexed by a regular
expression) with an inductive definition. Now given a regular expression
r:Exp, the type 'Language r' is not quite a set of strings. It is more like
an inductive type, i.e. some free algebra of some sort. However, any element
of type Language r can easily be translated into a string via some
'semantics' function defined below *)

Inductive Language : Exp -> Set :=
  | LangLit     : forall c:char, Language (Lit c)
  | LangAnd     : forall r1 r2: Exp,
                    Language r1  -> Language r2  -> Language (And r1 r2)
  | LangOrLeft  : forall r1 r2: Exp, Language r1  -> Language (Or r1 r2)
  | LangOrRight : forall r1 r2: Exp, Language r2  -> Language (Or r1 r2)
  | LangEmpty   : forall r: Exp, Language (Many r)
  | LangMany    : forall r: Exp,
                    Language (Many r) -> Language r -> Language (Many r).

Fixpoint semantics {r:Exp}(s:Language r) : string :=
  match s with
    | LangLit c           => (c::nil)
    | LangAnd r1 r2 s1 s2 => semantics s1 ++ semantics s2
    | LangOrLeft r1 r2 s  => semantics s
    | LangOrRight r1 r2 s => semantics s
    | LangEmpty r         => nil
    | LangMany r s1 s2    => semantics s1 ++ semantics s2
  end.

(* We now attempt to formalize the relation 'recognize' which expresses the
fact that a string is an element of the language defined by a regular expression.
Since we have already formalized the notion of 'Language', the fact that s:string
is 'recognized' by a regular expression r (i.e. that it belongs to its language),
can be expressed as the fact that s = semantics x for some x:Language r. Rather
than proceeding this way, we now attempt to define the 'recognize' relation
directly as an inductive predicate. We shall then attempt to prove the equivalence
between the two approaches. *)

Inductive recognize : Exp -> string -> Prop :=
  | recogLit    : forall c:char, recognize (Lit c) (c::nil)
  | recogAnd    : forall (r1 r2:Exp)(s1 s2:string),
      recognize r1 s1 -> recognize r2 s2 -> recognize (And r1 r2) (s1 ++ s2)
  | recogOrLeft : forall (r1 r2:Exp)(s :string),
      recognize r1 s -> recognize (Or r1 r2) s
  | recogOrRight: forall (r1 r2:Exp)(s :string),
      recognize r2 s -> recognize (Or r1 r2) s
  | recogEmpty  : forall (r:Exp), recognize (Many r) nil
  | recogMany   : forall (r:Exp) (s1 s2: string),
      recognize (Many r) s1 -> recognize r s2 -> recognize (Many r) (s1 ++ s2).

(* First we show that a recognized string is part of the language *)
(* The proof flows naturally from an induction on the inductive predicate *)
Lemma recognize_imp_in_language: forall (r:Exp)(s:string),
  recognize r s -> (exists x:Language r, semantics x = s).
Proof.
  (* induction on the recognize predicate *)
  intros r s H. generalize H. elim H.

  clear H r s. intros c H. exists (LangLit c). simpl. reflexivity.

  clear H r s. intros r1 r2 s1 s2 H1 H1' H2 H2' H.
  elim H1'. intros x1 S1. clear H1'.
  elim H2'. intros x2 S2. clear H2'.
  exists (LangAnd r1 r2 x1 x2). simpl. rewrite S1, S2. reflexivity.
  exact H2. exact H1.

  clear H r s. intros r1 r2 s H H' H0. clear H0.
  elim H'. intros x S. exists (LangOrLeft r1 r2 x). simpl. exact S. exact H.

  clear H r s. intros r1 r2 s H H' H0. clear H0.
  elim H'. intros x S. exists (LangOrRight r1 r2 x). simpl. exact S. exact H.

  clear H r s. intros r H. exists (LangEmpty r). simpl. reflexivity.

  clear H r s. intros r s1 s2 H1 H1' H2 H2' H.
  elim H1'. intros x1 S1. clear H1'.
  elim H2'. intros x2 S2. clear H2'.
  exists (LangMany r x1 x2). simpl. rewrite S1, S2. reflexivity.
  exact H2. exact H1.
Qed.

(* Next we show that all strings of the language are recognized *)
(* very simple coq proof with an induction on x                 *)
Lemma recognize_language: forall (r:Exp)(x: Language r),
  recognize r (semantics x).
Proof.
  (* induction on x *)
  intros r x. elim x.
  (* x = LangLit c *)
  clear r x. simpl. apply recogLit.
  (* x = LangAnd r1 r2 x1 x2 *)
  clear r x. intros r1 r2 x1 H1 x2 H2. simpl.
  apply recogAnd. exact H1. exact H2.
  (* x = LangOrLeft r1 r2 x1 *)
  clear r x. intros r1 r2 x1 H1. simpl.
  apply recogOrLeft. exact H1.
  (* x = LangOrRight r1 r2 x2 *)
  clear r x. intros r1 r2 x2 H2. simpl.
  apply recogOrRight. exact H2.
  (* x = LangEmpty r *)
  clear r x. intros r. simpl. apply recogEmpty.
  (* x = LangMany r x1 x2 *)
  clear r x. intros r x1 H1 x2 H2. simpl.
  apply recogMany. exact H1. exact H2.
Qed.

(* re-formatting previous lemma *)
Lemma in_language_imp_recognize: forall (r:Exp)(s:string),
  (exists x:Language r, semantics x = s) -> recognize r s.
Proof.
  intros r s H. elim H. intros x Hx. clear H. rewrite <- Hx.
  apply recognize_language.
Qed.

(* This efectively show the equivalence between the two approaches *)
Lemma in_language_is_recognize: forall (r:Exp)(s:string),
  (exists x:Language r, semantics x = s) <-> recognize r s.
Proof.
  intros r s. split. apply in_language_imp_recognize.
  apply recognize_imp_in_language.
Qed.

(* At this stage, we have defined what a regular expression is as well
as what it means for a string to be recognized by a regular expression.
Now an obvious question arises: given a regular expression (r:Exp) and
a string (s:string), how do I decide whether s is recognized by r?
From a mathematical point of view, there exists a function
f : Exp -> string -> bool which returns 1 if and only if s belongs to
the language of r (i.e. s = semantics x for some x:Language r)
However, we would like a program which implements such a function *)

(*
(* this definition is needed for the next lemma *)
Definition Lang_of_Lit_Pred {r:Exp}(x:Language r) := (* major trick *)
  match r (* return Language r -> Prop *) with
   | Lit c => fun x => x = LangLit c
   | other => fun _ => True
 end x.

Lemma Lang_of_Lit: forall (c:char)(x:Language (Lit c)),
  x = LangLit c.
Proof.
  intros c x. fold (Lang_of_Lit_Pred x).
  cut(forall (r:Exp)(x:Language r), Lang_of_Lit_Pred x). eauto.
  clear c x. intros r x. destruct x; simpl; auto.
Qed.

(* this definition is needed for the next lemma *)
Definition Lang_of_And_Pred {r:Exp}(x:Language r) := (* major trick *)
  match r with
    | And r1 r2   => fun x =>
        exists (x1: Language r1)(x2: Language r2), x = LangAnd r1 r2 x1 x2
    | other       => fun _ =>
        True
  end x.

Lemma Lang_of_And: forall (r1 r2: Exp)(x: Language (And r1 r2)),
  exists (x1: Language r1)(x2: Language r2),
  x = LangAnd r1 r2 x1 x2.
Proof.
  intros r1 r2 x. fold (Lang_of_And_Pred x).
  cut(forall (r:Exp)(x:Language r), Lang_of_And_Pred x). eauto.
  clear r1 r2 x. intros r x. destruct x; simpl; eauto.
Qed.

(* this definition is needed for the next lemma *)
Definition Lang_of_Or_Pred {r:Exp}(x:Language r) := (* major trick *)
  match r with
    | Or r1 r2   => fun x =>
        (exists (x1: Language r1), x = LangOrLeft r1 r2 x1) \/
        (exists (x2: Language r2), x = LangOrRight r1 r2 x2)
    | other       => fun _ =>
        True
  end x.

Lemma Lang_of_Or: forall (r1 r2: Exp)(x: Language (Or r1 r2)),
  (exists (x1: Language r1), x = LangOrLeft r1 r2 x1) \/
  (exists (x2: Language r2), x = LangOrRight r1 r2 x2).
Proof.
  intros r1 r2 x. fold (Lang_of_Or_Pred x).
  cut(forall (r:Exp)(x:Language r), Lang_of_Or_Pred x). eauto.
  clear r1 r2 x. intros r x. destruct x; simpl; eauto.
Qed.

(* this definition is needed for the next lemma *)
Definition Lang_of_Many_Pred {r:Exp}(x:Language r) := (* major trick *)
  match r with
    | Many r'     => fun x =>
        (x = LangEmpty r') \/
        (exists (x1: Language (Many r'))(x2: Language r'),
          x = LangMany r' x1 x2)
    | other       => fun _ =>
        True
  end x.

Lemma Lang_of_Many: forall (r: Exp)(x: Language (Many r)),
  (x = LangEmpty r) \/
  (exists (x1: Language (Many r))(x2: Language r),
    x = LangMany r x1 x2).
Proof.
  intros r x. fold (Lang_of_Many_Pred x).
  cut (forall (r: Exp)(x:Language r), Lang_of_Many_Pred x). eauto.
  clear r x. intros r x. destruct x; simpl; eauto.
Qed.

*)


Module ForallExists.

Require Import Classical.

Theorem forall_exists : forall D, forall P : D -> Prop,
  ~ (forall x : D, P x) <-> (exists x : D, ~ P x).
split.
intros.
Check Peirce.
apply Peirce.
intros.
exfalso.
apply H.
intros.
apply Peirce.
intros.
exfalso.
apply H0.
exists x.
assumption.
intros.
unfold not.
intros.
elim H.
intros.
assert (P x).
apply H0.
contradiction.
Qed.

Print forall_exists.

End ForallExists.


Require Import Verse.Word.
Require Import Verse.NFacts.

Require Import Coq.setoid_ring.Ring_theory.
Require Import BinNums.
Require Import BinInt.

Require Import NArith.

Local Notation wO   := (bits (N2Bv_gen _ 0)).
Local Notation wI   := (bits (N2Bv_gen _ 1)).
Local Notation wadd := (numBinOp N.add).
Local Notation wmul := (numBinOp N.mul).
Local Notation weq  := (@eq (Word.t _)).

Section WordRing.

  Variable n : nat.

  Infix "==" := weq (at level 70).

  Ltac crush_mod_ring :=
    repeat (intros []); unfold numBinOp, numUnaryOp;
    apply f_equal;
    apply Bv2N_inj; rewrite ?Bv2N_N2Bv_gen_mod;
    simpl;
    try (rewrite ?N.add_mod_idemp_l);
    try rewrite ?N.add_mod_idemp_r;
    try rewrite ?N.mul_mod_idemp_l;
    try rewrite ?N.mul_mod_idemp_r;
    try rewrite N.mul_1_l;
    try rewrite N.mul_add_distr_l;
    try rewrite N.mul_add_distr_r;
    trivial;
    try rewrite N.add_assoc +
    rewrite N.mul_assoc +
    rewrite N.add_comm  +
    rewrite N.mul_comm  +
    rewrite N.mod_small;
    trivial;
    try (discriminate + apply two_power_nonzero + apply Bv2N_small).

  Lemma wadd_0_l : forall (x : Word.t n), wadd wO x == x.
  Proof.
    crush_mod_ring.
  Qed.

  Lemma wadd_comm : forall (x y : Word.t n), wadd x y == wadd y x.
  Proof.
    crush_mod_ring.
  Qed.

  Lemma wadd_assoc : forall (x y z : Word.t n), wadd x (wadd y z) == wadd (wadd x y) z.
  Proof.
    crush_mod_ring.
  Qed.

  Lemma wmul_1_l : forall x : Word.t n, wmul wI x == x.
  Proof.
    crush_mod_ring.
  Qed.

  Lemma wmul_0_l : forall x : Word.t n, wmul wO x == wO.
  Proof.
    crush_mod_ring.
  Qed.

  Lemma wmul_comm : forall x y : Word.t n, wmul x y == wmul y x.
  Proof.
    crush_mod_ring.
  Qed.

  Lemma wmul_assoc : forall x y z : Word.t n, wmul x (wmul y z) == wmul (wmul x y) z.
  Proof.
    crush_mod_ring.
  Qed.

  Lemma wdistr_l : forall x y z : Word.t n, wmul (wadd x y) z == wadd (wmul x z) (wmul y z).
  Proof.
    crush_mod_ring.
  Qed.

  Definition mod_semi_ring : semi_ring_theory wO wI wadd wmul weq :=
    {|
      SRadd_0_l := wadd_0_l;
      SRadd_comm := wadd_comm;
      SRadd_assoc := wadd_assoc;
      SRmul_1_l := wmul_1_l;
      SRmul_0_l := wmul_0_l;
      SRmul_comm := wmul_comm;
      SRmul_assoc := wmul_assoc;
      SRdistr_l := wdistr_l
    |}.

  Add Ring Word : mod_semi_ring.

End WordRing.


Require Import Arith Omega.

Definition divides (n m:nat) := exists p:nat, p*n = m.

Ltac first_step :=
  unfold divides;
  intros.

Lemma divides_O : forall n:nat, divides n 0.
  first_step.
  exists 0.
  ring.
Qed.

Lemma divides_plus : forall n m:nat, divides n m -> divides n (n+m).
  first_step.
  destruct H.
  exists (S x).
  rewrite mult_succ_l.
  omega.
Qed.

Lemma not_divides_plus : forall n m:nat, ~ divides n m -> ~ divides n (n+m).
  first_step.
  unfold not in *.
  intros.
  apply H.
  destruct H0.
  exists(x - 1).
  rewrite mult_minus_distr_r.
  omega.
Qed.

Lemma not_divides_lt : forall n m:nat, 0<m ->  m<n -> ~ divides n m.
  first_step.
  unfold not.
  intros.
  destruct H1.
  rewrite <- H1 in *.
  destruct x.
  omega.
  clear H H1.
  absurd(S x * n < n).
  apply le_not_lt.
  rewrite mult_succ_l.
  apply le_plus_r.
  assumption.
Qed.

Lemma not_lt_2_divides : forall n m:nat, n <> 1 -> n < 2 -> 0 < m -> ~ divides n m.
  first_step.
  unfold not.
  intros.
  destruct H2.
  destruct n.
  omega.
  destruct n.
  auto.
  absurd(S (S n) < 2).
  omega.
  auto.
Qed.

Lemma le_plus_minus : forall n m:nat, le n m -> m = n+(m-n).
  intros.
  omega.
Qed.

Lemma lt_lt_or_eq : forall n m:nat, n < S m ->  n < m \/ n = m.
  intros.
  omega.
Qed.

Goal forall n p:nat, n <= p -> p < S n -> n = p.
  intros.
  omega.
Qed.


From mathcomp Require Import all_ssreflect.
Require Import ssr_frap.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Set Print All. *)

(* Let's shake things up a bit by adding variables to expressions.
 * Note that all of the automated proof scripts from before will keep working
 * with no changes!  That sort of "free" proof evolution is invaluable for
 * theorems about real-world compilers, say. *)

Module ArithWithVariables.

  Inductive arith : Set :=
  | Const (n : nat)
  | Var (x : var)
  | Plus (e1 e2 : arith)
  | Times (e1 e2 : arith).

  Example ex1 := Const 42.
  Example ex2 := Plus (Const 1) (Times (Var "x") (Const 3)).

  Fixpoint size (e : arith) : nat :=
    match e with
    | Const _ => 1
    | Var _ => 1
    | Plus e1 e2 => (size e1 + size e2).+1
    | Times e1 e2 => (size e1 + size e2).+1
    end.

  Compute size ex1.
  Compute size ex2.

  Fixpoint depth (e : arith) : nat :=
    match e with
    | Const _ => 1
    | Var _ => 1
    | Plus e1 e2 => (maxn (depth e1) (depth e2)).+1
    | Times e1 e2 => (maxn (depth e1) (depth e2)).+1
    end.

  Compute depth ex1.
  Compute depth ex2.

  (* linear_arithmetic で解く補題のサンプル *)
  Lemma max_le_add m1 n1 m2 n2 : m1 <= m2 -> n1 <= n2 ->
                                 maxn m1 n1 <= m2 + n2.
  Proof.
    rewrite /maxn.
    case H : (m1 < n1) => Hm Hn. (* destruct (m1 < n1) eqn: H => Hm Hn *)
    - rewrite -[n1]add0n. by apply: leq_add.
    - rewrite addnC -[m1]add0n. by apply: leq_add.

    Restart.
    rewrite /maxn.
    case H : (m1 < n1) => Hm Hn.
    - by ssromega.
    - by ssromega.

    Restart.
      by linear_arithmetic.
  Qed.

  Theorem depth_le_size e : depth e <= size e.
  Proof.
    elim: e => [n | x | e1 He1 e2 He2 | e1 He1 e2 He2] //=.
    - by linear_arithmetic.                (* by apply: max_le_add. *)
    - by linear_arithmetic.                (* by apply: max_le_add. *)
  Qed.

  Theorem depth_le_size_snazzy e : depth e <= size e.
  Proof.
      by elim: e => //=; linear_arithmetic.
    (* Oo, look at that!  Chaining tactics with semicolon, as in [t1; t2],
     * asks to run [t1] on the goal, then run [t2] on *every*
     * generated subgoal.  This is an essential ingredient for automation. *)
  Qed.

  (* A silly recursive function: swap the operand orders of all binary operators. *)
  Fixpoint commuter (e : arith) : arith :=
    match e with
    | Const _ => e
    | Var _ => e
    | Plus e1 e2 => Plus (commuter e2) (commuter e1)
    | Times e1 e2 => Times (commuter e2) (commuter e1)
    end.

  Compute commuter ex1.
  Compute commuter ex2.

  (* [commuter] has all the appropriate interactions with other functions (and itself). *)

  Theorem size_commuter e : size (commuter e) = size e.
  Proof.
    by elim: e => //=; linear_arithmetic.
  Qed.

  Theorem depth_commuter e : depth (commuter e) = depth e.
  Proof.
    elim: e => //= [e1 He1 e2 He2 | e1 He1 e2 He2];
                 (* congr (_ + _) *)
                 by rewrite He1 He2 maxnC.
  Qed.

  Theorem commuter_inverse e : commuter (commuter e) = e.
  Proof.
      by elim: e => //= [e1 He1 e2 He2 | e1 He1 e2 He2]; equality. (* rewrite He1 He2. *)
    (* [equality]: a complete decision procedure for the theory of equality
     *   and uninterpreted functions.  That is, the goal must follow
     *   from only reflexivity, symmetry, transitivity, and congruence
     *   of equality, including that functions really do behave as functions. *)
  Qed.

  (* Now that we have variables, we can consider new operations,
   * like substituting an expression for a variable.
   * We use an infix operator [==v] for equality tests on strings.
   * It has a somewhat funny and very expressive type,
   * whose details we will try to gloss over.
   * (To dig into it more on your own, the appropriate keyword is "dependent types.") *)
  Fixpoint substitute (inThis : arith) (replaceThis : var) (withThis : arith) : arith :=
    match inThis with
    | Const _ => inThis
    | Var x =>
      if x == replaceThis then withThis else inThis (* eqType の == を使う。 *)
    | Plus e1 e2 =>
      Plus (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
    | Times e1 e2 =>
      Times (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
    end.

  Lemma max_le_add_c m1 n1 m2 n2 c : m1 <= m2 + c -> n1 <= n2 + c ->
                                 maxn m1 n1 <= maxn m2 n2 + c.
  Proof.
    by linear_arithmetic.

    Restart.
    (* linear_arithemtic' の repeat が効いている例 *)
    move=> Hm Hn.
    rewrite {1}/maxn.
    case H1 : (m1 < n1).
    - rewrite /maxn.
      case H2 : (m2 < n2); by ssromega.
    - rewrite /maxn.
      case H2 : (m2 < n2); by ssromega.
  Qed.

  (* An intuitive property about how much [substitute] might increase depth. *)
  Theorem substitute_depth replaceThis withThis inThis :
    depth (substitute inThis replaceThis withThis) <= depth inThis + depth withThis.
  Proof.
    elim: inThis => //= [x | e1 He1 e2 He2 | e1 He1 e2 He2].
    - case H : (x == replaceThis).
      (* [cases e]: break the proof into one case for each constructor that might have
       * been used to build the value of expression [e].  In the special case where
       * [e] essentially has a Boolean type, we consider whether [e] is true or false. *)

      + by linear_arithmetic.
      + rewrite /depth.
        by linear_arithmetic.
    - (* rewrite -addnA leq_add2l. *)
        by apply: max_le_add_c.
    - (* rewrite -addnA leq_add2l. *)
        by apply: max_le_add_c.
  Qed.

  (* Let's get fancier about automation, using [match goal] to pattern-match the goal
   * and decide what to do next!
   * The [|-] syntax separates hypotheses and conclusion in a goal.
   * The [context] syntax is for matching against *any subterm* of a term.
   * The construct [try] is also useful, for attempting a tactic and rolling back
   * the effect if any error is encountered. *)

  Theorem substitute_depth_snazzy replaceThis withThis inThis :
    depth (substitute inThis replaceThis withThis) <= depth inThis + depth withThis.
  Proof.
    elim: inThis; simplify;
    try match goal with
        | [ |- context[if ?a == ?b then _ else _] ] => cases (a == b); simplify
        end; linear_arithmetic.
    Qed.

  (* A silly self-substitution has no effect. *)

  Theorem substitute_self replaceThis inThis :
    substitute inThis replaceThis (Var replaceThis) = inThis.
  Proof.
    elim: inThis => //= [x | e1 He1 e2 He2 | e1 He1 e2 He2].
    - case H : (x == replaceThis).
      + move/eqP in H.
        by rewrite H.
      + done.
    - by rewrite He1 He2.
    - by rewrite He1 He2.
  Qed.

  Theorem substitute_self_snazzy replaceThis inThis :
    substitute inThis replaceThis (Var replaceThis) = inThis.
  Proof.
    elim: inThis; simplify;
    try match goal with
        | [ |- context[if ?a == ?b then _ else _] ] => cases (a == b); simplify
        end; try equality.
    (* H : x == replaceThis が残ってしまう。 *)
    by move/eqP in Heq; equality.
  Qed.

  (* We can do substitution and commuting in either order. *)

  Theorem substitute_commuter replaceThis withThis inThis :
    commuter (substitute inThis replaceThis withThis)
    = substitute (commuter inThis) replaceThis (commuter withThis).
  Proof.
    elim: inThis => //= [x | e1 He1 e2 He2 | e1 He1 e2 He2].
    - by case H : (x == replaceThis).
    - by rewrite He1 He2.
    - by rewrite He1 He2.
  Qed.

  Theorem substitute_commuter_snazzy replaceThis withThis inThis :
    commuter (substitute inThis replaceThis withThis)
    = substitute (commuter inThis) replaceThis (commuter withThis).
  Proof.
    elim: inThis; simplify;
    try match goal with
        | [ |- context[if ?a == ?b then _ else _] ] => cases (a == b); simplify
        end; equality.
  Qed.

  (* *Constant folding* is one of the classic compiler optimizations.
   * We repeatedly find opportunities to replace fancier expressions
   * with known constant values. *)
  Fixpoint constantFold (e : arith) : arith :=
    match e with
    | Const _ => e
    | Var _ => e
    | Plus e1 e2 =>
      let e1' := constantFold e1 in
      let e2' := constantFold e2 in
      match e1', e2' with
      | Const n1, Const n2 => Const (n1 + n2)
      | Const 0, _ => e2'
      | _, Const 0 => e1'
      | _, _ => Plus e1' e2'
      end
    | Times e1 e2 =>
      let e1' := constantFold e1 in
      let e2' := constantFold e2 in
      match e1', e2' with
      | Const n1, Const n2 => Const (n1 * n2)
      | Const 1, _ => e2'
      | _, Const 1 => e1'
      | Const 0, _ => Const 0
      | _, Const 0 => Const 0
      | _, _ => Times e1' e2'
      end
    end.

  (* This is supposed to be an *optimization*, so it had better not *increase*
   * the size of an expression!
   * There are enough cases to consider here that we skip straight to
   * the automation.
   * A new scripting construct is [match] patterns with dummy bodies.
   * Such a pattern matches *any* [match] in a goal, over any type! *)
  Theorem size_constantFold e : size (constantFold e) <= size e.
  Proof.
    induction e; simpl;
      repeat match goal with
             | [ |- context[match ?E with _ => _ end] ] =>
               destruct E; simpl in *
             end;
        by ssromega.
  Qed.

  (* Business as usual, with another commuting law *)
  Theorem commuter_constantFold e :
    commuter (constantFold e) = constantFold (commuter e).
  Proof.
    (*
    induction e; simpl;
    repeat match goal with
           | [ |- context[match ?E with _ => _ end] ] => destruct E; simpl; simpl in *
           | [ H : ?f _ = ?f _ |- _ ] => inversion H
           | [ |- ?f _ = ?f _ ] => f_equal
           end.
     *)
    (* Error: Out of memory. *)
    Admitted.

  (* To define a further transformation, we first write a roundabout way of
   * testing whether an expression is a constant.
   * This detour happens to be useful to avoid overhead in concert with
   * pattern matching, since Coq internally elaborates wildcard [_] patterns
   * into separate cases for all constructors not considered beforehand.
   * That expansion can create serious code blow-ups, leading to serious
   * proof blow-ups! *)
  Definition isConst (e : arith) : option nat :=
    match e with
    | Const n => Some n
    | _ => None
    end.

  (* Our next target is a function that finds multiplications by constants
   * and pushes the multiplications to the leaves of syntax trees,
   * ideally finding constants, which can be replaced by larger constants,
   * not affecting the meanings of expressions.
   * This helper function takes a coefficient [multiplyBy] that should be
   * applied to an expression. *)
  Fixpoint pushMultiplicationInside' (multiplyBy : nat) (e : arith) : arith :=
    match e with
    | Const n => Const (multiplyBy * n)
    | Var _ => Times (Const multiplyBy) e
    | Plus e1 e2 => Plus (pushMultiplicationInside' multiplyBy e1)
                         (pushMultiplicationInside' multiplyBy e2)
    | Times e1 e2 =>
      match isConst e1 with
      | Some k => pushMultiplicationInside' (k * multiplyBy) e2
      | None => Times (pushMultiplicationInside' multiplyBy e1) e2
      end
    end.

  (* The overall transformation just fixes the initial coefficient as [1]. *)
  Definition pushMultiplicationInside (e : arith) : arith :=
    pushMultiplicationInside' 1 e.

  (* Let's prove this boring arithmetic property, so that we may use it below. *)
  Lemma n_times_0 n : n * 0 = 0.
  Proof.
      by linear_arithmetic.
  Qed.

  (* A fun fact about pushing multiplication inside:
   * the coefficient has no effect on depth!
   * Let's start by showing any coefficient is equivalent to coefficient 0. *)
  Lemma depth_pushMultiplicationInside'_irrelevance0 e multiplyBy :
    depth (pushMultiplicationInside' multiplyBy e)
    = depth (pushMultiplicationInside' 0 e).
  Proof.
    elim: e multiplyBy => //= [e1 IHe1 e2 IHe2 n | e1 IHe1 e2 IHe2 n].
    - move: (IHe1 n) (IHe2 n).
        by linear_arithmetic.
    - case H : (isConst e1) => /=.
      + rewrite IHe2 n_times_0.
        by linear_arithmetic.
      + rewrite IHe1.
        by linear_arithmetic.
  Qed.

  (* It can be remarkably hard to get Coq's automation to be dumb enough to
   * help us demonstrate all of the primitive tactics. ;-)
   * In particular, we can redo the proof in an automated way, without the
   * explicit rewrites. *)
  Lemma depth_pushMultiplicationInside'_irrelevance0_snazzy e multiplyBy :
    depth (pushMultiplicationInside' multiplyBy e)
    = depth (pushMultiplicationInside' 0 e).
  Proof.
    elim: e multiplyBy => //= [e1 IHe1 e2 IHe2 n | e1 IHe1 e2 IHe2 n];
    try match goal with
        | [ |- context[match ?E with _ => _ end] ] => cases E; simplify
        end; equality.
(*
    try match goal with
        | [ |- context[match ?E with _ => _ end] ] => destruct E; simpl
        end; congruence.
*)
  Qed.

  (* Now the general corollary about irrelevance of coefficients for depth. *)
  Lemma depth_pushMultiplicationInside'_irrelevance e multiplyBy1 multiplyBy2 :
    depth (pushMultiplicationInside' multiplyBy1 e)
    = depth (pushMultiplicationInside' multiplyBy2 e).
  Proof.
    transitivity (depth (pushMultiplicationInside' 0 e)).
    (* [transitivity X]: when proving [Y = Z], switch to proving [Y = X]
     * and [X = Z]. *)
    - by apply: depth_pushMultiplicationInside'_irrelevance0.
    (* [apply H]: for [H] a hypothesis or previously proved theorem,
     *   establishing some fact that matches the structure of the current
     *   conclusion, switch to proving [H]'s own hypotheses.
     *   This is *backwards reasoning* via a known fact. *)
    - symmetry.
    (* [symmetry]: when proving [X = Y], switch to proving [Y = X]. *)
        by apply: depth_pushMultiplicationInside'_irrelevance0.
  Qed.

  (* Let's prove that pushing-inside has only a small effect on depth,
   * considering for now only coefficient 0. *)
  Lemma depth_pushMultiplicationInside' e :
    depth (pushMultiplicationInside' 0 e) <= (depth e).+1.
  Proof.
    elim: e => //= [e1 IHe1 e2 IHe2 | e1 IHe1 e2 IHe2].
    - by linear_arithmetic.
    - case H : (isConst e1) => /=.
      + rewrite n_times_0.
          by linear_arithmetic.
      + by linear_arithmetic.
  Qed.

  Hint Rewrite n_times_0.
  (* Registering rewrite hints will get [simplify] to apply them for us
   * automatically! *)

  Lemma depth_pushMultiplicationInside'_snazzy e :
    depth (pushMultiplicationInside' 0 e) <= (depth e).+1.
  Proof.
    elim: e => //= [e1 IHe1 e2 IHe2 | e1 IHe1 e2 IHe2];
    try match goal with
        | [ |- context[match ?E with _ => _ end] ] =>
          cases E; simplify
       (* destruct E; try autorewrite with core; simpl *)
        end; linear_arithmetic.
  Qed.

  Theorem depth_pushMultiplicationInside e :
    depth (pushMultiplicationInside e) <= (depth e).+1.
  Proof.
    unfold pushMultiplicationInside.
    (* [unfold X]: replace [X] by its definition. *)
    rewrite depth_pushMultiplicationInside'_irrelevance0.
    by apply depth_pushMultiplicationInside'.
  Qed.

End ArithWithVariables.

(* END *)


(** Algoritmo de Ordenação por Inserção em listas *)

Require Import List Arith.
Open Scope nat_scope.

(** * Definição de ordenação *)

Inductive ordenada: list nat -> Prop :=
| lista_vazia: ordenada nil
| lista_unit: forall x, ordenada (x :: nil)
| lista_mult: forall x y l, x <= y -> ordenada (y :: l) -> ordenada (x :: y :: l).

(** * Definição da função de inserção *)

Fixpoint insere (n:nat) (l: list nat) :=
  match l with
  | nil => n :: nil
  | h :: tl => if n <=? h then (n :: l)
             else (h :: (insere n tl))
                      end.

(** * Definição da função principal do algoritmo. *)

 Fixpoint ord_insercao l :=
  match l with
    | nil => nil
    | h :: tl => insere h (ord_insercao tl)
  end.

(** A função [insert] preserva a ordenação. *)

Lemma insere_preserva_ordem: forall l x, ordenada l -> ordenada (insere x l).
Proof.
(* Substitua esta linha pela sua prova. Provas completas terminam com Qed. *)  Admitted.

(** O algoritmo ord_insercao ordena. *)

Lemma ord_insercao_ordena: forall l, ordenada (ord_insercao l).
Proof.
(* Substitua esta linha pela sua prova. Provas completas terminam com Qed. *)  Admitted.

(** * Permutação *)

Inductive perm: list nat -> list nat -> Prop :=
| perm_refl: forall l, perm l l
| perm_hd: forall x l l', perm l l' -> perm (x::l) (x::l')
| perm_swap: forall x y l l', perm l l' -> perm (x::y::l) (y::x::l')
| perm_trans: forall l l' l'', perm l l' -> perm l' l'' -> perm l l''.

Lemma ord_insercao_perm: forall l, perm l (ord_insercao l).
Proof.
(* Substitua esta linha pela sua prova. Provas completas terminam com Qed. *)  Admitted.

Theorem correcao_ord_insercao: forall l, ordenada (ord_insercao l) /\ perm l (ord_insercao l).
Proof.
  Admitted.

(** Extração de código certificado *)

Require Extraction.

Recursive Extraction ord_insercao.
Extraction "ord_insercao.ml" ord_insercao.


Require Export List.
Require Export Omega.

Module Type Comparable_data.
Parameter A : Set.
Parameter Ale : A -> A -> Prop.
Parameter Ale_dec : forall x y:A, {Ale x y} + {Ale y x}.
End Comparable_data.

Module Type SORTING_BASICS.
Parameter A : Set.
Parameter Ale : A -> A -> Prop.
Parameter Ale_dec : forall x y:A, {Ale x y} + {Ale y x}.
Parameter sort : list A -> list A.

Inductive sorted : list A -> Prop :=
  | sorted0 : sorted nil
  | sorted1 : forall x:A, sorted (x :: nil)
  | sorted2 :
      forall (x y:A) (l:list A),
        Ale x y -> sorted (y :: l) -> sorted (x :: y :: l).

Inductive permutation : list A -> list A -> Prop :=
  | transpose_first :
      forall (a b:A) (l:list A), permutation (a :: b :: l) (b :: a :: l)
  | permutation_same_head :
      forall (a:A) (l1 l2:list A),
        permutation l1 l2 -> permutation (a :: l1) (a :: l2)
  | permutation_empty : permutation nil nil
  | permutation_transitive :
      forall l1 l2 l3:list A,
        permutation l1 l2 -> permutation l2 l3 -> permutation l1 l3.

Parameter sort_sorted : forall l:list A, sorted (sort l).

Parameter sort_permutation : forall l:list A, permutation (sort l) l.

End SORTING_BASICS.

Module merge_sort_basics (Data: Comparable_data) :
  SORTING_BASICS
  with   Definition A := Data.A
  with Definition Ale := Data.Ale
  with Definition  Ale_dec := Data.Ale_dec.

Definition A := Data.A.
Definition Ale := Data.Ale.
Definition Ale_dec := Data.Ale_dec.

Fixpoint merge_aux (l1 l2:list A) (b:nat) {struct b} :
 list A :=
  match b with
  | O => nil (A:=A)
  | S b' =>
      match l1, l2 with
      | nil, l => l
      | l, nil => l
      | a :: l, b :: l' =>
          match Ale_dec a b with
          | left _ => a :: merge_aux l (b :: l') b'
          | right _ => b :: merge_aux (a :: l) l' b'
          end
      end
  end.

Definition merge (l1 l2:list A) := merge_aux l1 l2 (length l1 + length l2).

(* Make a list of singleton lists to initiate merging. *)

Fixpoint mk_singletons (l:list A) : list (list A) :=
  match l with
  | nil => nil (A:=(list A))
  | a :: tl => (a :: nil) :: mk_singletons tl
  end.

(* Given a list of lists, merge the first with the second,
  then the third with the fourth, and so on. *)

Fixpoint sort_aux1 (l:list (list A)) : list (list A) :=
  match l with
  | l1 :: l2 :: tl => merge l1 l2 :: sort_aux1 tl
  | _ => l
  end.

Fixpoint sort_aux2 (l:list (list A)) (b:nat) {struct b} :
 list A :=
  match b with
  | O => nil (A:=A)
  | S b' =>
      match l with
      | nil => nil (A:=A)
      | l' :: nil => l'
      | _ => sort_aux2 (sort_aux1 l) b'
      end
  end.

Definition sort (l:list A) := sort_aux2 (mk_singletons l) (length l).

(* In principle the exercise stops here.  But what follows is
  used to ensure that the sorting function we have defined does really
  sort a list of data. *)

Inductive sorted : list A -> Prop :=
  | sorted0 : sorted nil
  | sorted1 : forall x:A, sorted (x :: nil)
  | sorted2 :
      forall (x y:A) (l:list A),
        Ale x y -> sorted (y :: l) -> sorted (x :: y :: l).

Theorem sorted_inv : forall (a:A) (l:list A), sorted (a :: l) -> sorted l.
Proof.
 intros a l H; inversion H; assumption || constructor.
Qed.

Inductive all_sorted : list (list A) -> Prop :=
  | all_sorted_nil : all_sorted nil
  | all_sorted_rec :
      forall (l:list A) (tl:list (list A)),
        sorted l -> all_sorted tl -> all_sorted (l :: tl).

Theorem mk_singletons_all_sorted :
 forall l:list A, all_sorted (mk_singletons l).
Proof.
 intros l; elim l; simpl in |- *; repeat (intros; constructor || assumption).
Qed.

Theorem mk_singletons_length :
 forall l:list A, length (mk_singletons l) = length l.
Proof.
 simple induction l; simpl in |- *; auto.
Qed.

Inductive first_elem_prop : list A -> list A -> list A -> Prop :=
  | all_empty : first_elem_prop nil nil nil
  | fep_first :
      forall (a:A) (l1 l2 l3:list A),
        first_elem_prop (a :: l1) l2 (a :: l3)
  | fep_second :
      forall (a:A) (l1 l2 l3:list A),
       first_elem_prop l1 (a :: l2) (a :: l3).

Theorem merge_aux_sorted :
 forall (b:nat) (l1 l2:list A),
   length l1 + length l2 <= b ->
   sorted l1 ->
   sorted l2 ->
   sorted (merge_aux l1 l2 b) /\
   first_elem_prop l1 l2 (merge_aux l1 l2 b).
Proof.
 intros b; elim b.
 intros l1 l2.
 case l1; case l2; simpl in |- *;
  try (intros; match goal with
               | id:(S _ <= _) |- _ => inversion id; fail
               end).
 repeat constructor.

 intros b' Hrec l1; case l1.
 simpl in |- *; intros; split; [ assumption | case l2; constructor ].
 intros a l l2; case l2.
 simpl in |- *; intros; split; [ assumption | constructor ].
 simpl in |- *; intros a' l' Hle Hsorted1 Hsorted2; case (Ale_dec a a').
 elim (Hrec l (a' :: l')); auto.
 intros Hsorted' Hfep.
 generalize Hsorted' Hsorted1 Hsorted2; clear Hsorted1 Hsorted2 Hsorted'.
 inversion Hfep.
 intros Hsorted' Hsorted1 Hsorted2 Hale.
 inversion Hsorted1; repeat constructor || assumption.
 intros Hsorted' Hsorted1 Hsorted2 Hale.
 inversion Hsorted2; repeat constructor || assumption.
 simpl in |- *; omega.
 eapply sorted_inv; eauto.
 elim (Hrec (a :: l) l'); auto.
 intros Hsorted' Hfep.
 generalize Hsorted' Hsorted1 Hsorted2; clear Hsorted1 Hsorted2 Hsorted'.
 inversion Hfep.
 intros Hsorted' Hsorted1 Hsorted2 Hale.
 inversion Hsorted1; repeat constructor || assumption.
 intros Hsorted' Hsorted1 Hsorted2 Hale.
 inversion Hsorted2; repeat constructor || assumption.
 simpl in |- *; omega.
 eapply sorted_inv; eauto.
Qed.

Theorem merge_sorted :
 forall l1 l2:list A, sorted l1 -> sorted l2 -> sorted (merge l1 l2).
Proof.
 unfold merge in |- *.
 intros l1 l2 H1 H2;
  elim (merge_aux_sorted (length l1 + length l2) l1 l2);
  auto.
Qed.

(* sort_aux1 has a multiple recursion step, we need a
   specific induction principle to work on this function. *)

Theorem list_ind2 :
 forall (B:Set) (P:list B -> Prop),
   P nil ->
   (forall x:B, P (x :: nil)) ->
   (forall (x1 x2:B) (l:list B), P l -> P (x1 :: x2 :: l)) ->
   forall l:list B, P l.
Proof.
 intros B P P0 P1 Pr l.
 cut (P l /\ (forall x:B, P (x :: l))).
 intuition.
 elim l; intuition.
Qed.

Theorem sort_aux1_all_sorted :
 forall l:list (list A), all_sorted l -> all_sorted (sort_aux1 l).
Proof.
 intros l; elim l using list_ind2.
 simpl in |- *; trivial.
 simpl in |- *; trivial.
 intros x1 x2 tl Hrec Has.
 inversion Has; clear Has.
 match goal with
 | id:(all_sorted _) |- _ => inversion id
 end.
 simpl in |- *; constructor.
 apply merge_sorted; assumption.
 auto.
Qed.

Theorem sort_aux1_shorter :
 forall l:list (list A), length (sort_aux1 l) <= length l.
Proof.
 intros l; elim l using list_ind2; simpl in |- *; auto with arith.
Qed.

Theorem sort_aux2_sorted :
 forall (b:nat) (l:list (list A)),
   length l <= b -> all_sorted l -> sorted (sort_aux2 l b).
Proof.
 intros b; elim b.
 intros l; case l.
 intros; constructor.
 simpl in |- *; intros a l' Hle; inversion Hle.
 intros b' Hrec l; case l.
 simpl in |- *; intros; constructor.
 intros l1 tl; case tl.
 intros Hle Has; inversion Has; assumption.
 simpl in |- *; intros l2 tl' Hle Has.
 apply Hrec.
 simpl in |- *.
 generalize (sort_aux1_shorter tl'); intros; omega.
 inversion Has; clear Has.
 match goal with
 | id:(all_sorted _) |- _ => inversion id
 end.
 constructor.
 apply merge_sorted; assumption.
 apply sort_aux1_all_sorted; assumption.
Qed.

Theorem sort_sorted : forall l:list A, sorted (sort l).
Proof.
 intros l; unfold sort in |- *.
 apply sort_aux2_sorted.
 rewrite mk_singletons_length; auto.
 apply mk_singletons_all_sorted.
Qed.

Inductive permutation : list A -> list A -> Prop :=
  | transpose_first :
      forall (a b:A) (l:list A), permutation (a :: b :: l) (b :: a :: l)
  | permutation_same_head :
      forall (a:A) (l1 l2:list A),
        permutation l1 l2 -> permutation (a :: l1) (a :: l2)
  | permutation_empty : permutation nil nil
  | permutation_transitive :
      forall l1 l2 l3:list A,
        permutation l1 l2 -> permutation l2 l3 -> permutation l1 l3.

Theorem permutation_reflexive : forall l:list A, permutation l l.
Proof.
 intros l; elim l; constructor; assumption.
Qed.

Theorem permutation_symetric :
 forall l1 l2:list A, permutation l1 l2 -> permutation l2 l1.
Proof.
 intros l1 l2 H; elim H; try (intros; constructor; assumption).
 intros l3 l4 l5; intros; apply permutation_transitive with l4;
  assumption.
Qed.

Theorem permutation_app_cons :
 forall (l:list A) (a:A) (l':list A),
   permutation (l ++ a :: l') (a :: l ++ l').
Proof.
 intros l; elim l.
 simpl in |- *; intros; apply permutation_reflexive.
 simpl in |- *; intros a' tl Hrec a l'.
 apply permutation_transitive with (a' :: a :: tl ++ l');
  constructor; auto.
Qed.

Theorem merge_aux_permutation :
 forall (b:nat) (l1 l2:list A),
   length l1 + length l2 <= b ->
   permutation (merge_aux l1 l2 b) (l1 ++ l2).
Proof.
 intros b; elim b.
 intros l1 l2; case l1; case l2;
  try
   (simpl in |- *; intros;
     match goal with
     | id:(S _ <= _) |- _ => inversion id; fail
     end).
 simpl in |- *; constructor.
 intros b' Hrec l1 l2; case l1.
 simpl in |- *; intros Hle; apply permutation_reflexive.
 simpl in |- *; intros a l; case l2.
 simpl in |- *; intros Hle; rewrite <- app_nil_end;
  apply permutation_reflexive.
 simpl in |- *; intros a' l'; case (Ale_dec a a').
 intros Hale Hle.
 apply permutation_transitive with (a :: a' :: l ++ l').
 apply permutation_same_head.
 apply permutation_transitive with (l ++ a' :: l').
 apply (Hrec l (a' :: l')).
 simpl in |- *; omega.
 apply permutation_app_cons.
 constructor.
 apply permutation_symetric.
 apply permutation_app_cons.
 intros Hale Hle.
 apply permutation_transitive with (a' :: a :: l ++ l').
 apply permutation_same_head.
 apply (Hrec (a :: l) l').
 simpl in |- *; omega.
 apply permutation_transitive with (a :: a' :: l ++ l').
 constructor.
 apply permutation_same_head.
 apply permutation_symetric.
 apply permutation_app_cons.
Qed.

Theorem merge_permutation :
 forall l1 l2:list A, permutation (merge l1 l2) (l1 ++ l2).
Proof.
 unfold merge in |- *; intros l1 l2; apply merge_aux_permutation; auto.
Qed.

Fixpoint app_all (l:list (list A)) : list A :=
  match l with
  | nil => nil (A:=A)
  | l1 :: tl => l1 ++ app_all tl
  end.

Theorem app_all_mk_singletons_eq :
 forall l:list A, app_all (mk_singletons l) = l.
Proof.
 intros l; elim l; simpl in |- *; auto.
 intros a l' Hrec; rewrite Hrec; auto.
Qed.

Theorem permutation_app :
 forall l1 l2:list A, permutation (l1 ++ l2) (l2 ++ l1).
Proof.
 intros l1; elim l1; simpl in |- *.
 intros l2; rewrite <- app_nil_end.
 apply permutation_reflexive.
 intros a tl Hrec l2.
 apply permutation_transitive with (a :: l2 ++ tl).
 apply permutation_same_head.
 apply Hrec.
 apply permutation_symetric.
 apply permutation_app_cons.
Qed.

Theorem permutation_long_head :
 forall l1 l2 l3:list A,
   permutation l2 l3 -> permutation (l1 ++ l2) (l1 ++ l3).
Proof.
 intros l1; elim l1; simpl in |- *; auto.
 intros a l1' Hrec l2 l3 H.
 constructor.
 auto.
Qed.

Theorem permutation_app4 :
 forall l1 l2 l3 l4:list A,
   permutation l1 l2 ->
   permutation l3 l4 -> permutation (l1 ++ l3) (l2 ++ l4).
Proof.
 intros l1 l2 l3 l4 H H0.
 apply permutation_transitive with (l1 ++ l4).
 apply permutation_long_head; assumption.
 apply permutation_transitive with (l4 ++ l1).
 apply permutation_app.
 apply permutation_transitive with (l4 ++ l2).
 apply permutation_long_head; assumption.
 apply permutation_app.
Qed.

Theorem sort_aux1_permutation :
 forall l:list (list A), permutation (app_all (sort_aux1 l)) (app_all l).
Proof.
 intros l; elim l using list_ind2.
 simpl in |- *; constructor.
 simpl in |- *; intros; apply permutation_reflexive.
 intros l1 l2 tl Hrec; simpl in |- *.
 rewrite ass_app.
 apply permutation_app4.
 apply merge_permutation.
 auto.
Qed.

Theorem sort_aux2_permutation :
 forall (b:nat) (l:list (list A)),
   length l <= b -> permutation (sort_aux2 l b) (app_all l).
Proof.
 intros b; elim b; simpl in |- *; auto.
 intros l; case l; simpl in |- *; try constructor.
 intros l' tl H; inversion H.
 intros b' Hrec l; case l.
 simpl in |- *; intros; constructor.
 intros l1 tl; case tl.
 simpl in |- *; intros;
   rewrite <- app_nil_end; apply permutation_reflexive.
 intros l2 tl' Hle;
 apply permutation_transitive with
    (app_all (sort_aux1 (l1 :: l2 :: tl'))).
 apply Hrec.
 simpl in Hle.
 generalize (sort_aux1_shorter tl').
 simpl in |- *; intros Hle'; omega.
 apply sort_aux1_permutation.
Qed.

Theorem sort_permutation : forall l:list A, permutation (sort l) l.
Proof.
 unfold sort in |- *; intros l; rewrite <- mk_singletons_length.
 pattern l at 3 in |- *; rewrite <- app_all_mk_singletons_eq.
 apply sort_aux2_permutation.
 auto.
Qed.

(* A nice complement to the exercise would be to define another merge-sorting
  function, but this time using well-founded induction, and yet another
  step would be to use an ad-hoc domain predicate. *)

End merge_sort_basics.


(*Datatype for our numerical system with 0, U and D*)
Inductive BN :=
  Z: BN
| U: BN -> BN
| D: BN -> BN.

(* Successor function for BN numbers  *)
Fixpoint sucBN (b:BN) : BN :=
  match b with
      Z => U Z
    | U x => D x (*S(U x) = S(2x + 1) = 2x + 2 = D x*)
    | D x => U (sucBN x) (*S(D x)= S(2x + 2) = S(S(2x + 1)) = S(2x + 1) + 1  *)
                 (* 2(S(x)) + 1 = 2(x+1) + 1 = (2x + 2) + 1 = S(2x + 1) + 1*)
  end.

(* Predeccesor function with error *)

Parameter (undefBN: BN). (* we assume a constant undefBN:BN representing an undefined BN number *)

Fixpoint predBN (b:BN): BN :=
 match b with
  Z => undefBN
 |U Z => Z
 |U x => D (predBN x)
 |D x => U x
 end.

(* Conversion functions *)

(* Recursive function that converts a number of type BN
 to its respective natural number*)
Fixpoint toN (b:BN) : nat :=
  match b with
      Z => 0
    | U x => 2*(toN x) + 1
    | D x => 2*(toN x) + 2
  end.

(* Converts a nat value to BN value.
   Inverse of the above one.*)
Fixpoint toBN (n: nat) : BN :=
  match n with
      0 => Z
    | S x => sucBN (toBN x)
  end.

(* Definition of sum of BN elements*)

Fixpoint plusBN (a b : BN) : BN :=
  match a,b with
    | Z, b => b
    | a, Z  => a
    | U x, U y => D(plusBN x y)
    | D x, U y => U(sucBN (plusBN x y))
    | U x, D y => U(sucBN (plusBN x y))
    | D x, D y => D(sucBN (plusBN x y))
  end.

Notation "a ⊞ b" := (plusBN a b) (at level 60).

Inductive ltBN : BN -> BN -> Prop :=
 | ltBNZU : forall (a:BN), ltBN Z (U a)
 | ltBNZD : forall (a:BN), ltBN Z (D a)
 | ltBNUU : forall (a b:BN), ltBN a b -> ltBN (U a) (U b)
 | ltBNUDeq : forall (a :BN), ltBN (U a) (D a)
 | ltBNUD : forall (a b:BN), ltBN a b -> ltBN (U a) (D b)
 | ltBNDU : forall (a b:BN), ltBN a b -> ltBN (D a) (U b)
 | ltBNDD : forall (a b:BN), ltBN a b -> ltBN (D a) (D b).

Inductive lteqBN: BN -> BN -> Prop :=
 | lteqBNref: forall (a:BN), lteqBN a a
 | lteqBNl: forall (a b: BN), ltBN a b -> lteqBN a b.

Notation "a <BN b" := (ltBN a b) (at level 70).
Notation "a <BN b <BN c" := (ltBN a b /\ ltBN b c) (at level 70, b at next level).

Notation "a ≤BN b" := (lteqBN a b) (at level 70).


(* Lecture 8, CIS 670, Fall 2012 *)

Require Import List.

Require Import CpdtTactics.

Set Implicit Arguments.
Set Asymmetric Patterns.

(** * Introducing Subset Types *)

(* Note about the exercises:

For all of the versions of pred, to get some hands on practice,
try to implement a safe head function (for plain coq lists).

I've pointed out a few versions of pred which I think are good
to do this exercise on, but feel free to skip or add exercises
as you see fit.

Some hints: if you want to do this for polymorphic lists (and why not?),
the type of the list elements should be in Set, not Type (try it).

Depending on how you set up the postcondition, you may need to add [eauto]
instead of just using [crush].
*)

(* Suppose we want to write a safe predecessor function. *)
Lemma zgtz : 0 > 0 -> False.
  crush.
Qed.

Definition pred_strong1 (n : nat) : n > 0 -> nat :=
  match n with
    | O => fun pf : 0 > 0 => match zgtz pf with end
    | S n' => fun _ => n'
  end.

(* Exercise (Optional): Do the same for head. It should have type

head_strong1 (A : type) (l : list A) : (length l) > 0 -> nat
*)

Lemma egtz {A : Set} : length (nil : list A) > 0 -> False.
  crush.
Qed.

Definition head_strong1 (A : Set) (l : list A) : length l > 0 -> A :=
  match l with
  | nil => fun pf : length nil > 0 => match egtz pf with end
  | cons h t => fun _ => h
  end.

Theorem two_gt0 : 2 > 0.
  crush.
Qed.

Eval compute in pred_strong1 two_gt0.

(* We can do this with less ad-hoc types, using the [sig] type. *)
Print sig.

(* This type is similar to the existential type [ex], except that it
lives in [Set] instead of [Prop].

The main difference: we can project the witness out of a value of type
[sig], while we can't for a value of type [ex]. *)

(* Exercise (10 min.)
Write a function that takes a value of type sig, and returns
the witness value.

Try to write the same function for ex. What goes wrong?
*)

Print sig.
Definition myproj1_sig (A : Type) (P : A -> Prop) (s : sig P) : A :=
  match s with
  | exist x _ => x
  end.

Print ex.
(*
Definition myproj1_ex (A : Type) (P : A -> Prop) (s : ex P) : A :=
  match s with
  | ex_intro x _ => x
  end.

Error:
Incorrect elimination of "s" in the inductive type "ex":
the return type has sort "Type" while it should be "Prop".
Elimination of an inductive object of sort Prop
is not allowed on a predicate in sort Type
because proofs can be eliminated only to build proofs.
*)

Definition pred_strong2 (s : {n : nat | n > 0}) : nat :=
  match s with
    | exist O pf => match zgtz pf with end
    | exist (S n') _ => n'
  end.

Eval compute in pred_strong2 (exist _ 2 two_gt0).

(* We can guarantee the output is correct, as well *)

Definition pred_strong3 (s : {n : nat | n > 0}) : {m : nat | proj1_sig s = S m} :=
  match s return {m : nat | proj1_sig s = S m} with
    | exist 0 pf => match zgtz pf with end
    | exist (S n') pf => exist _ n' (eq_refl _)
  end.

Eval compute in pred_strong3 (exist _ 2 two_gt0).

(* Exercise (Optional): Do the same thing for head. *)
Print ex.
Definition head_strong3 {A : Set} (s : {l : list A | length l > 0})
    : {h : A | ex (fun t => cons h t = proj1_sig s)} :=
  match s with
  | exist nil pf => match egtz pf with end
  | exist (cons h t) _ => exist _ h (ex_intro _ t (eq_refl (cons h t)))
  end.

(* We have managed to reach a type that is, in a formal sense, the most
expressive possible for [pred].  Any other implementation of the same
type must have the same input-output behavior.  However, there is
still room for improvement in making this kind of code easier to
write. Since we are explicitly passing around proofs in our functions,
it can get tedious to construct proof terms by hand everywhere.

A different approach: we write the skeleton of the function, then use
tactics to fill in the missing proofs. This uses the [refine] tactic,
which generates subgoals for missing proofs. *)

Definition pred_strong4 : forall n : nat, n > 0 -> {m : nat | n = S m}.
  refine (fun n =>
    match n with
      | O => fun _ => False_rec _ _
      | S n' => fun _ => exist _ n' _
    end); crush.
Defined.

(* Exercise: Do the same thing for head. *)

Definition head_strong4 {A : Set} : forall l : list A, length l > 0 ->
    {h : A | ex (fun t => cons h t = l)}.
  refine (fun l =>
    match l with
    | nil => fun _ => False_rec _ _
    | h :: t => fun _ => exist _ h _
    end
  ); crush; eauto.
Defined.
Print head_strong4. Extraction head_strong4.
(* We end the "proof" with [Defined] instead of [Qed]. Proofs marked
Qed can't be unfolded, while proofs marked with Defined can be. *)

Print pred_strong4.

Eval compute in pred_strong4 two_gt0.

(* Now, some syntax to make things more readable... *)

(* Read: Contradicted hypothesis. *)
Notation "!" := (False_rec _ _).

(* Read: Produced a value e, along with a proof that proposition
holds of e. *)
Notation "[ e ]" := (exist _ e _).

Definition pred_strong5 : forall n : nat, n > 0 -> {m : nat | n = S m}.
  refine (fun n =>
    match n with
      | O => fun _ => !
      | S n' => fun _ => [n']
    end); crush.
Defined.

Eval compute in pred_strong5 two_gt0.

(* Exercise (30 min.)

Use this safe predecessor function to define a safe "minus 2" function,
with type

pred2_strong : forall (n : nat), n > 1 -> {m : nat | n = S (S m)}

*)
Search (_ > _ -> _ > _ -> _).
Require Import Arith.
Search (_ > O). Search (_ > _ -> _ > _). Check gt_S_n.
Definition pred2_strong : forall n, n > 1 -> {m : nat | n = S (S m)}.
  refine (fun n p =>
    match pred_strong5 (gt_trans n 1 O p (gt_Sn_O O)) with
    | exist n' e' =>
        match pred_strong5 (gt_S_n O n' _) with
        | exist n'' e'' => exist _ n'' _
        end
    end
  ); crush.
Defined.

Definition pred2_strong' : forall n : nat, n > 1 -> {m : nat | n = S (S m)}.
  refine (fun n =>
    match n with
    | O => fun _ => !
    | S O => fun _ => !
    | S (S n') => fun _ => [n']
    end
  ); crush.
Defined.

Extraction pred2_strong.
Extraction pred2_strong'.

(* Exercise (Optional)

Though defining functions that offer correctness guarantees is
requires a little more upfront work, they often compose better than
more weakly typed functions. For example, suppose we start with our
original predecessor function:

pred_strong1 : forall (n : nat), (n > 0) -> nat.

Try to use pred_strong1 to define a function

pred2_partial : forall (n : nat), (n > 1) -> nat.

*)

Hint Unfold pred_strong1.
Definition pred2_partial : forall n : nat, n > 1 -> nat. Print gt_trans.
  refine (fun n p =>
    pred_strong1 (_ : pred_strong1 (gt_trans n 1 O p (gt_Sn_O O)) > 0)
  ); unfold pred_strong1; destruct n; crush. Qed.

(*
  One other alternative is worth demonstrating.  Recent Coq versions
  include a facility called [Program] that
  streamlines this style of definition.  Here is a complete
  implementation using [Program].
*)

Obligation Tactic := crush.

Program Definition pred_strong6 (n : nat) (_ : n > 0) : {m : nat | n = S m} :=
  match n with
    | O => _
    | S n' => n'
  end.

Print pred_strong6.

(* [Program] and [refine] generate similar programs in this case.
In general, [refine] gives more control over the shape of the program. *)

Eval compute in pred_strong6 two_gt0.

(** * Detour: Decidable Proposition Types *)

(* There is another type in the standard library which captures the
idea of program values that indicate which of two propositions is
true. *)

Print sumbool.

(* Convention: the left constructor corresponds to success, while
the right constructor corresponds to failure. *)

(* Read: Found a witness of success, and a proof. *)
Notation "'Yes'" := (left _ _).

(* Read: Found a witness of failure, and a proof. *)
Notation "'No'" := (right _ _).

(* Read: If x succeeds, then take the proof of success and
convert to a proof of success for the entire expression.
Same if x fails. *)
Notation "'Reduce' x" := (if x then Yes else No) (at level 50).

(* Note that the [if] construct is overloaded: it works on a value of
any type with two constructors, returning either the first thing, or
the second thing. *)

(* A one example of [sumbool] is the decidable equality type,
which indicates that given two values, we can come up with a proof of
equality, or a proof of disequality. For instance, we can do this for
[nat]. *)

Definition eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
  refine (fix f (n m : nat) : {n = m} + {n <> m} :=
    match n, m with
      | O, O => Yes
      | S n', S m' => Reduce (f n' m')
      | _, _ => No
    end); congruence.
Defined.

(* Exercise (20 min.)

Write down the proof obligations that are generated by refine.
There's no need to write down every last hypothesis, just try to
write informally what is to be proved, under what hypothesis.
Try to do this without peeking.

For example, the first obligation should be:

Prove (0 = 0) under no hypothesis.
---
Prove (O <> S m') under no hypothesis
Prove (S n' <> O) under no hypothesis
Prove (S n' = S m') under hyp n' = m'
Prove (S n' <> S m') under hyp n' <> m'

*)

Eval compute in eq_nat_dec 2 2.

Eval compute in eq_nat_dec 2 3.

(* Exercise (Optional)

Write a decidable equality for lists of natural numbers.

*)
Print list_eq_dec.

Search ( _ -> _ :: _  = _ :: _).

Lemma eq_h_t : forall h1 h2 : nat, h1 = h2
    -> forall t1 t2 : list nat, t1 = t2 ->
    h1 :: t1 = h2 :: t2.
Proof.
  crush.
Qed.

Definition eq_list_nat_dec : forall l1 l2 : list nat, {l1 = l2} + {l1 <> l2}.
  induction l1, l2.
    auto 3.
    refine (right _); discriminate.
    refine (right _); discriminate.
    destruct (IHl1 l2), (eq_nat_dec a n).
      refine (left _); rewrite e, e0; reflexivity.
      refine (right _); crush.
      refine (right _); crush.
      refine (right _); crush.
Defined.
Print eq_list_nat_dec.

Lemma head_inj : forall (h1 h2 : nat) (t1 t2 : list nat), h1 :: t1 = h2 :: t2 -> h1 = h2.
crush. Qed.

Lemma tail_inj : forall (h1 h2 : nat) (t1 t2 : list nat), h1 :: t1 = h2 :: t2 -> t1 = t2.
crush. Qed.

Definition eq_list_nat_dec' : forall l1 l2 : list nat, {l1 = l2} + {l1 <> l2}.
  refine (fix f (l1 l2 : list nat) : {l1 = l2} + {l1 <> l2} :=
    match l1, l2 return {l1 = l2} + {l1 <> l2} with
    | nil, nil => left _ _
    | h1 :: t1, h2 :: t2 => match Reduce (eq_nat_dec h1 h2) with
        | left ph => match Reduce (f t1 t2) with
            | left p1 => left (eq_h_t ph p1)
            | right p2 => right (fun k => p2 (tail_inj k))
            end
        | right p3 => right (fun k => p3 (head_inj k))
        end
    | _, _ => No
    end
  ); crush.
Defined.

(* Or, we can use a tactic, [decide equality] *)
Definition eq_nat_dec' (n m : nat) : {n = m} + {n <> m}.
  decide equality.
Defined.

(* We can now write a list membership function which returns a proof
of membership, or a proof that the element is not in the list. *)

(* Read: if x returns a positive result, return a positive result.
Otherwise, evaluate y. *)
Notation "x || y" := (if x then Yes else Reduce y).

Section In_dec.
  Variable A : Set.
  Variable A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Definition In_dec : forall (x : A) (ls : list A), {In x ls} + {~ In x ls}.
    refine (fix f (x : A) (ls : list A) : {In x ls} + {~ In x ls} :=
      match ls with
	| nil => No
	| x' :: ls' => A_eq_dec x x' || f x ls'
      end); crush.
  Defined.
End In_dec.

Eval compute in In_dec eq_nat_dec 2 (1 :: 2 :: nil).
Eval compute in In_dec eq_nat_dec 3 (1 :: 2 :: nil).

(* Exercise (30 min.): Write a decidable equality function for
list A, assuming a decidable equality for A.

Hint: It might be good to start with some new notation...
*)

Section eq_list_dec.
  Variable A : Set.

  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Notation "x && y" := (if x then Reduce y else No).

  Definition list_A_eq_dec : forall l1 l2 : list A, {l1 = l2} + {~ l1 = l2}.
    refine (fix f (l1 l2 : list A ) : {l1 = l2} + {~ l1 = l2} :=
      match l1, l2 with
      | nil, nil => Yes
      | h1 :: t1, h2 :: t2 => A_eq_dec h1 h2 && f t1 t2
      | h :: t , _ => No
      | _, h :: t => No
      end
    ); crush.
  Qed.

End eq_list_dec.

(** * Partial Subset Types *)

(* Up to this point, our types guarantee that on valid input, the output
of our function is correct. What if we want our functions to handle bad
input, say by producing a proof that the input is bad? *)

Inductive maybe (A : Set) (P : A -> Prop) : Set :=
| Unknown : maybe P
| Found : forall x : A, P x -> maybe P.

(** We can define some new notations, analogous to those we defined
for subset types. *)

(* Read: there is maybe an element x that satisfies P. *)
Notation "{{ x | P }}" := (maybe (fun x => P)).

(* Read: we failed to find an x, for some reason. *)
Notation "??" := (Unknown _).

(* Read: we found an x, and here is the proof that P x is
is satisfiable. *)
Notation "[| x |]" := (Found _ x _).

(** Now our next version of [pred] is trivial to write. *)

Definition pred_strong7 : forall n : nat, {{m | n = S m}}.
  refine (fun n =>
    match n return {{m | n = S m}} with
      | O => ??
      | S n' => [|n'|]
    end); trivial.
Defined.

(* Exercise (Optional): Do the same for head. *)
Notation "[| x , y |]" := (Found _ x y).

Definition head_strong7 {A : Set} : forall l : list A, {{ h | ex (fun t => h :: t = l)}}.
  refine (fun l =>
    match l with
    | nil => ??
    | h :: t => [| h , ex_intro _ t (eq_refl (h :: t)) |]
    end
  ).
Defined.

Eval compute in pred_strong7 2.

Eval compute in pred_strong7 0.

(* In the failure case, we don't provide any proof at all. The
implementation that always fails could be given this type. We
want to rule these out, and we'll use the [sumor] type, which
is either a value, or a proof. *)

Print sumor.

(* We add notations for easy use of the [sumor] constructors. *)

(* Read: here is a proof of B. (Convention: proof of failure) *)
Notation "!!" := (inright _ _).

(* Read: we found a witness x to the proposition P, and a proof that
P x. Note: only works when the "value" type in [sumor] is a subset
type. *)
Notation "[|| x ||]" := (inleft _ [x]).

(* Now, we can give a version of pred that works on all inputs,
and is fully specified. *)

Definition pred_strong8 : forall n : nat, {m : nat | n = S m} + {n = 0}.
  refine (fun n =>
    match n with
      | O => !!
      | S n' => [||n'||]
    end); trivial.
Defined.

Eval compute in pred_strong8 2.
Eval compute in pred_strong8 0.

Definition head_strong8 {A : Set} : forall l : list A,
    {h : A | ex (fun t => h :: t = l)} + {l = nil}.
  refine (fun l : list A =>
    match l return {h : A | ex (fun t => h :: t = l)} + {l = nil} with
    | nil => inright _ _
    | h :: t => inleft _ (exist _ h (ex_intro _ t _))
    end
  ); reflexivity.
Defined.

(* Composing specified functions

Until now, we have been working with just the pred function. How
can we compose these functions together? Plumbing around all the
proofs is tedious, so we'll define some notation so we don't have
to deal with this. *)

(** * Monadic Notations *)

(** We can treat [maybe] like a monad, like how the Maybe type in
Haskell is interpreted as possible failure. *)

(* Read: If e1 produces a witness, see if e2 produces a witness.
If e1 fails, fail. *)
Notation "x <- e1 ; e2" := (match e1 with
                             | Unknown => ??
                             | Found x _ => e2
                           end)
(right associativity, at level 60).

(* Now, say we want to use [pred] to take the predecessor of two
values (at the same time!) *)

Definition doublePred : forall n1 n2 : nat, {{p | n1 = S (fst p) /\ n2 = S (snd p)}}.
  refine (fun n1 n2 =>
    m1 <- pred_strong7 n1;
    m2 <- pred_strong7 n2;
    [|(m1, m2)|]); tauto.
Defined.

(* Exercise (Optional): do the same for head. *)
Definition doubleHead {A B : Set} : forall (l1 : list A) (l2 : list B),
    {{p | ex (fun t => fst p :: t = l1) /\ ex (fun t => snd p :: t = l2)}}.
  refine (fun l1 l2 =>
    h1 <- head_strong7 l1;
    h2 <- head_strong7 l2;
    [|(h1, h2)|]
  ); tauto.
Defined.

(** We can build a [sumor] version of the "bind" notation and use it
to write a similarly straightforward version of this function. *)

(* Read: If e1 produces a proof of failure, produce a proof of failure.
If e1 produces a witness and a proof of success, evaulate e2. *)
Notation "x <-- e1 ; e2" := (match e1 with
                               | inright _ => !!
                               | inleft (exist x _) => e2
                             end)
(right associativity, at level 60).

Definition doublePred' : forall n1 n2 : nat,
  {p : nat * nat | n1 = S (fst p) /\ n2 = S (snd p)}
  + {n1 = 0 \/ n2 = 0}.
  refine (fun n1 n2 =>
    m1 <-- pred_strong8 n1;
    m2 <-- pred_strong8 n2;
    [||(m1, m2)||]); tauto.
Defined.

(** * A Type-Checking Example *)

(* Let's use these ideas to build a certified typechecker. First,
our language... *)

Inductive exp : Set :=
| Nat : nat -> exp
| Plus : exp -> exp -> exp
| Bool : bool -> exp
| And : exp -> exp -> exp.

Inductive type : Set := TNat | TBool.

Inductive hasType : exp -> type -> Prop :=
| HtNat : forall n,
  hasType (Nat n) TNat
| HtPlus : forall e1 e2,
  hasType e1 TNat
  -> hasType e2 TNat
  -> hasType (Plus e1 e2) TNat
| HtBool : forall b,
  hasType (Bool b) TBool
| HtAnd : forall e1 e2,
  hasType e1 TBool
  -> hasType e2 TBool
  -> hasType (And e1 e2) TBool.

(* We build a equality type decision procedure for [type]. *)

Definition eq_type_dec : forall t1 t2 : type, {t1 = t2} + {t1 <> t2}.
  decide equality.
Defined.

(* In the process of generating the type, our typechecker will need
to assert that certain terms have specific types. We'll introduce
some notation to capture this pattern. *)

(* Read: If e1 succeeds (produces a witness), then do e2. Else, fail. *)
Notation "e1 ;; e2" := (if e1 then e2 else ??)
  (right associativity, at level 60).

(* With the notation we've defined and some automation, we can create
a certified typechecker that is only a little more complex than the
uncertified typechecker. *)

Definition typeCheck : forall e : exp, {{t | hasType e t}}.
  Hint Constructors hasType.

  refine (fix F (e : exp) : {{t | hasType e t}} :=
    match e return {{t | hasType e t}} with
      | Nat _ => [|TNat|]
      | Plus e1 e2 =>
        t1 <- F e1;
        t2 <- F e2;
        eq_type_dec t1 TNat;; (* Assert that t1 is a nat *)
        eq_type_dec t2 TNat;; (* Assert that t2 is a nat *)
        [|TNat|]
      | Bool _ => [|TBool|]
      | And e1 e2 =>
        t1 <- F e1;
        t2 <- F e2;
        eq_type_dec t1 TBool;;
        eq_type_dec t2 TBool;;
        [|TBool|]
    end); crush.
Defined.

(** Despite manipulating proofs, our type checker is easy to run. *)

Eval simpl in typeCheck (Nat 0).

Eval simpl in typeCheck (Plus (Nat 1) (Nat 2)).

Eval simpl in typeCheck (Plus (Nat 1) (Bool false)).

(* The type checker also extracts to some reasonable OCaml code. *)

Extraction typeCheck.

(* We can adapt this implementation to use [sumor], so that we know
our type-checker only fails on ill-typed inputs.  First, we define an
analogue to the "assertion" notation. *)

(* Read: Same as e1 ;; e2, except if we fail this time, we get a proof
of failure, which we can return. *)
Notation "e1 ;;; e2" := (if e1 then e2 else !!)
  (right associativity, at level 60).

(** Next, we prove a helpful lemma, which states that a given
expression can have at most one type. *)

Lemma hasType_det : forall e t1,
  hasType e t1
  -> forall t2, hasType e t2
    -> t1 = t2.
  induction 1; inversion 1; crush.
Qed.

(** Now we can define the type-checker.  Its type expresses that it
only fails on untypable expressions. *)

Definition typeCheck' : forall e : exp, {t : type | hasType e t} + {forall t, ~ hasType e t}.
  Hint Constructors hasType.
  (** We register all of the typing rules as hints. *)

  Hint Resolve hasType_det.
  (* Note that [hasType_det] has forall bound variables that don't
     show up in the final type, and so we need [eauto] to apply it. *)

  (** The implementation can be translated from our previous
      implementation, just by switching a few notations. *)

  refine (fix F (e : exp) : {t : type | hasType e t} + {forall t, ~ hasType e t} :=
    match e return {t : type | hasType e t} + {forall t, ~ hasType e t} with
      | Nat _ => [||TNat||]
      | Plus e1 e2 =>
        t1 <-- F e1;
        t2 <-- F e2;
        eq_type_dec t1 TNat;;;
        eq_type_dec t2 TNat;;;
        [||TNat||]
      | Bool _ => [||TBool||]
      | And e1 e2 =>
        t1 <-- F e1;
        t2 <-- F e2;
        eq_type_dec t1 TBool;;;
        eq_type_dec t2 TBool;;;
        [||TBool||]
    end); clear F; crush' tt hasType; eauto.

  (** We clear [F], the local name for the recursive function, to
  avoid strange proofs that refer to recursive calls that we never
  make. *)

  (* [crush'] is similar to [crush], except that it performs inversion
     on the types that we specify. We need [eauto] to apply [hasType_det]. *)
Defined.

(* Exercise (45 min.)

Add products to the language.

*)

(** The short implementation here hides just how time-saving
automation is.  Every use of one of the notations adds a proof
obligation, giving us 12 in total.  Most of these obligations require
multiple inversions and either uses of [hasType_det] or applications
of [hasType] rules.

Our new function remains easy to test, and now have additional
information in the failure case. *)

Eval simpl in typeCheck' (Nat 0).

Eval simpl in typeCheck' (Plus (Nat 1) (Nat 2)).

Eval simpl in typeCheck' (Plus (Nat 1) (Bool false)).


(** * ProofObjects: Working with Explicit Evidence in Coq *)

Require Export Logic.

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

(**  We have seen that Coq has mechanisms both for _programming_,
    using inductive data types (like [nat] or [list]) and functions
    over these types, and for _proving_ properties of these programs,
    using inductive propositions (like [ev] or [eq]), implication, and
    universal quantification.  So far, we have treated these mechanisms
    as if they were quite separate, and for many purposes this is
    a good way to think. But we have also seen hints that Coq's programming and
    proving facilities are closely related. For example, the
    keyword [Inductive] is used to declare both data types and
    propositions, and [->] is used both to describe the type of
    functions on data and logical implication. This is not just a
    syntactic accident!  In fact, programs and proofs in Coq are almost
    the same thing.  In this chapter we will study how this works.

    We have already seen the fundamental idea: provability in Coq is
    represented by concrete _evidence_.  When we construct the proof
    of a basic proposition, we are actually building a tree of evidence,
    which can be thought of as a data structure. If the proposition
    is an implication like [A -> B], then its proof will be an
    evidence _transformer_: a recipe for converting evidence for
    A into evidence for B.  So at a fundamental level, proofs are simply
    programs that manipulate evidence.
*)
(**
    Q. If evidence is data, what are propositions themselves?

    A. They are types!

    Look again at the formal definition of the [beautiful] property.  *)

Print beautiful.
(* ==>
  Inductive beautiful : nat -> Prop :=
      b_0 : beautiful 0
    | b_3 : beautiful 3
    | b_5 : beautiful 5
    | b_sum : forall n m : nat, beautiful n -> beautiful m -> beautiful (n + m)
*)

(** The trick is to introduce an alternative pronunciation of "[:]".
    Instead of "has type," we can also say "is a proof of."  For
    example, the second line in the definition of [beautiful] declares
    that [b_0 : beautiful 0].  Instead of "[b_0] has type
    [beautiful 0]," we can say that "[b_0] is a proof of [beautiful 0]."
    Similarly for [b_3] and [b_5]. *)

(** This pun between types and propositions (between [:] as "has type"
    and [:] as "is a proof of" or "is evidence for") is called the
    _Curry-Howard correspondence_.  It proposes a deep connection
    between the world of logic and the world of computation.
<<
                 propositions  ~  types
                 proofs        ~  data values
>>
    Many useful insights follow from this connection.  To begin with, it
    gives us a natural interpretation of the type of [b_sum] constructor: *)

Check b_sum.
(* ===> b_sum : forall n m,
                  beautiful n ->
                  beautiful m ->
                  beautiful (n+m) *)
(** This can be read "[b_sum] is a constructor that takes four
    arguments -- two numbers, [n] and [m], and two values, of types
    [beautiful n] and [beautiful m] -- and yields evidence for the
    proposition [beautiful (n+m)]." *)

(** Now let's look again at a previous proof involving [beautiful]. *)

Theorem eight_is_beautiful: beautiful 8.
Proof.
    apply b_sum with (n := 3) (m := 5).
    apply b_3.
    apply b_5. Qed.

(** Just as with ordinary data values and functions, we can use the [Print]
command to see the _proof object_ that results from this proof script. *)

Print eight_is_beautiful.
(* ===> eight_is_beautiful = b_sum 3 5 b_3 b_5
     : beautiful 8  *)

(** In view of this, we might wonder whether we can write such
    an expression ourselves. Indeed, we can: *)

Check (b_sum 3 5 b_3 b_5).
(* ===> beautiful (3 + 5) *)

(** The expression [b_sum 3 5 b_3 b_5] can be thought of as
    instantiating the parameterized constructor [b_sum] with the
    specific arguments [3] [5] and the corresponding proof objects for
    its premises [beautiful 3] and [beautiful 5] (Coq is smart enough
    to figure out that 3+5=8).  Alternatively, we can think of [b_sum]
    as a primitive "evidence constructor" that, when applied to two
    particular numbers, wants to be further applied to evidence that
    those two numbers are beautiful; its type,
[[
    forall n m, beautiful n -> beautiful m -> beautiful (n+m),
    expresses this functionality, in the same way that the polymorphic
    type [forall X, list X] in the previous chapter expressed the fact
    that the constructor [nil] can be thought of as a function from
    types to empty lists with elements of that type. *)

(** This gives us an alternative way to write the proof that [8] is
    beautiful: *)

Theorem eight_is_beautiful': beautiful 8.
Proof.
   apply (b_sum 3 5 b_3 b_5).
Qed.

(** Notice that we're using [apply] here in a new way: instead of just
    supplying the _name_ of a hypothesis or previously proved theorem
    whose type matches the current goal, we are supplying an
    _expression_ that directly builds evidence with the required
    type. *)

(* ##################################################### *)
(** ** Proof Scripts and Proof Objects *)

(** These proof objects lie at the core of how Coq operates.

    When Coq is following a proof script, what is happening internally
    is that it is gradually constructing a proof object -- a term
    whose type is the proposition being proved.  The tactics between
    the [Proof] command and the [Qed] instruct Coq how to build up a
    term of the required type.  To see this process in action, let's
    use the [Show Proof] command to display the current state of the
    proof tree at various points in the following tactic proof. *)

Theorem eight_is_beautiful'': beautiful 8.
Proof.
   Show Proof.
   apply b_sum with (n:=3) (m:=5).
   Show Proof.
   apply b_3.
   Show Proof.
   apply b_5.
   Show Proof.
Qed.

(** At any given moment, Coq has constructed a term with some
    "holes" (indicated by [?1], [?2], and so on), and it knows what
    type of evidence is needed at each hole.  *)

(**
    Each of the holes corresponds to a subgoal, and the proof is
    finished when there are no more subgoals.  At this point, the
    [Theorem] command gives a name to the evidence we've built and
    stores it in the global context. *)

(** Tactic proofs are useful and convenient, but they are not
    essential: in principle, we can always construct the required
    evidence by hand, as shown above. Then we can use [Definition]
    (rather than [Theorem]) to give a global name directly to a
    piece of evidence. *)

Definition eight_is_beautiful''' : beautiful 8 :=
  b_sum 3 5 b_3 b_5.

(** All these different ways of building the proof lead to exactly the
    same evidence being saved in the global environment. *)

Print eight_is_beautiful.
(* ===> eight_is_beautiful    = b_sum 3 5 b_3 b_5 : beautiful 8 *)
Print eight_is_beautiful'.
(* ===> eight_is_beautiful'   = b_sum 3 5 b_3 b_5 : beautiful 8 *)
Print eight_is_beautiful''.
(* ===> eight_is_beautiful''  = b_sum 3 5 b_3 b_5 : beautiful 8 *)
Print eight_is_beautiful'''.
(* ===> eight_is_beautiful''' = b_sum 3 5 b_3 b_5 : beautiful 8 *)

(** **** Exercise: 1 star (six_is_beautiful) *)
(** Give a tactic proof and a proof object showing that [6] is [beautiful]. *)

Theorem six_is_beautiful :
  beautiful 6.
Proof.
  apply (b_sum 3 3 b_3 b_3). Qed.

Definition six_is_beautiful' : beautiful 6 :=
  b_sum 3 3 b_3 b_3.

(** **** Exercise: 1 star (nine_is_beautiful) *)
(** Give a tactic proof and a proof object showing that [9] is [beautiful]. *)

Theorem nine_is_beautiful :
  beautiful 9.
Proof.
  apply (b_sum 6 3 six_is_beautiful' b_3). Qed.

Definition nine_is_beautiful' : beautiful 9 :=
  b_sum 6 3 six_is_beautiful' b_3.

(* ##################################################### *)
(** ** Quantification, Implications and Functions *)

(** In Coq's computational universe (where we've mostly been living
    until this chapter), there are two sorts of values with arrows in
    their types: _constructors_ introduced by [Inductive]-ly defined
    data types, and _functions_.

    Similarly, in Coq's logical universe, there are two ways of giving
    evidence for an implication: constructors introduced by
    [Inductive]-ly defined propositions, and... functions!

    For example, consider this statement: *)

Theorem b_plus3: forall n, beautiful n -> beautiful (3+n).
Proof.
   intros n H.
   apply b_sum.
   apply b_3.
   apply H.
Qed.

(** What is the proof object corresponding to [b_plus3]?

    We're looking for an expression whose _type_ is [forall n,
    beautiful n -> beautiful (3+n)] -- that is, a _function_ that
    takes two arguments (one number and a piece of evidence) and
    returns a piece of evidence!  Here it is: *)

Definition b_plus3' : forall n, beautiful n -> beautiful (3+n) :=
  fun (n : nat) => fun (H : beautiful n) =>
    b_sum 3 n b_3 H.

Check b_plus3'.
(* ===> b_plus3' : forall n : nat, beautiful n -> beautiful (3+n) *)

(** Recall that [fun n => blah] means "the function that, given [n],
    yields [blah]."  Another equivalent way to write this definition is: *)

Definition b_plus3'' (n : nat) (H : beautiful n) : beautiful (3+n) :=
  b_sum 3 n b_3 H.

Check b_plus3''.
(* ===> b_plus3'' : forall n, beautiful n -> beautiful (3+n) *)

(** When we view the proposition being proved by [b_plus3] as a function type,
    one aspect of it may seem a little unusual. The second argument's
    type, [beautiful n], mentions the _value_ of the first argument, [n].
    While such _dependent types_ are not commonly found in programming
    languages, even functional ones like ML or Haskell, they can
    be useful there too.

    Notice that both implication ([->]) and quantification ([forall])
    correspond to functions on evidence.  In fact, they are really the
    same thing: [->] is just a shorthand for a degenerate use of
    [forall] where there is no dependency, i.e., no need to give a name
    to the type on the LHS of the arrow. *)

(** For example, consider this proposition: *)

Definition beautiful_plus3 : Prop :=
  forall n, forall (E : beautiful n), beautiful (n+3).

(** A proof term inhabiting this proposition would be a function
    with two arguments: a number [n] and some evidence [E] that [n] is
    beautiful.  But the name [E] for this evidence is not used in the
    rest of the statement of [funny_prop1], so it's a bit silly to
    bother making up a name for it.  We could write it like this
    instead, using the dummy identifier [_] in place of a real
    name: *)

Definition beautiful_plus3' : Prop :=
  forall n, forall (_ : beautiful n), beautiful (n+3).

(** Or, equivalently, we can write it in more familiar notation: *)

Definition beatiful_plus3'' : Prop :=
  forall n, beautiful n -> beautiful (n+3).

(** In general, "[P -> Q]" is just syntactic sugar for
    "[forall (_:P), Q]". *)

(** **** Exercise: 3 stars (b_times2) *)
(** First prove this theorem using tactics. *)
Print beautiful.
Theorem b_times2: forall n, beautiful n -> beautiful (2*n).
Proof.
  intros. simpl. apply b_sum. apply H. apply b_sum. apply H. apply b_0. Qed.

(** Now write a corresponding proof object directly. *)

Definition b_times2': forall n, beautiful n -> beautiful (2*n) :=
  fun (n : nat) => fun (E : beautiful n) =>
                     b_sum n (n+0) E (b_sum n 0 E b_0).

(** **** Exercise: 2 stars, optional (gorgeous_plus13_po) *)
(** Give a proof object corresponding to the theorem [gorgeous_plus13] from Prop.v *)

Definition gorgeous_plus13_po: forall n, gorgeous n -> gorgeous (13+n):=
  fun (n : nat) =>
    fun (E : gorgeous n) => g_plus5 (8+n) (g_plus5 (3+n) (g_plus3 n E)).

(** It is particularly revealing to look at proof objects involving the
logical connectives that we defined with inductive propositions in Logic.v. *)

Theorem and_example :
  (beautiful 0) /\ (beautiful 3).
Proof.
  apply conj.
   (* Case "left". *)  apply b_0.
   (* Case "right". *)  apply b_3.  Qed.

(** Let's take a look at the proof object for the above theorem. *)

Print and_example.
(* ===>  conj (beautiful 0) (beautiful 3) b_0 b_3
            : beautiful 0 /\ beautiful 3 *)

(** Note that the proof is of the form
    conj (beautiful 0) (beautiful 3)
         (...pf of beautiful 3...) (...pf of beautiful 3...)
    as you'd expect, given the type of [conj]. *)

(** **** Exercise: 1 star, optional (case_proof_objects) *)
(** The [Case] tactics were commented out in the proof of
    [and_example] to avoid cluttering the proof object.  What would
    you guess the proof object will look like if we uncomment them?
    Try it and see. *)
(** [] *)

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  intros P Q H.
  inversion H as [HP HQ].
  split.
    (* Case "left". *) apply HQ.
    (* Case "right". *) apply HP.  Qed.

(** Once again, we have commented out the [Case] tactics to make the
    proof object for this theorem easier to understand. It is still
    a little complicated, but after performing some simple reduction
    steps, we can see that all that is really happening is taking apart
    a record containing evidence for [P] and [Q] and rebuilding it in the
    opposite order: *)

Print and_commut.
(* ===>
    and_commut =
      fun (P Q : Prop) (H : P /\ Q) =>
        (fun H0 : Q /\ P => H0)
            match H with
            | conj HP HQ => (fun (HP0 : P) (HQ0 : Q) => conj Q P HQ0 HP0) HP HQ
            end
      : forall P Q : Prop, P /\ Q -> Q /\ P *)

(** After simplifying some direct application of [fun] expressions to arguments,
we get: *)

(* ===>
   and_commut =
     fun (P Q : Prop) (H : P /\ Q) =>
     match H with
     | conj HP HQ => conj Q P HQ HP
     end
     : forall P Q : Prop, P /\ Q -> Q /\ P *)

(** **** Exercise: 2 stars, optional (conj_fact) *)
(** Construct a proof object demonstrating the following proposition. *)

Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
  fun (P Q R : Prop) =>
    fun (H0 : P /\ Q) =>
      fun (H1 : Q /\ R) => match H0, H1 with
                               |conj P' _, conj _ R' => conj P R P' R'
                           end.

(** **** Exercise: 2 stars, advanced (beautiful_iff_gorgeous) *)

(** We have seen that the families of propositions [beautiful] and
    [gorgeous] actually characterize the same set of numbers.
    Prove that [beautiful n <-> gorgeous n] for all [n].  Just for
    fun, write your proof as an explicit proof object, rather than
    using tactics. (_Hint_: if you make use of previously defined
    theorems, you should only need a single line!) *)

(*
gorgeous__beautiful: forall n : nat, gorgeous n -> beautiful n
beautiful__gorgeous: forall n : nat, beautiful n -> gorgeous n
*)

Print conj.

Definition beautiful_iff_gorgeous : forall n, beautiful n <-> gorgeous n :=
  fun (n : nat) =>
    conj _ _ (beautiful__gorgeous n) (gorgeous__beautiful n).

(** **** Exercise: 2 stars, optional (or_commut'') *)
(** Try to write down an explicit proof object for [or_commut] (without
    using [Print] to peek at the ones we already defined!). *)

Definition or_commut : forall P Q : Prop, P \/ Q -> Q \/ P :=
  fun (P Q : Prop) =>
    fun(H : P \/ Q) => match H with
                           |or_introl HP => or_intror Q P HP
                           |or_intror HQ => or_introl Q P HQ
                       end.

(** Recall that we model an existential for a property as a pair consisting of
a witness value and a proof that the witness obeys that property.
We can choose to construct the proof explicitly.

For example, consider this existentially quantified proposition: *)

Definition some_nat_is_even : Prop :=
  ex nat ev.

(** To prove this proposition, we need to choose a particular number
    as witness -- say, 4 -- and give some evidence that that number is
    even. *)

Definition snie : some_nat_is_even :=
  ex_intro _ ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

(** **** Exercise: 2 stars (ex_beautiful_Sn) *)
(** Complete the definition of the following proof object: *)

Definition p : ex nat (fun n => beautiful (S n)) :=
  ex_intro nat (fun n => beautiful (S n)) 2 b_3.

(* ##################################################### *)
(** ** Giving Explicit Arguments to Lemmas and Hypotheses *)

(** Even when we are using tactic-based proof, it can be very useful to
understand the underlying functional nature of implications and quantification.

For example, it is often convenient to [apply] or [rewrite]
using a lemma or hypothesis with one or more quantifiers or
assumptions already instantiated in order to direct what
happens.  For example: *)

Check plus_comm.
(* ==>
    plus_comm
     : forall n m : nat, n + m = m + n *)

Lemma plus_comm_r : forall a b c, c + (b + a) = c + (a + b).
Proof.
   intros a b c.
   (* rewrite plus_comm. *)
      (* rewrites in the first possible spot; not what we want *)
   rewrite (plus_comm b a).  (* directs rewriting to the right spot *)
   reflexivity.  Qed.

(** In this case, giving just one argument would be sufficient. *)

Lemma plus_comm_r' : forall a b c, c + (b + a) = c + (a + b).
Proof.
   intros a b c.
   rewrite (plus_comm b).
   reflexivity.  Qed.

(** Arguments must be given in order, but wildcards (_)
may be used to skip arguments that Coq can infer.  *)

Lemma plus_comm_r'' : forall a b c, c + (b + a) = c + (a + b).
Proof.
  intros a b c.
  rewrite (plus_comm _ a).
  reflexivity. Qed.

(** The author of a lemma can choose to declare easily inferable arguments
to be implicit, just as with functions and constructors.

  The [with] clauses we've already seen is really just a way of
  specifying selected arguments by name rather than position:  *)

Lemma plus_comm_r''' : forall a b c, c + (b + a) = c + (a + b).
Proof.
  intros a b c.
  rewrite plus_comm with (n := b).
  reflexivity. Qed.

(** **** Exercise: 2 stars (trans_eq_example_redux) *)
(** Redo the proof of the following theorem (from MoreCoq.v) using
an [apply] of [trans_eq] but _not_ using a [with] clause. *)

Print trans_eq.

Example trans_eq_example' : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros.
  apply (trans_eq (list nat) [a;b] [c;d] [e;f] H H0).
  Qed.

(* ##################################################### *)
(** ** Programming with Tactics *)

(** If we can build proofs with explicit terms rather than
tactics, you may be wondering if we can build programs using
tactics rather than explicit terms.  Sure! *)

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

Print add1.
(* ==>
    add1 = fun n : nat => S n
         : nat -> nat
*)

Eval compute in add1 2.
(* ==> 3 : nat *)

(** Notice that we terminate the [Definition] with a [.] rather than with
[:=] followed by a term.  This tells Coq to enter proof scripting mode
to build an object of type [nat -> nat].  Also, we terminate the proof
with [Defined] rather than [Qed]; this makes the definition _transparent_
so that it can be used in computation like a normally-defined function.

This feature is mainly useful for writing functions with dependent types,
which we won't explore much further in this book.
But it does illustrate the uniformity and orthogonality of the basic ideas in Coq. *)

(* $Date: 2013-07-17 16:19:11 -0400 (Wed, 17 Jul 2013) $ *)


Require Import ZArith.
Require Import PolTac.

Open Scope Z_scope.

Theorem pols_test1 x y :
  x < y -> x + x < y + x.
Proof.
intros.
pols.
auto.
Qed.

Theorem pols_test2 x y :
  y < 0 -> x + y < x.
Proof.
intros.
pols.
auto.
Qed.

Theorem pols_test3 x y :
  0 < y * y ->
  (x + y) * (x - y) < x * x.
Proof.
intros.
pols.
auto with zarith.
Qed.

Theorem pols_test4 x y :
  x * x < y * y ->
  (x + y) * (x + y) < 2 * (x * y + y * y).
Proof.
intros.
pols.
auto.
Qed.

Theorem pols_test5 x y z :
  x + y * (y + z) = 2 * z ->
  2 * x + y * (y + z) = (x + z) + z.
Proof.
intros.
pols.
auto.
Qed.

Theorem polf_test1 x y :
  0 <= x -> 1 <= y -> x <= x * y.
Proof.
intros.
polf.
Qed.

Theorem polf_test2 x y :
  0 < x -> x <= x * y -> 1 <= y.
Proof.
intros H1 H2.
hyp_polf H2.
Qed.

Theorem polr_test1 x y z :
  x + z < y -> x + y + z < 2 * y.
Proof.
intros H.
polr H.
pols.
auto.
pols.
auto with zarith.
Qed.


(* Exercise coq_list_03 *)

(* Those are the definitions from the previous exercise: *)

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

Fixpoint append (l m : natlist) {struct l} : natlist :=
  match l with
  | nil => m
  | cons x xs => cons x (append xs m)
  end.

(* Now let us define the length function that returns the
   length of a given list. *)

Fixpoint length (l : natlist) {struct l} : nat :=
  (***** write the body of a function here *****)
  match l with
  | nil => 0
  | cons x xs => 1 + length xs
  end.
(* Now let us try this definition on two simple examples.
   (Hint: usually this is a good idea to do that with newly
   introduced definitions) *)

Lemma length_nil : length nil = 0.

Proof.
  unfold length.
  reflexivity.
Qed.

Lemma length_3 : forall a b c,
  length (cons a (cons b (cons c nil))) = 3.

Proof.
  intros.
  simpl.
reflexivity.

Qed.