Require Import List.
Require Import Arith.
Require Import Omega.

Theorem list_in_dec : forall (x : nat) (X : list nat), {In x X} + { ~ In x X}.
Proof.
  apply in_dec.
  apply eq_nat_dec.
Defined.

Definition list_eq X Y :=
  forall x : nat, In x X <-> In x Y.

Theorem incl_list_eq : forall X Y, list_eq X Y <-> incl X Y /\ incl Y X.
Proof.
  intros.
  split;
  unfold list_eq.
  intros.
  unfold incl.
  split;
  intros;
  specialize (H a);
  intuition.
  intros.
  destruct H.
  unfold incl in *.
  split;
  intros;
  specialize (H x);
  specialize (H0 x);
  intuition.
Qed.

Theorem incl_dec : forall X Y : list nat, {incl X Y} + {~ incl X Y}.
Proof.
  intros.
  induction X.
  left.
  unfold incl.
  intros.
  inversion H.
  destruct IHX.
  assert ({In a Y} + {~In a Y}).
  apply in_dec.
  apply eq_nat_dec.
  destruct H;
  [left | right].
  unfold incl.
  intros.
  simpl In in *.
  intuition.
  replace a0;
  intuition.
  unfold not.
  intros.
  apply n.
  unfold incl in H.
  specialize (H a).
  apply H;
  intuition.
  right.
  unfold not;
  intros.
  apply n.
  unfold incl in *.
  intros.
  specialize (H a0).
  apply H.
  intuition.
Defined.

Theorem list_eq_dec : forall X Y, {list_eq X Y} + {~ list_eq X Y}.
Proof.
  intros.
  assert ( {incl X Y} + {~ incl X Y}).
  apply incl_dec.
  assert ({incl Y X} + {~ incl Y X} ).
  apply incl_dec.
  destruct H;
  destruct H0;
  [left | right | right | right];
  unfold not;
  intros.
  apply incl_list_eq.
  intuition.
  apply n.
  apply incl_list_eq in H.
  intuition.
  apply n.
  apply incl_list_eq in H.
  intuition.
  apply n.
  apply incl_list_eq in H.
  intuition.
Defined.

Theorem list_eq_ref :
  forall L, list_eq L L.
Proof.
  intros.
  unfold list_eq.
  intuition.
Qed.

Theorem list_eq_symmetric :
  forall X Y, list_eq X Y -> list_eq Y X.
Proof.
  intros.
  unfold list_eq in *.
  intuition;
  apply H;
  intuition.
Qed.

Theorem list_eq_trans :
  forall X Y Z, list_eq X Y -> list_eq Y Z -> list_eq X Z.
Proof.
  intros.
  unfold list_eq in *.
  intuition.
  apply H0.
  apply H.
  intuition.
  apply H.
  apply H0.
  intuition.
Qed.

Fixpoint LeastElem (X : list nat) : option nat :=
  match X with
  | nil => None
  | cons x X' =>
      match LeastElem X' with
      | None => Some x
      | Some y =>  if (lt_dec x y) then Some x else Some y
      end
  end.

Theorem LeastElem_spec1 : forall X : list nat, X = nil <-> LeastElem X = None.
Proof.
  intros.
  split;
  intros.
  replace X.
  reflexivity.
  destruct X.
  reflexivity.
  simpl LeastElem in H.
  destruct LeastElem.
  destruct lt_dec in H;
  inversion H.
  inversion H.
Qed.

Theorem LeastElem_spec2 : forall X : list nat, X <> nil <-> exists x : nat,  LeastElem X = Some x.
Proof.
  split;
  intros.
  case_eq X;
  intuition.
  simpl LeastElem.
  case LeastElem.
  intros.
  destruct lt_dec;
  [exists n | exists n0];
  intuition.
  exists n.
  intuition.
  case_eq X.
  intros.
  replace X in H.
  destruct H.
  simpl LeastElem in H.
  inversion H.
  unfold not.
  intros.
  inversion H1.
Qed.

Theorem LeastElemDec : forall (x : nat) (X : list nat), {LeastElem X = Some x} + {LeastElem X <> Some x}.
Proof.
  intros.
  destruct LeastElem.
  assert ({n = x} + {n <> x}).
  apply eq_nat_dec.
  destruct H as [H | H]; [left | right].
    replace n. intuition.
    unfold not. intros negH.
    inversion negH. intuition.
  right. unfold not; intros negH ; inversion negH.
Qed.

Theorem LeastElem_spec3 : forall (x : nat) (X : list nat), LeastElem X = Some x -> In x X.
Proof.
  intros.
  induction X.
  assert (LeastElem nil = None).
  apply LeastElem_spec1.
  intuition.
  replace (LeastElem nil) in H.
  inversion H.
  simpl LeastElem in H.
  destruct (LeastElem X).
  destruct lt_dec in H;
  inversion H;
  replace x;
  intuition.
  replace n;
  intuition.
  inversion H.
  intuition.
Qed.

Theorem LeastElem_decons1 : forall (x y : nat) (X : list nat), LeastElem X = Some y -> (x <= y <-> LeastElem (cons x X) = Some x).
Proof.
  split;
  intros.
  simpl LeastElem.
  replace (LeastElem X).
  destruct lt_dec.
  intuition.
  assert (x = y).
  omega.
  intuition.
  simpl LeastElem in H0.
  replace (LeastElem X) in H0.
  destruct lt_dec in H0.
  omega.
  inversion H0.
  omega.
Qed.

Theorem LeastElem_decons2 : forall (x y : nat) (X : list nat), LeastElem X = Some y -> (y <= x <-> LeastElem (cons x X) = Some y).
Proof.
  split;
  intros.
  simpl LeastElem.
  replace (LeastElem X).
  destruct lt_dec.
  assert (x = y).
  omega.
  intuition.
  intuition.
  simpl LeastElem in H0.
  replace (LeastElem X) in H0.
  destruct lt_dec in H0.
  inversion H0.
  omega.
  omega.
Qed.

Theorem LeastElem_spec4 :
  forall (X : list nat),  LeastElem X = None \/ (exists x : nat, LeastElem X = Some x /\ (forall y : nat, In y X -> x <= y)).
Proof.
  intros.
  induction X.
  left. reflexivity.
  right.
  destruct IHX.
  exists a.
  apply LeastElem_spec1 in H.
  replace X. simpl. intuition.
  destruct H.
  destruct H as [H0 H1].
  assert (H : {x <= a} + {a < x}).
  apply le_lt_dec.
  destruct H as [H | H].
  exists x.
  simpl LeastElem.
  replace (LeastElem X).
  destruct lt_dec.
  split; intros ; omega.
  split ; intuition.
  simpl In in H2.
  destruct H2 as [H2 | H2].
  omega.
  apply H1; intuition.
  exists a.
  simpl LeastElem.
  replace (LeastElem X).
  destruct lt_dec.
  split; intros.
  intuition.
  simpl In in H2.
  destruct H2 as [H2 | H2].
  omega.
  apply H1 in H2. omega.
  intuition.
Qed.

