(* 定数の定義 (再定義はできない) *)
Definition one : nat := 1.

(* 関数の定義 *)
Definition double x := x + x.

Print double. (* double = fun x : nat => x + x : nat -> nat *)

Eval compute in double 2. (* = 4 : nat (式の計算) *)

(* 局所的な名前束縛 *)
Definition quad x := let y := double x in 2 * y.
Eval compute in quad 2. (* = 8 : nat *)

Definition quad' x := double (double x).
Eval compute in quad' 2.

Definition triple x :=
  let double x := x + x in
  double x + x.

Eval compute in triple 3. (* = 9 : nat *)
Eval compute in 1 - 2. (* = 0 : nat (自然数の引き算は整数と違う) *)

Require Import ZArith. (* 整数モジュールのインポート *)

Module Z. (* 定義の範囲を区切るために Module を使う *)
  Open Scope Z_scope. (* 数値や演算子を整数として解釈する *)
  Eval compute in 1 - 2. (* = -1 : Z (Z は整数の型) *)
  Eval compute in (2 + 3) / 2. (* = 2 : Z *)
  Definition p (x y : Z) := 2 * x - y * y.
  Print p. (* p = fun x y : Z => 2 * x - y * y : Z -> Z -> Z *)
  Eval compute in p 3 4. (* = -10 : Z *)
  Definition p' := fun x => fun y => 2 * x - y * y.
  Print p'. (* p' = fun x y : Z => 2 * x - y * y : Z -> Z -> Z *)
  Definition q := p 3. (* 部分適用 *)
  Eval compute [p q] in q. (* p と q の定義だけを展開する *)


(**
A Gentle Introduction to Type Classes and Relations in Coq
の
Chapter 3. Lost in Manhattan (抜萃、つづき)

typeclassestut.pdf
typeclassesTut/Lost_in_NY.v

このうち、
3.7 Deciding Route Equivalence の Ex1'
を証明するまでを抜粋する。

3.7 では、それ以前の節の
「Type Classを使って reflexivityとrewriteを拡張する」
という内容とは打って変わって、起点と終点が同じなら、同じルートであること、
to prove some path equivalences through a simple computation
を説明している。

つまり、3.7で証明したことだけを使うなら、ルートの中に変数が含まれていてはいけない。
しかし、そうでない場合は、a simple computation になる。
*)

(* We consider the discrete plan the coordinate system of which
    is based on Z *)
Require Import List.
Require Import ZArith.
Require Import Bool.
Open Scope Z_scope.
Require Import Relations.
Require Import Setoid.

(* Require Import coq_gitcrc_3_digest. *)
(*************************************************************)
(**
3.2 Data Type and Definitions
 *)
(* Types for representing routes in the dicrete  plane *)
Inductive direction : Type := North | East | South | West.
Definition route := list direction.

Record Point : Type :=
  {
    Point_x : Z;
    Point_y : Z
  }.

Definition Point_O := Build_Point 0 0.

(**
3.3 Route Semantics
 *)
Definition translate (dx dy:Z) (P : Point) :=
  Build_Point (Point_x P + dx) (Point_y P + dy).