Fixpoint Subtract_list (X Y : list nat) :=
  match X with
  | nil => nil
  | cons x X' =>
     if list_in_dec x Y
       then Subtract_list X' Y
       else cons x (Subtract_list X' Y)
  end.

Theorem Subtract_list_r_nil : forall X : list nat, Subtract_list X nil = X.
Proof.
  intros.
  induction X.
  simpl. reflexivity.
  simpl.
  rewrite -> IHX.
  reflexivity.
Qed.

Theorem Subtract_list_l_nil : forall X : list nat, Subtract_list nil X = nil.
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Theorem Subtract_list_spec : forall (x : nat) (X Y : list nat),  In x (Subtract_list X Y) <-> (In x X /\ ~ In x Y).
  split;
  intros.
  induction X.
  simpl Subtract_list in H.
  inversion H.
  simpl Subtract_list in H.
  destruct list_in_dec.
  apply IHX in H.
  simpl In. intuition.
  simpl In in H.
  destruct H.
  replace x.
  intuition.
  apply IHX in H.
  simpl In. intuition.
  destruct H as [H H0].
  induction X.
  inversion H.
  simpl In in H.
  destruct H as [H | H];
  simpl Subtract_list;
  destruct list_in_dec.
  replace a in i. intuition.
  replace x. intuition.
  apply IHX. intuition.
  apply IHX in H.
  simpl In.
  intuition.
Qed.
 (*Finds the smallest element of X, but not Y*)
Definition delta_min ( X Y : list nat) : option nat :=
  LeastElem (Subtract_list X Y).

  (*Let's prove it!*)
Theorem delta_min_dec : forall X Y : list nat,
  delta_min X Y = None \/
  (exists x : nat,
    delta_min  X Y = Some x /\
                     In x X /\
                     ~ In x Y /\
                     forall y : nat, In y X -> ~ In y Y -> x <= y).
Proof.
  intros.
  unfold delta_min.
  assert ( forall (X : list nat),  LeastElem X = None \/ (exists x : nat, LeastElem X = Some x /\ (forall y : nat, In y X -> x <= y))).
  apply LeastElem_spec4.
  specialize (H (Subtract_list X Y)).
  destruct H.
  intuition.
  right.
  destruct H.
  exists x.
  destruct H.
  split.
  exact H.
  assert (In x X /\ ~ In x Y).
  apply Subtract_list_spec.
  apply LeastElem_spec3.
  exact H.
  split; intuition.
  assert (In y (Subtract_list X Y)).
  apply Subtract_list_spec.
  intuition.
  apply H0.
  intuition.
Qed.

Theorem delta_min_disj : forall X Y : list nat, delta_min X Y = None \/ delta_min X Y <> delta_min Y X.
Proof.
  intros.
  assert (delta_min X Y = None \/ (exists x : nat,
                                    delta_min  X Y = Some x /\
                                    In x X /\
                                    ~ In x Y /\
                                    forall y : nat, In y X -> ~ In y Y -> x <= y)).
  apply delta_min_dec.
  assert (delta_min Y X = None \/ (exists y : nat,
                                    delta_min  Y X = Some y /\
                                    In y Y /\
                                    ~ In y X /\
                                    forall x : nat, In x Y -> ~ In x X -> y <= x)).
  apply delta_min_dec.
  destruct H. intuition.
  destruct H0.
  destruct H. destruct H.  right. replace (delta_min X Y). replace (delta_min Y X). intuition.  inversion H2.
  right.
  unfold not. intros.
  destruct H. destruct H0. intuition.
  rewrite -> H2 in H1. rewrite -> H in H1.
  inversion H1.
  rewrite <- H9 in H3.
  intuition.
Qed.

Theorem delta_min_l_nil : forall  X, delta_min X nil = LeastElem X.
Proof.
  intros.
  unfold delta_min.
  rewrite -> Subtract_list_r_nil.
  reflexivity.
Qed.

Theorem delta_min_r_nil : forall X, delta_min nil X = None.
Proof.
  intros.
  unfold delta_min.
  rewrite -> Subtract_list_l_nil.
  simpl.
  reflexivity.
Qed.

Theorem delta_min_subs : forall X Y : list nat, delta_min X Y = None <-> forall x : nat, In x X -> In x Y.
Proof.
  split; intros.
  unfold delta_min in H.
  induction X.
  inversion H0.
  simpl LeastElem in H.
  destruct list_in_dec in H.
    simpl In in H0. destruct H0.
    replace a in i. intuition.
    apply IHX. intuition.
    exact H0.
  assert (exists n : nat,  LeastElem (a :: Subtract_list X Y) = Some n).
    apply LeastElem_spec2.
    unfold not. intros. inversion H1.
  destruct H1.
  rewrite H1 in H. inversion H.
  induction X.
  simpl.
  simpl.
  rewrite -> delta_min_r_nil.
  intuition.
  unfold delta_min.
  simpl.
  destruct list_in_dec.
  apply IHX.
  intros. apply H. simpl. right. exact H0.
  assert (In a (a::X)).
  intuition.
  specialize H.
  apply H in H0.
  intuition.
Qed.

Inductive list_order :=
| lt_list : list_order
| eq_list : list_order
| gt_list : list_order.

Fixpoint dec_order (X Y : list nat) : list_order :=
  match delta_min X Y with
  | None =>
      match delta_min Y X with
      | None => eq_list
      | Some y => gt_list
      end
  | Some x =>
      match delta_min Y X with
      | None => lt_list
      | Some y =>
          if lt_dec x y
          then lt_list
          else gt_list
      end
  end.

(*Connexity of the above program *)
Theorem dec_order_dec : forall X Y : list nat, {dec_order X Y = lt_list} + {dec_order X Y = eq_list} + {dec_order X Y = gt_list}.
Proof.
  intros.
  destruct dec_order; intuition.
Qed.

Theorem dec_order_nil_l_neg : forall X Y : list nat, dec_order nil X <> lt_list.
Proof.
  intros.
  simpl.
  destruct delta_min;
  intuition; inversion H.
Qed.

Theorem dec_order_nil_r_neg : forall X Y : list nat, dec_order X nil <> gt_list.
Proof.
  intros.
  destruct X.
  simpl; unfold not; intros; inversion H.
  unfold dec_order.
  rewrite -> delta_min_r_nil.
  destruct delta_min;
  unfold not;
  simpl; intros; inversion H.
Qed.

Example dec_order_nil : forall X Y : list nat, dec_order nil nil = eq_list.
Proof.
  intros.
  simpl.
  reflexivity.
Qed.
  (*Show that dec_order's eq is equivalent to the membership def in list_eq *)
Theorem dec_order_eq_spec : forall X Y : list nat, dec_order X Y = eq_list <-> list_eq X Y.
Proof.
  intros.
  unfold list_eq.
  split; intros.
  assert (delta_min X Y = None).
    unfold dec_order in H.
    destruct X; destruct Y;
    destruct delta_min;
      try (destruct lt_dec; inversion H); try intuition.
      destruct delta_min. destruct lt_dec. inversion H.
      inversion H. inversion H.
      destruct delta_min. destruct lt_dec.
      inversion H. inversion H. inversion H.
      destruct delta_min. destruct lt_dec.
      inversion H. inversion H. inversion H.
  assert (delta_min Y X = None).
    unfold dec_order in H.
    destruct X; destruct Y;
    destruct delta_min;
      try (destruct lt_dec; inversion H); try intuition.
      destruct delta_min. destruct lt_dec. inversion H.
      inversion H. inversion H.
      destruct delta_min.
        inversion H. reflexivity.
        destruct delta_min. destruct lt_dec.
        inversion H. inversion H. inversion H.
        destruct delta_min. inversion H. reflexivity.
  split; apply delta_min_subs; intuition.
  assert (delta_min X Y = None).
    apply delta_min_subs.
    apply H.
  assert (delta_min Y X = None).
    apply delta_min_subs.
    apply H.
  destruct X.
  simpl. rewrite -> H1. reflexivity.
  simpl. rewrite -> H0. rewrite -> H1. reflexivity.
Qed.

(*Show that lt is the dual of gt *)
Theorem dec_order_dual_spec : forall X Y : list nat, dec_order X Y = lt_list <-> dec_order Y X = gt_list.
Proof.
  split;
  intros.
  unfold dec_order in *.
  destruct Y; destruct X; simpl in *.
    inversion H.
    destruct delta_min.
      intuition.
      inversion H.
    destruct delta_min.
      intuition.
      inversion H.
    destruct delta_min;
    destruct delta_min.
    destruct lt_dec; destruct lt_dec;
    try omega; try reflexivity; try inversion H.
    reflexivity. inversion H. inversion H.
  unfold dec_order in *.
  destruct Y; destruct X; simpl in *.
    inversion H.
    destruct delta_min.
      intuition.
      inversion H.
    destruct delta_min.
      intuition.
      inversion H.
    remember (delta_min (n0 :: X) (n :: Y)) as i.
    remember (delta_min (n :: Y) (n0 :: X)) as j.
    assert (i <> j).
    unfold not; intros.
      assert (~ (j = None /\ i = None)).
        unfold not; intros.
        destruct H1.
        rewrite -> H1 in H.
        rewrite -> H2 in H.
        inversion H.
      assert (delta_min (n0 :: X) (n :: Y) = None \/ delta_min (n0 :: X) (n :: Y) <> delta_min (n :: Y) (n0 :: X)).
      apply delta_min_disj.
      destruct H2. rewrite -> H2 in Heqi. rewrite -> Heqi in H0.
      apply H1. split. intuition. intuition.
      rewrite <- Heqi in H2. rewrite <- Heqj in H2.
      intuition.
    destruct delta_min; destruct delta_min;
      replace i in H0; replace j in H0;
      rewrite -> Heqj in H; rewrite -> Heqi in H; replace i; replace j.
    destruct lt_dec; destruct lt_dec.
      reflexivity.
      inversion H.
      reflexivity.
      assert (n1 = n2). omega. assert (Some n1 = Some n2). intuition. intuition.
      reflexivity.
      inversion H.
      intuition.
Qed.

Theorem delta_min_in : forall (x : nat) (X Y : list nat), delta_min X Y = Some x -> In x X.
Proof.
  intros x X Y H0.
  assert (delta_min X Y = None \/
           (exists x : nat,
           delta_min X Y = Some x /\
           In x X /\ ~ In x Y /\ (forall y : nat, In y X -> ~ In y Y -> x <= y))) as H1.
  apply delta_min_dec.
  destruct H1 as [H1 | [n [H1 [H2 [H3 H4]]]]].
  rewrite -> H1 in H0. inversion H0.
  rewrite -> H0 in H1.
    assert (x = n) as H5. inversion H1. reflexivity.
    rewrite -> H5. apply H2.
Qed.

Theorem delta_min_neg_in : forall x X Y, delta_min X Y = Some x -> ~ In x Y.
Proof.
  intros x X Y H0.
  assert (delta_min X Y = None \/
           (exists x : nat,
           delta_min X Y = Some x /\
           In x X /\ ~ In x Y /\ (forall y : nat, In y X -> ~ In y Y -> x <= y))) as H1.
  apply delta_min_dec.
  destruct H1 as [H1 | [n [H1 [H2 [H3 H4]]]]].
  rewrite -> H1 in H0. inversion H0.
  rewrite -> H0 in H1.
    assert (x = n) as H5. inversion H1. reflexivity.
    rewrite -> H5. apply H3.
Qed.


(* Code for Coq'Art, Chapter 5: Everyday Logic. *)

Section EverydayLogic.

Require Import Arith.
Require Import ZArith.
Require Import List.

(* Examples *)
Section Examples.

Definition lt (n p : nat) : Prop :=
  S n <= p.

Theorem conv_example :
  forall n : nat, 7 * 5 < n -> 6 * 6 <= n.
(* The two formulas are convertible:
  + a delta-reduction on lt,
  + two beta-reductions, (function application), get "S (7*5) <= n".
  + then, convert "S (7*5) <= n" and "6*6 <= n" both to 36<=n.
  After "intros n h1", the convertiblity of the goal and hypothesis h1 make the
  tactic "apply h1" succeed.*)
Proof.
  intros n h1.
  apply h1.
Qed.
Print conv_example.

(* Polymorphic version of "implication transitivity". *)
Theorem imp_trans_poly :
  forall P Q R : Prop, (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R h1 h2 h3.
  apply h2; apply h1; apply h3.
Qed.
Implicit Arguments imp_trans_poly [P Q R].
Print imp_trans_poly.
Print le_S.
Check (imp_trans_poly _ _ _ (le_S 0 1) (le_S 0 2)).

Definition neutral_left (A : Set) (op : A -> A -> A) (e : A) :=
  forall x : A, op e x = x.
Theorem neutral_left_one :
  neutral_left Z Zmult 1%Z.
Proof.
  intros v.
  destruct v. (* "case v." and "elim v." are also can solve the proof. *)
  + simpl; reflexivity.
  + simpl; reflexivity.
  + simpl; reflexivity.
Qed.
Print neutral_left_one.

Theorem ls_SS :
  forall i : nat, i <= S (S i).
Proof.
  intros i.
  apply le_S; apply le_S; apply le_n.
Qed.

Theorem imp_dist_all :
  forall (A : Type) (P Q : A -> Prop), (
    forall x : A, P x -> Q x) -> (
      forall y : A, P y) ->
        forall z : A, Q z.
Proof.
  intros TA P Q h1 h2.
  intros value.
  apply h1; apply h2.
Qed.
Print imp_dist_all.

Lemma zero_le_nat :
  forall n : nat, O <= n.
Proof.
  induction n.
  - apply le_n.
  - apply le_S; apply IHn.
Qed.

Lemma le_trans :
  forall n m p : nat, n <= m -> m <= p -> n <= p.
Proof.
  intros n m p h1 h2.
  induction h2. (* perform induction on the inductive predicate: "le". *)
  + assumption.
  + apply le_S.
    assumption.
Qed.

Lemma mult_le_compat_l :
  forall n m p : nat, n <= m -> p * n <= p * m.
Proof.
  induction p; simpl.
  + trivial.
  + intros h1.
    apply plus_le_compat.
    - assumption.
    - apply IHp; assumption.
Qed.

Lemma mult_le_compat_r :
  forall n m p : nat, n <= m -> n * p <= m * p.
Proof.
  intros n m p.
  pattern (n * p); rewrite mult_comm.
  pattern (m * p); rewrite mult_comm.
  apply mult_le_compat_l.
Qed.

(* Use apply...at... or eapply... . *)

Theorem le_mult_mult :
  forall a b c d : nat, a <= c -> b <= d -> a * b <= c * d.
Proof.
  intros a b c d h1 h2.
  (* apply ... with ... to build explicit mapping. *)
  apply le_trans with (m := c * b); [
      apply mult_le_compat_r; apply h1
    | apply mult_le_compat_l; apply h2
  ].
Qed.
Print le_mult_mult.

Theorem le_mult_mult' :
  forall a b c d : nat, a <= c -> b <= d -> a * b <= c * d.
Proof.
  intros a b c d h1 h2.
  eapply le_trans.
  apply mult_le_compat_l.
  apply h2.
  apply mult_le_compat_r.
  apply h1.
Qed.

Lemma le_0_mult :
  forall n p : nat, 0 * n <= 0 * p.
Proof.
  intros n p.
  apply le_n.
Qed.

Lemma lt_8_9 : 8 < 9.
Proof.
  apply le_n.
Qed.

Open Scope Z_scope.

Definition Zsquare_diff (x y : Z) := x * x - y * y.

Theorem unfold_example :
  forall x y : Z, x * x = y * y -> Zsquare_diff x y * Zsquare_diff (x + y) (x * y) = 0.
Proof.
  intros x y h1.
  unfold Zsquare_diff at 1 2.
  rewrite h1.
  assert (h2 : y * y - y * y = 0).
  + omega.
  + rewrite h2; simpl; reflexivity.
Qed.
Print unfold_example.

Open Scope nat_scope.

Theorem lt_S :
  forall n p : nat, n < p -> n < S p.
Proof.
  intros n p h1.
  apply le_S.
  apply lt_le_S; assumption. (* or directly use the tactic "trivial". *)
Qed.

(* Logic Connectives. *)
Section LogicConnectives.

(* If a logic system is inconsistant, any propositions can be proved in via
  eliminating the contradiction (using the "elim" tactic).
  The "False" proposition represents the absolute contradiction. There's no
  introduction rule for this proposition, it's only possible to prove it in
  a context that already contains a contradiction. *)
Section InconsistantExample.

Hypothesis false : False.

Check False_ind.
Print False_ind.

(* The "elim" tactic:
  usage: "elim t".
  + if "t" is a term with type "False", then the current goal was solved immediately.
  + or else, if "t" is a negation (with form "~ x"), "elim t" ("elim ~ x") will solve
    the current goal with creating a new subgoal "x". then, if "x" can be proved,
    the original proposition can be proved.
    NOTE: if "t" doesn't have a "~ ", CAN NOT apply the "elim" tactic on it. *)

Lemma false_ex1 : 220 = 284.
Proof.
  apply False_ind.
  exact false.
Qed.

Lemma false_ex2 : 220 = 284.
Proof.
  elim false.
Qed.

Theorem absurd :
  forall P Q : Prop, P -> ~ P -> Q.
Proof.
  intros P Q h1 h2.
  elim h2. (* "h2 = ~ p", so, this step will solve "q" and introduce a subgoal "p". *)
  assumption.
Qed.
Print absurd.

(* Under the intuitionism logic, the goal "double_neg_l" can't be proved, however
  the goal "double_neg_r" can be proved trivially. *)

(* Theorem double_neg_l :
  forall P : Prop, ~ ~ P -> P. *)

Theorem double_neg_r :
  forall P : Prop, P -> ~ ~ P.
Proof.
  intros P hp.
  (* Here, we want to prove "~ ~ p", the "intros hp_neg" will introduce a hypothesis
    "~ p" and a subgoal "False". The tiatics "elim" the "~ p" (in the context), and
    "apply p" will lead to a contradiction. (NOTE: CAN NOT "elim p"). *)
  intros hp_neg.
  elim hp_neg; apply hp. (* another solution: "apply hg_neg; apply hp.". *)
Qed.
Print False.
Print double_neg_r.

Theorem contrad_example :
  forall P Q : Prop, ((P -> Q) -> P) -> (~ P -> P).
Proof.
  intros P Q.
  intros h1 h2.
  apply h1.
  intros h3.
  (* NOTE now we get a contradiction. *)
  elim h2; assumption.
Qed.

End InconsistantExample.

(* The theorem "double_neg_r" is a simple instance of the modus ponens rule.
  "modus_ponens p False" equals to "P -> (P -> False) -> False".
  After "unfold not", the goal "P -> ~ ~ P" becomes "P -> (P -> False) -> False". *)

Theorem modus_ponens :
  forall P Q : Prop, P -> (P -> Q) -> Q.
Proof.
  intros P Q h1 h2.
  apply h2; assumption.
Qed.
Print modus_ponens.

Theorem double_neg_r' :
  forall P : Prop, P -> ~ ~ P.
Proof.
  intros P.
  unfold not.
  exact (modus_ponens P False).
Qed.
Print double_neg_r'.

(* The contraposition is a direct application of "implication transitivity".
  After "unfold not.", the goal becomes "(a -> b) -> (b -> False) -> a -> False". *)

Theorem contrap :
  forall A B : Prop, (A -> B) -> ~ B -> ~ A.
Proof.
  intros A B.
  unfold not.
  apply imp_trans_poly.
Qed.

Theorem split_example :
  forall P Q : Prop, P -> Q -> P /\ Q.
Proof.
  intros P Q h1 h2.
  split; [assumption | assumption].
Qed.

Theorem conj3 :
  forall P Q R : Prop, P -> Q -> R -> P /\ Q /\ R.
Proof.
  intros P Q R h1 h2 h3.
  repeat split; assumption.
Qed.

Theorem disj4_3 :
  forall P Q R S : Prop, R -> P \/ Q \/ R \/ S.
Proof.
  intros P Q R S h1.
  right; right; left; assumption.
Qed.

Theorem and_commutes :
  forall A B : Prop, A /\ B -> B /\ A.
Proof.
  intros A B h1.
  split; apply h1.
Qed.

Theorem and_commutes' :
  forall A B : Prop, A /\ B -> B /\ A.
Proof.
  intros A B h1.
  elim h1.
  (* "split" = "intros; apply conj." *)
  split; assumption.
Qed.

Theorem or_commutes :
  forall A B : Prop, A \/ B -> B \/ A.
Proof.
  intros A B.
  intros [h1 | h2]; [right | left]; assumption.
Qed.

End LogicConnectives.

Theorem ex_imp_ex :
  forall (A : Type) (P Q : A -> Prop), (ex P) -> (
    forall x : A, P x -> Q x) -> (ex Q).
Proof.
  intros TA P Q h1 h2.
  elim h1.
  intros x h3.
  exists x.
  apply h2; assumption.
Qed.
Print ex_imp_ex.

Theorem eq_36 : 6 * 6 = 4 * 9.
Proof.
  apply refl_equal.
Qed.

Theorem eq_36' : 6 * 6 = 4 * 9.
Proof.
  reflexivity.
Qed.

Open Scope Z_scope.

Theorem diff_of_squares :
  forall a b : Z, (a+b) * (a-b) = a*a - b*b.
Proof.
  intros.
  ring. (* defined in "ZArithRing" *)
Qed.

Theorem symbol_equal :
  forall (A : Type) (a b : A), a = b -> b = a.
Proof.
  intros TA a b.
  intros h1.
  rewrite h1. (* also can be done by "rewrite <- h1". *)
  trivial.
Qed.

Theorem Zmult_distr_example_l :
  forall n x : Z, n * x + x = (n + 1) * x.
Proof.
  intros n x.
  rewrite Zmult_plus_distr_l.
  rewrite Zmult_1_l.
  trivial.
Qed.

Theorem Zmult_distr_example_r :
  forall n x : Z, n * x + x = x * (n + 1).
Proof.
  intros n x.
  rewrite Zmult_plus_distr_r.
  rewrite Zmult_1_r.
  rewrite Z.mul_comm.
  trivial.
Qed.

Theorem regroup :
  forall x : Z, x + x + x + x + x = 5 * x.
Proof.
  intros x.
  pattern x at 1 2 3 4 5.
  rewrite <- Zmult_1_l.
  repeat rewrite <- Zmult_plus_distr_l.
  trivial.
Qed.

Open Scope nat_scope.

Lemma le_lt_S_eq :
  forall n p : nat, n <= p -> p < S n -> n = p.
Proof.
  intros n p.
  omega.
Qed.

Theorem cond_rewrite_example :
  forall n : nat, 8 < n + 6 -> 3 + n < 6 -> n * n = n + n.
Proof.
  (* Where I was always felt stuck here ?
    I thought when n equals to 2, the first premise "8 < n + 6" didn't hold,
    so, there must be something wrong with this proof, but I couldn't get it.
    I suddenly realised that when n equals to 2, this proposition is equivalent
    with "False -> True -> True", it holds trivially! *)
  intros n h1 h2.
  rewrite <- (le_lt_S_eq 2 n).
  + reflexivity.
  + apply plus_le_reg_l with (p := 6).
    rewrite plus_comm in h1.
    simpl (6 + 2).
    apply Nat.lt_le_incl.
    assumption.
  + apply plus_lt_reg_l with (p:= 3).
    apply h2.
Qed.

End Examples.

(* Exercises. *)
Section Exercises.

(* Exercise 5.1 Polymorphic minimal propositional logic. *)

Lemma id_P :
  forall P : Prop, P -> P.
Proof.
  intros P h1.
  apply h1.
Qed.
Print id_P.

Lemma id_PP :
  forall P : Prop, (P -> P) -> (P -> P).
Proof.
  intros P h1.
  apply h1.
Qed.

Lemma imp_trans :
  forall P Q R : Prop, (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R h1 h2 h3.
  apply h2.
  apply h1.
  apply h3.
Qed.

Lemma imp_perm :
  forall P Q R : Prop, (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros P Q R h1 h2 h3.
  apply h1.
  apply h3.
  apply h2.
Qed.

Lemma ignore_Q :
  forall P Q R : Prop, (P -> R) -> P -> Q -> R.
Proof.
  intros P Q R h1 h2 h3.
  apply h1; apply h2.
Qed.

Lemma delta_imp :
  forall P Q R : Prop, (P -> P -> Q) -> P -> Q.
Proof.
  intros P Q R h1 h2.
  apply h1; [apply h2 | apply h2].
Qed.

Lemma delta_impR :
  forall P Q R : Prop, (P -> Q) -> (P -> P -> Q).
Proof.
  intros P Q R h1 h2.
  apply h1.
Qed.

Lemma diamond :
  forall P Q R T : Prop, (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
Proof.
  intros P Q R T h1 h2 h3 h4.
  apply h3; [apply h1; apply h4 | apply h2; apply h4].
Qed.
Print diamond.

Lemma weak_peirce :
  forall P Q R : Prop, ((((P -> Q) -> P) -> P) -> Q) -> Q.
(* Perice formula: ((P -> Q) -> P) -> P. can't be proved by Coq (Calculus of
  Constructions), it uses normalization properties in typed lambda-calculi. *)
Proof.
  intros P Q R h1.
  apply h1.
  intros h2.
  apply h2.
  intros h3.
  apply h1.
  intros h4.
  apply h3.
Qed.
Print weak_peirce.

(* Exercise 5.2 Some proofs in predicate calculus. *)

Theorem all_perm' :
  forall (A : Type) (P : A -> A -> Prop), (
    forall (x y : A), P x y) ->
      forall (x y : A), P y x.
Proof.
  intros TA P h1 v1 v2.
  apply h1.
Qed.
Print all_perm'.

Theorem resolution :
  forall (A : Type) (P Q R S : A -> Prop), (
    forall (a : A), Q a -> R a -> S a) -> (
      forall (b : A), P b -> Q b) -> (
        forall (c : A), P c -> R c -> S c).
Proof.
  intros TA P Q R S h1 h2.
  intros v1.
  intros v2 v3.
  apply h1; [apply h2; apply v2 | apply v3].
Qed.
Print resolution.

(* Exercise 5.3 On Negation, prove WITHOUT "False_ind". *)

Lemma lem1 : ~ False.
Proof.
  (* If item "t" can imply "False", then "~ t" will be proved. *)
  intros h1.
  apply h1.
Qed.

Lemma lem2 :
  forall P : Prop, ~ ~ ~ P -> ~ P.
Proof.
  intros P.
  intros h1 h2.
  apply h1.
  intros h3.
  elim h3; apply h2.
Qed.

Lemma lem3 :
  forall P Q : Prop, ~ ~ ~ P -> P -> Q.
Proof.
  intros P Q h1 h2.
  elim h1.
  intros h3.
  elim h3; apply h2.
Qed.

Lemma lem4 :
  forall P Q : Prop, (P -> Q) -> ~ Q -> ~ P.
Proof.
  intros P Q h1 h2 h3.
  (* Assume "q" and prove it, the get contradiction. *)
  elim h2.
  apply h1; assumption.
Qed.

Lemma lem4' :
  forall P Q : Prop, (P -> Q) -> ~ Q -> ~ P.
Proof.
  intros P Q.
  unfold not.
  apply imp_trans_poly.
Qed.

Lemma lem5 :
  forall P Q R : Prop, (P -> Q) -> (P -> ~ Q) -> P -> R.
Proof.
  intros P Q R.
  intros h1 h2 value.
  elim (h2 value); apply h1; assumption.
Qed.
Print lem5.

(* Exercise 5.4 Some bad inference rules. *)

(** TODO **)

(* Exercise 5.5 Introducing equality and disjunction. *)

Theorem refl_eq :
  forall (A : Set) (a b c d : A), a = c \/ b = c \/ c = c \/ d = c.
Proof.
  intros TA a b c d.
  right; right; left.
  (* The equal relation is reflexive. *)
  apply refl_equal. (* Here the tactic "reflexivity" also work. *)
Qed.

(* Exercise 5.6 Intuitionistic Propositional Logic. *)

Theorem and_assoc :
  forall A B C : Prop, A /\ (B /\ C) -> (A /\ B) /\ C.
Proof.
  (* Bind variable in conjunctive pattern with hypothesis using "intros". *)
  intros A B C [h1 [h2 h3]].
  repeat split; assumption.
Qed.

Theorem and_imp_dist :
  forall A B C D : Prop, (A -> B) /\ (C -> D) -> A /\ C -> B /\ D.
Proof.
  intros A B C D [h1 h2] [h3 h4].
  split; [apply h1 | apply h2]; assumption.
Qed.

Theorem not_contrad :
  forall A : Prop, ~ (A /\ ~ A).
Proof.
  intros A [h1 h2].
  apply h2; apply h1.
Qed.
Print not_contrad.

Theorem or_assoc :
  forall A B C : Prop, A \/ (B \/ C) -> (A \/ B) \/ C.
Proof.
  intros A B C.
  intros [h1 | [h2 | h3]].
  left; left; assumption.
  left; right; assumption.
  right; assumption.
Qed.

Theorem double_neg_true :
  forall A : Prop, ~ ~ (A \/ ~ A).
Proof.
  intros A h1.
  elim h1.
  right; intros h2.
  elim h1.
  left; assumption.
Qed.
Print double_neg_true.

(* TODO There's another way to finish this proof. Why this implimentation
  successes ? What's the detailed type of "h1" ? *)
Theorem double_neg_true' :
  forall A : Prop, ~ ~ (A \/ ~ A).
Proof.
  intros A h1.
  exact (h1 (or_intror (fun value : A => h1 (or_introl value)))).
Qed.
Print double_neg_true'.

Theorem or_and_not :
  forall A B : Prop, (A \/ B) /\ ~ A -> B.
Proof.
  intros A B [[h1 | h2] h3].
  elim h3; apply h1.
  assumption.
Qed.

(* Exercise 5.7 Five characterizations of classical logic. *)

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).

Goal peirce <-> classic.
Proof.
  unfold peirce; unfold classic; unfold not.

  split.

  intros hypo_perice.
  intros P h2.
  apply (hypo_perice P False).
  intros h3; elim h2; assumption.

  intros hypo_classic.
  intros P Q h1.
  apply hypo_classic; intros h2.
  apply h2.
  apply h1.
  intros h3.
  apply hypo_classic;
  intros h4.
  apply h2; apply h3.
Qed.

Goal peirce <-> excluded_middle.
Proof.
  unfold peirce; unfold excluded_middle.

  split.

  (* NOTE important skill !!!. *)
  intros hypo_perice P.
  apply (hypo_perice (P \/ ~ P) False).
  intros h1.
  right; intros h2.
  elim h1.
  left; assumption.

  intros hypo_em P Q h1.
  elim (hypo_em P);
    [ intros h2
    | intros h2; apply h1; intros h3; elim h2
    ];
    assumption.
Qed.

Goal peirce <-> de_morgan_not_and_not.
Proof.
  unfold peirce; unfold de_morgan_not_and_not.

  split.
  (* TODO *)
Admitted.

Goal peirce <-> implies_to_or.
Proof.
  (* TODO *)
Admitted.

Goal classic <-> excluded_middle.
Proof.
  unfold classic; unfold excluded_middle; unfold not.

  split.

  intros hypo_classic P.
  (* NOTE important skill !!!. *)
  apply hypo_classic.
  intros h2; apply h2.
  right; intros h3.
  elim h2.
  left; assumption.

  intros hypo_em P;
  elim (hypo_em P); intros h1 h2; [idtac | elim h2]; apply h1.
Qed.

Goal classic <-> de_morgan_not_and_not.
Proof.
  unfold classic; unfold de_morgan_not_and_not.

  split.

  intros hypo_classic P Q.
  intros h1.
  apply (hypo_classic (P \/ Q)).
  intros h2.
  apply h1; split; intros h3; elim h2; [left | right]; apply h3.

  intros hypo_de_morgan P.
  intros h1.
  elim (hypo_de_morgan P (~ P));
    [ trivial
    | intros h2; elim h1; assumption
    | intros h2; elim h2; intros h3 h4; elim h4; assumption
    ].
Qed.

Goal classic <-> implies_to_or.
Proof.
  (* TODO *)
Admitted.

Goal excluded_middle <-> de_morgan_not_and_not.
Proof.
  (* TODO *)
Admitted.

Goal excluded_middle <-> implies_to_or.
Proof.
  unfold excluded_middle; unfold implies_to_or.

  split.

  unfold not.
  intros hypo_em P Q.
  intros h1.
  elim (hypo_em P);
    [ intros h2; right; apply h1; apply h2
    | intros h3; left; apply h3
    ].

  intros hypo_impl P.
  elim (hypo_impl P P); intros;
    [ right
    | left
    | idtac];
    assumption.
Qed.

Goal de_morgan_not_and_not <-> implies_to_or.
Proof.
  (* TODO *)
Admitted.

(* Exercise 5.8 *)

(** The usage of:
  + "repeat idtac" keep a goal as it was.
  + "repeat fail" ? (* TODO *) **)

(* Exercise 5.9 On the existential quantifier. *)

Theorem ex_or_l :
  forall (A : Type) (P Q : A -> Prop), (
    exists x : A, P x \/ Q x) -> ex P \/ ex Q.
Proof.
  intros TA P Q h1.
  elim h1.
  intros x h2.
  elim h2; [left | right]; exists x; assumption.
Qed.

Theorem ex_or_r :
  forall (A : Type) (P Q : A -> Prop), (ex P \/ ex Q) -> (
    exists x : A, P x \/ Q x).
Proof.
  intros TA P Q.
  intros [h1 | h2];
    [ elim h1
    | elim h2
    ];
    intros; exists x;
    [ left
    | right
    ]; assumption.
Qed.

Theorem ex_universal_relation :
  forall (A : Type) (P Q : A -> Prop), (
    exists x : A,
      forall R : A -> Prop, R x) -> 2 = 3.
Proof.
  intros TA P Q.
  intros h1.
  elim h1.
  intros x hr1.
  (* Construct  a relation that maps all elements with type "TA" to "False".
    TODO The question if that how this approach works and how to construct a solution
    for general problem ? *)
  elim (hr1 (fun e : TA => False)).
Qed.

Theorem forall_not_ex :
  forall (A : Type) (P Q : A -> Prop), (
    forall x : A, P x) -> ~ (
      exists y : A, ~ P y).
Proof.
  intros TA P Q.
  intros h1 h2.
  elim h2.
  intros x h3.
  elim h3; apply h1.
Qed.

(* Exercise 5.10 Using "pattern" and "rewrite". *)

Open Scope nat_scope.

Theorem nat_plus_permute :
  forall n m p : nat, n + m + p = n + p + m.
Proof.
  intros n m p.
  rewrite plus_assoc_reverse.
  rewrite plus_assoc_reverse.
  rewrite (plus_comm n (m + p)).
  rewrite (plus_comm n (p + m)).
  rewrite (plus_comm m p).
  trivial.
Qed.

(* Exercise 5.11 Transitivity of Leibniz equality. *)

Theorem eq_trans :
  forall (A : Type) (x y z : A), x = y -> y = z -> x = z.
Proof.
  intros TA x y z h1 h2.
  rewrite h1; assumption.
Qed.

Theorem eq_trans' :
  forall (A : Type) (x y z : A), x = y -> y = z -> x = z.
Proof.
  intros TA x y z h1.
  rewrite h1; trivial.
Qed.

Theorem eq_trans'' :
  forall (A : Type) (x y z : A), x = y -> y = z -> x = z.
Proof.
  intros TA x y z h1.
  pattern y at 1.
  apply eq_ind with TA x;
    [ trivial
    | assumption
    ].
Qed.

(* Exercise 5.12 *)

(* Exercise 5.13 On Negation (impredicative definition). *)
(* Exercise 5.14 An impredicative definition of equality. *)
(* Exercise 5.15 Some impredicative definitions. *)
(* Exercise 5.16 An impredicative definition of "<=". *)

End Exercises.

End EverydayLogic.


Require Arith.

Lemma le_n_plus_pn n p : n <= p + n.
Proof.
  Print le.
  induction p as [ | p IHp ]; simpl.
  + constructor 1.
  + constructor 2; assumption.
Qed.

Check le_ind.

Lemma le_plus n m : n <= m -> exists p, p+n = m.
Proof.
  Print le.
  induction 1 as [ | m H IH ].
  + exists 0; simpl; trivial.
  + destruct IH as (p & Hp).
    exists (S p); simpl; f_equal; trivial.
Qed.

Lemma foo_gen n : 1 <= n -> n = 0 -> False.
Proof.
  intros H.
  induction H.
  + discriminate.
  + discriminate.
Qed.

Lemma foo_1 : ~ 1 <= 0.
Proof.
  red.
  intros H.
  destruct foo_gen with (1 := H).
  reflexivity.
Qed.

Lemma foo : ~ 1 <= 0.
Proof.
  intros H.
  inversion H.
Qed.

Lemma le_n_0 n : n <= 0 -> n = 0.
Proof.
  Print le.
  inversion 1.
  reflexivity.
Qed.

Fixpoint leb n m : bool :=
  match n, m with
    | 0, _     => true
    | S _, 0   => false
    | S n, S m => leb n m
  end.

Lemma le_5_45 : 5 <= 45.
Proof.
(*  do 40 constructor.
  constructor 1. *)
  repeat constructor.
Qed.

Lemma leb_5_45 : leb 5 45 = true.
Proof. reflexivity. Qed.

Print leb_5_45.

Lemma le_trans : forall n p q, n <= p -> p <= q -> n <= q.
Proof.
(*  intros n p q Hpq.
  induction 1 as [ | q H1 IH1 ].
  + trivial.
  + constructor; trivial. *)
  induction 2; [ | constructor ]; trivial.
Qed.

Lemma le_Sn_Sp_inv n p : S n <= S p -> n <= p.
Proof.
  inversion 1.
  + constructor.
  + apply le_trans with (2 := H1).
    do 2 constructor.
Qed.

Lemma le_Sn_Sp n p : n <= p -> S n <= S p.
Proof.
  induction 1; constructor; auto.
Qed.

Lemma le_leb_iff n m : n <= m <-> leb n m = true.
Proof.
  split.
  + revert m.
    induction n as [ | n IHn ]; intros [ | m ]; simpl; auto.
    * inversion 1.
    * intro; apply IHn, le_Sn_Sp_inv; auto.
  + revert m.
    induction n as [ | n IHn ].
    * induction m; simpl; auto.
    * intros [ | m ]; simpl; auto.
      - discriminate.
      - intros H; apply IHn in H.
        apply le_Sn_Sp; trivial.
Qed.

Fact le_78_1090 : 78 <= 1090.
Proof.
  apply le_leb_iff.
  reflexivity.
Qed.

Print le_78_1090.

Require Import Arith.

Fact leb_n_np n p : leb n (n+p) = true.
Proof.
  apply le_leb_iff.
  rewrite plus_comm.
  apply le_n_plus_pn.
Qed.

Print le.

Inductive le' : nat -> nat -> Prop :=
  | le'_n : forall n, le' n n
  | le'_S : forall n m, le' n m -> le' n (S m).

Print le.

Print and.
Print or.
Print ex.
Print eq.
Print True.
Print False.

Check refl_equal.

Definition two_two_four : 2+2 = 4 := eq_refl.


Require Import ZArith.
Section A_declared.

        Variables (A:Set) (P Q: A-> Prop) (R: A -> A -> Prop).
        Theorem all_imp_dist:
                (forall a: A, P a -> Q a)-> (forall a, P a) -> (forall a: A, Q a).
        intros h1 h2.
        intro a.
        apply h1.
        apply h2.
        Qed.

        Theorem all_perm:
                (forall (a b: A), R a b) -> (forall (a b : A), R b a).
        intros h1.
        intros a b.
        apply h1.
        Qed.

        Theorem all_delta :
                (forall (a b :A), R a b) -> (forall (a : A), R a a).
        intros h1 a.
        apply h1.
        Qed.

End A_declared.
Section fourpfour_sec.
        Theorem fpf_id:
                forall A:Set, A -> A.
                Proof.
        intros A a.
        assumption.
                Qed.

Theorem fpf_diag:
               forall A B : Set, (A -> A -> B) -> A -> B.
               Proof.
                       intros A B h1.
                       intro a.
                       apply h1.
                       assumption.
                       assumption.
               Qed.
               Theorem fpf_permute:
                       forall A B C: Set,(A -> B -> C) -> B ->A ->C.
                       Proof.
                               intros A B C h1 b c.
                               apply h1;assumption.
                       Qed.

                       Theorem fpf_f_nat_Z:
                               forall A:Set,(nat -> A) -> Z -> A.
                               Proof.
intros A h1 b.
apply h1;apply(fun (a: Z) => 0);assumption.
                               Qed.
End fourpfour_sec.

Section fourpfive.
        Theorem fpfv_all_perm :
                forall (A:Type) (P:A -> A -> Prop),
                (forall x y : A, P x y) -> (forall x y :A, P y x).
        Proof.
                intros A h1 h2 x y.
                apply h2.
        Qed.
        Theorem fpfv_resolution :
                forall (A:Type) (P Q R S : A -> Prop), (forall a:A,Q a -> R a -> S a) -> (forall b:A, P b -> Q b) -> (forall c : A,P c -> R c -> S c).
        Proof.
                intros A P Q R S h1 h2 c p r.
                apply h1;[(apply h2;assumption)| assumption ].

        Qed.


(*the library would generalize over 4, and have good enough automation to not require these specialized lemmas*)
Require Import Coq.ZArith.ZArith. Local Open Scope Z_scope.
Require Import coqutil.Z.Lia.

Lemma mod4_0_add: forall (x y: Z),
    x mod 4 = 0 ->
    y mod 4 = 0 ->
    (x + y) mod 4 = 0.
Proof.
  intros *. intros Hx Hy.
  rewrite Zplus_mod. rewrite Hx, Hy. reflexivity.
Qed.

Lemma mod4_0_sub: forall (x y: Z),
    x mod 4 = 0 ->
    y mod 4 = 0 ->
    (x - y) mod 4 = 0.
Proof.
  intros *. intros Hx Hy.
  rewrite Zminus_mod. rewrite Hx, Hy. reflexivity.
Qed.

Lemma mod4_mul4_l: forall (x: Z),
    (4 * x) mod 4 = 0.
Proof. intros. rewrite Z.mul_comm. rewrite Z.mod_mul; blia. Qed.

Lemma mod4_mul4_r: forall (x: Z),
    (x * 4) mod 4 = 0.
Proof. intros. rewrite Z.mod_mul; blia. Qed.

Lemma mod4_mul_l: forall (x y: Z),
    x mod 4 = 0 ->
    (x * y) mod 4 = 0.
Proof.
  intros.
  rewrite <- Z.mul_mod_idemp_l by blia.
  rewrite H.
  rewrite Z.mul_0_l.
  reflexivity.
Qed.

Lemma mod4_mul_r: forall (x y: Z),
    y mod 4 = 0 ->
    (x * y) mod 4 = 0.
Proof.
  intros.
  rewrite <- Z.mul_mod_idemp_r by blia.
  rewrite H.
  rewrite Z.mul_0_r.
  reflexivity.
Qed.

Lemma mod_pow2_mod4: forall x p,
    2 <= p ->
    (x mod 2 ^ p) mod 4 = x mod 4.
Proof.
  intros.
  rewrite <- Znumtheory.Zmod_div_mod.
  - reflexivity.
  - reflexivity.
  - apply Z.pow_pos_nonneg; blia.
  - unfold Z.divide.
    exists (2 ^ p / 2 ^ 2).
    rewrite <- Z.pow_sub_r by blia.
    change 4 with (2 ^ 2).
    rewrite <- Z.pow_add_r by blia.
    f_equal.
    blia.
Qed.

Lemma mod4_0_mod_pow2: forall (x p: Z),
    x mod 4 = 0 ->
    (x mod 2 ^ p) mod 4 = 0.
Proof.
  intros.
  assert (p < 0 \/ p = 0 \/ p = 1 \/ 2 <= p) as C by blia. destruct C as [C | [C | [C | C]]].
  - rewrite Z.pow_neg_r by assumption. now rewrite Zmod_0_r.
  - subst p. simpl. rewrite Z.mod_1_r. reflexivity.
  - subst p. change (2 ^ 1) with 2.
    rewrite Z.mod_eq in H by blia.
    replace x with (x / 4 * 2 * 2) by blia.
    rewrite Z.mod_mul by blia.
    reflexivity.
  - rewrite mod_pow2_mod4; assumption.
Qed.

Lemma mod4_0_4: 4 mod 4 = 0. Proof. reflexivity. Qed.

Lemma mod4_0_opp: forall z,
    z mod 4 = 0 ->
    - z mod 4 = 0.
Proof.
  intros. Z.div_mod_to_equations. blia.
Qed.

#[global] Hint Resolve
     mod4_0_mod_pow2
     mod4_0_add
     mod4_0_sub
     mod4_0_mod_pow2
     mod4_mul4_l
     mod4_mul4_r
     mod4_0_4
     mod4_mul_l
     mod4_mul_r
     mod4_0_opp
  : mod4_0_hints.

Ltac solve_mod4_0 := auto 30 with mod4_0_hints.


Require Import Reals.
Require Import Interval.Tactic.

Goal forall x, (1 <= x)%R -> (0 < x)%R.
intros.
interval.
Qed.

Goal forall x, (1 <= x)%R -> (x <= x * x)%R.
intros.
interval with (i_bisect_diff x).
Qed.

Goal forall x, (2 <= x)%R -> (x < x * x)%R.
intros.
interval with (i_bisect_diff x).
Qed.

Goal forall x, (-1 <= x)%R -> (x < 1 + powerRZ x 3)%R.
intros.
interval with (i_bisect_diff x).
Qed.


(* Exercise 24 *)

Require Import BenB.

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

Theorem exercise_024 : (exists x, ~(P x \/ Q x)) -> ~(forall x, P x).
Proof.
imp_i a1.
exi_e (exists x:D, ~(P x \/ Q x)) a a2.
hyp a1.
neg_i (P a) a3.
neg_i (P a \/ Q a) a4.
hyp a2.
dis_i1.
hyp a4.
all_e (forall x:D, P x) a.
hyp a3.
Qed.


Require Import Coq.Init.Nat.
Require Import Coq.ZArith.ZArith.
Require Import Omega.

Module NatAttempt.

Definition ABigOmega (f g : nat -> nat) : Prop :=
  exists a, a > 0 ->
  exists N, forall n, N < n ->
    g n <= a * (f n).

Definition ABigO (f g : nat -> nat) : Prop :=
  exists a, a > 0 ->
  exists N, forall n, N < n ->
    f n <= a * (g n).

Definition ABigTheta (f g : nat -> nat) : Prop :=
  ABigOmega f g /\ ABigO f g.

(** An example for asymptotic bound of cubic function *)
Definition cube1 : nat -> nat := fun x => x*x*x.
Definition poly1 : nat -> nat := fun x => 3*(x*x*x) + x*x - x.

Example boungs_eg1 : ABigTheta poly1 cube1.
Proof.
  unfold ABigTheta, ABigOmega, ABigO, cube1, poly1.
  split.
  - exists 1; intros.
    exists 1; intros.
    simpl. repeat rewrite <- plus_n_O.
    repeat rewrite Nat.mul_add_distr_r.
    rewrite <- Nat.add_sub_assoc.
    + rewrite <- Nat.add_assoc.
      apply le_plus_l.
    + rewrite <- Nat.mul_1_r at 1.
      apply Nat.mul_le_mono_l.
      omega.
  - exists 4; intros.
    exists 0; intros.
    assert (4 = 3 + 1). omega.
    rewrite H1, Nat.mul_add_distr_r; clear H1.
    assert (n <= n*n).
    {
      rewrite <- Nat.mul_1_r at 1.
      apply Nat.mul_le_mono_l.
      omega.
    }
    rewrite <- Nat.add_sub_assoc; [| apply H1].
    Search (_+_<=_+_).
    apply plus_le_compat_l.
    simpl. rewrite <- plus_n_O.
    assert (n = n * 1). omega.
    rewrite H2 at 3; clear H2.
    rewrite <- Nat.mul_sub_distr_l.
    rewrite <- Nat.mul_assoc.
    apply mult_le_compat_l.
    eapply le_trans; [| apply H1]. omega.
Qed.

End NatAttempt.

Module ZAttempt.

Open Scope Z.

Definition ABigOmega (f g : Z -> Z) : Prop :=
  exists (a : Z), a > 0 ->
  exists (N : Z), forall (n : Z), N < n ->
    g n <= a * (f n).

Definition ABigO (f g : Z -> Z) : Prop :=
  exists a, a > 0 ->
  exists N, forall n, N < n ->
    f n <= a * (g n).

Definition ABigTheta (f g : Z -> Z) : Prop :=
  ABigOmega f g /\ ABigO f g.

(** An example for asymptotic bound of cubic function *)
Definition cube1 : Z -> Z := fun x => x*x*x.
Definition poly1 : Z -> Z := fun x => 3*(x*x*x) + x*x - x.

Example boungs_eg1 : ABigTheta poly1 cube1.
Proof.
  unfold ABigTheta, ABigOmega, ABigO, cube1, poly1.
  split.
  - exists 1; intros.
    exists 1; intros.
    rewrite Z.mul_1_l.
    rewrite <- (Z.mul_1_r n) at 9.
    rewrite <- Z.add_sub_assoc.
    rewrite <- Z.mul_sub_distr_l.
    assert (0 <= n * (n - 1)).
    {
      apply (Z.mul_nonneg_nonneg n (n-1)).
      omega. omega.
    }
    assert (n*n*n <= 3*(n*n*n)).
    {
      rewrite <- (Z.mul_1_l (n*n*n)) at 1.
      apply (Z.mul_le_mono_nonneg_r 1 3 (n*n*n)); [| omega].
      apply Z.mul_nonneg_nonneg.
      apply Z.square_nonneg.
      omega.
    }
    omega.
  - exists 4; intros.
    exists 0; intros.
    (* split 3 * (n * n * n) + 1 * (n * n * n) *)
    assert (4 = 3 + 1). omega.
    rewrite H1; clear H1.
    rewrite Z.mul_add_distr_r.
    (* remove 3 * (n * n * n) *)
    rewrite <- Z.add_sub_assoc.
    apply Zplus_le_compat_l.
    (* remove n *)
    rewrite Z.mul_1_l.
    rewrite <- (Z.mul_1_r n) at 3.
    rewrite <- Z.mul_sub_distr_l.
    rewrite <- Z.mul_assoc.
    apply Z.mul_le_mono_nonneg_l; [omega |].
    (* n - 1 <= n <= n * n *)
    apply Z.le_trans with n; [omega |].
    rewrite <- (Z.mul_1_r n) at 1.
    apply Z.mul_le_mono_nonneg_l; omega.
Qed.

End ZAttempt.


Lemma and_assoc : forall A B C:Prop, A /\ (B /\ C) -> (A /\ B) /\ C.
Proof.
 intros A B C [a [b c]]; repeat split; assumption.
Qed.

Lemma and_imp_dist : forall A B C D:Prop,
   (A -> B) /\ (C -> D) -> A /\ C -> B /\ D.
Proof.
  intros A B C D [H1 H2] [a c].
  split;[apply H1|apply H2];assumption.
Qed.

Lemma not_contrad : forall A : Prop, ~(A /\ ~A).
Proof.
 intros A [a a']; apply a'; assumption.
Qed.

Lemma or_and_not : forall A B : Prop, (A\/B)/\~A -> B.
Proof.
 intros A B [[a|b] a'];[elim a'| idtac]; trivial.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat.

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

(** Some basic functions *)

Definition const {A B} (a : A) := fun _ : B => a.

Definition flip {A B C} (f : A -> B -> C) : B -> A -> C :=
  fun b a => f a b.

Arguments const {A B} a _ /.
Arguments flip {A B C} f b a /.

(* move to logic_exercises *)
Section IntLogic.

Variables A B C D : Prop.

Lemma axiomK :
  A -> B -> A.
Proof. exact: const. Qed.

(* note: flip is more general *)
Lemma contraposition :
  (* (A -> (B -> False)) -> (B -> (A -> False)) *)
  (A -> ~ B) -> (B -> ~ A).
(* Proof. exact: flip. Qed. *)
Proof.
  rewrite /not.
  Check flip.
  exact: flip.
Qed.

Lemma p_imp_np_iff_np :
  (* Which is equivalent to:
    ((A -> (A -> False)) -> (A -> False))        /\
    ((A -> False)        -> (A -> (A -> False)))
  *)
  (A -> ~A) <-> ~A.
Proof.
  split.
  - move => a_i_not_a a.
    exact: (a_i_not_a a).
  - move => not_a _.
    exact: not_a.
Qed.

(* We can generalize the previous lemma into *)
Lemma p_p_q_iff_p_q : (A -> A -> B) <-> (A -> B).
Proof.
  split.
  - move=> aa_i_b a.
    exact: (const aa_i_b a).
  - move=> a_i_b _.
    exact: a_i_b.
Qed.

(* [apply] без [:] использует другой движок унификации,
   что может в дальнейшем привести к проблемам, т.е.
   лучше всегда использовать версию c [:], т.e. [apply: whatever] *)

Lemma p_is_not_equal_not_p :
  (* ((A -> (A -> False) /\ (A -> False) -> A) -> False) *)
  ~ (A <-> ~ A).
Proof.
  (* unfold not. *)
  rewrite /not.
  case.
  move=> a_i_not_a not_a_i_a.
  apply: (a_i_not_a).
  apply: not_a_i_a.
  move=> a.
  apply: (a_i_not_a).
  exact: a.
  exact: a.

  apply: not_a_i_a.
  move=> a.
  apply: a_i_not_a.
  exact: a.
  exact: a.
Qed.

Lemma p_is_not_equal_not_p' :
  (* ((A -> (A -> False) /\ (A -> False) -> A) -> False) *)
  ~ (A <-> ~ A).
Proof.
  (* unfold not. *)
  (* rewrite /not. *)
  case.

  (* У нас выше есть доказанная лемма:
     p_imp_np_iff_np : (A -> ~A) <-> ~A *)

  move/p_imp_np_iff_np.
  move=> not_a not_a_i_a.
  apply: (not_a).
  by apply: not_a_i_a.
Qed.

Lemma not_not_lem :
  ~ ~ (A \/ ~ A).
Proof.
  rewrite /not.
  move=> not_lem.
  apply: (not_lem).
  left.

  Undo 1.

  right.
  move=> a.
  apply: not_lem.
  left.
  exact: a.
Qed.

Lemma not_not_lem' :
  ~ ~ (A \/ ~ A).
Proof. intuition. Defined.
Eval compute in not_not_lem'.

Lemma constructiveDNE :
  ~ ~ ~ A -> ~ A.
Proof.
  rewrite /not.
  move=> H a.
  apply: H.
  apply.
  exact: a.
Qed.

End IntLogic.

(* Boolean logic (decidable fragment enjoys classical laws) *)

Section BooleanLogic.

Lemma LEM_decidable a :
  a || ~~ a.
Proof.
  (* Используя команду [Set Printing Coercions].
     можно увидеть, что целью на самом деле является [is_true (a || ~~ a)],
     где [is_true] определяется как [fun b => b = true] *)
  Set Printing Coercions.
  (* [is_true] -- это стандартный способ поднять булево значение
     на уровень типов, коэрцию Coq вставляет неявно, в зависимости
     от контекста. Поскольку цель -- это всегда какой-то тип, то
     Coq понимает, что нужно булево значение преобразовать в тип,
     используя базу данных коэрций (в которую заранее добавлен [is_true]) *)
  Unset Printing Coercions.

  (* Unset Printing Notations. *)

  (* Search _ (orb _ (negb _)). *)
  (* Search _ (_ || ~~_). *)

  (* Print orbN. *)
  (* apply orbN. *)
  (* Set Printing Notations. *)

  (* case a. by []. by []. *)
  (* case a. done. done. *)
  by case a.
Qed.

(* Check erefl. *)
(* Check (erefl true). *)

About implb.

Lemma disj_implb a b :
  a || (a ==> b).
Proof.
  case a.
  - done.
  done.
  Restart.

  by case a.
Qed.

Lemma iff_is_if_and_only_if a b :
  (a ==> b) && (b ==> a) = (a == b).
Proof.
  Locate "==>".
  (* Definition implb (b1 b2:bool) : bool := if b1 then b2 else true. *)
  by case a; case b.

  Restart.

  move: a b.
  by case; case.

  Restart.

  move: a b=> [[] | []] /=.
  Undo.
  by move: a b=> [[] | []].
Qed.

Lemma implb_trans : transitive implb.
Proof.
  Eval hnf in transitive implb.

  (* case. case. case. done. done. done. *)
  (* case. done. done. *)

  by do 2! case.
  Undo 1.
  by case; case.
Qed.

Lemma triple_compb (f : bool -> bool) :
  f \o f \o f =1 f.
Proof.
  (* Unset Printing Notations. *)
  (* Print eqfun. *)
  (* Print funcomp. *)
  Locate "=1".
  (* Set Printing Notations. *)

  (* Это моё глупое решение, следующие два более хитрые и короткие. *)

 (* [simpl] это не ssreflec'овая тактика,
    так больше не делаем :) *)
  case. simpl.

  Undo 2.

  (* Если раскрыть определения [eqfun] и [funcomp],
     то [case] ниже станет более понятным *)
  rewrite /eqfun.
  rewrite /funcomp.

  (* Вот так правильно делать вместo [simpl], [//=] упрощает цель *)
  case=>//=.
  (* Мы можем разобрать возможные результаты
     ф-ции [f : bool -> bool] (их всего 2, тк в [bool] всегда 2 жителя) *)
  - case E1:(f true).
    (* ^ Именуем вариант, когда [f true = true] и сохраняем его в контексте,
         тк дальше будем использовать это равенство для переписывания *)
    + by rewrite E1.
      (* Здесь тоже рассматриваем возможные результаты ф-ции [f false]*)
    + case E2:(f false).
      * by rewrite E1.
      * by rewrite E2.
    + case E2:(f false).
      case E1:(f true).
      * by rewrite E1.
      * by rewrite E2.

    (* Приходится повторять тоже самое ещё раз...
       Если появляется необходимость повторять док-во,
       то обычно это знак, что есть какая-то симметрия,
       которую изначально не уловили и пошли другим путём.
     *)

  Restart.

  (* [rewrite !E1] -- Переписать 1 или более раз
     [rewrite ?E2] -- Переписать 0 или более раз *)

  by case; case E1:(f true)=>/=; case E2:(f false); rewrite ?E1 ?E2. Restart.
  by case=>/=; case E1:(f true); case E2:(f false); rewrite ?E1 ?E2.

  (* [by t1; t2; ...] выполняет вот эти вот [t1; t2; ...] для каждой подцели.
     Т.е [by case;] сгенерит первые пару целей, потом следующие два [case]
     дадут нам ещё несколько случаев. И вот для каждого случая мы
     переписываем пока переписывается. *)

   (* The [;] tactical applies the tactic on the right side of the
      semicolon to all the subgoals produced by tactic on the left
      side. *)
Qed.

(* negb \o odd means "even" *)
Lemma even_add :
  {morph (negb \o odd) : x y / x + y >-> x == y}.
Proof.
  Eval hnf in {morph (negb \o odd) : x y / x + y >-> x == y}.

  Locate "morph".
  Unset Printing Notations.
  Set Printing Notations.
  About morphism_2. (* Print morphism_2. *)
  (* В сущности мы говорим, что можем "продавить" морфизм [f] внутрь аргументов:
     Definition morphism_2 aOp rOp := forall x y, f (aOp x y) = rOp (f x) (f y). *)
  rewrite /morphism_2.
  (* Прикол в том, чтобы научиться доказывать леммы без
     использования индукции и предпочитать переписывания.
     Для этого нужно уметь искать другие леммы, тк
     oбычно значительная часть времени по доказательству
     уходит на поиск уже доказанных подходящих лемм,
     которые можно задействовать/использовать. *)
  move=> x y /=.
  Search _ (odd (_ + _)).
  About odd_add.
  Locate "(+)".
  About addb.
  (* have H: ~~ odd (x + y). rewrite odd_add. *)
  (* C [have H] это альтернативный путь, по которому можно пойти.
     Но можно просто переписывать часть цели/выражения.*)
  rewrite [in ~~ odd (x + y)] odd_add.
  (* Вот такой синтаксис как выше позволяет выпoлнить
     переписывание только в указанной часть выражения. *)
  (* Search _ (~~ _ (+) _). *)
  Search _ (~~ _ == _).
  rewrite eqb_negLR.
  Search _ (~~ ~~ _).
  rewrite Bool.negb_involutive.
  (* Search _ involutive. *)
  (* Search _ (~~ _ = _). *)
  (* rewrite negbK. *)

  Search _ (~~ (_ (+) _)).
  by rewrite negb_add.
Qed.

End BooleanLogic.

(* some properties of functional composition *)

Section eq_comp.
Variables A B C D : Type.

Lemma compA (f : A -> B) (g : B -> C) (h : C -> D) :
  h \o g \o f = h \o (g \o f).
Proof.
  done. Undo.
  Unset Printing Notations.
  (* Search _ (funcomp _). Print invariant. *)
  Set Printing Notations.
  About funcomp.
  (*     (B -> A) ->     (C -> B) -> C -> A *)
  (* (g : B -> C) \o (f : A -> B) -> A -> C  *)
  rewrite /funcomp.
  done.
Qed.

Lemma eq_compl (f g : A -> B) (h : B -> C) :
  f =1 g -> h \o f =1 h \o g.
Proof.
  Unset Printing Notations.
  Set Printing Notations.
  rewrite /eqfun /funcomp.
  move=> H a.
  by rewrite (H a).
Qed.

Lemma eq_compr (f g : B -> C) (h : A -> B) :
  f =1 g -> f \o h =1 g \o h.
Proof.
  by rewrite /funcomp; move=> H a; rewrite (H (h a)).
Qed.

Lemma eq_idl (g1 g2 : A -> B) (f : B -> B) :
  f =1 id -> f \o g1 =1 f \o g2 -> g1 =1 g2.
Proof.
  rewrite /funcomp /eqfun.
  move=> H_id H_eq_comp a.
  move: (H_eq_comp a); clear H_eq_comp.
  rewrite (H_id (g1 a)).
  rewrite (H_id (g2 a)).
  apply.
Qed.

Lemma eq_idr (f1 f2 : A -> B) (g : A -> A) :
  g =1 id -> f1 \o g =1 f2 \o g -> f1 =1 f2.
Proof.
  rewrite /funcomp.
  move=> H_id H_eq_comp a.
  move: (H_eq_comp a); clear H_eq_comp.
  (* Когда смотришь на что-то типа [g =1 id]
     нужно всегда иметь ввиду [foral x : A, g x = x]. *)
  by rewrite (H_id a).
Qed.

End eq_comp.

(* Dependent pattern-matching practice.
   Also see Lecture 3 (+links).
*)

About f_equal.
About eq_add_S.

About f_equal_pred.
Print eq_refl.

(* f_equal_pred : forall x y : nat, x = y -> x.-1 = y.-1 *)

Definition succ_inj (n m : nat) :
  S n = S m -> n = m
:=
  fun eqS =>
    match
      eqS in (_ = S v) (* v = m *)
      return (n = v)
    with
    | erefl => erefl
    end.

Definition false_eq_true_implies_False :
  false = true -> False :=
  fun prf =>
    match prf in (_ = t)
          return (if t then False else True)
    with
    | erefl => I
    end.

(* TL;DR про поиск:

   https://github.com/math-comp/math-comp/wiki/Search
   https://github.com/math-comp/math-comp/blob/master/CONTRIBUTING.md#where

   В общем виде поисковый запрос выглядит так:

   Search (-)?(symbol|pattern)+ (in (module)+)?

   где
     symbol  - какая-то подстрока
     pattern - какой-то шаблон

   Запрос вида Search pattern. ищет только в заключениях.
   Чтобы поискать везде, включая предпосылки, нужно писать:

   Search _ pattern.

*)

Search -(_ < _) -(_ = _) "odd" in ssrnat.

(*
Definition neq_sym A (x y : A) :
  x <> y -> y <> x
:=

Definition f_congr {A B} (f : A -> B) (x y : A) :
  x = y  ->  f x = f y
:=

Definition f_congr' A B (f g : A -> B) (x y : A) :
  f = g  ->  x = y  ->  f x = g y
:=

Definition pair_inj A B (a1 a2 : A) (b1 b2 : B) :
  (a1, b1) = (a2, b2) -> (a1 = a2) /\ (b1 = b2)
:=
*)


Require Export P08.

(** **** Exercise: 4 stars (factorial)  *)
(** Recall that [n!] denotes the factorial of [n] (i.e. [n! =
    1*2*...*n]).  Here is an Imp program that calculates the factorial
    of the number initially stored in the variable [X] and puts it in
    the variable [Y]:
    {{ X = m }}
  Y ::= 1 ;;
  WHILE X <> 0
  DO
     Y ::= Y * X ;;
     X ::= X - 1
  END
    {{ Y = m! }}

    Fill in the blanks in following decorated program:
    {{ X = m }} ->>
    {{ (st X)! * Y = m! [Y|->1]}}
  Y ::= 1;;
    {{ (st X)! * Y = m! }} : I
  WHILE X <> 0
  DO   {{  I  /\ X <> 0         }} ->>
       {{    I [Y |-> Y*X] [X |-> X-1]         }}
     Y ::= Y * X;;
       {{    I [X |-> X-1]                     }}
     X ::= X - 1
       {{    I                                 }}
  END
    {{ (st X)! * Y = m!  /\  st X = 0 }} ->>
    {{ Y = m! }}
*)

Print fact.

Lemma mult_dist_l : forall a b c,
  a * (b + c) = a * b + a * c.
Proof. intros. induction a. reflexivity.
  simpl. rewrite IHa. omega. Qed.
Lemma mult_dist_r : forall a b c,
(a + b) * c = a * c + b * c.
Proof. intros. rewrite mult_comm. rewrite mult_dist_l.
  rewrite mult_comm. replace (c*b) with (b*c). omega. apply mult_comm. Qed.

Lemma fact_mult : forall m,
  m <> 0 -> fact (m - 1) * m = fact m.
Proof. intros. induction m. contradiction H. reflexivity.
  simpl. replace (m-0) with m. replace (S m) with (1 + m).
  rewrite mult_dist_l. rewrite mult_comm. simpl. rewrite mult_comm. omega. omega. omega. Qed.

Theorem factorial_dec_correct: forall m,
  {{ fun st => st X = m }}
  Y ::= ANum 1 ;;
  WHILE BNot (BEq (AId X) (ANum 0))
  DO
     Y ::= AMult (AId Y) (AId X) ;;
     X ::= AMinus (AId X) (ANum 1)
  END
  {{ fun st => st Y = fact m }}.
Proof.
  intros m. eapply hoare_consequence with (P':= (fun st=> fact (st X) * st Y = fact m)[Y|->ANum 1]) (Q':= (fun st => fact (st X) * st Y = fact m /\ st X = 0)).
  Case "{{P'}} c;;while {{Q'}}".
    apply hoare_seq with (Q:= (fun st=> fact (st X) * st Y = fact m )). (* Q = I *)
    SCase "{{I}} while {{Q'}}".
      eapply hoare_consequence_post. apply hoare_while.
      SSCase "{{I/\b}} c1;;c2 {{I}}".
        eapply hoare_seq. (* {{I'}} c2 {{I}} *) apply hoare_asgn.
        (* {{I/\b}} c1 {{I'}} *)
        eapply hoare_consequence_pre. apply hoare_asgn.
        unfold assert_implies, assn_sub. simpl. intros.
        unfold update. simpl.
        destruct H. destruct H.
        apply negb_true_iff in H0. apply beq_nat_false_iff in H0.
        replace (st Y * st X) with (st X * st Y).
        rewrite mult_assoc. rewrite fact_mult. omega. assumption.
        apply mult_comm.
      SSCase "I ->> Q'".
        unfold hoare_triple, assert_implies. intros.
        destruct H. simpl in H0. apply negb_false_iff in H0. apply beq_nat_true_iff in H0. split; assumption.
    SCase "{{P'}} c {{I}}".
      apply hoare_asgn.
  Case "P ->> P'".
    unfold assert_implies, assn_sub.  intros.
    unfold update. simpl. rewrite H. omega.
  Case "Q' ->> Q".
    unfold assert_implies. intros.
    destruct H.  rewrite H0 in H. rewrite<-H. simpl. omega.
Qed.


(** * Generic definitions. *)
(** This script provides generic definition of relations that are used along the overall formalization. Most of the definitions and lemmas implemented here are quite trivial. *)

Require Export Arith Relations Program Omega Utf8.

(** Some usefull tactics *)
Ltac inv H := inversion H;try subst;try congruence.

Ltac fomega := elimtype False;omega.

Ltac do_stable H P x0 :=
  try assert(P x0) by (eapply H;esplit;eauto).

Ltac destruct2 v H :=
  destruct v;destruct H.

(** Reflexive and transitive closure of a relation [R] *)

Inductive star (A:Type)(R:relation A) : A -> A -> Prop :=
| star_refl :
  forall x:A, star A R x x
| star_tran :
  forall x y:A,
    R x y -> forall z:A, star A R y z -> star A R x z.

(** Indexed reflexive and transitive closure over a relation [R] *)

Inductive starn (A:Type)(R:relation A) : nat -> A -> A -> Prop :=
| starn_refl :
  forall x:A,
    starn A R 0 x x
| starn_tran :
  forall x y:A,
    R x y -> forall (n:nat)(z:A), starn A R n y z -> starn A R (S n) x z.

Hint Constructors star starn.

(** Lemmas about the reflexive and transitive closure of a relation *)

Lemma star2starn:
  forall A R x y,
    star A R x y -> exists n, starn A R n x y.
Proof.
  induction 1.
  exists 0;auto.
  destruct IHstar.
  exists (S x0);econstructor 2;eauto.
Qed.

Lemma starn2star:
  forall A R n x y,
    starn A R n x y -> star A R x y.
Proof.
  induction n;intros.
  inversion H;auto.
  inversion_clear H.
  econstructor 2;eauto.
Qed.

(** Two simple tactics to exchange [nat]-indexed closure with the non-indexed one. *)

Ltac do_star2starn H :=
  let t := fresh "H" in
    pose proof (star2starn _ _ _ _ H) as t;clear H;
    let n := fresh "n" with m := fresh "H" in destruct t as [n m].

Ltac do_starn2star H :=
  let t := fresh "H" in
    pose proof (starn2star _ _ _ _ _ H);clear H.

(** Transitivity of closures (indexed or not). *)

Lemma star_starn_trans :
  forall n A R x y,
    starn A R n x y ->
    forall z,
      star A R y z ->  star A R x z.
Proof.
  induction n;intros.
  inversion_clear H.
  assumption.
  inversion_clear H.
  constructor 2 with y0.
  assumption.
  eapply IHn.
  apply H2.
  assumption.
Qed.

Lemma star_trans :
  forall A R x y,
    star A R x y ->
    forall z, star A R y z -> star A R x z.
Proof.
  intros.
  do_star2starn H.
  eapply star_starn_trans;eauto.
Qed.

Lemma starn_trans :
  forall n A R x y,
    starn A R n x y ->
    forall m z,
      starn A R m y z ->
      starn A R (n+m) x z.
Proof.
  induction n;intros.
  inv H.
  simpl.
  assumption.
  inv H.
  constructor 2 with y0;eauto.
Qed.

Lemma starn_ex :
  forall n A R x y,
    starn A R n x y ->
    exists m x', m <= n /\ starn A R m x x' /\ starn A R (n-m) x' y.
Proof.
  induction n;intros.
  inv H.
  simpl.
  exists 0 y.
  split;auto with arith.
  inv H.
  pose proof IHn _ _ _ _ H2.
  destruct H0 as [m [x' [H4 [H5 H6]]]].
  exists (S m) x'.
  split;auto with arith.
  split.
  constructor 2 with y0;auto.
  simpl.
  assumption.
Qed.

Lemma star_R_star :
  forall A (R:relation A) x y,
    R x y ->
    star A R x y.
Proof.
  intros.
  constructor 2 with y.
  assumption.
  constructor.
Qed.

(** Closure for sub-relation. *)

Lemma star_R_star_incl :
  forall A (R1 R2:relation A) x y,
    (forall a b, R1 a b -> R2 a b) ->
    star A R1 x y ->
    star A R2 x y.
Proof.
  intros until y;intro H.
  induction 1;auto.
  constructor 2 with y.
  apply H.
  assumption.
  apply IHstar.
Qed.

(** Closure of a reflexive and transitive relation. *)

Lemma star_R_trans_imply_own :
  forall A (R:relation A) x y,
    (forall a, R a a) ->
    (forall a b c, R a b -> R b c -> R a c) ->
    star _ R x y -> R x y.
Proof.
  induction 3;intros.
  apply H.
  inv H2.
  apply H0 with y;assumption.
Qed.

(** Alternative inductive principle for dealing with the reflexive and
transitive closures. This one is used, in particular, in the soundness
proof of the while rule.

This lemma indeed states that if we reach a state [s'] such that [P
s'] is statisfied in all the intermediate states [s''], then the
property [P] models the overall computation. This implies that the
reflexive and transitive closure [star] must be decomposed in the nth
transitions in the middle. One can look at this particular inductive
principle as a more detailed notion of well-founded induction over the
natural numbers, where each natural number refers to the nth-step of
execution of a program.
*)

Lemma RT_ind_gen :
    forall (X:Type) (R P : X -> X -> Prop),
      (forall x : X, P x x) ->
      (forall (x y z: X) n, R x y -> starn _ R n y z ->
      (forall y1 k, k <= n -> starn _ R k y1 z -> P y1 z) -> P x z) ->
      forall x y : X, star _ R x y -> P x y.
Proof.
  intros.
  case (star2starn _ _ _ _ H1).
  intros.
  assert (forall k z, k <= x0 -> starn _ R k z y -> P z y).
  induction H2.
  intros.
  replace k with 0 in *;try omega.
  inv H3;auto.
  intros.
  assert(k <= n \/ k = S n) by omega.
  destruct H6.
  eapply IHstarn with k.
  eapply starn2star with n.
  assumption.
  assumption.
  assumption.
  subst k.
  inv H5.
  pose proof H8.
  do_starn2star H3.
  eapply H0;eauto.
  eapply H3;eauto.
Qed.


(* Exercise 47 *)

Require Import BenB.

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

Variable A : Prop.

Theorem exercise_047 : (forall x, P x -> A) -> (exists x, P x) -> A.
Proof.
imp_i a1.
imp_i a2.
exi_e (exists x:D, P x) a a3.
hyp a2.
imp_e (P a).
all_e (forall x:D, P x -> A) a.
hyp a1.
hyp a3.
Qed.


Inductive Exp := ConstE : nat -> Exp | BinopE : (nat -> nat -> nat) -> (Exp -> Exp -> Exp).
Inductive StackOp := PushS : nat -> StackOp | BinopS : (nat -> nat -> nat) -> StackOp.

Fixpoint evalExp e := match e with
    | ConstE n => n
    | BinopE f e1 e2 => f (evalExp e1) (evalExp e2)
    end.

Definition builder A := list A -> list A.
Definition build {A} (b : builder A) : list A := b nil.
Definition singleton {A} (x : A) : builder A := cons x.
Definition append {A} (x y : builder A) : builder A := fun z => x (y z).
Fixpoint prefix {A} (xs : list A) : builder A := match xs with nil => fun a => a | cons y ys => append (singleton y) (prefix ys) end.

Require Import Setoid.
Lemma build_prefix_id : forall A (xs : list A), build (prefix xs) = xs.
    intros a xs; induction xs; [|rewrite <- IHxs at 2]; reflexivity. Qed.
Lemma prefix_nil_id : forall A (xs : list A), prefix xs nil = xs.
    intros a xs; induction xs; [|rewrite <- IHxs at 2]; reflexivity. Qed.

Theorem append_assoc : forall A (x y z : builder A), append x (append y z) = append (append x y) z.
    intros A x y z. unfold append. reflexivity. Qed.

Fixpoint compile e := match e with
    | ConstE n => singleton (PushS n)
    | BinopE f e1 e2 => append (append (compile e2) (compile e1)) (singleton (BinopS f))
    end.

Fixpoint bad_compile e := match e with
    | ConstE n => singleton (PushS n)
    | BinopE f e1 e2 => append (append (bad_compile e1) (bad_compile e2)) (singleton (BinopS f))
    end.

(*Eval cbn in compile (BinopE mult (BinopE plus (ConstE 2) (ConstE 3)) (ConstE 4)) nil.*)

Fixpoint evalStackM (prog : list StackOp) (stack : list nat) := (match prog with
    | PushS n :: prog' => evalStackM prog' (n :: stack)
    | BinopS f :: prog' => match stack with
        | x :: y :: stack' => evalStackM prog' (f x y :: stack')
        | _ => None
        end
    | nil => match stack with
        | x :: _ => Some x
        | nil => None
        end
    end)%list.

Theorem compile_correct : forall e p s, evalStackM ((compile e) p) s = evalStackM p (evalExp e :: s)%list.
    intros e. induction e; intros p s.
    - reflexivity.
    - cbn. unfold append. rewrite IHe2, IHe1. reflexivity.
    Qed.

Theorem bad_compile_correct : forall e p s, evalStackM ((bad_compile e) p) s = evalStackM p (evalExp e :: s)%list.
    intros e. induction e; intros p s.
    - reflexivity.
    - cbn. unfold append. rewrite IHe1, IHe2. cbn.
(* At this point, the goal is:
evalStackM p (n (evalExp e2) (evalExp e1) :: s) =
evalStackM p (n (evalExp e1) (evalExp e2) :: s)
which demonstrates that bad_compile is unprovable without assuming n's commutativity
*)
    Show. Abort.


Require Import bool.
Require Import list.
Require Import In.
Require Import filter.

(* merge k m l  == 'l is an in order merge of k and m' *)
Inductive merge (a:Type) : list a -> list a -> list a -> Prop :=
| merge_nil_l  : forall (l:list a), merge a [] l l
| merge_nil_r  : forall (l:list a), merge a l [] l
| merge_cons_l : forall (k m l: list a) (x:a),
    merge a k m l -> merge a (x :: k) m (x :: l)
| merge_cons_r : forall (k m l:list a) (x:a),
    merge a k m l -> merge a k (x :: m) (x :: l)
.

Arguments merge {a} _ _ _.

Theorem filter_merge : forall (a:Type) (test:a -> bool) (k m l:list a),
    (forall x, In x k -> test x = true) ->
    (forall x, In x m -> test x = false) ->
    merge k m l ->
    filter test l = k.
Proof.
    intros a test k m l Hk Hm H. revert Hk Hm.
    induction H as [l|l|k m l x H IH|k m l x H IH].
    - intros H0 H. clear H0. apply filter_of_false. exact H.
    - intros H H0. clear H0. apply filter_of_true. exact H.
    - intros H1 H2. assert (test x = true) as Hx. { apply H1. left. reflexivity. }
        simpl. rewrite Hx. assert (filter test l = k) as H0.
            { apply IH.
                + intros y H'. apply H1. right. exact H'.
                + exact H2.
            }
        rewrite H0. reflexivity.
    - intros H1 H2. assert (test x = false) as Hx. { apply H2. left. reflexivity. }
        simpl. rewrite Hx. apply IH.
            + exact H1.
            + intros y H'. apply H2. right. exact H'.
Qed.


(** Syntax and semantics of the language called IMP, a small
    imperative structured language. *)

Require Import Coq.Program.Equality.
Require Import Bool.
Require Import ZArith.
Require Import Sequences.

Open Scope Z_scope.

(** * 1. Abstract syntax *)

(** Variables are identified by integers. *)
Definition ident : Type := Z.

Definition eq_ident: forall (x y: ident), {x=y}+{x<>y} := Z_eq_dec.

(** Syntax of arithmetic expressions  *)
Inductive aexp : Type :=
  | Const: Z -> aexp                    (**r constant *)
  | Var: ident -> aexp                  (**r variable *)
  | Plus: aexp -> aexp -> aexp          (**r sum [a1 + a2] *)
  | Minus: aexp -> aexp -> aexp.         (**r difference [a1 - a2] *)

(** Syntax of boolean expressions.
    Boolean expressions are used as conditions in [if] and [while] commands. *)
Inductive bexp : Type :=
  | TRUE: bexp                          (**r always true *)
  | FALSE: bexp                         (**r always false *)
  | Eq: aexp -> aexp -> bexp            (**r equality test [a1 == a2] *)
  | Le: aexp -> aexp -> bexp            (**r less or equal test [a1 <= a2] *)
  | Not: bexp -> bexp                   (**r negation [!b] *)
  | And: bexp -> bexp -> bexp.          (**r conjunction [b1 & b2] *)

(** Syntax of commands ("statements"). *)
Inductive command : Type :=
  | Skip                                (**r do nothing *)
  | Assign: ident -> aexp -> command    (**r assignment [x = a;] *)
  | Seq: command -> command -> command  (**r sequence [c1; c2] *)
  | If: bexp -> command -> command -> command (**r conditional [if (b) { c1 } else {c2}] *)
  | While: bexp -> command -> command.  (**r loop [while (b) { c }] *)

Definition vx : ident := 1.
Definition vy : ident := 2.
Definition vq : ident := 3.
Definition vr : ident := 4.

(* Define the following commands :
- assignment "vr = vx"
- the infinite loop such that its condition is always true and its body is the skip command
- the euclidian division, corresponding to the following algorithm
<<
                      r = x;
                      q = 0;
                      while (y <= r) {
                          r = r - y;
                          q = q + 1;
                      }
>>
*)
Definition assign1 := Assign vx (Var vr).

Definition infinite_loop := While (TRUE) Skip.

Definition euclidean_division : command :=
  Seq (Assign vr (Var vx))
   (Seq (Assign vq (Const 0))
     (While (Le (Var vy) (Var vr))
       (Seq (Assign vr (Minus (Var vr) (Var vy)))
            (Assign vq (Plus (Var vq) (Const 1)))))).

(** * 2. Denotational semantics (begin) *)
Definition state := ident -> Z.

Definition initial_state: state := fun (x: ident) => 0.

(** Update the value of a variable, without changing the other variables. *)
Definition update (s: state) (x: ident) (n: Z) : state :=
  fun y => if eq_ident x y then n else s y.

(** Good variable properties for [update]. *)

Lemma update_same:
  forall x val m, (update m x val) x = val.
Proof.
  unfold update; intros. destruct (eq_ident x x); congruence.
Qed.

Lemma update_other:
  forall x val m y, x <> y -> (update m x val) y = m y.
Proof.
  unfold update; intros. destruct (eq_ident x y); congruence.
Qed.

(* Evaluation of expressions *)

Fixpoint aeval (s: state) (e: aexp) {struct e} : Z :=
  match e with
  | Var x => s x
  | Const n => n
  | Plus e1 e2 => aeval s e1 + aeval s e2
  | Minus e1 e2 => aeval s e1 - aeval s e2
  end.

Fixpoint beval (s: state) (b: bexp) : bool :=
  match b with
  | TRUE => true
  | FALSE => false
  | Eq e1 e2 =>
      if Z_eq_dec (aeval s e1) (aeval s e2) then true else false
  | Le e1 e2 =>
      if Z_le_dec (aeval s e1) (aeval s e2) then true else false
  | Not b1     => negb (beval s b1)
  | And b1 b2  => (beval s b1) && (beval s b2)
  end.

Compute (aeval initial_state (Var vx)).

Compute (
  let x : ident := 0 in
  let s : state := update initial_state x 12 in
  aeval s (Plus (Var x) (Const 1))).

(* An example of optimization of expressions
   Write a function that transforms any arithmetic expression such as
   0 + a into a, and leave other expressions unchanged. *)

Fixpoint optimize_0plus (e:aexp) : aexp :=
  match e with
  | Const n => Const n
  | Var v => Var v
  | Plus (Const 0) e2 =>
      optimize_0plus e2
  | Plus e1 e2 =>
      Plus (optimize_0plus e1) (optimize_0plus e2)
  | Minus e1 e2 =>
      Minus (optimize_0plus e1) (optimize_0plus e2)
  end.

Compute (
  optimize_0plus (Plus (Const 2)
                       (Plus (Const 0)
                             (Plus (Const 0) (Const 1))))).

(* Prove that the previous optimization is sound:
   every evaluation of an optimized expression yields the same value as
   the evaluation of the original expression.
   You should need to use induction here !
*)

Theorem optimize_0plus_sound : forall s e,
aeval s (optimize_0plus e) = aeval s e.
Proof.
intros se; induction e; simpl; auto.

(* Plus *)
destruct e1.
destruct z; simpl. auto.
rewrite IHe2; auto.
rewrite IHe2; auto.
simpl. rewrite IHe2; auto.

simpl; simpl in IHe1; rewrite IHe1; rewrite IHe2; auto.

simpl. rewrite IHe2. simpl in IHe1. rewrite IHe1. auto.

(* Minus *)
rewrite IHe1; rewrite IHe2; auto.
Qed.

(** * 3. Small-step semantics *)

Inductive red: command * state -> command * state -> Prop :=
  | red_assign: forall x e s,
      red (Assign x e, s) (Skip, update s x (aeval s e))
  | red_seq_left: forall c1 c2 s c1' s',
      red (c1, s) (c1', s') ->
      red (Seq c1 c2, s) (Seq c1' c2, s')
  | red_seq_skip: forall c s,
      red (Seq Skip c, s) (c, s)
  | red_if_true: forall s b c1 c2,
      beval s b = true ->
      red (If b c1 c2, s) (c1, s)
  | red_if_false: forall s b c1 c2,
      beval s b = false ->
      red (If b c1 c2, s) (c2, s)
  | red_while_true: forall s b c,
      beval s b = true ->
      red (While b c, s) (Seq c (While b c), s)
  | red_while_false: forall b c s,
      beval s b = false ->
      red (While b c, s) (Skip, s).

(* Prove the following lemma stating that red is deterministic.
   Use "induction 1" to reason by induction on derivations.
*)
Lemma red_deterministic:
  forall cs cs1, red cs cs1 -> forall cs2, red cs cs2 -> cs1 = cs2.
Proof.
  induction 1; intros cs2 RED; inversion RED; subst; auto; try congruence.
  generalize (IHred _ H4). congruence.
  inversion H.
  inversion H3.
Qed.

(** * 4. Natural sematnics (big-step) *)

(** [eval m a n] is true if the expression [a] evaluates to value [n] in memory state [m]. *)

Inductive eval: state -> aexp -> Z -> Prop :=
  | eval_const: forall m n,
      eval m (Const n) n
  | eval_var: forall m x n,
      m x = n ->
      eval m (Var x) n
  | eval_plus: forall m a1 a2 n1 n2,
      eval m a1 n1 -> eval m a2 n2 ->
      eval m (Plus a1 a2) (n1 + n2)
  | eval_minus: forall m a1 a2 n1 n2,
      eval m a1 n1 -> eval m a2 n2 ->
      eval m (Minus a1 a2) (n1 - n2).

(** Prove the following example of evaluation. *)
Goal eval (update initial_state vx 42) (Plus (Var vx) (Const 2)) 44.
Proof.
  change 44 with (42 + 2). apply eval_plus.
  apply eval_var. apply update_same.
  apply eval_const.
Qed.

(** ** Boolean expressions *)

(** [beval m be bv] is true if the boolean expression [be] evaluates to the
  boolean value [bv] (either [true] or [false]) in memory state [m]. *)

Inductive beval2: state -> bexp -> bool -> Prop :=
  | beval_true: forall m,
      beval2 m TRUE true
  | beval_false: forall m,
      beval2 m FALSE false
  | beval_eq_true: forall m a1 a2 n1 n2,
      eval m a1 n1 -> eval m a2 n2 -> n1 = n2 ->
      beval2 m (Eq a1 a2) true
  | beval_eq_false: forall m a1 a2 n1 n2,
      eval m a1 n1 -> eval m a2 n2 -> n1 <> n2 ->
      beval2 m (Eq a1 a2) false
  | beval_le_true: forall m a1 a2 n1 n2,
      eval m a1 n1 -> eval m a2 n2 -> n1 <= n2 ->
      beval2 m (Le a1 a2) true
  | beval_le_false: forall m a1 a2 n1 n2,
      eval m a1 n1 -> eval m a2 n2 -> n1 > n2 ->
      beval2 m (Le a1 a2) false
  | beval_not: forall m be1 bv1,
      beval2 m be1 bv1 ->
      beval2 m (Not be1) (negb bv1)
  | beval_and: forall m be1 bv1 be2 bv2,
      beval2 m be1 bv1 -> beval2 m be2 bv2 ->
      beval2 m (And be1 be2) (bv1 && bv2).

(** [exec m c m'] is true if the command [c], executed in the initial
  state [m], terminates without error in final state [m']. *)

Inductive exec: state -> command -> state -> Prop :=
  | exec_skip: forall m,
      exec m Skip m
  | exec_assign: forall m x a,
      exec m (Assign x a) (update m x (aeval m a))
  | exec_seq: forall m c1 c2 m' m'',
      exec m c1 m' -> exec m' c2 m'' ->
      exec m (Seq c1 c2) m''
  | exec_if_true: forall m b ifso ifnot m',
      beval m b = true -> exec m ifso m' ->
      exec m (If b ifso ifnot) m'
  | exec_if_false: forall m b ifso ifnot m',
      beval m b = false -> exec m ifnot m' ->
      exec m (If b ifso ifnot) m'
  | exec_while_false: forall m b body,
      beval m b = false ->
      exec m (While b body) m
  | exec_while_true: forall m b body m' m'',
      beval m b = true -> exec m body m' -> exec m' (While b body) m'' ->
      exec m (While b body) m''.

(** Prove the following example of program execution  *)
Goal let prog := If (Le (Const 1) (Const 2)) (Assign vx (Const 3)) (Assign vx (Const 0)) in
     exists m, exec initial_state prog m /\ m vx = 3.
Proof.
  simpl. econstructor; split.
  apply exec_if_true. simpl. auto.
  eapply exec_assign.
  apply update_same.
Qed.

(** Example of non terminating execution *)

Goal let prog := While TRUE Skip in
     forall m m', ~ exec m prog m'.
Proof.
  simpl; intros; red; intros. dependent induction H. inversion H. auto.
Qed.

Ltac inv H := inversion H; subst; clear H.

(* In order to prove this lemma, you should need
  several uses of inversion, but not induction. *)
Lemma equiv1 :
  forall x i m m',
   exec m (Seq (Assign x (Const 1)) (While (Le (Var x) (Const 2)) i)) m' ->
   exec m (Seq (Assign x (Const 1))
             (Seq i (While (Le (Var x) (Const 2)) i))) m'.
Proof.
intros.
inv H. inv H3. inv H5.
inv H3.
rewrite update_same in H0. discriminate.
econstructor.
econstructor.
econstructor; eauto.
Qed.

(** * 5. Small-step semantics (cont'd) *)

(** Un programme termine sans erreurs s'il existe une suite finie de transitions
- depuis l'etat initial: commande = programme, etat memoire = etat memoire initial
- jusqu'a un etat final: commande = [Skip].
*)

Definition prog_terminates (prog: command) (m_init m_final: state) : Prop :=
  star red (prog, m_init) (Skip, m_final).

(** Si [R] est une relation binaire, [star R] est sa fermeture
reflexive et transitive.  (Voir le module [Sequences] pour la
definition.)  [star red] represente donc une suite de
zero, une ou plusieurs etapes de calcul. *)

(** Un programme diverge s'il existe une suite infinie de transitions
a partir de l'etat initial. *)

Definition prog_diverges (prog: command) (m_init: state) : Prop :=
  infseq red (prog, m_init).

(** De meme, [infseq R] represente une suite infinie de transitions [R].
  (egalement defini dans le module [Sequences].) *)

(** Enfin, un programme "plante" s'il existe une suite finie de transitions depuis
l'etat initial jusqu'a un etat qui n'est pas final et qui ne peut pas faire de transitions. *)

Definition prog_crashes (prog: command) (m_init: state) : Prop :=
  exists c, exists m,
      star red (prog, m_init) (c, m)
   /\ irred red (c, m) /\ ~(c = Skip ).

(** * 6. Premieres preuves d'equivalences entre semantiques *)

(** ** Semantique naturelle -> semantique a transitions. *)

Remark star_red_seq_left:
  forall c s c' s' c2,
  star red (c, s) (c', s') ->
  star red (Seq c c2, s) (Seq c' c2, s').
Proof.
  intros. dependent induction H. constructor.
  destruct b. econstructor. apply red_seq_left; eauto. eauto.
Qed.

Lemma exec_terminates:
  forall m c m', exec m c m' -> prog_terminates c m m'.
Proof.
  induction 1; intros.
(* skip *)
  apply star_refl.
(* assign *)
  apply star_one. constructor; auto.
(* seq *)
  apply star_trans with (Seq Skip c2, m').
  apply star_red_seq_left. auto.
  apply star_step with (c2, m'). apply red_seq_skip. auto.
(* if true *)
  eapply star_step. apply red_if_true; auto. apply IHexec.
(* if false *)
  eapply star_step. apply red_if_false; auto. apply IHexec.
(* while false *)
  apply star_one. apply red_while_false; auto.
(* while true *)
  eapply star_step. apply red_while_true; auto.
  apply star_trans with (Seq Skip (While b body), m').
  apply star_red_seq_left. auto.
  eapply star_step. eapply red_seq_skip. auto.
Qed.

(** ** Small-step -> big-step *)

(** The reverse implication, from small-step to big-step, is more subtle.
The key lemma is the following, showing that one step of reduction
followed by a big-step evaluation to a final state can be collapsed
into a single big-step evaluation to that final state. *)

Lemma red_preserves_exec:
  forall c1 s1 c2 s2,
  red (c1, s1) (c2, s2) ->
  forall s3,
  exec s2 c2 s3 ->
  exec s1 c1 s3.
Proof.
  intros until s2. intro STEP. dependent induction STEP; intros.
(* assign *)
  inversion H; subst. apply exec_assign.
(* sequence *)
  inversion H; subst. apply exec_seq with m'. eauto. auto.
(* sequence finish *)
  apply exec_seq with s2. apply exec_skip. auto.
(* ifso *)
  apply exec_if_true; auto.
(* ifnot *)
  apply exec_if_false; auto.
(* while *)
  inversion H0; subst.
  apply exec_while_true with m'; auto.
  inversion H0; subst.
  apply exec_while_false; auto.
Qed.

(** As a consequence, a term that reduces to [Skip] evaluates in big-step
  with the same final state. *)

Theorem terminates_exec:
  forall m c m',
  prog_terminates c m m' ->
  exec m c m'.
Proof.
   unfold prog_terminates; intros. dependent induction H.
  apply exec_skip.
  destruct b as [m1 c1]. apply red_preserves_exec with m1 c1; auto.
Qed.

(** *8. Definitionnal interpreter *)

(** We can improve the readability of this definition by introducing
    an auxiliary function [bind_option] to hide some of the "plumbing"
    involved in repeatedly matching against optional states. *)

Definition bind (r: option state) (f: state -> option state) : option state :=
  match r with Some s => f s | None => None end.

Fixpoint interp (n: nat) (c: command) (s: state) {struct n} : option state :=
  match n with
  | O => None
  | S n' =>
      match c with
      | Skip => Some s
      | Assign x e => Some (update s x (aeval s e))
      | Seq c1 c2 => bind (interp n' c1 s) (fun s1 => interp n' c2 s1)
      | If b c1 c2 => interp n' (if (beval s b) then c1 else c2) s
      | While b c1 => if (beval s b)
                      then (bind (interp n' c1 s) (fun s1 => interp n' (While b c1) s1))
                      else Some s
     end
  end.

Theorem interp_more: forall i1 i2 s s' c,
  (i1 <= i2)%nat -> interp i1 c s = Some s' ->
  interp i2 c s = Some s'.
Proof.
induction i1 as [|i1']; intros i2 s s' c Hle Hinterp.
(* i1 = 0 *)
    inversion Hinterp.
(* i1 = S i1 *)
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': (i1' <= i2')%nat) by omega.
    destruct c.
    (* Skip *)
      simpl in Hinterp. inversion Hinterp.
      reflexivity.
    (* assign *)
      simpl in Hinterp. inversion Hinterp.
      reflexivity.
    (* sequence *)
      simpl in Hinterp. simpl.
      remember (interp i1' c1 s) as s1'o.
      destruct s1'o.
        symmetry in Heqs1'o.
        apply (IHi1' i2') in Heqs1'o; try assumption.
        rewrite Heqs1'o. simpl. simpl in Hinterp.
        apply (IHi1' i2') in Hinterp; try assumption.
        inversion Hinterp.
     (* if *)
      simpl in Hinterp. simpl.
      remember (beval s b) as bval.
      destruct bval; apply (IHi1' i2') in Hinterp; assumption.
     (* while *)
    simpl in Hinterp. simpl.
      destruct (beval s b); try assumption.
      remember (interp i1' c s) as s1'o.
      destruct s1'o.
        symmetry in Heqs1'o.
        apply (IHi1' i2') in Heqs1'o; try assumption.
        rewrite -> Heqs1'o. simpl. simpl in Hinterp.
        apply (IHi1' i2') in Hinterp; try assumption.
        simpl in Hinterp. inversion Hinterp.
Qed.

Lemma interp_exec:
  forall n c s s', interp n c s = Some s' -> exec s c s'.
Proof.
Admitted.

Lemma exec_interp:
  forall s c s', exec s c s' -> exists n, interp n c s = Some s'.
Proof.
Admitted.

(** We now show a similar result for the coinductive big-step semantics
  for divergence. *)

Remark exec_interp_either:
  forall n c s s', exec s c s' -> interp n c s = None \/ interp n c s = Some s'.
Proof.
  intros.
  destruct (exec_interp _ _ _ H) as [m EVAL].
  remember (interp n c s). destruct o.
  right.
  assert ((m <= n \/ n <= m)%nat) by omega.
  destruct H0.
  assert (interp n c s = Some s').
    apply interp_more with m; auto.
  congruence.
  assert (interp m c s = Some s0).
    apply interp_more with n; auto.
  congruence.
  left; auto.
Qed.

(** For the converse result, we again need a bit of classical logic
  (the axiom of excluded middle) to show that the sequence
  [n => interp st c n] has a limit: it stabilizes to a fixed result
  when [n] is big enough. *)

Require Import Classical.
Require Import Max.

Lemma interp_limit:
  forall s c,
  exists res, exists m, forall n, (m <= n)%nat -> interp n s c = res.
Proof.
  intros.
  destruct (classic (forall n, interp n s c = None)).
(* divergence *)
  exists (@None state); exists 0%nat; auto.
(* convergence *)
  assert (EX: exists m, interp m s c <> None).
    apply not_all_ex_not. auto.
  destruct EX as [m EVAL].
  remember (interp m s c) as res.
  destruct res as [s' | ].
  exists (Some s'); exists m; intros.
  apply interp_more with m; auto.
  congruence.
Qed.

(** * 9. Definitional interpreter and denotational semantics *)

(** Using yet another bit of logic (an axiom of description -- a variant
  of the axiom of choice), we can show the existence of a function
  [denot st c] which is the limit of the sequence [n => ceval_step st c n]
  as [n] goes to infinity.  The result of this function is to be
  interpreted as the denotation of command [c] in state [st]:
- [denot st c = None] (or "bottom") means that [c] diverges
- [denot st c = Some st'] means that [c] terminates with final state [st'].
*)

Require Import ClassicalDescription.

Definition interp_limit_dep (s: state) (c: command) :
  { res: option state | exists m, forall n, (m <= n)%nat -> interp n c s = res}.
Proof.
  intros. apply constructive_definite_description.
  destruct (interp_limit c s) as [res X].
  exists res. red. split. auto. intros res' X'.
  destruct X as [m P]. destruct X' as [m' P'].
  transitivity (interp (max m m') c s).
  symmetry. apply P. apply le_max_l.
  apply P'. apply le_max_r.
Qed.

Definition denot (s: state) (c: command) : option state :=
  proj1_sig (interp_limit_dep s c).

Lemma denot_limit:
  forall s c,
  exists m, forall n, (m <= n)%nat -> interp n c s = denot s c.
Proof.
  intros. unfold denot. apply proj2_sig.
Qed.

Lemma denot_charact:
  forall s c m res,
  (forall n, (m <= n)%nat -> interp n c s = res) ->
  denot s c = res.
Proof.
  intros. destruct (denot_limit s c) as [m' I].
  assert (interp (max m m') c s = res).
    apply H. apply le_max_l.
  assert (interp (max m m') c s = denot s c).
    apply I. apply le_max_r.
  congruence.
Qed.

(**  From a definitional interpreter to a denotational semantics *)

Lemma denot_terminates:
  forall s c n s', interp n c s = Some s' -> denot s c = Some s'.
Proof.
  intros.
  apply denot_charact with n. intros. apply interp_more with n; auto.
Qed.

(** We can then show that this [denot] function satisfies the equations of
  denotational semantics for the Imp language. *)

Lemma denot_skip:
  forall s, denot s Skip = Some s.
Proof.
  intros. apply denot_terminates with 1%nat. simpl. auto.
Qed.

Lemma denot_assign:
  forall v a s, denot s (Assign v a) = Some (update s v (aeval s a)).
Proof.
  intros. apply denot_terminates with 1%nat. simpl. auto.
Qed.

Lemma denot_seq:
  forall c1 c2 s,
  denot s (Seq c1 c2) = bind (denot s c1) (fun s' => denot s' c2).
Proof.
  intros. destruct (denot_limit s c1) as [m1 LIM1].
  destruct (denot s c1) as [s' | ]; simpl.
(* c1 terminates *)
  destruct (denot_limit s' c2) as [m2 LIM2].
  apply denot_charact with (S (max m1 m2)). intros.
  destruct n. elimtype False; omega.
  simpl. rewrite LIM1; simpl. apply LIM2.
  apply le_trans with (max m1 m2). apply le_max_r. omega.
  apply le_trans with (max m1 m2). apply le_max_l. omega.
(* c1 diverges *)
  apply denot_charact with (S m1); intros.
  destruct n. elimtype False; omega.
  simpl. rewrite LIM1; simpl. auto. omega.
Qed.

Lemma denot_ifthenelse:
  forall b c1 c2 s,
  denot s (If b c1 c2) =
  if beval s b then denot s c1 else denot s c2.
Proof.
  intros.
  remember (beval s b). destruct b0.
(* b is true *)
  destruct (denot_limit s c1) as [m LIM].
  apply denot_charact with (S m); intros.
  destruct n. elimtype False; omega.
  simpl. rewrite <- Heqb0. apply LIM. omega.
(* b is false *)
  destruct (denot_limit s c2) as [m LIM].
  apply denot_charact with (S m); intros.
  destruct n. elimtype False; omega.
  simpl. rewrite <- Heqb0. apply LIM. omega.
Qed.

Lemma denot_while:
  forall b c s,
  denot s (While b c) =
  if beval s b
  then bind (denot s c) (fun s' => denot s' (While b c))
  else Some s.
Proof.
  intros. remember (beval s b). destruct b0.
(* b is true *)
  destruct (denot_limit s c) as [m1 LIM1].
  destruct (denot s c) as [s' | ]; simpl.
(* c terminates *)
  destruct (denot_limit s' (While b c)) as [m2 LIM2].
  apply denot_charact with (S (max m1 m2)). intros.
  destruct n. elimtype False; omega.
  simpl. rewrite <- Heqb0. rewrite LIM1; simpl. apply LIM2.
  apply le_trans with (max m1 m2). apply le_max_r. omega.
  apply le_trans with (max m1 m2). apply le_max_l. omega.
(* c diverges *)
  apply denot_charact with (S m1); intros.
  destruct n. elimtype False; omega.
  simpl. rewrite <- Heqb0. rewrite LIM1; simpl. auto. omega.
(* b is false *)
  apply denot_terminates with 1%nat. simpl. rewrite <- Heqb0. auto.
Qed.

(** Moreover, [denot s (While b c)] is the least fixpoint of the equation above. *)

Definition result_less_defined (r1 r2: option state) : Prop :=
  r1 = None \/ r1 = r2.

Lemma denot_while_least_fixpoint:
  forall b c (f: state -> option state),
  (forall s,
   f s = if beval s b then bind (denot s c) f else Some s) ->
  (forall s,
   result_less_defined (denot s (While b c)) (f s)).
Proof.
  intros.
  assert (forall n s, result_less_defined (interp n (While b c) s) (f s)).
    induction n; intros; simpl.
    red; auto.
    rewrite (H s0). destruct (beval s0 b).
    remember (interp n c s0). destruct o; simpl.
    replace (denot s0 c) with (Some s1). simpl.
    apply IHn. symmetry. eapply denot_terminates; eauto.
    red; auto.
    red; auto.
  destruct (denot_limit s (While b c)) as [m LIM].
  rewrite <- (LIM m). auto. omega.
Qed.

(** Composing the various results so far, we obtain the following equivalences
  between the denotational semantics and the big-step semantics. *)

Lemma denot_exec:
  forall c s s',
  exec s c s'  <->  denot s c = Some s'.
Proof.
  intros; split; intros.
(* -> *)
  destruct (exec_interp _ _ _ H) as [m EVAL].
  apply denot_terminates with m; auto.
(* <- *)
  destruct (denot_limit s c) as [m LIMIT].
  apply interp_exec with (n:=m). rewrite <- H. apply LIMIT. omega.
Qed.

(** Semantique executable -> semantique relationnelle *)

Lemma aeval_sound:
  forall m a n, aeval m a = n -> eval m a n.
Proof with (try congruence).
  induction a; simpl; intros.
  inv H. constructor.
  constructor; auto.
  destruct (aeval m a1) as []_eqn... destruct (aeval m a2) as []_eqn... inv H; constructor; auto.
inv H; constructor; auto.
inv H; constructor; auto.
inv H; constructor; auto.
inv H; constructor; auto.
  destruct (aeval m a1) as []_eqn... destruct (aeval m a2) as []_eqn... inv H; constructor; auto.
inv H; constructor; auto.
inv H; constructor; auto.
inv H; constructor; auto.
inv H; constructor; auto.
Qed.

Lemma beval_f_sound:
  forall m be bv, beval m be = bv -> beval2 m be bv.
Proof with (try congruence).
  induction be; simpl; intros.
  inv H. constructor.
  inv H. constructor.
Admitted.

(** On peut iterer [interp] jusqu'a obtenir un etat final ou une erreur.
  Cependant, toutes les fonctions Coq doivent terminer, et donc
  nous devons borner a priori le nombre d'iterations. *)

Definition run_prog (prog: command) : option state := interp 100%nat prog initial_state.

(** Quelques exemples d'execution de programmes. *)

Compute (let prog := If (Le (Const 1) (Const 2)) (Assign vx (Const 3)) (Assign vx (Const 0)) in
         match run_prog prog with
         | Some s => Some (s vx)
         | _ => None
         end).

Compute (let prog := Seq (Assign vx (Const 101)) (Seq (Assign vy (Const 7)) euclidean_division) in
         match run_prog prog with
         | Some s => (Some (s vq), Some (s vr))
         | _ => (None, None)
         end).

Compute (let prog := Assign vx (Var vx) in
         run_prog prog).

Compute (let prog := While TRUE Skip in
         run_prog prog).


Definition tautology :  forall P : Prop, P -> P
:=
fun P x => x.

Definition Modus_tollens' : forall P Q : Prop, ~Q /\ (P-> Q) -> ~P.
Proof.
Show Proof.
intros.
Show Proof.
intro.
Show Proof.
apply H.
Show Proof.
apply H.
Show Proof.
apply H0.
Show Proof.
Qed.

Definition Modus_tollens : forall P Q : Prop, ~Q /\ (P -> Q) -> ~P
:=
fun (P Q : Prop) (H1 : ~Q /\ (P -> Q)) (H2 : P) =>
((match H1 with | conj notq _ => notq end) ((match H1 with | conj _ ptoq => ptoq end) H2)).

Definition Disjunctive_syllogism' : forall P Q : Prop, (P \/ Q) -> ~P -> Q.
Proof.
intros.
case H.
intros.
exfalso.
apply H0.
apply H1.
intros.
apply H1.
Qed.

Print Disjunctive_syllogism'.

Definition Disjunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q
:=
fun (P Q : Prop) (PorQ : P \/ Q) (notP : ~P) =>
match PorQ with
| or_introl P => False_ind Q (notP P)
| or_intror Q => Q
end.

Definition tautology_on_Set' : forall A : Set, A -> A.
Proof.
intros.
apply H.
Qed.

Definition tautology_on_Set : forall A : Set, A -> A
:=
fun (A : Set) (A : A)
=> A.

Definition Modus_tollens_on_Set' : forall A B : Set, (B -> Empty_set) * (A -> B) -> (A -> Empty_set).
Proof.
intros.
apply H.
apply H.
apply H0.
Qed.

Print Modus_tollens_on_Set'.

Definition Modus_tollens_on_Set : forall A B : Set, (B -> Empty_set) * (A -> B)-> (A -> Empty_set)
:=
fun (A B : Set) (BtoEMPTYprodAtoB : (B -> Empty_set)*(A->B)) (A : A)
=>
((let (BtoEMPTY, _) := BtoEMPTYprodAtoB in BtoEMPTY) ((let (_, AtoB) := BtoEMPTYprodAtoB in AtoB) A)).

Definition Disjunctive_syllogism_on_Set' : forall A B : Set, (A + B) -> (A -> Empty_set) -> B.
Proof.
intros.
case H.
intros.
contradiction.
intros.
apply b.
Qed.

Print Disjunctive_syllogism_on_Set'.

Definition Disjunctive_syllogism_on_Set : forall A B : Set, (A + B) -> (A -> Empty_set) -> B
:=
fun (A B : Set) (AplusB : A + B) (AtoEMPTY : A -> Empty_set) =>
match AplusB with
| inl A => Empty_set_rec (fun _ : Empty_set => B) (AtoEMPTY A)
| inr B => B
end.