(* Equality test  between Points *)
Definition Point_eqb (P P':Point) :=
  Zeq_bool (Point_x P) (Point_x P') &&
           Zeq_bool (Point_y P) (Point_y P').

(*  move P r follows the route r starting from P *)
Fixpoint move (r:route) (P:Point) : Point :=
  match r with
    | nil => P
    | North :: r' => move r' (translate 0 1 P)
    | East :: r' => move r' (translate 1 0 P)
    | South :: r' => move r' (translate 0 (-1) P)
    | West :: r' => move r' (translate (-1) 0 P)
  end.

(* We consider that two routes are "equivalent" if they define
  the same moves. For instance, the routes
  East::North::West::South::East::nil and East::nil are equivalent *)

Definition route_equiv : relation route :=
  fun r r' => forall P:Point , move r P = move  r' P.
Infix "=r=" := route_equiv (at level 70):type_scope.

(**
3.6 Some Other instances of Proper
*)
Lemma route_compose :
  forall r r' P, move (r ++ r') P = move r' (move r P).
Proof.
  induction r as [|d s IHs]; simpl;
  [auto | destruct d; intros;rewrite IHs;auto].
Qed.
(*************************************************************)

(**
3.7 Deciding Route Equivalence
*)

(* Prove the correctness of Point_eqb *)
Lemma Point_eqb_correct :
  forall p p',
    Point_eqb p p' = true <-> p = p'.
Proof.
  destruct p; destruct p'; simpl; split.
  unfold Point_eqb;  simpl;  rewrite andb_true_iff; destruct 1.
  repeat rewrite <- Zeq_is_eq_bool in *.
  rewrite H, H0; reflexivity.
  injection 1; intros H0 H1; rewrite H0, H1; unfold Point_eqb; simpl;
  rewrite andb_true_iff; repeat rewrite <- Zeq_is_eq_bool; now split.
Qed.

Lemma translate_comm :
  forall dx dy dx' dy' P,
    translate dx dy (translate dx' dy' P) = translate dx' dy' (translate dx dy P).
Proof.
  unfold translate; simpl; intros; f_equal; ring.
Qed.

Lemma move_translate :
  forall r P dx dy,
    move r (translate dx dy P) = translate dx dy (move r P).
Proof.
  induction r as [|a r]; simpl; [reflexivity|].
  destruct a;simpl; intros;rewrite <- IHr;rewrite  (translate_comm); auto.
Qed.

Lemma move_comm :
  forall r r' P,
    move r (move r' P) =  move r' (move r P).
Proof.
  induction r as [| a r']; [reflexivity|].
  simpl; destruct a;
  intros; repeat rewrite move_translate; rewrite IHr'; auto.
Qed.

Lemma app_comm : forall r r', r++r' =r=  r'++r.
Proof.
  intros r r' P; repeat rewrite route_compose; apply move_comm.
Qed.

(** the following lemma  will be used for deciding route equivalence *)
Lemma route_equiv_Origin :
  forall r r', r =r= r' <-> move r Point_O  = move r' Point_O .
Proof.
  split; intro H.
  rewrite H; trivial.
  intro P; replace P with (translate (Point_x P) (Point_y P) Point_O).
  repeat rewrite move_translate.
  rewrite H; reflexivity.
  destruct P; simpl; unfold translate; f_equal.
Qed.

Definition route_eqb r r' : bool :=
  Point_eqb (move r Point_O) (move r' Point_O).

(**  ... we can now prove route_eqb's  correctness *)
Lemma route_equiv_equivb :
  forall r r',
    route_equiv r r' <-> route_eqb r r' = true.
Proof.
  intros r r'; rewrite route_equiv_Origin;
  unfold route_eqb; rewrite Point_eqb_correct; tauto.
Qed.

Ltac route_eq_tac := rewrite route_equiv_equivb; reflexivity.

(** another proof of Ex1, using computation  *)
Example Ex1' : East::North::West::South::East::nil =r= East::nil.
Proof.
  rewrite route_equiv_equivb.
  unfold route_eqb, Point_eqb, Zeq_bool.
  simpl.                                    (* true = true *)
  reflexivity.

  Restart.
  route_eq_tac.
Qed.

(*****************
オリジナル文書にはない補足説明
@suharahiromichi

route_equiv と route_eqb は、reflect の関係にあるので、それを証明すれば、
Ex1 の =r= (route_equiv) を route_eqb にして証明することができる。

SSReflectの上で、Morphisms を使うのは難しそうなので、
ここで、試験的に局所的にSSReflectをImportしている。
******************
*)
Section SSR.
  From mathcomp Require Import all_ssreflect.

  Lemma route_equivP (r r' : route) :
    reflect (r =r= r') (route_eqb r r').
  Proof.
    apply: (@iffP (route_eqb r r')).
    - by apply: idP.
    - by apply (route_equiv_equivb r r').
    - by apply (route_equiv_equivb r r').
  Qed.

  Example Ex1'' : East::North::West::South::East::nil =r= East::nil.
  Proof.
    apply/route_equivP.
      by [].
  Qed.
End SSR.

(* END *)


Require Import Setoid
    Sigma.Algebra.Hierarchy
    Coq.Classes.Morphisms
    Coq.Unicode.Utf8.

Section Monoid.

  Context
    {T : Type}
    {eq : T -> T -> Prop}
    {op : T -> T -> T}
    {id : T}
    {Hmonoid : @monoid T eq op id}.

  Local Infix "=" := eq : type_scope.
  Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Infix "*" := op.

  Lemma monoid_cancel_left z iz (Hinv : op iz z = id) :
    forall x y, (z * x) = (z * y) <-> x = y.
  Proof.
    intros ? ?;
    split; intros H.
    assert (Hcut : (iz * (z * x))  = (iz * (z * y))).
    rewrite H. reflexivity.
    rewrite !(@monoid_is_associative T eq op id Hmonoid) in Hcut.
    rewrite Hinv in Hcut.
    rewrite !monoid_is_left_idenity in Hcut.
    exact Hcut.
    rewrite H.
    reflexivity.
  Qed.

  Lemma monoid_cancel_right z iz (Hinv : op z iz = id) :
    forall x y, x * z = y * z <-> x = y.
  Proof.
    intros ? ?; split; intro H.
    assert (op (op x z) iz = op (op y z) iz) as Hcut.
    rewrite H; reflexivity.
    rewrite <- !(@monoid_is_associative T eq op id Hmonoid) in Hcut.
    rewrite Hinv in Hcut.
    rewrite !monoid_is_right_identity in Hcut.
    exact Hcut.
    rewrite H; reflexivity.
  Qed.

  (* what can I say about the reverse direction? *)
  Lemma monoid_both_identity :
    forall a b, a = id ∧ b = id -> a * b = id.
  Proof.
    intros ? ? H.
    destruct H as [H₁ H₂];
    rewrite H₁.
    rewrite monoid_is_left_idenity.
    exact H₂.
  Qed.

  Lemma monoid_inv_inv a b c : b * a = id -> c * b = id -> c = a.
  Proof.
    intros H₁ H₂.
    assert (Ht : c * (b * a) = c * id)
      by (rewrite H₁; reflexivity).
    rewrite (@monoid_is_associative T eq op id Hmonoid) in Ht.
    rewrite H₂,
      monoid_is_left_idenity,
      monoid_is_right_identity in Ht.
    symmetry in Ht.
    exact Ht.
  Qed.

  Lemma monoid_inv_op x y a b :
    a * x = id -> b * y = id -> (b * a) * (x * y) = id.
  Proof.
    intros Hx Hy.
    assert(Ht : (a * (x * y)) = ((a * x) * y))
      by (rewrite associative; reflexivity).
    rewrite <- associative.
    rewrite Ht, Hx, left_identity.
    exact Hy.
  Qed.

End Monoid.


(* Some useful definitions and lemmas *)
Require Import Arith Omega.
Require Export Vectors.

 Set Implicit Arguments.

 Section Addition_subtraction_multiplication.

  (* addition, subtraction and composition *)
    (* addition, subtraction and composition *)
   Fixpoint vAdd (n : nat) (i : Vec nat n) : Vec nat n -> Vec nat n :=
     match i in Vec _ e return (Vec nat e -> Vec nat e) with
    | vnil => fun _ => vnil _
    | vcons _ x xs => fun j => match vCons j with
                               | isvcons y ys => vcons (x + y) (vAdd xs ys)
                               end
    end.

    Fixpoint vSub (n : nat) (i : Vec nat n) : Vec nat n -> Vec nat n :=
     match i in Vec _ e return (Vec nat e -> Vec nat e) with
    | vnil => fun _ => vnil _
    | vcons _ x xs => fun j => match vCons j with
                               | isvcons y ys => vcons (x - y) (vSub xs ys)
                               end
    end.

    (* compute the evaluation matrix *)
   Fixpoint Vtimes (n : nat) (l : Vec nat n)  : Vec nat n -> Vec nat n :=
    match l as l in (Vec _ e) return Vec nat e -> Vec nat e with
    | vnil => fun _ => vnil _
    | vcons _ x ls =>
              fun j => match vCons j with
                       | isvcons y ys => vcons (x * y) (Vtimes ls ys)
                       end
    end.

  (* sum the elements of a vector *)
  Fixpoint vsum (n : nat) (i : Vec nat n)  :=
   match i with
   | vnil  => 0
   | vcons _ n ns => n + vsum ns
   end.

  Lemma vsum_vplus n m (i : Vec nat n) (j : Vec nat m) :  vsum (vPlus i j)  = vsum i + vsum j.
  Proof.
      induction i; simpl; trivial.
      intros j; rewrite (IHi j); auto with arith.
  Qed.

  Lemma vsum_plus n m (v : Vec nat (n + m)):
       vsum v = match vplusView _ _ v with
                | vplus a b => vsum a + vsum b
                end.
  Proof.
    intros n m v; vSimp; apply vsum_vplus.
  Qed.

   Fixpoint ZSumz (n : nat) (l : Vec nat n)   :=
     match l as l in (Vec _ e)  with
       | vnil => 0
       | vcons _ x ls =>  (ZSumz ls) + x
     end.

 Lemma ZSz_Vtms (n : nat ) (v i0 i : Vec nat n) :
   ZSumz (Vtimes (vAdd v i0) i) = ZSumz (Vtimes v i) + ZSumz (Vtimes i0 i).
 Proof.
    induction v; intros; vSimp; simpl; trivial. rewrite (IHv i0 i); ring.
  Qed.

(* Lemma ZSz_sub (n : nat ) (v i0 i : Vec nat n) :
   ZSumz (Vtimes (vSub v i0) i) = ZSumz (Vtimes v i) - ZSumz (Vtimes i0 i).
  Proof.
   induction v; intros; vSimp; simpl; trivial. rewrite (IHv i0 i).
   replace ((x - a0) * a) with (x * a - a0 * a); auto with arith. omega.
  Qed. *)

  Lemma vtimesPlus (n m : nat) (i i1  : Vec nat n) (j j1 : Vec nat m) :
     Vtimes (vPlus i j) (vPlus i1 j1) = vPlus (Vtimes i i1) (Vtimes j j1).
  Proof.
   induction i;  intros; vSimp; simpl; trivial. rewrite (IHi i0 j j1); trivial.
  Qed.

 Lemma zSumzPlus (n m: nat) (i : Vec nat n) (j : Vec nat m) : ZSumz (vPlus i j) = ZSumz i + ZSumz j.
 Proof.
   induction i; simpl; trivial. intro j; rewrite (IHi j);  ring.
 Qed.

  Lemma ZSumz_vmap_Vtimes (n : nat) (v : Vec nat n) (a  : nat) :
     forall x,  ZSumz (Vtimes (vmap (fun x1  => a * x1) v) x) =  a * (ZSumz (Vtimes v x) ).
  Proof.
    induction v; intros; vSimp; simpl; trivial; try auto with arith.
    rewrite (IHv a i); ring.
  Qed.

 (* misc *)
 Ltac vsimpl :=  unfold vhead in *; unfold vtail in *;  simpl in *.

 Lemma vtimes0 n i j : i = vec n 0 -> Vtimes i j = vec n 0.
  Proof.
    induction n; intros; vSimp; simpl; auto. destruct (VeqInj2 H); vsimpl.
    rewrite (IHn i i0 H1); subst; trivial.
 Qed.

 Lemma vtimes_comm (n : nat) (i j : Vec nat n):  Vtimes i j = Vtimes j i.
 Proof.
  induction i; intros; vSimp; simpl; auto.
   rewrite (IHi i0). replace (a * x) with (x * a); trivial; try ring.
 Qed.

 Lemma Zsumz_0 : forall n , ZSumz (vec n 0) = 0.
  Proof.
    induction n; simpl; trivial. rewrite IHn; trivial.
  Qed.

 Lemma vecPlus0  n m i j :
   i = vec n 0 -> j = vec m 0 -> vPlus i j = vec (n + m) 0.
  Proof.
    induction i; intros; simpl; trivial. destruct (VeqInj2 H); vsimpl.
    rewrite H1. rewrite (IHi j H2 H0); trivial.
 Qed.

  Lemma vPluz_0 : forall n m,
    match vplusView _ _ (vec (n + m) 0)  with
     | vplus x y => x = vec n 0 /\ y = vec m 0
    end.
   induction n; intros; simpl;  auto.
    generalize ( IHn m); intro. destruct (vplusView _ _ (vec (n + m) 0)).
   destruct H. rewrite H; auto.
  Qed.

  Lemma vPluz_1 (A : Set) (n m : nat) (i : Vec  A n) (j : Vec A m) :
    match vplusView _ _ (vPlus i j)  with
     | vplus x y => x = i /\ y = j
    end.
   induction i; intros; simpl; auto.
    generalize ( IHi j).  destruct (vplusView _ _ (vPlus i j)).
    intro H; destruct H; subst; auto.
  Qed.

  Lemma vecPlus00  n m i j :  vPlus i j = vec (n + m) 0 ->  i = vec n 0 /\ j = vec m 0 .
  Proof.
    induction n; intros; vSimp; simpl; auto.
    destruct (VeqInj2 H); vsimpl. destruct (IHn m i j H1). rewrite H0.
    rewrite H2; auto.
  Qed.

  Lemma vadd_id  n i : vAdd i (vec n 0) = i.
    induction i;  simpl; trivial. rewrite plus_0_r; rewrite IHi ; trivial.
  Qed.

  Lemma vtimesPlus1 (n m : nat) ( v : Vec nat n) (v0 : Vec nat m) (i0 : Vec nat n) (j0 : Vec nat m) :
    ZSumz (Vtimes (vPlus v v0) (vPlus i0 j0))  = ZSumz (Vtimes v i0) + ZSumz (Vtimes v0 j0) .
  Proof.
    induction v; intros; vSimp; simpl; trivial.  rewrite (IHv v0 i j0); ring.
  Qed.

  Lemma vtimes_vcons_vsnoc n (xs : Vec nat n) (ys : Vec nat (S n)) x :
      ZSumz (Vtimes (vSnoc x xs) ys) = ZSumz (Vtimes xs (vfirst ys)) + x * (vlast ys).
  Proof.
    induction xs; intros; vSimp; vsimpl; simpl; trivial; try vecRwt.
    unfold vfirst;  vsimpl.
    rewrite (IHxs (vcons a0 i) x0 );  unfold vfirst; unfold vlast; vsimpl; ring.
  Qed.

   Lemma Vtimes_vSnoc n (v v1 : Vec nat (S n)) :
     ZSumz (Vtimes v (vSnoc (vlast v1) (vfirst v1))) =
     ZSumz (Vtimes (vfirst v) (vfirst v1)) +  vlast v * vlast v1.
   Proof.
     intros n v; destruct (vCons v) as [vh vt].
     generalize vh; clear; induction vt.
     intros vh v1; destruct (vCons v1); unfold vlast; unfold vfirst; vsimpl; vSimp; trivial.
     intros vh v1; destruct (vCons v1) as [b bs].
     destruct (vCons bs) as [y ys];  generalize (IHvt x (vcons y ys)); clear;
     unfold vlast; unfold vfirst; vsimpl.
     destruct ( vCons (vSnoc (vlast_aux y ys) (vfirst_aux y ys))); simpl.
     intro H;  rewrite H; ring.
   Qed.

 End Addition_subtraction_multiplication.

 (* exporting tactics *)


Require Import Arith.
Require Import ZArith.
Require Import Bool.

Open Scope Z_scope.

Locate "_ * _".

Print Scope Z_scope.

Check 33. (* default scope is Z *)
Check 33%nat. (* 33 interpreted within scope nat_scope with key 'nat' *)
Check 0. (* : Z *)
Check O. (* : nat *)

Open Scope nat_scope.
Check 33. (* : nat *)
Check 0. (* nat *)
Check 33%Z.
Check (-12)%Z.
Check (33%nat).

Check true. (* : bool *)
Check false. (* : bool *)

Check plus.
Check Zplus.
Check negb.
Check ifb.
Check S.
Check 0.
Check O.
Check S (S (S 0)).
Check mult (mult 5 (minus 5 4)) 7.
Check (5*(5-4)*7).

Unset Printing Notations.
Check 4.
Check (5*(5-4)*7).
Set Printing Notations.
Open Scope Z_scope.
Check (Zopp (Zmult 3 (Zmult (-5) (-8)))).
Check ((-4)*(7-7)).
Open Scope nat_scope.
Check Zabs_nat.
Check (5 + Zabs_nat (5-19)).

Check (fun n (z:Z) f => (n + (Zabs_nat(f z)))%nat).
Check (fun n _ : nat => n).
Check (fun n p:nat => n).

Definition f :=
  fun n p: nat => (let diff := n-p in
                   let square := diff*diff in
                   square*(square+n)%nat).
Check f.
Parameter max_int : Z.

Open Scope Z_scope.
Definition min_int := 1 - max_int.
Print min_int.

Definition cube1 := fun z:Z => z*z*z.
Definition cube2 (z:Z) : Z := z*z*z.
Definition cube3 z := z*z*z.
Print cube1.
Print cube2.
Print cube3.

Definition Z_thrice (f:Z->Z)(z:Z) := f (f (f z)).
Print Z_thrice.
Definition plus9 := Z_thrice (Z_thrice (fun z:Z => z + 1)).
Eval compute in plus9 2.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat.

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

Inductive bin :=
| o : bin -> bin
| i : bin -> bin
| z : bin.

Check (i (i (o z))).

Fixpoint binnat (b : bin) : nat :=          (* f *)
  match b with
  | z => 0
  | o b => (binnat b).*2
  | i b => (binnat b).*2 + 1
  end.

Compute binnat (o (i (i (o (o z))))).

Fixpoint bininc (b : bin) : bin :=
  match b with
  | i b => o (bininc b)
  | o b => i b
  | z => i z
  end.

Compute bininc (o (i (i (o (o z))))).
Compute bininc (i (i (i (o (o z))))).
Compute bininc (o (i (i z))).
Compute bininc (i (i (i z))).

Fixpoint natbin (n : nat) : bin :=          (* g *)
  match n with
  | 0 => z
  | n.+1 => bininc (natbin n)
  end.

(* 直接的な正規化 *)
Fixpoint normalize (b : bin) : bin :=
  match b with
  | o b =>
    match (binnat b) with
    | 0 => z
    | _ => o (normalize b)
    end
  | i b => i (normalize b)
  | z => z
  end.

Compute normalize (o (i (i (o (o z))))).
Compute natbin (binnat (o (i (i (o (o z)))))).

Lemma hodai1 n :
  natbin n.+1.*2 = o (natbin n.+1).
Proof.
  elim: n.
  - by [].
  - move=> /= n' H /=.
    by rewrite H /=.
Qed.
(*
natbin n.*2 = o (natbin n) を証明するには、
z = o z を認める必要がある。
つまり、一般的過ぎて証明できない。
 *)

Lemma hodai2 n :
  natbin (n.*2 + 1) = i (natbin n).
Proof.
  elim: n.
  - by [].
  - move=> /= n' H /=.
    by rewrite H /=.
Qed.

(* natを経由する正規化と、直接的な正規化が、同じ結果になることを証明する。 *)
Goal forall (b : bin),
    natbin (binnat b) = normalize b.
Proof.
  elim=> [b IHb|b IHb|] /=.
  - rewrite -IHb.
    case: (binnat b).
    + by [].
    + elim.
      * by [].
      * move=> n H.
          by apply hodai1.
  - rewrite -IHb.
    case: (binnat b).
    + by [].
    + elim.
      * by [].
      * move=> n H.
          by apply hodai2.
  - by [].
Qed.

(* ******** *)
(* **別解** *)
(* ******** *)

(* 再帰関数の、関数呼び出しに関する帰納法をできるようにする。
 * パターンマッチが入れ子になったりしている複雑な再帰関数のときに便利
 * https://gist.github.com/yoshihiro503/fc51fef8b94c3a42c3ca
 *)
Functional Scheme normalize_ind := Induction for normalize Sort Prop.
Goal forall (b : bin),
    natbin (binnat b) = normalize b.
Proof.
  move=> b.
  functional induction (normalize b) => /=.
  (* natbin (binnat b0).*2 = z *)
  - by rewrite e0 /=.
  (* natbin (binnat b0).*2 = o (normalize b0) *)
  - by rewrite -IHb0 e0 hodai1 /=.
  (* natbin ((binnat b0).*2 + 1) = i (normalize b0) *)
  - by rewrite -IHb0 hodai2 /=.
  (* z = z *)
  - by [].
Qed.

(* END *)


Require Import ZArith.
Open Local Scope Z_scope.

Inductive fact_domain : Z -> Prop :=
| fact_domain_zero :
  fact_domain 0
| fact_domain_pos :
  forall z : Z, z >= 0 -> fact_domain (Zminus z 1) -> fact_domain z.

Theorem fact_domain_pos_true : forall z : Z, fact_domain z -> z >= 0.
intros x H.
case H.
unfold Zge.
discriminate.
intros.
assumption.
Defined.

Theorem fact_domain_inv :
  forall z : Z, fact_domain z -> z > 0 -> fact_domain (Zminus z 1).
intros z H.
case H.
intros.
discriminate.
intros.
assumption.
Defined.

Fixpoint fact (z : Z) (h : fact_domain z) {struct h} : Z :=
match Z_gt_le_dec z 0 with
  | right hle =>
    match Z_ge_lt_dec z 0 with
      | right hlt => False_rec Z (fact_domain_pos_true z h hlt)
      | left _ => 1
    end
  | left hgt =>
    z * (fact (Zminus z 1) (fact_domain_inv z h hgt))
end.


Theorem example1 : forall a b: Prop, a /\ b -> b /\ a.
  intros a b H.
  split.
  destruct H as [H1 H2].
  exact H2.
  destruct H as [H1 H2].
  exact H1.
Qed.

Theorem example2 : forall A B, A \/ B -> B \/ A.
  intros A B H.
  destruct H as [H1 | H2].
  right.
  exact H1.
  left.
  exact H2.
Qed.

Check le_n.
Check le_S.

Theorem example3 : 3 <= 5.      (* dependent type here! *)
  apply le_S.
  apply le_S.
  apply le_n.
Qed.

Require Export Arith.

Check le_trans.

Theorem example4 : forall x y, x <= 10 -> 10 <= y -> x <= y.
  intros x y x10 y10.
  apply le_trans with (m := 10).
  exact x10.                    (* can also use assuption *)
  exact y10.
Qed.

Theorem example5 : forall x y, (x + y) * (x + y) = x * x + 2 * x * y + y * y.
  intros x y.
  SearchRewrite (_ * (_ + _)).
  rewrite mult_plus_distr_l.
  SearchRewrite ((_ + _) * _).
  rewrite mult_plus_distr_r.
  rewrite mult_plus_distr_r.
  SearchRewrite (_ + (_ + _)).
  rewrite plus_assoc.
  rewrite <- plus_assoc with (n := x * x).
  SearchPattern (?x * ?y = ?y * ?x).
  rewrite mult_comm with (n := y) (m := x).
  SearchRewrite (S _ * _).
  pattern (x * y) at 1; rewrite <- mult_1_l.
  rewrite <- mult_succ_l with (m := (x * y)). (* or can simply use rewrite <- mult_succ_l *)
  SearchRewrite (_ * (_ * _)).
  rewrite -> mult_assoc with (n := 2) (m := x) (p := y). (* or can simply use rewrite mult_assoc *)
  reflexivity.
Qed.

Require Import Omega.

Theorem omega_example : forall f x y, 0 < x -> 0 < f x -> 3 * f x <= 2 * y -> f x <= y.
  intros; omega.
Qed.

Fixpoint sum_n n :=
  match n with
    O => O
  | S p => p + sum_n p
end.

Check sum_n.

Theorem sum_n_p : forall n, 2 * sum_n n + n = n * n.
  induction n.                  (* 归纳证明 *)
  reflexivity.
  assert (SnSn : S n * S n = n * n + 2 * n + 1).
  ring.
  rewrite -> SnSn.
  rewrite <- IHn.
  simpl.                        (* replace with the sum_n symbolic computation *)
  ring.
Qed.

Require Import Bool.

Fixpoint evenb n :=
  match n with
    0 => true
  | 1 => false
  | S (S p) => evenb p
end.

Check evenb.

Theorem evenb_p : forall n, evenb n = true -> exists x, n = 2 * x.
  assert (Main : forall n, (evenb n = true -> exists x, n = 2 * x) /\ (evenb (S n) = true -> exists x, S n = 2 * x)).
  induction n.
  split.                        (* split conjunction *)
  exists O; ring.
  simpl.
  intros H.
  discriminate.
  split.
  destruct IHn as [_ IHn'].
  exact IHn'.
  simpl.
  intros H.
  destruct IHn as [IHn' _].
  assert (H' : exists x, n = 2 * x).
  apply IHn'.
  exact H.
  destruct H' as [x q].
  exists (x + 1).
  rewrite -> q.
  ring.
  intros n ev.
  destruct (Main n) as [H _].
  apply H.
  exact ev.
Qed.

Require Import List.
Print beq_nat.

Fixpoint leb (n : nat) : nat -> bool :=
  match n with
    | O => fun _ : nat => true
    | S n' => fun m : nat => match m with
                         | O => false
                         | S m' => leb n' m'
                       end
  end.

Eval compute in leb 3 3.
Eval compute in leb 3 6.
Eval compute in leb 6 3.

Fixpoint insert n l :=
  match l with
    nil => n :: nil
  | h :: t => if leb n h then n :: l else h :: insert n t
end.

Fixpoint count n l :=
  match l with
    nil => 0
  | h :: t => let r := count n t in if beq_nat n h then 1 + r else r
end.

(* induction nat O | S _ *)
(* induction list nil | _ :: _ *)

Theorem insert_incr : forall n l, count n (insert n l) = 1 + count n l.
  intros n l.
  induction l.
  simpl.
  SearchAbout beq_nat.
  rewrite <- beq_nat_refl.
  reflexivity.                  (* or ring *)
  simpl.
  case (leb n a).
  simpl.
  rewrite <- beq_nat_refl.
  reflexivity.
  simpl.
  case (beq_nat n a).
  rewrite IHl; reflexivity.
  rewrite IHl; reflexivity.
Qed.

(* define new datatypes *)

Inductive bin : Type :=          (* binary tree *)
  | L : bin                     (* leaf *)
  | N : bin -> bin -> bin.        (* node *)

Check N L (N L L).              (* nonsense but match the specification *)

Definition is_single_node (t : bin) : bool :=
  match t with
    | N L L => false
    | _ => true
  end.

Fixpoint flatten_aux (t1 t2 : bin) : bin :=
  match t1 with
    | L => N L t2
    | N t1' t2' => flatten_aux t1' (flatten_aux t2' t2)
  end.

Fixpoint flatten (t : bin) : bin :=
  match t with
    | L => L
    | N t1 t2 => flatten_aux t1 (flatten t2)
  end.

Fixpoint size (t : bin) : nat :=
  match t with
   | L => 1
   | N t1 t2 => 1 + size t1 + size t2
  end.

Eval compute in flatten_aux (N L L) L.
Eval compute in size (N (N L L) L).
Eval compute in size (N L L).

(* prove properties of functions *)

Theorem example_size : forall t, is_single_node t = false -> size t = 3.
  intro t.
  destruct t.                   (* the tactic destruct is quite similiar to induction but one is for hypothesis and one is for conclution *)
  simpl.
  intro H.
  discriminate H.               (* just got a contradiction assume true = false *)
  destruct t1.
  destruct t2.
  simpl.
  reflexivity.                  (* or use auto instead *)
  simpl.
  intro H.
  discriminate H.
  simpl.
  intro H; discriminate.
Qed.

Theorem flatten_aux_size : forall t1 t2, size (flatten_aux t1 t2) = size t1 + size t2 + 1.
  induction t1.
  intro t2.
  simpl.
  ring.
  intro t2.
  simpl.
  rewrite IHt1_1.
  rewrite IHt1_2.
  ring.
Qed.

Theorem not_subterm_self_1 : forall x y, ~ x = N x y.
  induction x.
  intro y.
  intro H.
  discriminate.
  intro y.
  intro abs.
  injection abs.
  intros h2 h1.
  assert (IHx1' : x1 <> N x1 x2).
  apply IHx1.
  case IHx1'.
  exact h1.
Qed.

Print nat.

Fixpoint nat_fact (n : nat) : nat :=
  match n with
    | O => 1
    | S p => S p * nat_fact p
  end.

Fixpoint fib (n : nat) : nat :=
  match n with
    | O => 0
    | S q => match q with
              | O => 1
              | S p => fib p + fib q
            end
  end.

Inductive even : nat -> Prop :=       (* even x is a proposition *)
  | evenO : even O
  | evenS : forall x : nat , even x -> even (S (S x)).

(*
judgement and inference rule

             n even
 ——————    ————————————
 0 even    S(S(n)) even

       ——————
       0 even
    ————————————
    S(S(0)) even
 ——————————————————
 S(S(S(S(0)))) even
*)

Theorem even_mult : forall x, even x -> exists y, x = 2 * y.
  intros x H.
  elim H.                       (* elim and induction are almose the same here *)
  exists 0.
  reflexivity.
  intros xO HevenO IHx.
  destruct IHx as [y Heq].
  rewrite Heq.
  exists (S y).
  ring.
Qed.

Theorem not_even_1 : ~even 1.
  intros even1.
  inversion even1.
Qed.

Theorem even_inv : forall x, even (S (S x)) -> even x. (* inversion of evenS *)
  intros x H.
  inversion H.
  exact H1.
Qed.

(*
Inductive properties can be used to express very complex notions. For instance, the semantics of a programming language can be defined as an inductive definition, using dozens of constructors, each one describing a an elementary step of computation.
*)


Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

From q3_2001 Require Export misc.

(* TODO Retire in favour of largest_elt? *)
Definition nat_list_max (l : list nat) : nat :=
  fold_right max 0 l.

Lemma nat_list_max_spec_0 : forall m l,
  m <= nat_list_max (m::l).
Proof. intros. simpl. apply Nat.le_max_l. Qed.

Lemma nat_list_max_spec_1 : forall m l,
  nat_list_max l <= nat_list_max (m::l).
Proof. intros. simpl. fold nat_list_max. apply Nat.le_max_r. Qed.

Lemma nat_list_max_spec_2 : forall (l : list nat),
  l <> [] -> In (nat_list_max l) l.
Proof.
  intros l Hl. generalize dependent l. induction l as [| x l IHl]; try contradiction.
  destruct (Nat.max_spec_le x (nat_list_max l)) as [[Hmax Hmax'] | [Hmax Hmax']];
  intros H; simpl; rewrite Hmax'.
  + destruct (list_empty_dec l) as [Hl' | Hl'].
    * left. subst. simpl. simpl in Hmax. omega.
    * right. apply IHl in Hl'. apply Hl'.
  + left. reflexivity.
Qed.

Lemma nat_list_max_spec_3 : forall (l : list nat) (m : nat),
  In m l -> m <= nat_list_max l.
Proof.
  intros l m Hm. induction l as [| x l IHl]; try contradiction.
  destruct Hm as [H | H].
  - subst. apply nat_list_max_spec_0.
  - apply IHl in H. pose (H' := (nat_list_max_spec_1 x l)). omega.
Qed.

Lemma nat_list_max_spec_4 : forall (l : list nat),
  nat_list_max l = 0 <-> (forall x, In x l -> x = 0).
Proof.
  intros l.
  split.
  - intros H x Hx.
    apply nat_list_max_spec_3 in Hx. rewrite H in Hx. omega.
  - intros H. destruct (list_empty_dec l) as [Hl | Hl].
    + rewrite Hl. auto.
    + apply nat_list_max_spec_2 in Hl. apply H in Hl. assumption.
Qed.


Require Import Recdef.

Inductive Z : Type :=
| Pos : nat -> Z
| Zero : Z
| Neg : nat -> Z.

Inductive Z' : Type :=
| Zero' : Z'
| MinusOne : Z'
| Next : Z' -> Z'.

(* Add for Z *)
Function succ (n: Z) : Z :=
match n with
| Pos k => Pos (S k)
| Zero => Pos O
| Neg O => Zero
| Neg (S n) => Neg n
end.

Function pred (n: Z) : Z :=
match n with
| Pos (S n) => Pos n
| Pos O => Zero
| Zero => Neg O
| Neg n => Neg (S n)
end.

Function map_n {A: Type} (n: nat) (f: A -> A) (x: A) : A :=
match n with
| O => x
| S n' => f (map_n n' f x)
end.

Function add (a b : Z) : Z :=
match a with
| Pos n => map_n (S n) succ b
| Zero => b
| Neg n => map_n (S n) pred b
end.

Theorem Z_ind' (P : Z -> Prop) (base: P Zero) (base_pos: P (Pos O)) (base_neg: P (Neg O))
  (suc: forall n: nat, P (Pos n) -> P (Pos (S n)))
  (pre: forall n: nat, P (Neg n) -> P (Neg (S n))) : forall z: Z, P z.
Proof.
  intro z. destruct z.
  - induction n.
    + assumption.
    + apply suc. assumption.
  - assumption.
  - induction n.
    + assumption.
    + apply pre. assumption.
Qed.

Theorem one_is_zero_succ : Pos O = succ Zero.
Proof.
  cbn. trivial.
Qed.

Theorem succ_S : forall n: nat, Pos (S n) = succ (Pos n).
Proof.
  destruct n; cbn; trivial.
Qed.

Theorem minus_one_is_zero_pred : Neg O = pred Zero.
Proof.
  cbn. trivial.
Qed.

Theorem pred_S : forall n: nat, Neg (S n) = pred (Neg n).
Proof.
  destruct n; cbn; trivial.
Qed.

Theorem succ_pred : forall n: Z, succ (pred n) = n.
Proof.
  intro n. induction n.
  - destruct n; cbn; trivial.
  - cbn. trivial.
  - destruct n; cbn; trivial.
Qed.

Theorem pred_succ : forall n: Z, pred (succ n) = n.
Proof.
  intro n. induction n.
  - destruct n; cbn; trivial.
  - cbn. trivial.
  - destruct n; cbn; trivial.
Qed.

Theorem add_r_zero : forall x: Z, add x Zero = x.
Proof.
  induction x using Z_ind'; trivial.
  - cbn; rewrite succ_S; f_equal; apply IHx.
  - cbn; rewrite pred_S; f_equal; apply IHx.
Qed.

Theorem add_r_succ : forall x y: Z, add x (succ y) = succ (add x y).
Proof.
  intros x y. revert x. induction x using Z_ind'; trivial.
  - cbn. rewrite pred_succ. rewrite succ_pred. trivial.
  - cbn in *. f_equal. apply IHx.
  - cbn in *. rewrite succ_pred. rewrite succ_pred in IHx. rewrite IHx. trivial.
Qed.

Theorem add_r_pred : forall x y: Z, add x (pred y) = pred (add x y).
Proof.
  intros x y. revert x. induction x using Z_ind'; trivial.
  - cbn. rewrite pred_succ. rewrite succ_pred. trivial.
  - cbn in *. rewrite pred_succ in *. rewrite IHx. trivial.
  - cbn in *. f_equal. apply IHx.
Qed.

Theorem add_sym: forall x y: Z, add x y = add y x.
Proof.
  intro x. induction x using Z_ind'; intro y.
  - rewrite add_r_zero. cbn. trivial.
  - cbn. rewrite one_is_zero_succ. rewrite add_r_succ. rewrite add_r_zero. trivial.
  - cbn. rewrite minus_one_is_zero_pred. rewrite add_r_pred.
    rewrite add_r_zero. trivial.
  - cbn. rewrite succ_S. rewrite add_r_succ. f_equal. apply IHx.
  - cbn. rewrite pred_S. rewrite add_r_pred. f_equal. apply IHx.
Qed.

Theorem add_pred_succ : forall x y: Z, add (pred x) (succ y) = add x y.
Proof.
  intros x y. rewrite add_r_succ. rewrite (add_sym (pred x) y). rewrite add_r_pred.
  rewrite succ_pred. rewrite add_sym. trivial.
Qed.

Theorem add_l_succ : forall x y: Z, add (succ x) y = succ (add x y).
Proof.
  intros x y. rewrite (add_sym (succ x) y). rewrite add_r_succ. f_equal.
  apply add_sym.
Qed.

Theorem add_succ_swap : forall x y: Z,  add x (succ y) = add (succ x) y.
Proof.
  intros x y. rewrite add_r_succ. rewrite add_l_succ. trivial.
Qed.

Theorem add_l_pred : forall x y: Z, add (pred x) y = pred (add x y).
Proof.
  intros x y. rewrite (add_sym (pred x) y). rewrite add_r_pred. f_equal.
  apply add_sym.
Qed.

Theorem add_pred_swap : forall x y: Z, add x (pred y) = add (pred x) y.
Proof.
  intros x y. rewrite add_r_pred. rewrite add_l_pred. trivial.
Qed.

(* Add for Z' *)
Function succ' (k : Z') : Z' :=
match k with
| Zero' => Next Zero'
| MinusOne => Zero'
| Next Zero' => Next (Next Zero')
| Next MinusOne => MinusOne
| Next k' => Next (succ' k')
end.

Function pred' (k : Z') : Z' :=
match k with
| Zero' => MinusOne
| MinusOne => Next MinusOne
| Next Zero' => Zero'
| Next MinusOne => Next (Next MinusOne)
| Next k' => Next (pred' k')
end.

Function abs (k: Z') : nat :=
match k with
| Zero'    => 0
| MinusOne => 1
| Next k'  => S (abs k')
end.

Function pos (k: Z') : bool :=
match k with
| Zero'    => true
| MinusOne => false
| Next k'  => pos k'
end.

Definition add' (a b : Z') : Z' :=
match pos a with
| true  => map_n (abs a) succ' b
| false => map_n (abs a) pred' b
end.

Lemma next_pos_is_same : forall z: Z', pos z = pos (Next z).
Proof.
  intros z. induction z; auto.
Qed.

Lemma if_pos_next_is_succ : forall z: Z', pos z = true -> Next z = succ' z.
Proof.
  intro z. induction z; auto.
  - intros H. cbn in *. discriminate H.
  - intros H. assert (P: pos z = true) by (rewrite <- H; apply next_pos_is_same; auto).
    cbn. specialize (IHz P). rewrite <- IHz. destruct z; auto. cbn in P. discriminate.
Qed.

Lemma if_neg_next_is_pred : forall z: Z', pos z = false -> Next z = pred' z.
Proof.
  intro z. induction z; auto.
  - intros H. cbn in *. discriminate H.
  - intros H. assert (P: pos z = false) by (rewrite <- H; apply next_pos_is_same; auto).
    cbn. specialize (IHz P). rewrite <- IHz. destruct z; auto. cbn in P. discriminate.
Qed.

Theorem Z'_ind' (P : Z' -> Prop) (base: P Zero') (suc: forall z: Z', P z -> P (succ' z))
  (pre: forall z: Z', P z -> P (pred' z)) : forall z: Z', P z.
Proof.
  intro z. induction z; auto.
  - apply (pre _ base).
  - destruct (pos z) eqn:pos.
    + rewrite (if_pos_next_is_succ z pos). apply (suc _ IHz).
    + rewrite (if_neg_next_is_pred z pos). apply (pre _ IHz).
Qed.

(* Izomorphism *)
Definition h (n: Z') : Z :=
match n with
| Zero'    => Zero
| MinusOne => Neg O
| Next n'  => if pos n'
              then Pos (abs n')
              else Neg (abs n')
end.

Definition h_inv (n: Z) : Z' :=
match n with
| Pos n' => map_n (S n') Next Zero'
| Zero   => Zero'
| Neg n' => map_n n' Next MinusOne
end.

Lemma abs_for_map_n : forall n: nat, abs (map_n n Next Zero') = n.
Proof.
  intros n. induction n; auto. cbn. f_equal. assumption.
Qed.

Lemma abs_for_map_n' : forall n: nat, abs (map_n n Next MinusOne) = S n.
Proof.
  intros n. induction n; auto. cbn. f_equal. assumption.
Qed.

Lemma pos_for_map_n : forall n: nat, pos (map_n n Next Zero') = true.
Proof.
  intros n. induction n; auto.
Qed.

Lemma pos_for_map_n' : forall n: nat, pos (map_n n Next MinusOne) = false.
Proof.
  intros n. induction n; auto.
Qed.

Lemma map_n_abs_pos : forall n: Z', pos n = true -> map_n (abs n) Next Zero' = n.
Proof.
  intros n H. induction n; auto.
  - cbn in *. discriminate.
  - cbn in *. f_equal. apply IHn. assumption.
Qed.

Lemma map_n_abs_neg : forall n: Z', pos n = false -> map_n (abs n) Next MinusOne = Next n.
Proof.
  intros n H. induction n; auto.
  - cbn in *. discriminate.
  - cbn in *. f_equal. apply IHn. assumption.
Qed.

(* Bijection of h function *)
Theorem h_bijection : forall x : Z, h (h_inv x) = x.
Proof.
  intros x. induction x using Z_ind'; auto.
  - cbn. rewrite pos_for_map_n, abs_for_map_n. auto.
  - cbn. rewrite pos_for_map_n', abs_for_map_n'. auto.
Qed.

Theorem h_bijection' : forall x : Z', h_inv (h x) = x.
Proof.
  intros x. destruct x; auto. cbn. destruct (pos x) eqn:P.
  - cbn. f_equal. apply map_n_abs_pos. assumption.
  - cbn. apply map_n_abs_neg. assumption.
Qed.

Lemma h_surjection : forall y: Z, exists x: Z', h x = y.
Proof.
  intros y. exists (h_inv y). apply h_bijection.
Qed.

Lemma h_iniection : forall x y: Z', h x = h y -> x = y.
Proof.
  intros x y H. rewrite <- (h_bijection' x), <- (h_bijection' y). f_equal. assumption.
Qed.

Lemma pred'_for_pos : forall x : Z', pos x = true -> pred' (Next x) = x.
Proof.
  intros x P. induction x; cbn in *; try discriminate; auto. specialize (IHx P).
  rewrite IHx. auto.
Qed.

Lemma succ'_for_neg : forall x : Z', pos x = false -> succ' (Next x) = x.
Proof.
  intros x P. induction x; cbn in *; try discriminate; auto. specialize (IHx P).
  rewrite IHx. auto.
Qed.

Lemma pred'_for_neg : forall x : Z', pos x = false -> pred' x = Next x.
Proof.
  intros x P. induction x; cbn in *; try discriminate; auto. specialize (IHx P).
  rewrite IHx. destruct x; auto. cbn in *. discriminate.
Qed.

Lemma succ'_for_pos : forall x : Z', pos x = true -> succ' x = Next x.
Proof.
  intros x P. induction x; cbn in *; try discriminate; auto. specialize (IHx P).
  rewrite IHx. destruct x; auto. cbn in *. discriminate.
Qed.

Lemma succ'_pred': forall k : Z', succ' (pred' k) = k.
Proof.
  intros x. functional induction (pred' x); cbn; auto. rewrite IHz.
  functional induction (pred' k'); cbn; auto. contradiction.
Qed.

Lemma pred'_succ' : forall k : Z', pred' (succ' k) = k.
Proof.
  intros k; functional induction (succ' k); cbn; auto.
  rewrite IHz. functional induction (succ' k'); cbn in *; auto.
  contradiction.
Qed.

Lemma pred_h : forall x: Z', pred (h x) = h (pred' x).
Proof.
  intro x. destruct (pos x) eqn:P.
  - destruct x; auto. cbn in P. rewrite pred'_for_pos; auto.
    cbn. rewrite P. destruct x; cbn in *; try discriminate; auto.
    rewrite P. auto.
  - destruct x; auto. cbn in P. rewrite pred'_for_neg; auto.
    cbn. rewrite P. auto.
Qed.

Lemma succ_h : forall x: Z', succ (h x) = h (succ' x).
Proof.
  intro x. destruct (pos x) eqn:P.
  - destruct x; auto. cbn in P. rewrite succ'_for_pos; auto.
    cbn. rewrite P. auto.
  - destruct x; auto. cbn in P. rewrite succ'_for_neg; auto.
    cbn. rewrite P. destruct x; cbn in *; try discriminate; auto.
    rewrite P. auto.
Qed.

Lemma add'_l_succ' : forall x y: Z', add' (succ' x) y = succ' (add' x y).
Proof.
  intros x y. revert x. induction y using Z'_ind'; auto; intro.
  - destruct x; auto. unfold add'. destruct (pos x) eqn:P.
    + rewrite succ'_for_pos; auto. cbn. rewrite P. auto.
    + rewrite succ'_for_neg; auto. cbn. rewrite P, succ'_pred'. auto.
  - destruct x; auto.
    + cbn. rewrite succ'_pred'. auto.
    + unfold add'. destruct (pos x) eqn:P.
      * rewrite succ'_for_pos; auto. cbn. rewrite P. auto.
      * rewrite succ'_for_neg; auto. cbn. rewrite P, succ'_pred'. auto.
  - destruct x; auto.
    + cbn. rewrite succ'_pred'. auto.
    + unfold add'. destruct (pos x) eqn:P.
      * rewrite succ'_for_pos; auto. cbn. rewrite P. auto.
      * rewrite succ'_for_neg; auto. cbn. rewrite P, succ'_pred'. auto.
Qed.

Lemma add'_l_pred' : forall x y: Z', add' (pred' x) y = pred' (add' x y).
Proof.
  intros x y. revert x. induction y using Z'_ind'; auto; intro.
  - destruct x; auto. unfold add'. destruct (pos x) eqn:P.
    + rewrite pred'_for_pos; auto. cbn. rewrite P, pred'_succ'. auto.
    + rewrite pred'_for_neg; auto. cbn. rewrite P. auto.
  - destruct x; auto. unfold add'. destruct (pos x) eqn:P.
    + rewrite pred'_for_pos; auto. cbn. rewrite P, pred'_succ'. auto.
    + rewrite pred'_for_neg; auto. cbn. rewrite P. auto.
  - destruct x; auto. unfold add'. destruct (pos x) eqn:P.
    + rewrite pred'_for_pos; auto. cbn. rewrite P, pred'_succ'. auto.
    + rewrite pred'_for_neg; auto. cbn. rewrite P. auto.
Qed.

(* Homomorphism of algebraic structures *)
Theorem Z_Z'_homo : forall x y: Z', add (h x) (h y) = h (add' x y).
Proof.
  intros x. induction x using Z'_ind'; auto; intros y.
  - rewrite add'_l_succ', <- succ_h, <- succ_h, <- IHx, add_l_succ. auto.
  - rewrite add'_l_pred', <- pred_h, <- pred_h, <- IHx, add_l_pred. auto.
Qed.


Inductive N: Set:=
| zero : N
| S: N -> N.

Definition I: N:= S zero.

Definition II: N:= S I.

Definition III: N:= S II.

Fixpoint sum (m n :N):=
match n with
   | zero => m
   | S n'=> S (sum m n')
end.

Notation "a '+' b" := (sum a b)(at level 50, left associativity).
Lemma ghazie1: sum I II=III.
Proof.
simpl.
trivial.
Qed.

Lemma unity: forall n:N, sum zero n=n.
Proof.
induction n.
-trivial.
-simpl. rewrite IHn. trivial.
Qed.

Lemma komaki2: forall m n:N, sum (S m) n=sum m (S n).
Proof.
induction n.
-simpl. trivial.
-simpl. rewrite IHn. reflexivity.
Qed.

Theorem comm: forall m n:N, sum m n=sum n m.
Proof.
intros.
induction m.
- simpl. apply unity.
- simpl. rewrite <- IHm. apply komaki2.
Qed.
(*****************************       All   Done!       ******************)
Fixpoint mult (m n:N):=
match n with
  |zero => zero
  |S n'=> sum (mult m n') m
end.

Notation "a '*' b" := (mult a b)(at level 40, left associativity).

Definition VI: N:= S (S (S III)).
(*Albatte in nemade 7 ha :D--> :)*)
Lemma do_seta_shishta: mult II III=VI.
Proof.
simpl. trivial.
Qed.

Theorem mozdavaj:forall n, mult n I=n.
Proof.
intros.
simpl.
apply unity.
Qed.

Lemma Zero_Mult: forall a:N , mult zero a = zero.
Proof.
induction a.
-trivial.
-simpl. apply IHa.
Qed.
Lemma Helper3: forall a b :N , sum ( S a ) b = S (sum a b).
Proof.
intros.
rewrite komaki2. simpl. trivial.
Qed.

Lemma Helper2: forall a b c :N, sum (sum a b ) c = sum a (sum b c).
Proof.
intros.
induction a.
- rewrite unity. rewrite unity. trivial.
-repeat rewrite Helper3; rewrite IHa. trivial.
Qed.

Lemma Helper1: forall a b:N, mult (S a) b = sum (mult a b) b.
Proof.
intros.
induction b.
-trivial.
-simpl. rewrite IHb. rewrite Helper2.
rewrite Helper2. rewrite comm with a b. trivial. (*ino tozih bede*)
Qed.
Lemma Jabejaei_Mult: forall a b :N, mult a b = mult b a.
Proof.
intros.
induction a.
-simpl. apply Zero_Mult.
- simpl. rewrite <-IHa. apply Helper1.
Qed.

Lemma distribut_mult: forall a m n :N, mult a (sum m n) =
sum (mult a m) (mult a n).
Proof.
intros.
induction a.
- repeat rewrite Zero_Mult in *. trivial.
- rewrite Helper1 in *. rewrite Helper1. rewrite Helper1. rewrite IHa. eauto.
rewrite Helper2 with (mult a m) m (sum (mult a n) n). rewrite comm with m (sum (mult a n) n).
rewrite Helper2 with (mult a n) n m. rewrite comm with n m.
rewrite Helper2 with (mult a m) (mult a n) (sum m n). trivial.
Qed.

(*proof next lemma as exercise*)
Lemma Comutativity_Mult: forall l m n:N, mult (mult l m) n=mult l (mult m n).
Proof.
intros.
induction n.
-auto.
-simpl. rewrite IHn. rewrite distribut_mult. trivial.
Qed.


(*
Calculus of construcctions
Set - type of sets
Type - type of type constructors
A -> B - type of functions from A to B
(forall x:T, U) family of types indexed on T
(fun (x:T) => U) - function from x of type T of body U (in CoC: [x:U] U)
( T U ) - T applied to U

Tactics to use
cbv flag1 flag2
	- call by value rewrite of term using flag1 and flag2 reductions (beta or delta for now)
lazy flag1 flag2
	- lazy evaluation rewrite of term using flag1 and flag2 reductions (beta or delta for now)
compute
	- alias for cbv beta iota
simpl
	- performs β-reductions and expands transparent constants (non lemmas)
Infix
	- defines infix syntax
*)

Section E4.
Variable A : Set.

Definition composition { A B C } := fun (x:B->C)(y:A->B)(z:A)=>(x (y z)).
Infix "o" := composition (left associativity, at level 94).

Definition id { A } := ....

Theorem e4 : forall x:A, (id o id) x = id x.
Proof.

Qed.

End E4.

Section E6.
(* Church encoded naturals *)
Definition N := forall X : Set, X -> (X -> X) -> X.
Definition Zero (X : Set) (o : X) (f : X -> X) := o.
Definition One  (X : Set) (o : X) (f : X -> X) := f (Zero X o f).

(* 6.1 *)
Definition Two  ...

(* 6.2 *)
Definition Succ ...

Lemma succOne : Succ One = Two.
Proof.

Qed.

(* 6.3 *)
Definition Plus (n m : N) : N
                := fun (X : Set) (o : X) (f : X -> X) => n X (m X o f) f.

Infix "++" := Plus (left associativity, at level 94).

Lemma sum1: (One ++ Zero) = One.
Proof.

Qed.

Lemma sum2: (One ++ One) = Two.
Proof.

Qed.

(* 6.4 *)
Definition Prod (n m : N) : N
                := fun (X:Set) (o:X) (f:X->X) => m X o (fun y:X => n X y f).

Infix "**" := ...

(* 6.5 *)
Lemma prod1 : (One ** Zero) = Zero.
Proof.

Qed.

Lemma prod2: (One ** Two) = Two.
Proof.

Qed.

End E6.


Inductive bool :=
  | true
  | false.

Parameter prop_variables : Set.

Check prop_variables.

Inductive prop_formula : Set :=
                       | Var : prop_variables -> prop_formula
                       | Top : prop_formula
                       | Bottom : prop_formula
                       | Not : prop_formula -> prop_formula
                       | And : prop_formula -> prop_formula -> prop_formula
                       | Or : prop_formula -> prop_formula -> prop_formula.

Notation "⊥" := Bottom.
Notation "⊤" := Top.
Notation "¬ P" := (Not P) (at level 51).
Infix "∧" := And (left associativity, at level 52).
Infix "∨" := Or (left associativity, at level 53).

Definition Implication (φ ψ : prop_formula) : prop_formula := ¬φ ∨ ψ.
Definition Equivalence (φ ψ : prop_formula) : prop_formula := φ ∧ ψ ∨ ¬φ ∧ ¬ψ.

Infix "→" := Implication (left associativity, at level 54).
Infix "↔" := Equivalence (left associativity, at level 55).

Fixpoint Interpretation (φ : prop_formula) (M : prop_variables -> bool) : bool :=
  match φ with
  | Var p => M p
  | ⊤ => true
  | ⊥ => false
  | ¬ψ => match Interpretation ψ M with
         | true => false
         | false => true
         end
  | ψ ∧ υ => match (Interpretation ψ M), (Interpretation υ M) with
            | false, _ => false
            | _, false => false
            | _, _ => true
            end
  | ψ ∨ υ => match (Interpretation ψ M), (Interpretation υ M) with
            | true, _ => true
            | _, true => true
            | _, _ => false
            end
  end.

Definition Satisfies (φ : prop_formula) M  := (Interpretation φ M) = true.
Definition DoubleTurnstile φ ψ := forall M, (Satisfies φ M) -> (Satisfies ψ M).
Definition Tautology φ := forall M, Satisfies φ M.
Infix "⊨" := DoubleTurnstile (left associativity, at level 56).
Notation "_⊨" := Tautology.

Definition SemanticEquivalence φ ψ := and (φ ⊨ ψ) (ψ ⊨ φ).
Infix "~" := SemanticEquivalence (left associativity, at level 56).

Module Problem_1.

Theorem Problem_1_a: forall φ ψ : prop_formula,
  _⊨ (φ → ψ) <-> φ ⊨ ψ.
Proof.
  intros φ ψ.
  split.
  - intros H1. unfold Tautology in H1. unfold DoubleTurnstile. intros M1 H2.
    unfold Satisfies. unfold Satisfies in H1. unfold Satisfies in H1, H2.
    assert (H3: Interpretation (φ → ψ) M1 = true). { apply H1. }
    unfold Implication in H3. unfold Interpretation in  H2, H3.
    rewrite -> H2 in H3.
    destruct (Interpretation ψ M1) eqn: E1.
    * reflexivity.
    * unfold Interpretation in E1. rewrite -> E1 in H3. discriminate H3.
  - intros H1. unfold Tautology. unfold DoubleTurnstile in H1. intros M1.
    unfold Satisfies. unfold Satisfies in H1.
    assert (H2: Interpretation φ M1 = true -> Interpretation ψ M1 = true). { apply H1. }
    unfold Implication.
    destruct (Interpretation φ M1) eqn: E1.
    * assert (H3: Interpretation ψ M1 = true). { apply H2. reflexivity. }
      unfold Interpretation. unfold Interpretation in E1, H3. rewrite -> E1. rewrite H3. reflexivity.
    * unfold Interpretation. unfold Interpretation in E1. rewrite -> E1. reflexivity.
Qed.

Theorem Problem_1_b: forall φ ψ : prop_formula,
  _⊨ (φ ↔ ψ) <-> φ ~ ψ.
Proof.
  intros φ ψ.
  split.
  - intros H1. unfold SemanticEquivalence. unfold Tautology in H1.
    split.
    * unfold DoubleTurnstile. intros M1 H2.
      unfold Satisfies. unfold Satisfies in H1. unfold Satisfies in H1, H2.
      assert (H3: Interpretation (φ ↔ ψ) M1 = true). { apply H1. }
      unfold Equivalence in H3. unfold Interpretation in H2, H3.
      rewrite -> H2 in H3.
      destruct (Interpretation ψ M1) eqn: E1.
      + reflexivity.
      + unfold Interpretation in E1. rewrite -> E1 in H3. discriminate H3.
    * unfold DoubleTurnstile. intros M1 H2.
      unfold Satisfies. unfold Satisfies in H1. unfold Satisfies in H1, H2.
      assert (H3: Interpretation (φ ↔ ψ) M1 = true). { apply H1. }
      unfold Equivalence in H3. unfold Interpretation in H2, H3.
      rewrite -> H2 in H3.
      destruct (Interpretation φ M1) eqn: E1.
      + reflexivity.
      + unfold Interpretation in E1. rewrite -> E1 in H3. discriminate H3.
  - intros H. unfold SemanticEquivalence in H. unfold Equivalence.
    destruct H as [ H1 H2 ]. unfold Tautology. intros M1.
    unfold Satisfies. unfold DoubleTurnstile in H1, H2. unfold Satisfies in H1, H2.
    assert (H3: Interpretation φ M1 = true -> Interpretation ψ M1 = true). { apply H1. }
    assert (H4: Interpretation ψ M1 = true -> Interpretation φ M1 = true). { apply H2. }
    destruct (Interpretation φ M1) eqn: Eφ.
    * assert (H5: Interpretation ψ M1 = true). { apply H3. reflexivity. }
      simpl. rewrite -> H5. rewrite -> Eφ. reflexivity.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + discriminate H4. reflexivity.
      + unfold Interpretation. unfold Interpretation in Eφ, Eψ. rewrite -> Eφ. rewrite -> Eψ. reflexivity.
Qed.

End Problem_1.

Module Problem_2.

Theorem Problem_2_a: forall φ : prop_formula,
  (¬¬φ)~φ.
Proof.
  intros φ. unfold SemanticEquivalence.
  split.
  - unfold DoubleTurnstile. unfold Satisfies. intros M1 H1. simpl in H1.
    destruct (Interpretation φ M1).
    * reflexivity.
    * discriminate H1.
  - unfold DoubleTurnstile. unfold Satisfies. intros M1 H1. simpl. rewrite -> H1. reflexivity.
Qed.

Theorem Problem_2_b: forall φ : prop_formula,
  _⊨ (φ ∨ ¬φ).
Proof.
  intros φ.
  unfold Tautology. intros M1. unfold Satisfies. unfold Interpretation.
  destruct (Interpretation φ M1) eqn: E1.
  - unfold Interpretation in E1. rewrite -> E1. reflexivity.
  - unfold Interpretation in E1. rewrite -> E1. reflexivity.
Qed.

Theorem Problem_2_c: forall φ ψ η: prop_formula,
  φ ∧ (ψ ∨ η) ~ (φ ∧ ψ) ∨ (φ ∧ η).
Proof.
  intros φ ψ η. unfold SemanticEquivalence.
  split.
  - unfold DoubleTurnstile. intros M1. unfold Satisfies. intros H1.
    destruct (Interpretation φ M1) eqn: Eφ.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in Eφ, Eψ. unfold Interpretation. rewrite -> Eφ. rewrite -> Eψ. reflexivity.
      + unfold Interpretation in Eφ, Eψ.
        unfold Interpretation in H1. rewrite -> Eφ in H1. rewrite -> Eψ in H1.
        unfold Interpretation. rewrite -> Eφ. rewrite -> Eψ. rewrite -> H1. reflexivity.
    * unfold Interpretation in H1, Eφ. unfold Interpretation. rewrite -> Eφ. rewrite -> Eφ in H1. discriminate H1.
  - unfold DoubleTurnstile. intros M1. unfold Satisfies. intros H1.
    destruct (Interpretation φ M1) eqn: Eφ.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in Eφ, Eψ. unfold Interpretation. rewrite -> Eφ. rewrite -> Eψ. reflexivity.
      + unfold Interpretation in Eφ, Eψ.
        unfold Interpretation in H1. rewrite -> Eφ in H1. rewrite -> Eψ in H1.
        unfold Interpretation. rewrite -> Eφ. rewrite -> Eψ. rewrite -> H1. reflexivity.
    * unfold Interpretation in H1, Eφ. unfold Interpretation. rewrite -> Eφ. rewrite -> Eφ in H1. discriminate H1.
Qed.

Theorem Problem_2_d: forall φ ψ η: prop_formula,
  φ ∨ (ψ ∧ η) ~ (φ ∨ ψ) ∧ (φ ∨ η).
Proof.
  intros φ ψ η. unfold SemanticEquivalence.
  split.
  - unfold DoubleTurnstile. intros M1. unfold Satisfies. intros H1.
    destruct (Interpretation φ M1) eqn: Eφ.
    * unfold Interpretation in Eφ. unfold Interpretation. rewrite -> Eφ. reflexivity.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in H1, Eφ, Eψ. unfold Interpretation.
        rewrite -> Eφ. rewrite -> Eψ. rewrite -> Eφ in H1. rewrite -> Eψ in H1. rewrite -> H1. reflexivity.
      + unfold Interpretation in H1, Eφ, Eψ. rewrite -> Eφ in H1. rewrite -> Eψ in H1. discriminate H1.
  - unfold DoubleTurnstile. intros M1. unfold Satisfies. intros H1.
    destruct (Interpretation φ M1) eqn: Eφ.
    * unfold Interpretation in Eφ. unfold Interpretation. rewrite -> Eφ. reflexivity.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in H1, Eφ, Eψ. unfold Interpretation.
        rewrite -> Eφ. rewrite -> Eψ. rewrite -> Eφ in H1. rewrite -> Eψ in H1. rewrite -> H1. reflexivity.
      + unfold Interpretation in H1, Eφ, Eψ. rewrite -> Eφ in H1. rewrite -> Eψ in H1. discriminate H1.
Qed.

Theorem Problem_2_e: forall φ ψ: prop_formula,
  φ ∨ (φ ∧ ψ) ~ φ.
Proof.
  intros φ ψ. unfold SemanticEquivalence. unfold DoubleTurnstile.
  split.
  - intros M1. unfold Satisfies.
    destruct (Interpretation φ M1) eqn: E1.
    * reflexivity.
    * intros H1. unfold Interpretation in H1, E1. rewrite -> E1 in H1. discriminate H1.
  - intros M1. unfold Satisfies.
    destruct (Interpretation φ M1) eqn: E1.
    * intros H1. unfold Interpretation in E1. unfold Interpretation. rewrite -> E1. reflexivity.
    * intros H1. discriminate H1.
Qed.

Theorem Problem_2_f: forall φ ψ: prop_formula,
  φ ∧ (φ ∨ ψ) ~ φ.
Proof.
  intros φ ψ. unfold SemanticEquivalence. unfold DoubleTurnstile. unfold Satisfies.
  split.
  - intros M1 H1.
    destruct (Interpretation φ M1) eqn: E1.
    * reflexivity.
    * unfold Interpretation in H1, E1. rewrite -> E1 in H1. discriminate H1.
  - intros M1 H1. unfold Interpretation in H1. unfold Interpretation. rewrite -> H1. reflexivity.
Qed.

Theorem Problem_2_g: forall φ ψ: prop_formula,
  ¬(φ ∧ ψ) ~ ¬φ ∨ ¬ψ.
Proof.
  intros φ ψ. unfold SemanticEquivalence. unfold DoubleTurnstile. unfold Satisfies.
  split.
  - intros M1 H1.
    destruct (Interpretation φ M1) eqn: Eφ.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in H1, Eφ, Eψ. rewrite -> Eφ in H1. rewrite -> Eψ in H1.
        unfold Interpretation. rewrite -> Eφ. rewrite -> Eψ.
        discriminate H1.
      + unfold Interpretation in Eφ, Eψ. unfold Interpretation. rewrite -> Eφ. rewrite -> Eψ. reflexivity.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in Eφ. unfold Interpretation. rewrite -> Eφ. reflexivity.
      + unfold Interpretation in Eφ. unfold Interpretation. rewrite -> Eφ. reflexivity.
  - intros M1 H1.
    destruct (Interpretation φ M1) eqn: Eφ.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in H1, Eφ, Eψ. rewrite -> Eφ in H1. rewrite -> Eψ in H1.
        unfold Interpretation. rewrite -> Eφ. rewrite -> Eψ.
        discriminate H1.
      + unfold Interpretation in Eφ, Eψ. unfold Interpretation. rewrite -> Eφ. rewrite -> Eψ. reflexivity.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in Eφ. unfold Interpretation. rewrite -> Eφ. reflexivity.
      + unfold Interpretation in Eφ. unfold Interpretation. rewrite -> Eφ. reflexivity.
Qed.

Theorem Problem_2_h: forall φ ψ: prop_formula,
  ¬(φ ∨ ψ) ~ ¬φ ∧ ¬ψ.
Proof.
  intros φ ψ. unfold SemanticEquivalence. unfold DoubleTurnstile. unfold Satisfies.
  split.
  - intros M1 H1.
    destruct (Interpretation φ M1) eqn: Eφ.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in H1, Eφ, Eψ. rewrite -> Eψ in H1. rewrite -> Eφ in H1.
        unfold Interpretation. rewrite -> Eψ. rewrite -> Eφ.
        discriminate H1.
      + unfold Interpretation in H1, Eφ, Eψ. rewrite -> Eψ in H1. rewrite -> Eφ in H1.
        unfold Interpretation. rewrite -> Eψ. rewrite -> Eφ.
        discriminate H1.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in H1, Eφ, Eψ. rewrite -> Eψ in H1. rewrite -> Eφ in H1.
        unfold Interpretation. rewrite -> Eψ. rewrite -> Eφ.
        discriminate H1.
      + unfold Interpretation in Eφ, Eψ. unfold Interpretation. rewrite -> Eψ. rewrite -> Eφ. reflexivity.
  - intros M1 H1.
    destruct (Interpretation φ M1) eqn: Eφ.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in H1, Eφ, Eψ. rewrite -> Eψ in H1. rewrite -> Eφ in H1.
        unfold Interpretation. rewrite -> Eψ. rewrite -> Eφ.
        discriminate H1.
      + unfold Interpretation in H1, Eφ, Eψ. rewrite -> Eψ in H1. rewrite -> Eφ in H1.
        unfold Interpretation. rewrite -> Eψ. rewrite -> Eφ.
        discriminate H1.
    * destruct (Interpretation ψ M1) eqn: Eψ.
      + unfold Interpretation in H1, Eφ, Eψ. rewrite -> Eψ in H1. rewrite -> Eφ in H1.
        unfold Interpretation. rewrite -> Eψ. rewrite -> Eφ.
        discriminate H1.
      + unfold Interpretation in Eφ, Eψ. unfold Interpretation. rewrite -> Eψ. rewrite -> Eφ. reflexivity.
Qed.

End Problem_2.

Module Problem_3.

Theorem Problem_3_a: forall p q : prop_formula,
  _⊨ ((p → q) ↔ (¬q → ¬p)).
Proof.
  intros p q. unfold Tautology. intros M1. unfold Satisfies.
  destruct (Interpretation p M1) eqn: Ep.
    - destruct (Interpretation q M1) eqn: Eq.
      * unfold Interpretation in Ep, Eq. unfold Interpretation. simpl. rewrite -> Eq. rewrite -> Ep. reflexivity.
      * unfold Interpretation in Ep, Eq. unfold Interpretation. simpl. rewrite -> Eq. rewrite -> Ep. reflexivity.
    - destruct (Interpretation q M1) eqn: Eq.
      * unfold Interpretation in Ep, Eq. unfold Interpretation. simpl. rewrite -> Eq. rewrite -> Ep. reflexivity.
      * unfold Interpretation in Ep, Eq. unfold Interpretation. simpl. rewrite -> Eq. rewrite -> Ep. reflexivity.
Qed.

Theorem Problem_3_b: forall p q r : prop_formula,
  _⊨ ((p → (q → r)) ↔ (¬r → (¬q → ¬p))).
Proof.
  intros p q r. unfold Tautology. intros M1. unfold Satisfies.
  destruct (Interpretation p M1) eqn: Ep.
    - destruct (Interpretation q M1) eqn: Eq.
      * destruct (Interpretation r M1) eqn: Er.
        -- unfold Interpretation in Ep, Eq, Er. unfold Interpretation. simpl.
           rewrite -> Eq. rewrite -> Ep. rewrite -> Er. reflexivity.
        -- unfold Interpretation in Ep, Eq, Er. unfold Interpretation. simpl.
           rewrite -> Eq. rewrite -> Ep. rewrite -> Er. Abort.

(*
  При интерпретации M:
    M[p] = true
    M[q] = true
    M[r] = false
  формула неверна. Т.е она необщезначимая,
  но при интерпретации M':
    M[p] = true
    M[q] = true
    M[r] = true
  формула выполнима.
 *)

End Problem_3.

Module Problem_4.

(*
  ННФ и КНФ:
  ¬(¬(p ∧ q) → ¬r) ~ ¬((p ∧ q) ∨ ¬r) ~ ¬(p ∧ q) ∧ r ~ (¬p ∨ ¬q) ∧ r
  (¬p ∨ ¬q) и r — дизъюнкты, т.е данная формула — конъюнкция дизъюнктов
 *)
Theorem Problem_4_a: forall p q r : prop_variables,
  ¬(¬((Var p) ∧ (Var q)) → ¬(Var r)) ~ (¬(Var p) ∨ ¬(Var q)) ∧ (Var r).
Proof.
  intros p q r. unfold SemanticEquivalence. unfold DoubleTurnstile. unfold Satisfies.
  split.
  - intros M1 H1.
    destruct (M1 p) eqn: Ep.
    * destruct (M1 q) eqn: Eq.
       + simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. discriminate H1.
       + destruct (M1 r) eqn: Er.
         -- simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. rewrite -> Er in H1.
            simpl. rewrite -> Ep. rewrite -> Eq. rewrite -> Er. reflexivity.
         -- simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. rewrite -> Er in H1.
            discriminate H1.
    * destruct (M1 r) eqn: Er.
      + simpl in H1. rewrite -> Ep in H1. rewrite -> Er in H1.
        simpl. rewrite -> Ep. rewrite -> Er. reflexivity.
      + simpl in H1. rewrite -> Ep in H1. rewrite -> Er in H1. discriminate H1.
  - intros M1 H1.
    destruct (M1 p) eqn: Ep.
    * destruct (M1 q) eqn: Eq.
       + simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. discriminate H1.
       + destruct (M1 r) eqn: Er.
         -- simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. rewrite -> Er in H1.
            simpl. rewrite -> Ep. rewrite -> Eq. rewrite -> Er. reflexivity.
         -- simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. rewrite -> Er in H1.
            discriminate H1.
    * destruct (M1 r) eqn: Er.
      + simpl in H1. rewrite -> Ep in H1. rewrite -> Er in H1.
        simpl. rewrite -> Ep. rewrite -> Er. reflexivity.
      + simpl in H1. rewrite -> Ep in H1. rewrite -> Er in H1. discriminate H1.
Qed.

(*
  ДНФ:
  ¬(¬(p ∧ q) → ¬r) ~ ¬((p ∧ q) ∨ ¬r) ~ ¬(p ∧ q) ∧ r ~ (¬p ∨ ¬q) ∧ r ~ (¬p ∧ r) ∨ (¬q ∧ r)
  (¬p ∧ r) и (¬q ∧ r) — конъюнкты, т.е данная формула — дизъюнкция конъюнктов
 *)
Theorem Problem_4_b: forall p q r : prop_variables,
  ¬(¬((Var p) ∧ (Var q)) → ¬(Var r)) ~ (¬(Var p) ∧ (Var r)) ∨ (¬(Var q) ∧ (Var r)).
Proof.
  intros p q r. unfold SemanticEquivalence. unfold DoubleTurnstile. unfold Satisfies.
  split.
  - intros M1 H1.
    destruct (M1 p) eqn: Ep.
    * destruct (M1 q) eqn: Eq.
       + simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. discriminate H1.
       + destruct (M1 r) eqn: Er.
         -- simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. rewrite -> Er in H1.
            simpl. rewrite -> Ep. rewrite -> Eq. rewrite -> Er. reflexivity.
         -- simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. rewrite -> Er in H1.
            discriminate H1.
    * destruct (M1 r) eqn: Er.
      + simpl in H1. rewrite -> Ep in H1. rewrite -> Er in H1.
        simpl. rewrite -> Ep. rewrite -> Er. reflexivity.
      + simpl in H1. rewrite -> Ep in H1. rewrite -> Er in H1. discriminate H1.
  - intros M1 H1.
    destruct (M1 p) eqn: Ep.
    * destruct (M1 q) eqn: Eq.
       + simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. discriminate H1.
       + destruct (M1 r) eqn: Er.
         -- simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. rewrite -> Er in H1.
            simpl. rewrite -> Ep. rewrite -> Eq. rewrite -> Er. reflexivity.
         -- simpl in H1. rewrite -> Ep in H1. rewrite -> Eq in H1. rewrite -> Er in H1.
            discriminate H1.
    * destruct (M1 r) eqn: Er.
      + simpl in H1. rewrite -> Ep in H1. rewrite -> Er in H1.
        simpl. rewrite -> Ep. rewrite -> Er. reflexivity.
      + simpl in H1. rewrite -> Ep in H1. rewrite -> Er in H1.
        destruct (M1 q) eqn: Eq.
        -- discriminate H1.
        -- discriminate H1.
Qed.

End Problem_4.

Module Problem_5.
End Problem_5.

Module Problem_6.
End Problem_6.

Module Problem_7.
End Problem_7.

Module Problem_8.
End Problem_8.

Module Problem_9.
End Problem_9.

Module Problem_10.
End Problem_10.


Require Import Arith Lia.

Definition iffT (X Y : Type) : Type := (X -> Y) * (Y -> X).
Notation "X <=> Y" := (iffT X Y) (at level 95, no associativity).

Definition inj {X Y} (f : X -> Y) :=
  forall x x', f x = f x' -> x = x'.

Definition inv {X Y} (g : Y -> X) (f : X -> Y) :=
  forall x, g (f x) = x.

Definition bijection X Y :=
  { f : X -> Y & { g & inv g f /\ inv f g }}.

Lemma size_rect {X} σ f :
  (forall x, (forall y : X, σ y < σ x -> f y) -> f x) -> forall x, f x.
refine (fun size_rec x => size_rec x
  (nat_rect (fun n => forall y, σ y < n -> f y)
    (fun y Hy0 => ltac:(lia))
    (fun x S_rec y Hyx => size_rec y
      (fun z Hzy => S_rec z ltac:(lia)))
    (σ x))).
Defined.

Section Cantor.

Definition next '(x,y) :=
  match x with
  | O => (S y, O)
  | S x' => (x', S y)
  end.

Fact n00_next : forall p, (0,0) <> next p.
Proof. destruct p as [[] ]; discriminate. Qed.

Fact inj_next : inj next.
Proof. intros [[] ][[] ]; cbn; congruence. Qed.

Fixpoint decode n :=
  match n with
  | 0 => (0,0)
  | S x => next (decode x)
  end.

Lemma inj_decode : inj decode.
Proof.
  intros n. induction n; intros []; auto.
  - now intros ?%n00_next.
  - now intros ?%eq_sym%n00_next.
  - intros [=?%inj_next%IHn]. congruence.
Qed.

(* show that next is almost surj. *)
Fact zero_or_next : forall p, {a | p = next a} + {p = (0,0)}.
Proof.
  intros [x []].
  - destruct x. now right. left; now exists (0,x).
  - left; now exists (S x, n).
Defined.

Fixpoint Σ n := match n with 0 => 0 | S x => n + Σ x end.

Definition code '(x,y) := Σ(x+y)+y.

Lemma code_next : forall p, code(next p) = S(code p).
Proof.
  intros [[|x] y]; cbn.
  - rewrite <-!plus_n_O, Nat.add_comm. auto.
  - rewrite !Nat.add_succ_r. cbn. auto.
Qed.

Lemma inv_dc : inv decode code.
Proof.
  unfold inv.
  apply (size_rect code). intros p rec.
  destruct (zero_or_next p) as [[? ->] | ->].
  - rewrite code_next. cbn. f_equal. apply rec.
    rewrite code_next; auto.
  - reflexivity.
Qed.

Fact inv_cd : inv code decode.
Proof.
  intros ?. apply inj_decode. now rewrite inv_dc.
Qed.

Corollary Bij_Nat_NatNat : bijection nat (nat * nat).
Proof.
  exists decode, code. split. apply inv_cd. apply inv_dc.
Qed.

Fact bound x y n : code (x, y) = n -> y < S n.
Proof. cbn. lia. Qed.

Section Cantor.


Require Import Setoid.
(*  Logique intuitionniste *)

Section LJ.
 Variables P Q R S T : Prop.
 (*  Tactiques pour la conjonction

    Introduction : pour prouver A /\ B : split (il faudra prouver A, puis B)
    Elimination : destruct H, si H : A /\ B
                  variante : destruct H as [H1 H2].
        Dans les deux cas, on récupère deux hypothèses pour A et B (et on
        choisit leurs noms, pour la variante "as..")
  *)
 Lemma and_comm : P /\ Q -> Q /\ P.
 Proof.
   intro H.
   destruct H as [H0 H1]. (* /\e *)
   (* " split /\i " *)
   split;assumption. (* "assumption" résout les deux sous-buts *)
 Qed.

 (* tactiques pour la disjonction
    Introduction:
     pour prouver A \/ B a partir de A : left
     pour prouver A \/ B a partir de B : right

    Elimination:
     preuve par cas : destruct H, si H: A \/ B
                      variante : destruct H as [H1 | H2]
        On aura a faire deux preuves, une pour chaque cas (cas A, cas B)
  *)

  Lemma or_not : P \/ Q -> ~P -> Q.
  Proof.
   intros H H0.
   destruct H.
   - exfalso.
     apply H0; assumption.
     (* alternative:
     assert (f:False).
     {
       apply H0; trivial.
     }
     destruct f. *)
     (* "destruct f" sur f:False résoud n'importe quel but *)
   - assumption.
   Qed.

  (* Structuration de la preuve: +,*,+
     utiles quand on a plusieurs sous-preuves non triviales;
     améliorent la lisibilité du script *)

   (*  equivalence logique (<->, iff):
       unfold iff transforme A <-> B en
                             (A -> B) /\ (B -> A).
       donc split, destruct, etc, marchent

       (iff pour "if and only if", le "si et seulement si" en anglais)
    *)

  Lemma iff_comm : (P <-> Q) -> (Q <-> P).
  Proof.
    intro H.
    destruct H.
    split.
    - assumption.
    - assumption.
    (* "assumption" résoud les deux sous-buts engendrés par "split"
    donc on peut remplacer les trois dernières lignes par
    split; assumption.
    *)
  Qed.

  (* la regle de remplacement est implantée en Coq *)
  (* "rewrite H" fait un remplacement uniforme quand H est une
     équivalence *)
  (* "rewrite H" réécrit le but courant avec H *)
  (* "rewrite H in H'" fait la réécriture de H dans une autre hypothèse H' *)
  (* "rewrite <- H" réécrit dans l'autre sens, le membre droit par le gauche *)
  Lemma L1 : (P <-> Q) -> ~(Q <-> ~P).
  Proof.
     intro H.
     rewrite H.
     intro H0.
     destruct H0.
     assert (~Q).
     { intro H2.
       apply H0; assumption.
     }
     apply H2. apply H1. assumption.
  Qed.

  (* Fin des exemples, début des exercices *)

  (* Exercice : remplacer tauto par des vraies preuves
     interactives *)
  (*  Exercices de la feuille 4 *)

  Lemma and_false : P /\ False -> False.
  Proof.
    intro Hpf.
    destruct Hpf.
    assumption.
  Qed.

  Lemma and_assoc : (P /\ Q) /\ R <-> P /\ (Q /\ R).
  Proof.
    split.
    - intros.
      destruct H as [Hpq Hr].
      destruct Hpq as [Hp Hq].
      split.
      assumption.
      split;assumption.
    - intros.
      destruct H as [Hp Hqr].
      destruct Hqr as [Hq Hr].
      split.
      split;assumption.
      assumption.
  Qed.

  (* Ex. 2 *)
  Lemma or_to_imp: ~ P \/ Q -> P -> Q.
  Proof.
    intros.
    destruct H.
    absurd (P);assumption.
    assumption.
  Qed.

  Lemma not_or_and_not: ~(P\/Q) -> ~P /\ ~Q.
  Proof.
    intros.
    split .
    (* but ~P *)
    - intro.
      apply H.
      left;assumption.
    (* but ~Q *)
    - intro.
      apply H.
      right;assumption.
  Qed.

  (* Exercice 4 *)

  Lemma absorption_or: P \/ False <-> P.
  Proof.
    split.
    - intro.
      destruct H.
      + assumption.
      + exfalso.
        assumption.
    - intro.
      left;assumption.
  Qed.

  Lemma and_or_dist : P /\ (Q \/ R) <-> P /\ Q \/ P /\ R.
  Proof.
    split.
    - intros.
      destruct H as [Hp Hqr].
      destruct Hqr.
      (* avec Q  *)
      + left.
        split;assumption.
      (* avec R *)
      + right.
        split;assumption.
    - intros.
      destruct H .
      (* avec p /\ Q *)
      + destruct H .
        split.
        * assumption.
        * left.
          assumption.
       (* avec P/\R  *)
      + destruct H.
        split.
        * assumption.
        * right.
          assumption.
  Qed.

  Lemma or_and_dist : P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
  Proof.
    split.
    - intros.
      destruct H.
      split.
      (* avec P  *)
       left;assumption.
       left; assumption.
      (* avec (Q /\ R) *)
       destruct H.
       split.
       right;assumption.
       right;assumption.
    - intros.
      destruct H.
      destruct H.
      + left;assumption.
      + destruct H0.
        * left ; assumption .
        * right .
        split;assumption.
  Qed.

  Lemma and_not_not_impl: P /\ ~ Q -> ~(P -> Q).
  Proof.
    intros.
    intro.
    destruct H.
    apply H1.
    apply H0;assumption.
  Qed.

  Lemma de_morgan1 : ~ (P \/ Q) <-> ~P /\ ~Q.
  Proof.
    split.
    (* not_or_and_not *)
    - auto.
    - intros.
      intro.
      destruct H.
      destruct H0.
      absurd (P);assumption.
      absurd Q ;assumption .
  Qed.

  Lemma reductio_ad_absurdum: (P -> ~P) -> ~P.
  Proof.
    intro.
    intro.
    absurd P .
    - apply H ; assumption .
    - assumption.
  Qed.

  Lemma np_p_nnp: (~P -> P) -> ~~P.
  Proof.
    intro.
    intro.
    absurd P .
    - assumption.
    - apply H.
      assumption.
  Qed.

  (* Exercice: reprendre toutes les preuves précédentes,
     en simplifiant et clarifiant les scripts:
     - structurer les sous-preuves avec +/-/*
     - inversement, quand c'est possible, factoriser avec
       l'enchainement de tactiques (par ";")

     Le but est de faire que le script soit plus facile à lire
     par un humain, pas pour la machine.
   *)

End LJ.


Require Import String.
Require Import ZArith.

Set Implicit Arguments.

Open Scope string.
Open Scope Z.

Require Import imp.

(* Defining a pure subset of expressions,
   extented to allow functions from the logic *)
Inductive exp :=
  | var : string -> exp
  | con : Z -> exp
  | plus : exp -> exp -> exp
  | app : (Z -> Z) -> exp -> exp
  .
Inductive bexp :=
  | bcon : bool -> bexp
  | le : exp -> exp -> bexp
  | eql : exp -> exp -> bexp
  | not : bexp -> bexp
  | and : bexp -> bexp -> bexp
  .
Fixpoint eval_e env e :=
  match e with
    | var v => env v
    | con z => z
    | plus e1 e2 => eval_e env e1 + eval_e env e2
    | app f e => f (eval_e env e)
  end.
Fixpoint eval_b env e :=
  match e with
    | bcon b => b
    | le e1 e2 => Z.leb (eval_e env e1) (eval_e env e2)
    | eql e1 e2 => Z.eqb (eval_e env e1) (eval_e env e2)
    | not b => negb (eval_b env b)
    | and b1 b2 => if eval_b env b1 then eval_b env b2 else false
  end.

(* pure boolean expressions are currently re-used as formulas.
   Supporting quantifiers probably requires distinguishing the types *)
Definition formula := bexp.
Definition holds f env := eval_b env f = true.

(* Identification and extraction of pure from general
   expressions is done with partial functions *)
Definition lift {A B} (f : A -> B) (oa : option A) : option B :=
  match oa with
    | Some a => Some (f a)
    | None => None
  end.
Arguments lift _ _ f !oa.
Definition lift2 {A B C} (f : A -> B -> C) (oa : option A) (ob : option B) : option C :=
  match oa with
    | Some a => lift (f a) ob
    | _ => None
  end.
Fixpoint is_pure_e (e : imp.exp) : option exp :=
  match e with
    | imp.var x => Some (var x)
    | imp.con z => Some (con z)
    | imp.plus e1 e2 => lift2 plus (is_pure_e e1) (is_pure_e e2)
    | _ => None
  end.
Fixpoint is_pure_b (b : imp.bexp) : option bexp :=
  match b with
    | imp.bcon b => Some (bcon b)
    | imp.le e1 e2 => lift2 le (is_pure_e e1) (is_pure_e e2)
    | imp.eql e1 e2 => lift2 eql (is_pure_e e1) (is_pure_e e2)
    | imp.not e => lift not (is_pure_b e)
    | imp.and e1 e2 => lift2 and (is_pure_b e1) (is_pure_b e2)
  end.

(* Defining the semantic notion of satisfaction of a triple,
   and the proof system *)
Definition valid (P : formula) (s : stmt) (Q : formula) : Prop :=
  forall env, holds P env -> forall n env', trc step_s n (s,env) (skip,env') -> holds Q env'.

Definition impl P Q := forall env, holds P env -> holds Q env.

Fixpoint subst_e x r e :=
  match e with
    | var x' => if string_dec x x' then r else e
    | con _ => e
    | plus e1 e2 => plus (subst_e x r e1) (subst_e x r e2)
    | app f e => app f (subst_e x r e)
  end.
Fixpoint subst x r b :=
  match b with
    | bcon _ => b
    | le e1 e2 => le (subst_e x r e1) (subst_e x r e2)
    | eql e1 e2 => eql (subst_e x r e1) (subst_e x r e2)
    | not b1 => not (subst x r b1)
    | and b1 b2 => and (subst x r b1) (subst x r b2)
  end.

Inductive proof : formula -> stmt -> formula -> Set :=
  | p_conseq_l : forall P P' Q s, proof P' s Q -> impl P P' -> proof P s Q
  | p_conseq_r : forall P Q Q' s, proof P s Q' -> impl Q' Q -> proof P s Q
  | p_assign : forall Q x e0 e, is_pure_e e0 = Some e -> proof (subst x e Q) (assign x e0) Q
  | p_skip : forall Q, proof Q skip Q
  | p_seq : forall P Q R s1 s2, proof P s1 Q -> proof Q s2 R -> proof P (seq s1 s2) R
  | p_cond : forall P b0 b s1 s2 Q, is_pure_b b0 = Some b ->
          proof (and P b) s1 Q -> proof (and P (not b)) s2 Q ->
                 proof P (cond b0 s1 s2) Q
  | p_while : forall P b0 b s, is_pure_b b0 = Some b ->
     proof (and P b) s P -> proof P (while b0 s) (and P (not b))
  .

(* Proving soundness requires various lemmas.
   Relating small-step execution of pure expresions to
   the evaluation functions takes much of the effort.
 *)

(* relating "set" and substitution *)
Lemma eval_e_subst : forall x r e env, eval_e env (subst_e x r e) = eval_e (set env x (eval_e env r)) e.
Proof. induction e;simpl;[unfold set;destruct (string_dec x s);simpl|..];congruence. Qed.

Lemma eval_subst : forall x r env e, eval_b env (subst x r e) = eval_b (set env x (eval_e env r)) e.
Proof.
induction e;simpl;rewrite ?eval_e_subst;try congruence.
rewrite IHe1, IHe2; reflexivity.
Qed.

Definition pure_pres {E Epure : Set} (is_pure : E -> option Epure)
                     {Res : Set} (eval : Env -> Epure -> Res) e e1 :=
  match is_pure (fst e) with
    | Some e' => snd e1 = snd e /\
        match is_pure (fst e1) with
          | Some e1' => eval (snd e) e1' = eval (snd e) e'
          | None => False
        end
    | None => True
  end.

Lemma pure_pres_refl : forall {E Ep} is {R} eval a, @pure_pres E Ep is R eval a a.
Proof. intros;unfold pure_pres. destruct (is (fst a));split;reflexivity. Qed.
Lemma pure_pres_trans : forall {E Ep} is {R} eval a b c,
   @pure_pres E Ep is R eval a b -> pure_pres is eval b c -> pure_pres is eval a c.
Proof. unfold pure_pres;intros.
  destruct (is (fst a));[destruct H|trivial].
  destruct (is (fst b));[destruct H0|destruct H1].
  split;[|destruct (is (fst c))];congruence.
Qed.

Lemma pure_pres_trc : forall {E Ep} is {R} eval n a b,
  trc (@pure_pres E Ep is R eval) n a b -> pure_pres is eval a b.
Proof. induction 1;subst;eauto using pure_pres_trans,pure_pres_refl. Qed.

Ltac pure_pres_tac := repeat match goal with
| [H : match is_pure_e ?x with _ => _ end |- _] => destruct (is_pure_e x);simpl;[|destruct H;exact I]
| [H : match is_pure_b ?x with _ => _ end |- _] => destruct (is_pure_b x);simpl;[|destruct H;exact I]
| [H : True |- _] => clear H
| [H : False |- _] => destruct H
| [H : _ /\ _ |- _] => destruct H
end;try (split;congruence).

Lemma eval_e_step : forall a b, step_e a b -> pure_pres is_pure_e eval_e a b.
Proof.
induction 1;unfold pure_pres in * |- *;simpl in * |- *;pure_pres_tac.
destruct (is_pure_e b);simpl;split;congruence.
Qed.

Lemma eval_e_result : forall e v n env env', trc step_e n (e, env) (imp.con v, env') ->
  forall e', is_pure_e e = Some e' -> env' = env /\ v = eval_e env e'.
Proof.
intros. apply (map_trc eval_e_step) in H. apply pure_pres_trc in H.
unfold pure_pres in H;simpl in H;rewrite H0 in H. assumption.
Qed.

Lemma eval_b_step : forall a b, step_b a b -> pure_pres is_pure_b eval_b a b.
Proof.
induction 1;repeat match goal with [H : step_e _ _ |- _] => apply eval_e_step in H end;
unfold pure_pres in * |- *;simpl in * |- *;pure_pres_tac;
match goal with [|- match lift _ ?x with _ => _ end] =>
  destruct x eqn:?;simpl;pure_pres_tac
end.
destruct b;[rewrite Heqo|];split;reflexivity.
rewrite H1;split;congruence.
Qed.

Lemma eval_b_result : forall e v n env env', trc step_b n (e, env) (imp.bcon v, env') ->
  forall e', is_pure_b e = Some e' -> env' = env /\ v = eval_b env e'.
Proof.
intros. apply (map_trc eval_b_step) in H. apply pure_pres_trc in H.
unfold pure_pres in H;simpl in H;rewrite H0 in H. assumption.
Qed.

(* tactics for working with option *)
Ltac option_lift_cleanup := repeat match goal with
| [H : lift ?f ?e = Some ?v |- _] => is_var v;
  destruct e eqn:?;[|discriminate H];injection H;clear H;intro;subst v
| [H : Some ?e = Some ?v |- _] => is_var v;
  injection H;clear H;intro;subst v
| [H : None = Some _ |- _] => discriminate H
| [H : lift2 ?f ?e1 ?e2 = Some ?v |- _] => is_var v;
  destruct e1 eqn:?;[simpl in H|discriminate H]
| [H : forall x, Some _ = Some x -> _ |- _] => specialize (H _ (eq_refl _))
| [H : forall x, ?e = Some x -> _, H2 : ?e = Some _ |- _] => specialize (H _ H2)
| [H : _ /\ _ |- _] => destruct H
| [H : exists _, _ |- _] => destruct H
end.

(* Tactics for induction over trc of step -
   The built-in induction tactics do not usually give useful induction hypotheses
   if indices of a dependent type have structure, like "step_e (a,b) (c,d)".
   This case should work because every pair has that form, and we help it along by
   abstracting a given pair to a single variable.
 *)
Ltac prep_trc :=
  match goal with [H : trc _ _ ?P ?Q |- _] =>
  remember P as p eqn:Heqp; remember Q as q eqn:Heqq; move Heqq at top; move Heqp at top; move H at top
  end.
Ltac trc_ind := intros;prep_trc;let rec reverts := match goal with [H : _ |- _] =>
  match type of H with trc _ _ _ _ => induction H | _ => revert H;reverts end end
in reverts.

Lemma assign_dec : forall x e n env env', trc step_s n (assign x e, env) (skip, env') ->
  exists v k env'', trc step_e k (e, env) (imp.con v, env'') /\ (k < n)%nat /\ set env'' x v = env'.
Proof.
trc_ind;intros;subst;[congruence| ].
inversion H;subst. (* splitting on how assign x e took a step *)
  (* at last step *)
  clear IHtrc. inversion H0;subst;[ | inversion H1]. injection H1.
  repeat eexists;eauto using done.
  (* stepping in e. *)
  specialize (IHtrc _ _ _ (eq_refl _) _ (eq_refl _)).
  destruct IHtrc as (v & k & env''& [? []]). exists v, (S k), env''.
  intuition. eapply step;eassumption.
Qed.

Lemma seq_dec : forall s1 s2 n env env', trc step_s n (seq s1 s2, env) (skip, env') ->
  exists env'' k1 k2, trc step_s k1 (s1, env) (skip, env'') /\ trc step_s k2 (s2, env'') (skip, env')
    /\ (k1 + k2 < n)%nat.
Proof.
trc_ind;intros;subst.
congruence.
inversion H;subst.
  (* was finished *)
  clear IHtrc;repeat eexists;eauto using done with arith.
  (* evaluating statement 1 *)
  specialize (IHtrc _ _ _ (eq_refl _) _ (eq_refl _)).
  decompose record IHtrc;clear IHtrc.
  repeat eexists;eauto using step with arith.
Qed.

Lemma cond_dec : forall c s1 s2 n env env', trc step_s n (cond c s1 s2, env) (skip, env') ->
  exists b env'' k1 k2, trc step_b k1 (c, env) (imp.bcon b, env'') /\
       trc step_s k2 (if b then s1 else s2, env'') (skip, env') /\
       (k1 + k2 < n)%nat.
Proof.
trc_ind;intros;subst;[congruence| ].
inversion H; clear H; subst.
  (* was finished *)
  repeat eexists;eauto using done with arith.
  (* evaluating in condition *)
  specialize (IHtrc _ _ _ _ (eq_refl _) _ (eq_refl _)).
  decompose record IHtrc;clear IHtrc.
  repeat eexists;eauto using step with arith.
Qed.

Inductive while_trace b s env : Env -> Prop :=
 | while_done : eval_b env b = false -> forall env', env' = env -> while_trace b s env env'
 | while_step : eval_b env b = true ->
     forall n env', trc step_s n (s, env) (skip, env') ->
     forall env'', while_trace b s env' env'' ->
        while_trace b s env env''
 .

Lemma while_dec : forall n b s env env', trc step_s n (while b s, env) (skip, env') ->
  forall b', is_pure_b b = Some b' -> while_trace b' s env env'.
Proof.
intro n. pattern n. apply (well_founded_induction lt_wf). clear n.
intros.
match goal with [H : trc _ _ _ _  |- _] => inversion H;clear H;subst end. congruence.
match goal with [H : step_s _ _  |- _] => inversion H;clear H;subst end.
match goal with [H : _ |- _] => apply cond_dec in H;decompose record H;clear H end.
match goal with [H : _ |- _] => eapply eval_b_result in H;[|eassumption];destruct H;subst end.
destruct (eval_b env b') eqn:?.
(* loop condition evaluated to true, take a step *)
apply seq_dec in H2;decompose record H2;clear H2.
  eapply while_step, H;try eassumption. omega.
(* false, finish now *)
apply while_done. assumption.
inversion H2;[|solve[inversion H0]];congruence.
Qed.

Lemma sound : forall P s Q, proof P s Q -> valid P s Q.
induction 1;unfold valid in * |- *;simpl;intros.
(* conseq l *)
eauto.
(* conseq r *)
eauto.
(* assign *)
apply assign_dec in H0;decompose record H0;clear H0.
eapply eval_e_result in H2;[|eassumption]. destruct H2. subst.
unfold holds. rewrite <- eval_subst. assumption.
(* skip *)
inversion H0;subst. congruence. inversion H1.
(* seq *)
specialize (IHproof1 _ H1); clear H1.
apply seq_dec in H2. decompose record H2;clear H2.
  specialize (IHproof1 _ _ H3). specialize (IHproof2 _ IHproof1 _ _ H1). assumption.
(* cond *)
apply cond_dec in H2;decompose record H2;clear H2.
eapply eval_b_result in H3;[|eassumption];destruct H3;subst.
revert H4. destruct (eval_b env b) eqn:?;[apply IHproof1|apply IHproof2];
unfold holds;simpl;rewrite H1, Heqb1;reflexivity.
(* while *)
eapply while_dec in H1;[|eassumption]. induction H1.
subst env'. unfold holds. simpl. rewrite H1, H0. reflexivity.
apply IHproof in H2. auto. unfold holds. simpl. rewrite H0. assumption.
Qed.

Require Import example.

Definition zero_loop_pf : proof (le (con 0) (var "x"))
                                zero_loop
           (and (le (con 0) (var "x")) (le (var "x") (con 0))).
eapply p_conseq_r.
eapply p_while. reflexivity.
eapply p_conseq_l.
eapply p_assign. reflexivity.
Ltac pre_impl := let env := fresh "env" in intro env; unfold holds; simpl;
  repeat match goal with [|- context[env ?v]] => generalize (env v);intro end;clear env.
pre_impl. destruct (Z.leb_spec 0 z);[|discriminate]. rewrite ?Z.leb_le. auto with zarith.
pre_impl. destruct (Z.leb_spec 0 z);[|discriminate]. rewrite Bool.negb_true_iff, ?Z.leb_le, ?Z.leb_gt.
  auto with zarith.
Defined.

Lemma zero_loop : valid (le (con 0) (var "x")) (while (imp.le (imp.con 1) (imp.var "x"))
                                          (assign "x" (imp.plus (imp.var "x") (imp.con (-1)))))
           (and (le (con 0) (var "x")) (le (var "x") (con 0))).
Proof. exact (sound zero_loop_pf). Qed.

Section sum_code.
Import imp.
Local Coercion con : Z >-> exp.
Local Coercion var : string >-> exp.

Definition sum_loop' : stmt :=
  seq (while (not (eql "n" 0)) (seq (assign "n" (plus "n" (-1)))
                                    (assign "s" (plus "s" "n"))))
      (assign "n" (plus "n" (-1))).
End sum_code.

Lemma bool_if : forall (a b c d : bool),
  ((if a then b else c) = d) <-> (a = true /\ b = d) \/ (a = false /\ c = d).
Proof. destruct a;intuition congruence. Qed.

Lemma diff_false_true_iff : false = true <-> False.
Proof. pose proof Bool.diff_true_false. intuition. Qed.
Lemma and_false : forall P, (P /\ False) <-> False.
Proof. tauto. Qed.
Lemma or_false : forall P, (P \/ False) <-> P.
Proof. tauto. Qed.

Local Coercion con : Z >-> exp.
Local Coercion var : string >-> exp.

Definition sum_pf : proof (and (le 0 "n") (eql (plus "s" (app sum_to (plus "n" (-1))))
                                               (plus "S" (app sum_to "N"))))
                          sum_loop'
                          (eql (var "s") (plus (var "S") (app sum_to (var "N")))).
Proof.
eapply p_seq;[|eapply p_assign;reflexivity].
eapply p_conseq_r.
eapply p_while;[reflexivity|].
eapply p_seq;[|eapply p_assign;reflexivity];eapply p_conseq_l;[eapply p_assign;reflexivity|].

simpl. pre_impl.
rewrite ?bool_if, ?Bool.negb_true_iff, ?Bool.negb_false_iff, ?diff_false_true_iff,
  ?and_false, ?or_false,
  ?Z.eqb_eq, ?Z.eqb_neq, ?Z.leb_le, ?Z.leb_gt.
  intuition.  rewrite <- H2;clear H2.
rewrite (sum_to_equation (z + -1)).
destruct (Z.ltb_spec (z + -1) 0);[exfalso|];auto with zarith.

simpl. pre_impl.
rewrite ?bool_if, ?Bool.negb_true_iff, ?Bool.negb_false_iff, ?diff_false_true_iff,
  ?and_false, ?or_false,
  ?Z.eqb_eq, ?Z.eqb_neq, ?Z.leb_le, ?Z.leb_gt.
  intuition.  rewrite <- H2;clear H2.
subst. rewrite sum_to_equation. simpl. auto with zarith.
Qed.


Require Import Ensembles.
Require Import Coq.Setoids.Setoid.

Variable U : Type.

Theorem distri_and_over_or : forall p q r : Prop, (p /\ (q \/ r)) <-> ((p /\ q) \/ (p /\ r)).

Proof.
intros.
split.
intro.
destruct H as (H0,H1).
destruct H1 as [H3|H3].
left.
split.
assumption.
assumption.
right.
split.
assumption.
assumption.

intro.
destruct H as [H4|H4].
split.
destruct H4 as (H5,H6).
assumption.
left.
destruct H4 as (H5,H6).
assumption.

split.
destruct H4 as (H5,H6).
assumption.
right.
destruct H4 as (H5,H6).
assumption.
Qed.

Theorem IntersectionToAnd : forall A B : Ensemble U, forall x : U,
   In U (Intersection U A B) x <-> (In U A x) /\ (In U B x).
Proof.
intros.
split.
intro.
destruct H.
split.
assumption.
assumption.
intro.
destruct H.
split.
assumption.
assumption.
Qed.

Theorem UnionToOr : forall A B : Ensemble U, forall x : U,
   In U (Union U A B) x <-> (In U A x) \/ (In U B x).

Proof.
intros.
split.
intro.
destruct H.
left.
assumption.
right.
assumption.
intro.
destruct H.
left.
assumption.
right.
assumption.
Qed.

Theorem SetDistri : forall A B C : Ensemble U,
             Intersection U A (Union U B C) =
             Union U (Intersection U A B) (Intersection U A C).
Proof.
intros.
apply Extensionality_Ensembles.

split.

intro. intro.
destruct H.
destruct H0.
left.
split.
assumption.
assumption.

apply UnionToOr.
right.
apply IntersectionToAnd.
split.
assumption.
assumption.

split.
apply UnionToOr in H.
destruct H.
destruct H.
assumption.
destruct H.
assumption.

destruct H.
destruct H.
left.
assumption.
destruct H.
right.
assumption.

Qed.

Variable A : Ensemble U.
Variable B : nat -> (Ensemble U).

Fixpoint unionB (n : nat) : Ensemble U :=
  match n with
  | 0   => B 0
  | S m => Union U (unionB m) (B (S m))
  end.

Fixpoint intersectionAB (n : nat) : Ensemble U :=
  match n with
  | 0   => Intersection U A (B 0)
  | S m => Union U (intersectionAB m) (Intersection U A (B (S m)))
  end.

Theorem generalizedSetDistri :
        forall n : nat, intersectionAB n = Intersection U A (unionB n).
Proof.

intro.
apply Extensionality_Ensembles.
induction n.

split.
split.
destruct H.
assumption.
destruct H.
apply H0.

split.
destruct H.
assumption.
destruct H.
apply H0.

split.
split.
destruct H.
apply IHn in H.
destruct H.
assumption.
destruct H.
assumption.
destruct H.
apply IHn in H.
destruct H.
left.
assumption.
destruct H.
right.
assumption.

intro.
intro.
right.
constructor 1.
destruct H.
assumption.
destruct H.
destruct H0.

(* alt attempt *)
intro.
intro.
left.

apply IHn.
split.
destruct H.
assumption.
destruct H.
destruct H0.
assumption.

(*alt attempt*)
(* to be completed *)

Qed.


From LF Require Export Basics.

(* Proof by Induction *)

Theorem plus_n_O : forall n : nat, n = n + 0.
Proof.
  intros n. induction n as [|n' IHn'].
  - reflexivity.
  - simpl. rewrite <- IHn'. reflexivity.
Qed.

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  intros n. induction n as [| n' IHn' ].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem mult_0_r : forall n, n * 0 = 0.
Proof.
  induction n as [| n' IHn' ].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.
Qed.

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

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

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p.
  induction n as [|n' IHn'].
  - rewrite plus_O_n. simpl. reflexivity.
  - simpl. rewrite IHn'. reflexivity.
Qed.

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

Lemma double_plus : forall n, double n = n + n.
Proof.
  induction n as [|n' IHn'].
  - reflexivity.
  - simpl. rewrite IHn'. rewrite <- plus_n_Sm. reflexivity.
Qed.

Theorem evenb_S : forall n : nat,
  evenb (S n) = negb (evenb n).
Proof.
  induction n as [|n' IHn'].
  - reflexivity.
  - rewrite -> IHn'. rewrite -> negation_fn_applied_twice.
    + simpl. reflexivity.
    + reflexivity.
Qed.

(* Proofs within Proofs *)