Module Four.

Inductive Day_of_the_Week : Set :=
Monday | Tuesday | Wednesday
| Thursday | Friday
| Saturday | Sunday.

Inductive Month_of_the_Year : Set :=
January | February | March
| April | May | June
| July | August | September
| October | November | December.

Definition Day_after (d : Day_of_the_Week) :=
    match d
    with Monday => Tuesday
    | Tuesday => Wednesday
    | Wednesday => Thursday
    | Thursday => Friday
    | Friday => Saturday
    | Saturday => Sunday
    | Sunday => Monday
    end.

Fail Definition Day_before (d : Day_of_the_Week) :=
    match d
    with Monday => Sunday
    | Tuesday => Monday
    | Wednesday => Tuesday
    | Thursday => Wednesday
    | Saturday => Friday
    | Sunday => Saturday
    end.

(* The command has indeed failed with message:
   Non exhaustive pattern-matching: no clause found for pattern
   Friday *)

Definition Day_before (d : Day_of_the_Week) :=
    match d
    with Monday => Sunday
    | Tuesday => Monday
    | Wednesday => Tuesday
    | Thursday => Wednesday
    | Friday => Thursday
    | Saturday => Friday
    | Sunday => Saturday
    end.

Theorem Two_days_after :
    eq (Wednesday) (Day_after (Day_after (Monday))).
Proof.
    assert (P1 := eq_refl : eq (Tuesday) (Day_after (Monday))).
    assert (P2 := eq_refl : eq (Wednesday) (Day_after (Tuesday))).
    rewrite P1 in P2.
    exact P2.
Qed.

Theorem Two_days_after_2 :
    eq (Wednesday) (Day_after (Day_after (Monday))).
Proof.
    assert (P2 := eq_refl : eq (Wednesday) (Day_after (Day_after (Monday)))).
    exact P2.
Qed.

Theorem Two_days_after_3 :
    eq (Wednesday) (Day_after (Day_after (Monday))).
Proof.
    exact (eq_refl : eq (Wednesday) (Day_after (Day_after (Monday)))).
Qed.

Theorem After_inverse_of_before
    (d : Day_of_the_Week)
    : Day_after (Day_before d) = d.
Proof.
    assert (D_A_D_B_Monday := eq_refl : eq (Day_after (Day_before (Monday))) (Monday)).
    assert (D_A_D_B_Tuesday := eq_refl : eq (Day_after (Day_before (Tuesday))) (Tuesday)).
    assert (D_A_D_B_Wednesday := eq_refl : eq (Day_after (Day_before (Wednesday))) (Wednesday)).
    assert (D_A_D_B_Thursday := eq_refl : eq (Day_after (Day_before (Thursday))) (Thursday)).
    assert (D_A_D_B_Friday := eq_refl : eq (Day_after (Day_before (Friday))) (Friday)).
    assert (D_A_D_B_Saturday := eq_refl : eq (Day_after (Day_before (Saturday))) (Saturday)).
    assert (D_A_D_B_Sunday := eq_refl : eq (Day_after (Day_before (Sunday))) (Sunday)).
    destruct d.
    { exact D_A_D_B_Monday. }
    { exact D_A_D_B_Tuesday. }
    { exact D_A_D_B_Wednesday. }
    { exact D_A_D_B_Thursday. }
    { exact D_A_D_B_Friday. }
    { exact D_A_D_B_Saturday. }
    { exact D_A_D_B_Sunday. }
Qed.

Theorem Day_must_be_MTWTFSS :
forall d : Day_of_the_Week,
or (eq d Monday) (or (eq d Tuesday)
(or (eq d Wednesday) (or (eq d Thursday)
(or (eq d Friday) (or (eq d Saturday)
(eq d Sunday)))))).

Proof.

intro d.

destruct d.

assert (A1 := eq_refl : eq Monday Monday).

assert (A2 := or_introl A1 : or
 (eq Monday Monday)
 (or (eq Monday Tuesday)
 (or (eq Monday Wednesday)
 (or (eq Monday Thursday)
 (or (eq Monday Friday)
 (or (eq Monday Saturday)
 (eq Monday Sunday))))))).

exact A2.

assert (B1 := eq_refl : eq Tuesday Tuesday).

assert (B2 := or_introl B1 : or
  (eq Tuesday Tuesday)
  (or (eq Tuesday Wednesday)
  (or (eq Tuesday Thursday)
  (or (eq Tuesday Friday)
  (or (eq Tuesday Saturday)
  (eq Tuesday Sunday)))))).

assert (B3 := or_intror B2 : or
  (eq Tuesday Monday)
  (or (eq Tuesday Tuesday)
  (or (eq Tuesday Wednesday)
  (or (eq Tuesday Thursday)
  (or (eq Tuesday Friday)
  (or (eq Tuesday Saturday)
  (eq Tuesday Sunday))))))).

exact B3.

assert (C1 := eq_refl : eq Wednesday Wednesday).

assert (C2 := or_introl C1 :
  or (eq Wednesday Wednesday)
  (or (eq Wednesday Thursday)
  (or (eq Wednesday Friday)
  (or (eq Wednesday Saturday)
  (eq Wednesday Sunday))))).

assert (C3 := or_intror C2 :
  or (eq Wednesday Tuesday)
  (or (eq Wednesday Wednesday)
  (or (eq Wednesday Thursday)
  (or (eq Wednesday Friday)
  (or (eq Wednesday Saturday)
  (eq Wednesday Sunday)))))).

assert (C4 := or_intror C3 :
  or (eq Wednesday Monday)
  (or (eq Wednesday Tuesday)
  (or (eq Wednesday Wednesday)
  (or (eq Wednesday Thursday)
  (or (eq Wednesday Friday)
  (or (eq Wednesday Saturday)
  (eq Wednesday Sunday))))))).

exact C4.

assert (D1 := eq_refl : eq Thursday Thursday).

assert (D2 := or_introl D1 :
  or (eq Thursday Thursday)
  (or (eq Thursday Friday)
  (or (eq Thursday Saturday)
  (eq Thursday Sunday)))).

assert (D3 := or_intror D2 :
  or (eq Thursday Wednesday)
  (or (eq Thursday Thursday)
  (or (eq Thursday Friday)
  (or (eq Thursday Saturday)
  (eq Thursday Sunday))))).

assert (D4 := or_intror D3 :
  or (eq Thursday Tuesday)
  (or (eq Thursday Wednesday)
  (or (eq Thursday Thursday)
  (or (eq Thursday Friday)
  (or (eq Thursday Saturday)
  (eq Thursday Sunday)))))).

assert (D5 := or_intror D4 :
  or (eq Thursday Monday)
  (or (eq Thursday Tuesday)
  (or (eq Thursday Wednesday)
  (or (eq Thursday Thursday)
  (or (eq Thursday Friday)
  (or (eq Thursday Saturday)
  (eq Thursday Sunday))))))).

exact D5.

assert (E1 := eq_refl : eq Friday Friday).

assert (E2 := or_introl E1 :
  or (eq Friday Friday)
  (or (eq Friday Saturday)
  (eq Friday Sunday))).

assert (E3 := or_intror E2 :
  or (eq Friday Thursday)
  (or (eq Friday Friday)
  (or (eq Friday Saturday)
  (eq Friday Sunday)))).

assert (E4 := or_intror E3 :
  or (eq Friday Wednesday)
  (or (eq Friday Thursday)
  (or (eq Friday Friday)
  (or (eq Friday Saturday)
  (eq Friday Sunday))))).

assert (E5 := or_intror E4 :
  or (eq Friday Tuesday)
  (or (eq Friday Wednesday)
  (or (eq Friday Thursday)
  (or (eq Friday Friday)
  (or (eq Friday Saturday)
  (eq Friday Sunday)))))).

assert (E6 := or_intror E5 :
  or (eq Friday Monday)
  (or (eq Friday Tuesday)
  (or (eq Friday Wednesday)
  (or (eq Friday Thursday)
  (or (eq Friday Friday)
  (or (eq Friday Saturday)
  (eq Friday Sunday))))))).

exact E6.

assert (F1 := eq_refl : eq Saturday Saturday).

assert (F2 := or_introl F1 :
  or (eq Saturday Saturday)
  (eq Saturday Sunday)).

assert (F3 := or_intror F2 :
  or (eq Saturday Friday)
  (or (eq Saturday Saturday)
  (eq Saturday Sunday))).

assert (F4 := or_intror F3 :
  or (eq Saturday Thursday)
  (or (eq Saturday Friday)
  (or (eq Saturday Saturday)
  (eq Saturday Sunday)))).

assert (F5 := or_intror F4 :
  or (eq Saturday Wednesday)
  (or (eq Saturday Thursday)
  (or (eq Saturday Friday)
  (or (eq Saturday Saturday)
  (eq Saturday Sunday))))).

assert (F6 := or_intror F5 :
  or (eq Saturday Tuesday)
  (or (eq Saturday Wednesday)
  (or (eq Saturday Thursday)
  (or (eq Saturday Friday)
  (or (eq Saturday Saturday)
  (eq Saturday Sunday)))))).

assert (F7 := or_intror F6 :
  or (eq Saturday Monday)
  (or (eq Saturday Tuesday)
  (or (eq Saturday Wednesday)
  (or (eq Saturday Thursday)
  (or (eq Saturday Friday)
  (or (eq Saturday Saturday)
  (eq Saturday Sunday))))))).

exact F7.

assert (G1 := eq_refl : eq Sunday Sunday).

assert (G2 := or_intror G1 :
  or (eq Sunday Saturday)
  (eq Sunday Sunday)).

assert (G3 := or_intror G2 :
  or (eq Sunday Friday)
  (or (eq Sunday Saturday)
  (eq Sunday Sunday))).

assert (G4 := or_intror G3 :
  or (eq Sunday Thursday)
  (or (eq Sunday Friday)
  (or (eq Sunday Saturday)
  (eq Sunday Sunday)))).

assert (G5 := or_intror G4 :
  or (eq Sunday Wednesday)
  (or (eq Sunday Thursday)
  (or (eq Sunday Friday)
  (or (eq Sunday Saturday)
  (eq Sunday Sunday))))).

assert (G6 := or_intror G5 :
  or (eq Sunday Tuesday)
  (or (eq Sunday Wednesday)
  (or (eq Sunday Thursday)
  (or (eq Sunday Friday)
  (or (eq Sunday Saturday)
  (eq Sunday Sunday)))))).

assert (G7 := or_intror G6 :
  or (eq Sunday Monday)
  (or (eq Sunday Tuesday)
  (or (eq Sunday Wednesday)
  (or (eq Sunday Thursday)
  (or (eq Sunday Friday)
  (or (eq Sunday Saturday)
  (eq Sunday Sunday))))))).

exact G7.

Qed.

End Four.


Set Implicit Arguments.

Require Export Coq.Init.Ltac.
Require Export Init.Notations.

(* Truth *)
Inductive True: Prop :=
  | tt: True.

Inductive False: Prop :=.

Notation "⊤" := True.
Notation "⊥" := False.

(* Implication *)
Notation "A → B" := (forall (_: A), B).

(* Negation *)
Definition not (A: Prop) := A → ⊥.

Notation "~ x" := (not x).

(* Conjunction *)
Inductive and (A B: Prop): Prop :=
  | conj: A → B → and A B.

Notation "A ∧ B" := (and A B).

(* Disjunction *)
Inductive or (A B: Prop): Prop :=
  | inl: A → or A B
  | inr: B → or A B.

Notation "A ∨ B" := (or A B).

(* If and Only If *)
Notation "A ↔ B" := ((A → B) ∧ (B → A)).

(* Basic Properties of Logic *)
Section Logic.
  Variable P Q R S : Prop.

  Lemma bot_e: ⊥ → P.
  Proof.
    intros [].
  Qed.

  Lemma explo_: Q → ~Q → P.
  Proof.
    intros P1 P2.
    apply bot_e.
    apply (P2 P1).
  Qed.

  Lemma and_i: P → Q → P ∧ Q.
  Proof.
    intros P1 P2.
    apply (conj P1 P2).
  Qed.

  Lemma and_el: P ∧ Q → P.
  Proof.
    intros [P1 _].
    apply P1.
  Qed.

  Lemma and_er: P ∧ Q → Q.
  Proof.
    intros [_ P1].
    apply P1.
  Qed.

  Lemma and_s: P ∧ Q → Q ∧ P.
  Proof.
    intros [P1 P2].
    apply (conj P2 P1).
  Qed.

  Lemma and_t: P ∧ Q → Q ∧ R → P ∧ R.
  Proof.
    intros [P1 _] [_ P2].
    apply (conj P1 P2).
  Qed.

  Lemma and_reorder: P ∧ Q → R ∧ S → P ∧ R.
  Proof.
    intros [P1 _] [P2 _].
    apply (conj P1 P2).
  Qed.

  Lemma or_il: P → P ∨ Q.
  Proof.
    intros P1.
    apply (inl _ P1).
  Qed.

  Lemma or_ir: Q → P ∨ Q.
  Proof.
    intros P1.
    apply (inr _ P1).
  Qed.

  Lemma or_s: P ∨ Q → Q ∨ P.
  Proof.
    intros [P1 | P1].
    + apply (inr _ P1).
    + apply (inl _ P1).
  Qed.

  Lemma imp_r: P → P.
  Proof.
    intros P1.
    apply P1.
  Qed.

  Lemma imp_t: (P → Q) → (Q → R) → P → R.
  Proof.
    intros P1 P2 P3.
    apply (P2 (P1 P3)).
  Qed.

  Lemma imp_i: ~P ∨ Q → (P → Q).
  Proof.
    intros [P1 | P1].
    + intros P2.
      destruct (P1 P2).
    + intros _.
      apply P1.
  Qed.

  (* imp_e in Classical *)

  Lemma iff_r: P ↔ P.
  Proof.
    split.
    + apply imp_r.
    + apply imp_r.
  Qed.

  Lemma iff_s: (P ↔ Q) → (Q ↔ P).
  Proof.
    intros [P1 P2].
    apply (conj P2 P1).
  Qed.

  Lemma iff_t: (P ↔ Q) → (Q ↔ R) → (P ↔ R).
  Proof.
    intros [P1 P2] [P3 P4].
    split.
    + intros P5.
      apply (P3 (P1 P5)).
    + intros P5.
      apply (P2 (P4 P5)).
  Qed.
End Logic.
(*----------------------------------------------------------------------------*)

(* Set *)
Parameter J    : Prop.
Parameter J_in : J → J → Prop.

Notation "x ∈ y" := (J_in x y).
Notation "x ∉ y" := (~(x ∈ y)).

(* Equality *)
Inductive eq: J → J → Prop :=
  | refl: forall x: J, eq x x.

Notation "x = y" := (eq x y).
Notation "x ≠ y" := (~(x = y)).

(* Basic Properties of Equality *)
Section Equality.
  Variable A B C: J.

  Theorem eq_r : A = A.
  Proof.
    apply refl.
  Qed.

  Theorem eq_s : A = B → B = A.
  Proof.
    intros [x].
    apply refl.
  Qed.

  Theorem eq_t : A = B → B = C → A = C.
  Proof.
    intros [_] [x].
    apply refl.
  Qed.

  Theorem eq_cl : forall P : J → Prop, A = B → P A → P B.
  Proof.
    intros P [x] H1.
    apply H1.
  Qed.

  Theorem eq_cr : forall P : J → Prop, A = B → P B → P A.
  Proof.
    intros P [x] H1.
    apply H1.
  Qed.

  Theorem eq_w : forall P : J → J, A = B → P A = P B.
  Proof.
    intros P [x].
    apply refl.
  Qed.

  Lemma neq_s: A ≠ B → B ≠ A.
  Proof.
    intros P1 P2.
    destruct P2.
    apply P1.
    apply refl.
  Qed.
End Equality.
(*----------------------------------------------------------------------------*)

(* Quantifier *)
Inductive ex (P: J → Prop): Prop :=
  | ex_i: forall x: J, P x → ex P.

(*Notation "'exists' x , p" := (ex (fun x => p)) (at level 200, right associativity).*)
Notation "∃   A , P" := (ex (fun A => P)).
Notation "∀   A , P" := (forall A: J, P).
Notation "∀ₚ  A , P" := (forall A: (J → Prop), P).
Notation "∀ₚₚ A , P" := (forall A: (J → J → Prop), P).
Notation "'λ' x , P" := (fun x => P).

Section Exist.
  Variable (P : J → Prop).

  Definition ex_outl (x : ex P) : J :=
    match x with
      | ex_i _ a _ => a
    end.

  Definition ex_outr (x : ex P) : P (ex_outl x) :=
    match x with
      | ex_i _ _ a => a
    end.
End Exist.
(*----------------------------------------------------------------------------*)


Inductive bool : Type :=
  | true
  | false.

Definition negb (b:bool) : bool :=
  match b with
    | true => false
    | false => true
  end.

Example test1_negb : (negb true) = false.
Proof. simpl. reflexivity. Qed.
Example test2_negb : (negb false) = true.
Proof. simpl. reflexivity. Qed.

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

Example test1_andb : (andb true true) = true.
Proof. simpl. reflexivity. Qed.
Example test2_andb : (andb true false) = false.
Proof. simpl. reflexivity. Qed.
Example test3_andb : (andb false true) = false.
Proof. simpl. reflexivity. Qed.
Example test4_andb : (andb false false) = false.
Proof. simpl. reflexivity. Qed.

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

Example test1_orb : (orb true true) = true.
Proof. simpl. reflexivity. Qed.
Example test2_orb : (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test3_orb : (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test4_odb : (orb false false) = false.
Proof. simpl. reflexivity. Qed.

(* Excercise 1, nandb *)
Definition nandb (b1 b2:bool) :=
  match b1 with
    | true => b2
    | false => negb(b2)
  end.

Example test1_nandb: (nandb true true) = true.
Proof. simpl. reflexivity. Qed.
Example test2_nandb: (nandb true false) = false.
Proof. simpl. reflexivity. Qed.
Example test3_nandb: (nandb false true) = false.
Proof. simpl. reflexivity. Qed.
Example test4_nandb: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.

(* Excercise 2, andb3 *)
Definition andb3 (b1 b2 b3:bool) : bool :=
  match b1 with
    | true => andb b2 b3
    | false => false
  end.

Example test1_andb3: (andb3 true true true) = true.
Proof.  reflexivity. Qed.
Example test2_andb3: (andb3 false true true) = false.
Proof. reflexivity. Qed.
Example test3_andb3: (andb3 true false true) = false.
Proof. reflexivity. Qed.
Example test4_andb3: (andb3 true true false) = false.
Proof. reflexivity. Qed.

Notation "x || y" := (orb x y).
Check true || false.

Eval simpl in (pred O).

Definition minustwo (n :nat): nat :=
  match n with
    | O => O
    | S(O) => O
    | S(S(n')) => n'
  end.

Eval simpl in (minustwo 4).

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

Definition oddb (n: nat): bool := negb(evenb n).

Example test_oddb1: (oddb (S O)) = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: (oddb (S (S (S (S 0))))) = false.
Proof. simpl. reflexivity. Qed.

Module playground2.

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

Eval compute in (plus (S (S (S 0))) (S 0)).

Fixpoint minus (n m:nat): nat :=
  match n, m with
    | 0, _ => 0
    | S _, 0 => n
    | S n', S m' => minus n' m'
  end.

Example test_minus1: (minus 4 3) = 1.
Proof. simpl. reflexivity. Qed.
Example test_minus2: (minus 3 3) = 0.
Proof. simpl. reflexivity. Qed.
Example test_minus3: (minus 1 4) = 0.
Proof. simpl. reflexivity. Qed.

Fixpoint mult (n m: nat): nat :=
  match n with
    | O => 0
    | S n' => plus m (mult n' m)
  end.

Example test_mult1: (mult 3 4) = 12.
Proof. simpl. reflexivity. Qed.

End playground2.

Fixpoint exp (base power: nat) :nat :=
  match power with
    | 0 => S(O)
    | S n' => mult base (exp base n')
  end.

Eval simpl in (exp 3 3).

Fixpoint factorial (n :nat) :nat :=
  match n with
    | O => S O
    | S O => S O
    | S m => mult n (factorial m)
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.

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

Example beq_nat1: (beq_nat 3 4) = false.
Proof. reflexivity. Qed.
Example beq_nat2: (beq_nat 3 3) = true.
Proof. reflexivity. Qed.
Example beq_nat3: (beq_nat 0 1) = false.
Proof. reflexivity. Qed.
Example beq_nat4: (beq_nat 0 0) = true.
Proof. reflexivity. Qed.

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

Example ble_nat1: (ble_nat 4 4) = true.
Proof. simpl. reflexivity. Qed.
Example ble_nat2: (ble_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.
Eval simpl in (minus 2 4).
Example ble_nat3: (ble_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.

Definition blt_nat (n m :nat) : bool :=
  match (minus m n) with
    | S n' => true
    | O => false
  end.

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. reflexivity. Qed.

Theorem plus_0_n : forall n:nat, 0 + n = n.
Proof.
  compute. reflexivity. Qed.

Eval simpl in (forall n:nat, n + 0 = n).
Eval simpl in (forall n:nat, 0 + n = n).

(* 2. tjedan *)

Theorem plus_0_n'' : forall n:nat, 0 + n = n.
Proof.
  intros. reflexivity. Qed.

Theorem mult_0_n' : forall n:nat, 0 * n = 0.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_1_n' : forall n:nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_id_example: forall n m:nat,
  n = m -> n + m = m + n.
Proof.
  intros n m H.
  rewrite <- H.
  reflexivity. Qed.

Theorem plus_id_excercise: forall n m o: nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o h1 h2.
  rewrite -> h1.
  rewrite -> h2.
  reflexivity. Qed.

Theorem mult_0_plus: forall n m: nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite <- plus_O_n.
  simpl.
  reflexivity. Qed.

Theorem mult_1_plus: forall n m: nat,
  (1 + n) * m = m + n * m.
Proof.
  intros n m.
  simpl.
  reflexivity. Qed.

Theorem plus_1_neq_0: forall n: nat,
  beq_nat (n + 1) 0 = false.
Proof.
  intros n.
  destruct n.
  reflexivity.
  compute.
  reflexivity. Qed.

Theorem negb_involutive: forall b:bool,
  negb (negb b) = b.
Proof.
  intros b.
  destruct b.
  compute.
  reflexivity.
  reflexivity. Qed.

Theorem zero_nbeq_plus : forall n:nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intros n.
  destruct n as [| n'].
  reflexivity.
  reflexivity. Qed.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1 : forall b c : bool,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity. Qed.

Theorem plus_0_r : forall n:nat, n + 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. reflexivity. Qed.

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  intros n.
  induction n.
  Case "n = 0".
    reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> IHn.
    reflexivity. Qed.

Theorem mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  intros. induction n.
  Case "n = 0".
    reflexivity.
  Case "n = S n".
    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.
  Case "n = 0".
    simpl.
    reflexivity.
  Case "n = S n".
    simpl. rewrite -> IHn. reflexivity. Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m.
  induction n.
  simpl. rewrite -> plus_0_r.
  reflexivity.

  simpl. rewrite -> IHn.
  rewrite -> plus_n_Sm.
  reflexivity. Qed.

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

Lemma double_plus : forall n, double n = n + n .
Proof.
  intros n.
  induction n.
  simpl. reflexivity.
  simpl. rewrite -> IHn.
  rewrite -> plus_n_Sm.
  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'].
  Case "n = 0".
    reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'. reflexivity. Qed.

Theorem beq_nat_refl: forall n: nat,
  true = beq_nat n n .
Proof.
  intro n.
  induction n.
  (* base: n = 0 *)
  reflexivity.
  (* suppose n = S n where true = beq_nat n n *)
  simpl.
  rewrite <- IHn.
  reflexivity.
Qed.

Theorem mult_0_plus' : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n).
    Case "Proof of assertion". reflexivity.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_rearrange_firsttry : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  (* We just need to swap (n + m) for (m + n)...
     it seems like plus_comm should do the trick!  *)
  rewrite -> plus_comm.
  (* Doesn't work...Coq rewrote the wrong plus! *)
Admitted.

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
    Case "Proof of assertion".
    rewrite -> plus_comm. reflexivity.
  rewrite -> H. reflexivity.
Qed.

Theorem plus_swap: forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  simpl.
  rewrite -> plus_assoc.
  assert (H: m + n = n + m).
    rewrite -> plus_comm. reflexivity.
  rewrite -> plus_assoc.
  rewrite -> H. reflexivity.
Qed.

Theorem mult_n_Sm : forall n m : nat, n * S m = n + n * m.
  Proof.
    intros n m.
    induction n.
    reflexivity.
    simpl.
    rewrite -> IHn.
    rewrite plus_swap.
    reflexivity.
Qed.

Theorem mult_comm : forall m n : nat,
 m * n = n * m.
Proof.
  intros m n.
  simpl.
  induction n.
    induction m.
      reflexivity.
      simpl. rewrite -> IHm. reflexivity.
  simpl. rewrite -> mult_n_Sm. rewrite -> IHn. reflexivity.
Qed.

Theorem ble_nat_refl : forall n:nat,
  true = ble_nat n n.
Proof.
  intros n.
  induction n.
  reflexivity.
  simpl. rewrite <- IHn. reflexivity.
Qed.

Theorem zero_nbeq_S : forall n:nat,
  beq_nat 0 (S n) = false.
Proof.
  intros n.
  simpl. reflexivity.
Qed.

Theorem plus_swap' : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  rewrite -> plus_assoc.
  rewrite -> plus_assoc.
  replace (n + m) with (m + n).
  reflexivity.
  rewrite -> plus_comm.
  reflexivity.
Qed.


Require Export Relation_Definitions.
Require Import Relation_Definitions_Implicit.
Require Import Classical_Wf.
Require Import Description.
Require Import FunctionalExtensionality.
Require Import Classical.
Require Import ZornsLemma.
Require Import Proj1SigInjective.
Require Import EnsemblesSpec.

Unset Standard Proposition Elimination Names.

Section WellOrder.

(* this definition is for the strict order, e.g. the element relation for ordinals of ZFC *)

Variable T:Type.

Definition total_strict_order (R:relation T) : Prop :=
  forall x y:T, R x y \/ x = y \/ R y x.

Record well_order (R:relation T) : Prop := {
  wo_well_founded: well_founded R;
  wo_total_strict_order: total_strict_order R
}.

Lemma wo_irrefl: forall R:relation T, well_order R ->
  (forall x:T, ~ R x x).
Proof.
intuition.
assert (forall y:T, Acc R y -> y <> x).
intros.
induction H1.
intuition.
rewrite H3 in H2.
apply H2 with x.
trivial.
trivial.

pose proof (wo_well_founded R H).
unfold well_founded in H2.
pose proof (H1 x (H2 x)).
auto.
Qed.

Lemma wo_antisym: forall R:relation T, well_order R ->
  (forall x y:T, R x y -> ~ R y x).
Proof.
intuition.
assert (forall z:T, Acc R z -> z <> x /\ z <> y).
intros.
induction H2.
intuition.
rewrite H4 in H3.
pose proof (H3 y H1).
tauto.
rewrite H4 in H3.
pose proof (H3 x H0).
tauto.

pose proof (wo_well_founded R H).
unfold well_founded in H3.
pose proof (H2 x (H3 x)).
tauto.
Qed.

Lemma wo_transitive: forall R:relation T, well_order R -> transitive R.
Proof.
intros.
unfold transitive.
intros.
case (wo_total_strict_order R H x z).
trivial.
intro.
case H2.
intro.
rewrite H3 in H0.
pose proof (wo_antisym R H y z).
contradict H0.
auto.

intro.

assert (forall a:T, Acc R a -> a <> x /\ a <> y /\ a <> z).
intros.
induction H4.
intuition.
rewrite H2 in H5.
pose proof (H5 z H3).
tauto.
rewrite H2 in H5.
pose proof (H5 x H0).
tauto.
rewrite H2 in H5.
pose proof (H5 y H1).
tauto.
rewrite H2 in H5.
pose proof (H5 z H3).
tauto.
rewrite H2 in H5.
pose proof (H5 x H0).
tauto.
rewrite H2 in H5.
pose proof (H5 y H1).
tauto.

pose proof (wo_well_founded R H).
unfold well_founded in H5.
pose proof (H4 x (H5 x)).
tauto.
Qed.

End WellOrder.

Arguments total_strict_order [T].
Arguments well_order [T].
Arguments wo_well_founded [T] [R].
Arguments wo_transitive [T] [R].
Arguments wo_total_strict_order [T] [R].
Arguments wo_irrefl [T] [R].
Arguments wo_antisym [T] [R].

Section WellOrderMinimum.

Variable T:Type.
Variable R:relation T.
Hypothesis well_ord: well_order R.

Definition WO_minimum:
  forall S:Ensemble T, Inhabited S ->
    { x:T | In S x /\ forall y:T, In S y -> y = x \/ R x y }.
refine (fun S H => constructive_definite_description _ _).
pose proof (WF_implies_MEP T R (wo_well_founded well_ord)).
unfold minimal_element_property in H0.
pose proof (H0 S H).

destruct H1.
destruct H1.
exists x.
red.
split.
split.
assumption.
intros.
case (wo_total_strict_order well_ord x y).
tauto.
intro.
case H4.
auto.
intro.
contradict H5.
auto.

intros.
destruct H3.
case (wo_total_strict_order well_ord x x').
intro.
pose proof (H4 x H1).
case H6.
trivial.
intro.
contradict H7.
auto.

intro.
case H5.
trivial.
intro.
contradict H6.
auto.
Defined.

End WellOrderMinimum.

Arguments WO_minimum [T].

Section WellOrderConstruction.

Variable T:Type.

Definition restriction_relation (R:relation T) (S:Ensemble T) :
  relation ({z:T | In S z}) :=
  fun (x y:{z:T | In S z}) => R (proj1_sig x) (proj1_sig y).

Record partial_WO : Type := {
  pwo_S: Ensemble T;
  pwo_R: relation T;
  pwo_R_lives_on_S: forall (x y:T), pwo_R x y -> In pwo_S x /\ In pwo_S y;
  pwo_wo: well_order (restriction_relation pwo_R pwo_S)
}.

(* the last condition below says that S WO1 is a downward closed
   subset of S WO2 *)
Record partial_WO_ord (WO1 WO2:partial_WO) : Prop := {
  pwo_S_incl: Included (pwo_S WO1) (pwo_S WO2);
  pwo_restriction: forall x y:T, In (pwo_S WO1) x -> In (pwo_S WO1) y ->
    (pwo_R WO1 x y <-> pwo_R WO2 x y);
  pwo_downward_closed: forall x y:T, In (pwo_S WO1) y -> In (pwo_S WO2) x ->
    pwo_R WO2 x y -> In (pwo_S WO1) x
}.

Lemma partial_WO_preord : preorder partial_WO_ord.
Proof.
constructor.
unfold reflexive.
intro.
destruct x.
constructor; simpl.
auto with sets.
split.
trivial.
trivial.
auto.

unfold transitive.
destruct x.
destruct y.
destruct z.
intros.
destruct H.
destruct H0.

simpl in pwo_S_incl0; simpl in pwo_restriction0;
  simpl in pwo_downward_closed0; simpl in pwo_S_incl1;
  simpl in pwo_restriction1; simpl in pwo_downward_closed1.
constructor; simpl.
auto with sets.
intros.
apply iff_trans with (pwo_R1 x y).
apply pwo_restriction0; auto with sets.
apply pwo_restriction1; auto with sets.

intros.
apply pwo_downward_closed0 with y; trivial.
apply pwo_downward_closed1 with y; trivial.
auto with sets.
apply <- (pwo_restriction1 x y); trivial.
auto with sets.
apply pwo_downward_closed1 with y; trivial.
auto with sets.
Qed.

Definition partial_WO_chain_ub: forall C:Ensemble partial_WO,
  chain partial_WO_ord C -> partial_WO.
refine (fun C H => let US := [ x:T | exists WO:partial_WO,
                                     In C WO /\ In (pwo_S WO) x ] in
           let UR := fun x y:T => exists WO:partial_WO, In C WO /\
                                     pwo_R WO x y in
        Build_partial_WO US UR _ _).
intros.
unfold UR in H0.
destruct H0.
destruct H0.
split.
constructor.
exists x0.
split.
assumption.
pose proof (pwo_R_lives_on_S x0 x y).
tauto.
constructor.
exists x0.
split.
assumption.
pose proof (pwo_R_lives_on_S x0 x y).
tauto.

constructor.
assert (forall (WO:partial_WO) (x:{z:T | In (pwo_S WO) z}),
   In C WO -> In US (proj1_sig x)).
intros.
constructor.
exists WO.
split.
assumption.
exact (proj2_sig x).

assert (forall (WO:partial_WO) (iC:In C WO) (x:{z:T | In (pwo_S WO) z}),
  Acc (restriction_relation (pwo_R WO) (pwo_S WO)) x ->
  Acc (restriction_relation UR US)
        (exist _ (proj1_sig x) (H0 WO x iC))).
intros.
induction H1.
constructor.
intros.
destruct x as [x ix].
destruct y as [y iy].
unfold restriction_relation in H3.
simpl in H3.
assert (In (pwo_S WO) y).
destruct H3.
destruct H3.
pose proof (H WO x0 iC H3).
case H5.
intro.
destruct H6.
apply pwo_downward_closed0 with x.
assumption.
pose proof (pwo_R_lives_on_S x0 y x).
tauto.
assumption.
intro.
destruct H6.
apply pwo_S_incl0.
pose proof (pwo_R_lives_on_S x0 y x).
tauto.

pose proof (H2 (exist (In (pwo_S WO)) y H4)).
simpl in H5.
assert (iy = H0 WO (exist (In (pwo_S WO)) y H4) iC).
apply proof_irrelevance.
rewrite <- H6 in H5.
apply H5.
unfold restriction_relation.
simpl.
destruct H3.
destruct H3.
pose proof (H WO x0 iC H3).
case H8.
intros.
destruct H9.
apply <- pwo_restriction0.
assumption.
assumption.
assumption.
intro.
destruct H9.
apply -> pwo_restriction0.
assumption.
pose proof (pwo_R_lives_on_S x0 y x).
tauto.
pose proof (pwo_R_lives_on_S x0 y x).
tauto.

red.
intro.
destruct a.
inversion i.
destruct H2.
destruct H2.
pose proof (H1 x0 H2 (exist _ x H3)).
simpl in H4.
assert (i = H0 x0 (exist _ x H3) H2).
apply proof_irrelevance.
rewrite <- H5 in H4.
apply H4.
apply (wo_well_founded (pwo_wo x0)).

unfold total_strict_order.
intros.
destruct x.
destruct y.
unfold restriction_relation.
simpl.
destruct i.
destruct e.
destruct a.
destruct i0.
destruct e.
destruct a.

case (H x1 x2 i i0).
intro.
assert (In (pwo_S x2) x).
apply H0.
assumption.
case (wo_total_strict_order (pwo_wo x2) (exist _ x H1) (exist _ x0 i2)).
unfold restriction_relation.
simpl.
left.
exists x2.
tauto.
intro.
case H2.
right; left.
apply subset_eq_compatT.
injection H3.
trivial.
unfold restriction_relation.
simpl.
right; right.
exists x2.
tauto.

intro.
assert (In (pwo_S x1) x0).
apply H0.
assumption.
case (wo_total_strict_order (pwo_wo x1) (exist _ x i1) (exist _ x0 H1)).
unfold restriction_relation.
simpl.
left.
exists x1.
tauto.
intro.
case H2.
right; left.
apply subset_eq_compatT.
injection H3.
trivial.
unfold restriction_relation; simpl.
right; right.
exists x1.
tauto.
Defined.

Lemma partial_WO_chain_ub_correct: forall (C:Ensemble partial_WO)
  (c:chain partial_WO_ord C), forall WO:partial_WO, In C WO ->
  partial_WO_ord WO (partial_WO_chain_ub C c).
Proof.
intros.
constructor.
unfold Included.
intros.
constructor.
exists WO.
tauto.

intros.
split.
intro.
exists WO.
tauto.
intro.
destruct H2.
destruct H2.
case (c WO x0 H H2).
intro.
destruct H4.
apply <- pwo_restriction0.
assumption.
assumption.
assumption.
intro.
destruct H4.
apply -> pwo_restriction0.
assumption.
pose proof (pwo_R_lives_on_S x0 x y).
tauto.
pose proof (pwo_R_lives_on_S x0 x y).
tauto.

intros.
destruct H2.
destruct H2.
case (c WO x0 H H2).
intro.
destruct H4.
apply pwo_downward_closed0 with y.
assumption.
pose proof (pwo_R_lives_on_S x0 x y).
tauto.
assumption.
intro.
apply H4.
pose proof (pwo_R_lives_on_S x0 x y).
tauto.
Qed.

Definition extend_strictly_partial_WO: forall (WO:partial_WO)
  (a:T), ~ In (pwo_S WO) a -> partial_WO.
refine (fun WO a H => let S' := Add (pwo_S WO) a in
  let R' := fun x y:T => pwo_R WO x y \/ (In (pwo_S WO) x /\ y = a) in
  Build_partial_WO S' R' _ _).
intros.
case H0.
intros.
split.
left.
pose proof (pwo_R_lives_on_S WO x y).
tauto.
left.
pose proof (pwo_R_lives_on_S WO x y).
tauto.
intros.
destruct H1.
split.
left.
assumption.
right.
rewrite H2.
auto with sets.

constructor.
red.
intros.
assert (forall x:{y:T | In (pwo_S WO) y}, In S' (proj1_sig x)).
intro.
destruct x.
left.
simpl.
assumption.

assert (forall x:{y:T | In (pwo_S WO) y},
  Acc (restriction_relation R' S') (exist _ (proj1_sig x) (H0 x))).
intro.
pose proof (wo_well_founded (pwo_wo WO) x).
induction H1.
constructor.
intros.
destruct x.
destruct y.
unfold restriction_relation in H3.
simpl in H3.
assert (In (pwo_S WO) x0).
case H3.
intro.
pose proof (pwo_R_lives_on_S WO x0 x).
tauto.
tauto.
assert (pwo_R WO x0 x).
case H3.
trivial.
intro.
destruct H5.
contradict H.
rewrite <- H6.
assumption.

pose proof (H2 (exist _ x0 H4)).
simpl in H6.
assert (i0 = (H0 (exist (In (pwo_S WO)) x0 H4))).
apply proof_irrelevance.
rewrite <- H7 in H6.
apply H6.
red.
simpl.
assumption.

destruct a0.
case i.
intros.
pose proof (H1 (exist _ x0 i0)).
simpl in H2.
assert (H0 (exist (In (pwo_S WO)) x0 i0) =
  Union_introl T (pwo_S WO) (Singleton a) x0 i0).
apply proof_irrelevance.
rewrite <- H3.
assumption.
intros.
generalize i0.
destruct i0.
intro.
constructor.
intros.
unfold restriction_relation in H2.
destruct y.
simpl in H2.
case H2.
intro.
contradict H.
pose proof (pwo_R_lives_on_S WO x0 a).
tauto.
intros.
destruct H3.
pose proof (H1 (exist _ x0 H3)).
simpl in H5.
assert (H0 (exist (In (pwo_S WO)) x0 H3) = i1).
apply proof_irrelevance.
rewrite H6 in H5.
assumption.

red.
intros.
destruct x.
destruct y.
unfold restriction_relation.
simpl.
case i.
case i0.
intros.
case (wo_total_strict_order (pwo_wo WO)
  (exist _ x2 i2) (exist _ x1 i1)).
intro.
red in H0.
simpl in H0.
left.
constructor 1.
assumption.
intro.
case H0.
right; left.
apply subset_eq_compatT.
injection H1.
trivial.

right; right.
red in H1.
simpl in H1.
constructor 1.
assumption.

intros.
left.
destruct i1.
constructor 2.
tauto.

case i0.
intros.
right; right.
destruct i2.
constructor 2.
tauto.

right; left.
apply subset_eq_compatT.
destruct i1.
destruct i2.
trivial.
Defined.

Lemma extend_strictly_partial_WO_correct: forall (WO:partial_WO)
  (x:T) (ni:~ In (pwo_S WO) x),
  partial_WO_ord WO (extend_strictly_partial_WO WO x ni).
Proof.
intros.
constructor.
unfold extend_strictly_partial_WO; simpl.
constructor 1.
assumption.
intros.
unfold extend_strictly_partial_WO; simpl.
split.
tauto.
intro.
case H1.
trivial.
intro.
destruct H2.
contradict ni.
rewrite <- H3.
assumption.

unfold extend_strictly_partial_WO; simpl.
intros.
case H1.
intro.
pose proof (pwo_R_lives_on_S WO x0 y).
tauto.
intro.
tauto.
Qed.

Lemma premaximal_partial_WO_is_full: forall WO:partial_WO,
  premaximal partial_WO_ord WO -> pwo_S WO = Full_set.
Proof.
intros.
apply Extensionality_Ensembles.
split.
unfold Included.
intros.
constructor.
unfold Included.
intros.
apply NNPP.
unfold not; intro.
pose (WO' := extend_strictly_partial_WO WO x H1).
assert (partial_WO_ord WO' WO).
apply H.
apply extend_strictly_partial_WO_correct.
assert (In (pwo_S WO') x).
simpl.
constructor 2.
auto with sets.
apply H1.
apply H2.
assumption.
Qed.

Theorem well_orderable: exists R:relation T, well_order R.
Proof.
assert (exists WO:partial_WO, premaximal partial_WO_ord WO).
apply ZornsLemmaForPreorders.
exact partial_WO_preord.
intros.
exists (partial_WO_chain_ub S H).
exact (partial_WO_chain_ub_correct S H).

destruct H as [WO].
exists (pwo_R WO).
constructor.
assert (forall x:T, In (pwo_S WO) x).
rewrite premaximal_partial_WO_is_full.
intro.
constructor.
assumption.

assert (forall a:{x:T | In (pwo_S WO) x}, Acc (pwo_R WO) (proj1_sig a)).
intro.
pose proof (wo_well_founded (pwo_wo WO)).
induction (H1 a).
destruct x.
simpl.
unfold restriction_relation in H3; simpl in H3.
constructor.
intros.
apply H3 with (y := exist _ y (H0 y)).
assumption.
red; intro.
apply H1 with (a := exist _ a (H0 a)).

red; intros.
assert (forall x:T, In (pwo_S WO) x).
rewrite premaximal_partial_WO_is_full; intro.
constructor.
apply H.
case (wo_total_strict_order (pwo_wo WO)
  (exist _ x (H0 x)) (exist _ y (H0 y))).
unfold restriction_relation; tauto.
intro.
case H1.
intro.
right; left.
injection H2.
trivial.
unfold restriction_relation; tauto.
Qed.

End WellOrderConstruction.

Section WO_implies_AC.

Lemma WO_implies_AC: forall (A B:Type) (R: A -> B -> Prop)
  (WO:relation B), well_order WO ->
  (forall x:A, exists y:B, R x y) ->
  exists f:A->B, forall x:A, R x (f x).
Proof.
intros.
assert (forall a:A, Inhabited [ b:B | R a b ]).
intro.
pose proof (H0 a).
destruct H1.
exists x.
constructor; assumption.

exists (fun a:A => proj1_sig
  (WO_minimum WO H [ b:B | R a b ] (H1 a))).
intro.
destruct @WO_minimum.
simpl.
destruct a.
destruct H2.
assumption.
Qed.

End WO_implies_AC.


Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Psatz.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Maps.

Module AExp.

  Inductive aexp : Type :=
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

  Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

  Fixpoint aeval (a : aexp) : nat :=
    match a with
    | ANum n => n
    | APlus e1 e2 => aeval e1 + aeval e2
    | AMinus e1 e2 => aeval e1 - aeval e2
    | AMult e1 e2 => aeval e1 * aeval e2
    end.

  Fixpoint beval (b : bexp) : bool :=
    match b with
    | BTrue => true
    | BFalse => false
    | BEq a1 a2 => beq_nat (aeval a1) (aeval a2)
    | BLe a1 a2 => leb (aeval a1) (aeval a2)
    | BNot b1 => negb (beval b1)
    | BAnd b1 b2 => andb (beval b1) (beval b2)
    end.

  Fixpoint optimize_0plus (a:aexp) : aexp :=
    match a with
    | ANum n =>
           ANum n
    | APlus (ANum 0) e2 =>
            optimize_0plus e2
    | APlus e1 e2 =>
            APlus (optimize_0plus e1) (optimize_0plus e2)
    | AMinus e1 e2 =>
             AMinus (optimize_0plus e1) (optimize_0plus e2)
    | AMult e1 e2 =>
            AMult (optimize_0plus e1) (optimize_0plus e2)
    end.

  Example test_optimize_0plus:
  optimize_0plus (APlus (ANum 2)
                        (APlus (ANum 0)
                               (APlus (ANum 0) (ANum 1))))
  = APlus (ANum 2) (ANum 1).
  cbn. auto. Qed.

  Theorem optimize_0plus_sound: forall a,
      aeval (optimize_0plus a) = aeval a.
  Proof.
    induction a;
      try (cbn; rewrite IHa1; rewrite IHa2; auto).
    + auto.
    + cbn. destruct a1;
             try (rewrite <- IHa1; rewrite <- IHa2; auto).
      ++ destruct n; try auto.
  Qed.

  Module aevalR_first_try.

    Inductive aevalR : aexp -> nat -> Prop :=
    | E_ANum n : aevalR (ANum n) n
    | E_APlus e1 e2 n1 n2 :
        aevalR e1 n1 -> aevalR e2 n2 -> aevalR (APlus e1 e2) (n1 + n2)
    | E_AMinus (e1 e2: aexp) (n1 n2: nat) :
      aevalR e1 n1 -> aevalR e2 n2 -> aevalR (AMinus e1 e2) (n1 - n2)
    | E_AMult (e1 e2: aexp) (n1 n2: nat) :
      aevalR e1 n1 -> aevalR e2 n2 -> aevalR (AMult e1 e2) (n1 * n2).

    Notation "e '\\' n"
      := (aevalR e n)
           (at level 50, left associativity)
         : type_scope.

  End aevalR_first_try.

  Reserved Notation "e '\\' n" (at level 50, left associativity).

  Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum n : (ANum n) \\ n
  | E_APlus e1 e2 n1 n2 :
      e1 \\ n1 -> e2 \\ n2 ->  (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus (e1 e2: aexp) (n1 n2: nat) :
      e1 \\ n1 -> e2 \\ n2 -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult (e1 e2: aexp) (n1 n2: nat) :
      e1 \\ n1 -> e2 \\ n2 -> (AMult e1 e2) \\ (n1 * n2)
  where "e '\\' n" := (aevalR e n) : type_scope.

  Theorem aeval_iff_aevalR : forall a n,
      (a \\ n) <-> aeval a = n.
  Proof.
    split.
    + revert n.
      induction a; cbn; intros; inversion H; subst; clear H; try auto.
    + revert n. induction a; cbn; intros; subst; constructor;
                  try (eapply IHa1); try (eapply IHa2); auto.
  Qed.

  Inductive bevalR : bexp -> bool -> Prop :=
  | E_BTrue : bevalR BTrue true
  | E_BFalse : bevalR BFalse false
  | E_BEq a1 a2 n1 n2 : aevalR a1 n1 -> aevalR a2 n2 -> bevalR (BEq a1 a2) (n1 =? n2)
  | E_BLe a1 a2 n1 n2 : aevalR a1 n1 -> aevalR a2 n2 -> bevalR (BLe a1 a2) (n1 <=? n2)
  | E_BNot b1 v1 : bevalR b1 v1 -> bevalR (BNot b1) (negb v1)
  | E_BAnd b1 b2 v1 v2 : bevalR b1 v1 -> bevalR b2 v2 -> bevalR (BAnd b1 b2) (andb v1 v2).

  Lemma beval_iff_bevalR : forall b bv,
      bevalR b bv <-> beval b = bv.
  Proof.
    split.
    + intros H. induction H; cbn; try auto.
      pose proof (aeval_iff_aevalR a1 n1).
      pose proof (aeval_iff_aevalR a2 n2).
      apply H1 in H. apply H2 in H0; subst; auto.

      pose proof (aeval_iff_aevalR a1 n1).
      pose proof (aeval_iff_aevalR a2 n2).
      apply H1 in H. apply H2 in H0; subst; auto.

      subst. auto.
      subst; auto.

    + generalize dependent bv.
      induction b; cbn; intros; subst.
      eapply E_BTrue.
      eapply E_BFalse.
      eapply E_BEq; eapply  aeval_iff_aevalR; auto.
      eapply E_BLe; eapply  aeval_iff_aevalR; auto.
      eapply E_BNot; eapply IHb; auto.
      eapply E_BAnd; [eapply IHb1 | eapply IHb2]; auto.
  Qed.

  Module aevalR_division.

    Inductive aexp : Type :=
    | ANum : nat -> aexp
    | APlus : aexp -> aexp -> aexp
    | AMinus : aexp -> aexp -> aexp
    | AMult : aexp -> aexp -> aexp
    | ADiv : aexp -> aexp -> aexp.

    Inductive aevalR : aexp -> nat -> Prop :=
    | E_ANum n : (ANum n) \\ n
    | E_APlus e1 e2 n1 n2 :
        e1 \\ n1 -> e2 \\ n2 ->  (APlus e1 e2) \\ (n1 + n2)
    | E_AMinus (e1 e2: aexp) (n1 n2: nat) :
        e1 \\ n1 -> e2 \\ n2 -> (AMinus e1 e2) \\ (n1 - n2)
    | E_AMult (e1 e2: aexp) (n1 n2: nat) :
        e1 \\ n1 -> e2 \\ n2 -> (AMult e1 e2) \\ (n1 * n2)
    | E_ADiv e1 e2 n1 n2 n3 :
        e1 \\ n1 -> e2 \\ n2 -> (n2 > 0) ->
        (mult n1 n2 = n3) -> (ADiv e1 e2) \\ n3
    where "e '\\' n" := (aevalR e n) : type_scope.

  End aevalR_division.
  Module aevalR_extended.

    Inductive aexp : Type :=
    | AAny : aexp
    | ANum : nat -> aexp
    | APlus : aexp -> aexp -> aexp
    | AMinus : aexp -> aexp -> aexp
    | AMult : aexp -> aexp -> aexp.

    Reserved Notation "e '\\' n" (at level 50, left associativity).

    Inductive aevalR : aexp -> nat -> Prop :=
    | E_AAny n : AAny \\ n
    | E_ANum n : (ANum n) \\ n
    | E_APlus e1 e2 n1 n2 :
        e1 \\ n1 -> e2 \\ n2 ->  (APlus e1 e2) \\ (n1 + n2)
    | E_AMinus (e1 e2: aexp) (n1 n2: nat) :
        e1 \\ n1 -> e2 \\ n2 -> (AMinus e1 e2) \\ (n1 - n2)
    | E_AMult (e1 e2: aexp) (n1 n2: nat) :
        e1 \\ n1 -> e2 \\ n2 -> (AMult e1 e2) \\ (n1 * n2)
    where "e '\\' n" := (aevalR e n) : type_scope.

  End aevalR_extended.

End AExp.

Module AState.
  Definition state := total_map nat.

  Print total_map.

  Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : string -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

  Definition W : string := "W".
  Definition X : string := "X".
  Definition Y : string := "Y".
  Definition Z : string := "Z".

  Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

  Coercion AId : string >-> aexp.
  Coercion ANum : nat >-> aexp.
  Definition bool_to_bexp (b: bool) : bexp :=
    if b then BTrue else BFalse.
  Coercion bool_to_bexp : bool >-> bexp.
  Bind Scope aexp_scope with aexp.
  Infix "+" := APlus : aexp_scope.
  Infix "-" := AMinus : aexp_scope.
  Infix "*" := AMult : aexp_scope.
  Bind Scope bexp_scope with bexp.
  Infix "<=" := BLe : bexp_scope.
  Infix "=" := BEq : bexp_scope.
  Infix "&&" := BAnd : bexp_scope.
  Notation "'!' b" := (BNot b) (at level 60) : bexp_scope.

  Fixpoint aeval (st : state) (a : aexp) : nat :=
    match a with
    | ANum n => n
    | AId x => st x
    | APlus e1 e2 => aeval st e1 + aeval st e2
    | AMinus e1 e2 => aeval st e1 - aeval st e2
    | AMult e1 e2 => aeval st e1 * aeval st e2
    end.

    Fixpoint beval (st : state) (b : bexp) : bool :=
    match b with
    | BTrue => true
    | BFalse => false
    | BEq a1 a2 => beq_nat (aeval st a1) (aeval st a2)
    | BLe a1 a2 => leb (aeval st a1) (aeval st a2)
    | BNot b1 => negb (beval st b1)
    | BAnd b1 b2 => andb (beval st b1) (beval st b2)
    end.

    Notation "{ a --> x }" :=
      (t_update { --> 0 } a x) (at level 0).
    Notation "{ a --> x ; b --> y }" :=
      (t_update ({ a --> x }) b y) (at level 0).
    Notation "{ a --> x ; b --> y ; c --> z }" :=
      (t_update ({ a --> x ; b --> y }) c z) (at level 0).
    Notation "{ a --> x ; b --> y ; c --> z ; d --> t }" :=
      (t_update ({ a --> x ; b --> y ; c --> z }) d t) (at level 0).
    Notation "{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }" :=
      (t_update ({ a --> x ; b --> y ; c --> z ; d --> t }) e u) (at level 0).
    Notation "{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }" :=
      (t_update ({ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }) f v) (at level 0).
    Example aexp1 :
      aeval { X --> 5 } (3 + (X * 2))
      = 13.
    cbn. auto.
  Qed.

  Example bexp1 :
    beval { X --> 5 } (true && !(X <= 4))
    = true.
  cbn. auto. Qed.

  Inductive com : Type :=
  | CSkip : com
  | CAss : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

  Bind Scope com_scope with com.
  Notation "'SKIP'" :=
    CSkip : com_scope.
  Notation "x '::=' a" :=
    (CAss x a) (at level 60) : com_scope.
  Notation "c1 ;; c2" :=
    (CSeq c1 c2) (at level 80, right associativity) : com_scope.
  Notation "'WHILE' b 'DO' c 'END'" :=
    (CWhile b c) (at level 80, right associativity) : com_scope.
  Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
    (CIf c1 c2 c3) (at level 80, right associativity) : com_scope.

  Open Scope com_scope.

  Definition fact_in_coq : com :=
    Z ::= X;;
    Y ::= 1;;
    WHILE ! (Z = 0) DO
         Y ::= Y * Z;;
         Z ::= Z - 1
    END.

  Definition plus2 : com :=
    X ::= X + 2.
  Definition XtimesYinZ : com :=
    Z ::= X * Y.
  Definition subtract_slowly_body : com :=
    Z ::= Z - 1 ;;
    X ::= X - 1.

  Definition subtract_slowly : com :=
  WHILE ! (X = 0) DO
    subtract_slowly_body
    END.

  Definition subtract_3_from_5_slowly : com :=
    X ::= 3 ;;
    Z ::= 5 ;;
    subtract_slowly.

  Definition loop : com :=
  WHILE true DO
    SKIP
  END.

  Check t_update.
 Fixpoint ceval_fun_no_while (st : state) (c : com)
                          : state :=
  match c with
    | SKIP =>
        st
    | x ::= a1 =>
        st & { x --> (aeval st a1) }
    | c1 ;; c2 =>
        let st' := ceval_fun_no_while st c1 in
        ceval_fun_no_while st' c2
    | IFB b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_fun_no_while st c1
          else ceval_fun_no_while st c2
    | WHILE b DO c END =>
        st (* bogus *)
  end.

 Reserved Notation "c1 '/' st '\\' st'"
          (at level 40, st at level 39).
 Inductive ceval : com -> state -> state -> Prop :=
 | E_Skip st : SKIP / st \\ st
 | E_Ass st a1 n x :
     aeval st a1 = n -> (x ::= a1) / st \\ st & {x --> n}
 | E_Seq c1 c2 st st' st'' :
     c1 / st \\ st' -> c2 / st' \\ st'' -> (c1 ;; c2) / st \\ st''
 | E_IfTrue st st' b c1 c2 :
     beval st b = true ->
     c1 / st \\ st' ->
     (IFB b THEN c1 ELSE c2 FI) / st \\ st'
 | E_IfFalse st st' b c1 c2 :
     beval st b = false ->
     c2 / st \\ st' ->
     (IFB b THEN c1 ELSE c2 FI) / st \\ st'
 | E_WhileFalse b st c :
     beval st b = false ->
     (WHILE b DO c END) / st \\ st
 | E_WhileTrue b st st' st'' c :
     beval st b = true ->
     c / st \\ st' ->
     (WHILE b DO c END) / st' \\ st'' ->
     (WHILE b DO c END) / st \\ st''

 where "c1 '/' st '\\' st'" := (ceval c1 st st').

 Example ceval_example1:
   (X ::= 2;;
     IFB X <= 1
       THEN Y ::= 3
       ELSE Z ::= 4
     FI)
   / { --> 0 } \\ { X --> 2 ; Z --> 4 }.
 Proof.
   apply E_Seq with { X --> 2 }.
   - apply E_Ass; auto.
   - apply E_IfFalse; auto.
     apply E_Ass; auto.
 Qed.

 Example ceval_example2:
  (X ::= 0;; Y ::= 1;; Z ::= 2) / { --> 0 } \\
  { X --> 0 ; Y --> 1 ; Z --> 2 }.
 Proof.
   eapply E_Seq. eapply E_Ass. cbn. instantiate (1 := 0). auto.
   eapply E_Seq; eapply E_Ass. cbn. auto.
   cbn. auto.
 Qed.

 Definition pup_to_n : com :=
   Y ::= 0;;
   WHILE ! (X = 0) DO
      Y ::= Y + X;;
      X ::= X - 1
   END.

 Theorem pup_to_2_ceval :
   pup_to_n / { X --> 2 }
            \\ { X --> 2 ; Y --> 0 ; Y --> 2 ; X --> 1 ; Y --> 3 ; X --> 0 }.
 Proof.
   unfold pup_to_n.
   eapply E_Seq. eapply E_Ass. cbn. instantiate (1 := 0). auto.
   eapply E_WhileTrue; auto.
   eapply E_Seq; eapply E_Ass; cbn. instantiate (1 := 2). auto.
   instantiate (1 := 1). auto.
   eapply E_WhileTrue; auto.
   eapply E_Seq; eapply E_Ass. cbn. instantiate (1 := 3); auto.
   cbn. instantiate (1 := 0); auto.
   eapply E_WhileFalse; cbn; auto.
 Qed.

 Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
   (* proof by induction on c *)
 Proof.
   intros  c st st1 st2 E1 E2.
   generalize dependent st2.
   induction E1; intros st2 E2; inversion E2; subst; clear E2.
   + auto.
   + auto.
   + pose proof (IHE1_1 _ H1). subst.
     pose proof (IHE1_2 _ H4). auto.
   + pose proof (IHE1 _ H6). auto.
   + rewrite H in H5. inversion H5.
   + rewrite H in H5. inversion H5.
   + pose proof (IHE1 _ H6). auto.
   + auto.
   + rewrite H in H2.  inversion H2.
   + rewrite H in H4.  inversion H4.
   + assert (st' = st'0). pose proof (IHE1_1 _ H3). auto.
     subst st'. pose proof (IHE1_2 _ H6). auto.
 Qed.

End AState.


Require Import BA.Basics.
Module NatList.

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

Definition fst (s:natprod): nat:=
    match s with
     | pair n _ => n
    end.

Check (pair 5 6).
Compute (fst (pair 4 3)).

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

Check (pair 5 6).
Compute (fst (pair 4 3)).

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

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

(* Exercise: 1 star (snd_fst_is_swap)*)

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

(*Exercise: 1 star, optional (fst_swap_is_snd)*)

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

(* inductive definition of a list *)

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

(* a more  suitble Notation*)

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

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

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

Fixpoint length (xs : natlist): nat :=
      match xs with
       | [] => 0
       | (x:ys) => 1 + length ys
     end.

Compute (length [1,2,3,4,5]).

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

Notation " xs ++ ys " := (app xs ys).
Fixpoint nonzeros (l:natlist) : natlist :=
    match l with
      | [] => []
      | (x:xs) => match x with
                    |O => nonzeros xs
                    |S n => S n : nonzeros xs
                  end
   end.

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

Fixpoint oddmembers (l:natlist) : natlist :=
    match l with
      | [] => []
      |x:xs => match (evenb x) with
               |true => oddmembers xs
               |false => x:oddmembers xs
               end
    end.

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

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

Example test_countoddmembers1:
  countoddmembers [1,0,3,1,4,5] = 4.
   reflexivity. Qed.

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

Example test_countoddmembers3:
  countoddmembers nil = 0.
   reflexivity. Qed.

 (*
Exercise: 3 stars, advanced (alternate)*)

Fixpoint alternate (l1 l2 : natlist) : natlist :=
     match l1  with
       |  [] => l2
       | (x:xs) => match l2 with
                    | [] =>( x:xs)
                    | (y:ys) => x: (y: alternate xs ys)
                    end
    end.

Example test_alternate1:
  alternate [1,2,3] [4,5,6] = [1,4,2,5,3,6].
 reflexivity. Qed.

Compute (alternate [1,3,5,7] [2,4,6]).

Example test_alternate2:
  alternate [1] [4,5,6] = [1,4,5,6].
  reflexivity. Qed.

Example test_alternate3:
  alternate [1,2,3] [4] = [1,4,2,3].
  reflexivity. Qed.

Example test_alternate4:
  alternate [] [20,30] = [20,30].
  reflexivity. Qed.

Definition bag:= natlist.

Fixpoint count (v:nat) (s:bag) : nat:=
    match s with
     | [] => 0
     |(x:xs) => match (beq_nat x v) with
                | true => 1+ count v xs
                | false => count v xs
               end
    end.

Compute (count 1 [1,2,3,1,4,1]).
Example test_count1: count 1 [1,2,3,1,4,1] = 3.
 reflexivity. Qed.
Example test_count2: count 6 [1,2,3,1,4,1] = 0.
 reflexivity. Qed.

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

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

Definition add (v:nat) (s:bag) : bag :=
   app (v:[]) s.

Example test_add1: count 1 (add 1 [1,4,1]) = 3.
 simpl. reflexivity. Qed.
Example test_add2: count 5 (add 1 [1,4,1]) = 0.
simpl. reflexivity. Qed.

Definition member (v:nat) (s:bag) : bool :=
     match (count v (sum []  s)) with
       |O => false
       | _ => true
     end.

Example test_member1: member 1 [1,4,1] = true.
simpl. reflexivity. Qed.

Example test_member2: member 2 [1,4,1] = false.
simpl. reflexivity. Qed.

(*proof some properteies over list *)

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1' IHl1'].
    reflexivity.
    simpl. rewrite -> IHl1'. reflexivity. Qed.

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

Example test_rev1: rev [1,2,3] = [3,2,1].
Proof. reflexivity. Qed.
Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.

(*---OPTIONS--*)

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

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

Example test_nth_error1 : nth_error [4,5,6,7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [4,5,6,7] 3 = Some 7.
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [4,5,6,7] 9 = None.
Proof. reflexivity. Qed.

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

(*Exercise: 2 stars (hd_error) *)

Definition hd_error (l : natlist) : natoption:=
   match l with
    | [] => None
    | (x:xs) => Some  x
   end.

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

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

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

 (* Haskell -> Coq

  indexOf :: Int -> [Int] -> Maybe Int
indexOf _ []                 = Nothing
indexOf x (y:ys) | x == y    = Just 0
                 | otherwise = case indexOf x ys of
                                 Nothing -> Nothing
                                 Just i  -> Just (i + 1)   *)

Fixpoint indexOf (n:nat) (xs:natlist): natoption :=
     match xs with
      | [] => None
      | (y:ys) => match (beq_nat y n) with
                    | true => Some 0
                    |false => match (indexOf n ys) with
                                | None => None
                                | Some n => Some (S n)
                              end
                  end
    end.

Example indexOf1: (indexOf 3 [1,2,3]) = Some 2.
Proof. reflexivity. Qed.

End NatList.


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

From q3_2001 Require Export ceil.
From q3_2001 Require Export misc.
From q3_2001 Require Export nat_list_sum.

(* TODO Fold instead of Fixpoint ? *)
Fixpoint largest_elt {X : Type} (l : list X) (size : X -> nat) : option X :=
  match l with
  | [] => None
  | x::l' => match largest_elt l' size with
             | None => Some x
             | Some y => if size x <=? size y then Some y else Some x
             end
  end.

Lemma largest_elt_spec_1 : forall {X : Type} (l : list X) (size : X -> nat),
  (exists y, largest_elt l size = Some y) <-> l <> [].
Proof. (* TODO Prove largest_elt_2 directly and get this via option_spec *)
  destruct l; split; intros.
  - destruct H as [y Hy]. simpl in Hy. inversion Hy.
  - contradiction.
  - intros Hl. inversion Hl.
  - destruct (largest_elt l size) eqn:Hl; simpl; rewrite -> Hl.
    + destruct (size x <=? size x0).
      * exists x0. reflexivity.
      * exists x. reflexivity.
    + exists x. reflexivity.
Qed.

Lemma largest_elt_spec_2 : forall {X : Type} (l : list X) (size : X -> nat),
  largest_elt l size = None <-> l = [].
Proof.
  intros. destruct (list_empty_dec l) as [Hl|Hl]; subst.
  - simpl. split; reflexivity.
  - assert (Hl' : exists y : X, largest_elt l size = Some y). { apply largest_elt_spec_1. assumption. }
    destruct Hl' as [y Hy]. rewrite -> Hy. split; intros H.
    + inversion H.
    + contradiction.
Qed.

Lemma largest_elt_spec_3 : forall {X : Type} (l : list X) (size : X -> nat) (y : X),
  largest_elt l size = Some y -> In y l.
Proof.
  induction l as [| x l IHl]; intros.
  - inversion H.
  - destruct (largest_elt l size) eqn:Hl; simpl in H; rewrite -> Hl in H.
    + apply IHl in Hl. destruct (size x <=? size x0).
      * right. inversion H. subst. assumption.
      * left. inversion H. reflexivity.
    + inversion H. left. reflexivity.
Qed.

Lemma largest_elt_spec_4 : forall {X : Type} (l : list X) (size : X -> nat) (y z : X),
  largest_elt l size = Some y -> In z l -> size z <= size y.
Proof.
  induction l as [| x l IHl]; intros size y z H_largest H_in.
  - intros. inversion H_in.
  - destruct H_in; subst.
    + destruct (largest_elt l size) eqn:Hl. simpl in H_largest; rewrite -> Hl in H_largest.
      * destruct (Nat.leb_spec0 (size z) (size x)) as [Hx|Hx]; inversion H_largest; subst.
        -- assumption.
        -- apply le_n.
      * simpl in H_largest. rewrite -> Hl in H_largest. inversion H_largest. apply le_n.
    + destruct (largest_elt l size) eqn:Hl. simpl in H_largest; rewrite -> Hl in H_largest.
      destruct (Nat.leb_spec0 (size x) (size x0)) as [Hx|Hx]; inversion H_largest; subst.
      * apply IHl; assumption.
      * apply (le_trans (size z) (size x0) (size y)).
        -- apply IHl; assumption.
        -- omega.
      * apply largest_elt_spec_2 in Hl. subst. inversion H.
Qed.

Lemma largest_elt_spec_5 : forall {X : Type} (l : list X) (size : X -> nat) (y : X),
  largest_elt l size = Some y -> nat_list_sum (map size l) <= (length l) * (size y).
Proof.
  intros. assert (H_len : length (map size l) = length l). { apply map_length. } rewrite <- H_len.
  apply nat_list_sum_bound. intros m H_in. rewrite in_map_iff in H_in. destruct H_in as [x [Hx Hx_in]]. subst.
  apply (largest_elt_spec_4 l); assumption.
Qed.

Lemma largest_elt_spec_6 : forall {X : Type} (l : list X) (size : X -> nat) (x y z : X),
  largest_elt l size = Some y -> largest_elt (x::l) size = Some z -> size y <= size z.
Proof.
  intros X l size x y z Hy Hz. simpl in Hz. rewrite -> Hy in Hz.
  destruct (Nat.leb_spec0 (size x) (size y)) as [Hxy|Hxy]; inversion Hz; subst; omega.
Qed.

Lemma largest_elt_spec_7 : forall {X : Type} (l : list X) (size : X -> nat) (y : X),
  let N' := nat_list_sum (map size l) in
    largest_elt l size = Some y -> ceil N' (length l) <= size y.
Proof.
  destruct l as [| s l']; intros size y N' H.
  - simpl. apply Nat.le_0_l.
  - destruct (list_empty_dec l') as [Hl' | Hl']; subst.
    + unfold length. rewrite ceil_spec_2. unfold N'. simpl. simpl in H. rewrite Nat.add_0_r. inversion H. subst. apply le_n.
    + assert (Hlenl' : length l' <> 0). { rewrite length_zero_iff_nil. assumption. }
      rewrite <- (largest_elt_spec_1 l' size) in Hl'. destruct Hl' as [y' Hl'].
      rewrite ceil_spec_0.
      * assert (H1 : size s <= size y). {
          apply (largest_elt_spec_4 (s::l')).
          - assumption.
          - left. reflexivity. }
        assert (H2 : nat_list_sum (map size l') <= (length l') * (size y')). {
          apply largest_elt_spec_5. assumption. }
        assert (H3 : (length l') * (size y') <= (length l') * (size y)). {
          apply mult_le_compat_l.
          apply (largest_elt_spec_6 l' size s y' y); assumption. }
        unfold N'. simpl. omega.
      * simpl. intros contra. inversion contra.
Qed.


Require Export D.

(** **** 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 }} ->>
    {{ 1 * X! = m! }}
  Y ::= 1;;
    {{ Y * X! = m! }}
  WHILE X <> 0
  DO   {{ Y * X! = m! /\ X <> 0  }} ->>
       {{ (Y*X) * (X-1)! = m! }}
     Y ::= Y * X;;
       {{ Y * (X-1)! = m! }}
     X ::= X - 1
       {{ Y * X! = m! }}
  END
    {{ Y * X! = m! /\ X = 0  }} ->>
    {{ Y = m! }}
*)

Print fact.

Lemma fact_mult : forall m,
  m <> 0 -> m * fact (m - 1) = fact m.
Proof.
  intros. induction m.
  - exfalso. unfold not in H. apply H. reflexivity.
  - simpl. rewrite <- minus_n_O. reflexivity.
Qed.

Theorem factorial_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. eapply hoare_consequence.
  - eapply hoare_seq with (Q := fun st => (st Y * fact (st X)) = fact m).
    + eapply hoare_while. eapply hoare_consequence_pre.
      * eapply hoare_seq.
        ++ apply hoare_asgn.
        ++ apply hoare_asgn.
      * unfold bassn, assert_implies, assn_sub, t_update. simpl. intros st [H1 H2].
        apply negb_true_iff in H2. apply beq_nat_false in H2. apply fact_mult in H2.
        rewrite mult_assoc_reverse. rewrite H2. assumption.
    + apply hoare_asgn.
  - unfold assn_sub, t_update. intros st H. subst. simpl. omega.
  - unfold bassn; simpl; intros st [H1 H2].
    apply eq_true_negb_classical in H2.
    apply Nat.eqb_eq in H2.
    rewrite H2 in H1. simpl in H1. omega.
Qed.


Add LoadPath "bezier-functions".

Require Import polynomial.
Import auxiliary.
Require Import QArith.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.RelationClasses.

Theorem bezier_curve_fst_order_interpolation_polynomial : forall (P0 P1 : point) (q : Q),
  calc_bezier_polynomial (P0 :: [P1]) q == (((1 - q) qp* P0) pp+ (q qp* P1)).
Proof.
  intros P0 P1 q.
  unfold calc_bezier_polynomial. unfold calc_polynomial. simpl.
  unfold calc_fact_div. simpl. unfold minus_1_sgn. simpl. unfold inject_Z.
  Search (_ qp* _). try rewrite qp_1_l.
  destruct P0 as [x0 y0]. destruct P1 as [x1 y1]. unfold "==". split.
  - simpl. ring.
  - simpl. ring.
Qed.

Theorem bezier_curve_fst_order_interpolation_polynomial_rev : forall (P0 P1 : point) (q : Q),
  calc_bezier_polynomial (rev (P0 :: [P1])) (1 - q) == (((1 - q) qp* P0) pp+ (q qp* P1)).
Proof.
  intros P0 P1 q.
  unfold calc_bezier_polynomial. unfold calc_polynomial. simpl.
  unfold calc_fact_div. simpl. unfold minus_1_sgn. simpl. unfold inject_Z.
  Search (_ qp* _). try rewrite qp_1_l.
  destruct P0 as [x0 y0]. destruct P1 as [x1 y1]. unfold "==". split.
  - simpl. ring.
  - simpl. ring.
Qed.


Require Import NPeano.
Require Import Coq.Program.Wf.
Require Import Recdef.

(** *Even length*)
Inductive even : nat -> Prop :=
| EvenO : even 0
| EvenS : forall n, even n -> even (S (S n)).

Function length_of_even (ls:list nat) : option nat :=
  match ls with
  | nil => Some 0
  | cons x1 (cons x2 ls') =>
    match length_of_even ls' with
    | Some n' => Some ( 2 + n')
    | _ => None
    end
  | cons x nil => None
  end.

Lemma LOE_correct:
  forall ls n,
    length_of_even ls = Some n ->
    even (length ls).
Proof.
  intros.
  induction ls;
    try constructor; simpl.
  simpl in H.
  destruct ls; try solve[inversion H].
  simpl; constructor.

  Restart.

  intros ls.
  functional induction (length_of_even ls).
  - constructor.
  - simpl; constructor.
    eapply IHo; eassumption.
  - intros ? HH; inversion HH.
  - intros ? HH; inversion HH.
Qed.

(** * Perm_of_sh *)
Require Import VST.veric.juicy_mem.
Require Import compcert.common.Memory.

Print perm_of_sh.
Lemma perm_of_sh_readable:
  forall sh P,
    shares.readable_share_dec sh = left P ->
    Mem.perm_order'' (perm_of_sh sh) (Some Readable).
Proof.
  intros.
  unfold perm_of_sh.
  destruct (shares.writable_share_dec sh).
  Restart.

  Functional Scheme perm_of_sh_ind := Induction for perm_of_sh Sort Prop.

  intros.
  functional induction (perm_of_sh sh);
    try congruence; (* Discard the impossible cases *)
    try solve[constructor]. (* Discard the rest of the cases *)
Qed.

(** * Merge *)

Definition double_measure (lss: list nat * list nat):= (length (fst lss) + length (snd lss)).

Function merge (lss: list nat * list nat)
         {measure double_measure}:=
  match lss with
    | (ls1, ls2) =>
  match ls1 with
    nil => ls2
  | cons n ls1' =>
    match ls2 with
      nil => ls1
    | cons m ls2' =>
      if n <? m then
        cons n (merge (ls1', ls2))
      else
        cons m (merge (ls1, ls2'))
    end
  end
    end.
- intros; simpl.
  unfold double_measure; simpl.
  lia.
- intros; simpl.
  unfold double_measure; simpl.
  lia.
Defined.

Lemma merge_length: forall lss,
    length (merge lss) = length (fst lss) + length (snd lss).
Proof.
  intros.

  functional induction (merge lss);
    auto; (*Trivial cases*)
    simpl; f_equal.
  - apply IHl.
  - rewrite IHl; simpl; lia.
Qed.

(** *Mutual recursion*)

Inductive even_list : Set :=
| ENil : even_list
| ECons : nat -> odd_list -> even_list

with odd_list : Set :=
| OCons : nat -> even_list -> odd_list.

Function elength (el : even_list) : nat :=
  match el with
    | ENil => O
    | ECons _ ol => S (olength ol)
  end

with olength (ol : odd_list) : nat :=
  match ol with
    | OCons _ el => S (elength el)
  end.

Function eapp (el1 el2 : even_list) : even_list :=
  match el1 with
    | ENil => el2
    | ECons n ol => ECons n (oapp ol el2)
  end

with oapp (ol : odd_list) (el : even_list) : odd_list :=
  match ol with
    | OCons n el' => OCons n (eapp el' el)
  end.

Functional Scheme eapp_mut := Induction for eapp Sort Prop
with oapp_mut := Induction for oapp Sort Prop.

Theorem elength_eapp : forall el1 el2 : even_list,
  elength (eapp el1 el2) = plus (elength el1) (elength el2).
Proof.
  intros.

  functional induction (eapp el1 el2) using eapp_mut
  with (P0:= (fun (ol: odd_list)( el : even_list)( ol': odd_list) =>
         olength ol' = plus (olength ol) (elength el))).
  - intros; reflexivity.
  - intros. simpl; f_equal; apply IHe.
  - intros. simpl; f_equal; apply IHe.
Qed.

Require Import mathcomp.ssreflect.ssreflect.

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

Module Test.

Variable A : Type.

Theorem counterexample P : (exists x : A, ~P x) -> ~(forall x, P x).
Proof.
by case=>x H1 H2; apply: H1 (H2 x).
Qed.

Print counterexample.

End Test.

Require Import List.
Fixpoint add_list l:=
  match l with
    | nil => 0
    | h::tl => h + (add_list tl)
  end.

Inductive subseq {A: Type}: list A -> list A -> Prop :=
  | nil_subseq : subseq nil nil
  | hd_subseq: forall a l1 l2, subseq l1 l2 -> subseq (a :: l1) (a :: l2)
  | tl_subseq: forall a l1 l2, subseq l1 l2 -> subseq l1 (a :: l2)
  .

Inductive subseq' {A: Type}: list A -> list A -> Prop :=
  | nilss : forall l, subseq' nil l
  | hdss: forall a l l1 l2, subseq' l l2 -> subseq' (a :: l) (l1 ++ a :: l2)
  .

Theorem ssss: forall A (l1 l2: list A), subseq l1 l2 <-> subseq' l1 l2.
split.
+ intros H; induction H; try constructor.
  replace (a::l2) with (nil ++ a::l2) by auto; constructor; auto.
  replace (cons a l2) with (app (cons a nil) l2) by auto.
  inversion IHsubseq. constructor. rewrite app_assoc. constructor.
  auto.
+ intros. induction H.
  induction l; constructor; auto.
  induction l1.
  simpl; constructor; auto.
  simpl.
  constructor; auto.
Qed.

Lemma subseq_trans: forall {A} (l1 l2 l3: list A), subseq l1 l2 -> subseq l2 l3 -> subseq l1 l3.
Proof.
intros A l1 l2 l3 H H0.
generalize dependent l3. induction H.
intros.
+ inversion H0; constructor. exact H.
+ intros.
  induction l3. inversion H0.
  constructor. apply IHl3.

apply ssss; apply ssss in H; apply ssss in H0.
generalize dependent l3.
induction H.
+ constructor.
+

induction l1; intros l3 H0; inversion H0.
  -  constructor; apply IHsubseq'; exact H4.
  - subst. apply IHl1.
    inversion H4. destruct l1; inversion H2.
    replace (l4 ++ a0 :: l3 ++ a1 :: l6) with ((l4 ++ a0 :: l3) ++ a1 :: l6 ).
    constructor. exact H2.
    rewrite app_comm_cons.
    rewrite app_assoc. reflexivity.
Qed.

+ constructor.
+ inversion H. subst l2. inversion H0.
  - destruct l0; simpl in H5; inversion H5.
  - clear H6. destruct l0; inversion H5.
    * subst. simpl in *. inversion H2. subst; inversion H4.

      constructor.

constructor.
subst l3; auto.
  -  auto.

revert l3.
induction H; intros l3 H0.
+ admit.
+ inversion H0.
  - constructor.
    apply IHsubseq; auto.
  - constructor. apply

Inductive foo: Type :=
   bar: foo -> foo.

Theorem blah: forall (x: foo), False.
  Proof.

Lemma and_or: forall (a b: bool),
             a = b ->
             andb a b = orb a b.
Proof.
destruct a; intros b H.
+ destruct b.
  - reflexivity.
  - inversion H.
+ destruct b.
  - inversion H.
  - reflexivity.
Qed.

Lemma blah: forall x, x=O -> ~ exists y, x = S y .
intros x H H0; destruct x.
+ destruct H0; inversion H0.
+ inversion H.
Qed.

Lemma zero_no_succ: forall n, O<>S n.
unfold not; intros n H.

Definition Is_S (n:nat) := match n with (*This is a hint!!!*)
                            | O => False
                            | S p => True
                            end.
Lemma Zero_not_Succ: forall n:nat, 0 <> S n.
	unfold not; intros n H.
        assert (HH: Is_S O = False) by reflexivity.
        rewrite <- HH.
        rewrite H. simpl.

Inductive bin:=
   OO: bin
  | SS: bin -> bin
  | TT: bin -> bin.

Theorem bin_to_nat_pres_incr : forall b : bin,
  bin_to_nat (incr b) = plus (bin_to_nat b) 1.

Lemma blah': forall x, x=0 ->

unfold not in H.

Require Import ssreflect.

Require Import ssrbool.
Require Import ssrnat.
Require Import ssrfun.

Require Import eqtype.
Require Import seq.
Require Import fintype.


From VFA Require Import Perm.

Fixpoint insert (v: nat) (l: list nat): list nat :=
  match l with
  | [] => [v]
  | h :: t => if v <=? h
              then v :: l
              else h :: (insert v t)
  end.

Fixpoint sort (l: list nat): list nat :=
  match l with
  | [] => []
  | h :: t => insert h (sort t)
  end.

Compute (sort [5; 4; 7; 0; 1; 2; 3; 1; 8; 9]).

Example sort_pi: sort [3; 1; 4; 1; 5; 9; 2; 6; 5; 3; 5] =
                 [1; 1; 2; 3; 3; 4; 5; 5; 5; 6; 9].
Proof.
  simpl. reflexivity.
Qed.

Eval compute in insert 7 [1; 3; 4; 8; 12; 14; 18].

Inductive sorted: list nat -> Prop :=
| sorted_nil:
    sorted nil
| sorted_1: forall x,
    sorted (x :: nil)
| sorted_cons: forall x y l,
    x <= y -> sorted (y :: l) -> sorted (x :: y :: l).

Check length.
Check nth.

Definition sorted' (l: list nat): Prop :=
  forall i j, i < j < (length l) -> (nth i l 0) <= (nth j l 0).

Definition is_a_sorting_algorithm (f: list nat -> list nat): Prop :=
  forall l, Permutation l (f l) /\ sorted (f l).

Search Permutation.

Lemma insert_perm: forall x l, Permutation (x :: l) (insert x l).
Proof.
  intros. induction l as [| h t IHl'].
  - simpl. Check Permutation_refl. apply Permutation_refl.
  - simpl. bdestruct (x <=? h).
    + apply Permutation_refl.
    + Check perm_swap. eapply perm_trans.
      * apply perm_swap.
      * Search (Permutation (_ :: _) (_ :: _)). apply perm_skip.
        apply IHl'.
Qed.

Theorem sort_perm: forall l, Permutation l (sort l).
Proof.
  intro. induction l as [| h t IHl'].
  - simpl. Search (Permutation [] []). apply perm_nil.
  - simpl. apply perm_trans with (l' := (h :: sort t)).
    + apply perm_skip. apply IHl'.
    + apply insert_perm.
Qed.

Lemma insert_sorted: forall a l,
    sorted l -> sorted (insert a l).
Proof.
  intros a l H. induction H.
  - simpl. apply sorted_1.
  - simpl. bdestruct (a <=? x);
             apply sorted_cons; try omega; try apply sorted_1.
  - simpl. bdestruct (a <=? x).
    + apply sorted_cons;
        try assumption; try apply sorted_cons; try assumption.
    + simpl in IHsorted.
      bdestruct (a <=? y);
        apply sorted_cons; try omega; try assumption.
Qed.

Theorem sort_sorted: forall l,
    sorted (sort l).
Proof.
  intro l. induction l as [| h t IHl'].
  - simpl. apply sorted_nil.
  - simpl. apply insert_sorted. apply IHl'.
Qed.

Theorem insertion_sort_correct:
  is_a_sorting_algorithm sort.
Proof.
  unfold is_a_sorting_algorithm. intro l. split.
  - apply sort_perm.
  - apply sort_sorted.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.

Local Open Scope morphism_scope.

Section Equalizer.
  Context {C : Category} {a b : Obj} (f g : a –≻ b).

  (** given two parallel arrows f,g : a -> b, their equalizer is an object e together with an arrow eq : e -> a such that f ∘ eq = g ∘ eq such that for any other object z and eqz : z -> a that we have f ∘ eqz = g ∘ eqz, there is a unique arrow h : z -> e that makes the following fiagram commute:

#
<pre>

          eqz
/—————————————————\     f
|                 ↓  ———————>
z ———–> e ——————> a          b
   ∃!h      eq       ———–——–>
                        g
</pre>
#
 *)

  Local Open Scope morphism_scope.

  Record Equalizer : Type :=
    {
      equalizer : C;

      equalizer_morph : equalizer –≻ a;

      equalizer_morph_com : f ∘ equalizer_morph = g ∘ equalizer_morph;

      equalizer_morph_ex (e' : Obj) (eqm : e' –≻ a) : f ∘ eqm = g ∘ eqm → e' –≻ equalizer;

      equalizer_morph_ex_com (e' : Obj) (eqm : e' –≻ a) (eqmc : f ∘ eqm = g ∘ eqm) :
        equalizer_morph ∘ (equalizer_morph_ex e' eqm eqmc) = eqm;

      equalizer_morph_unique (e' : Obj) (eqm : e' –≻ a) (com : f ∘ eqm = g ∘ eqm) (u u' : e' –≻ equalizer) : equalizer_morph ∘ u = eqm → equalizer_morph ∘ u' = eqm → u = u'
    }.

  Coercion equalizer : Equalizer >-> Obj.

  (** Equalizers are unique up to isomorphism. *)
  Theorem Equalizer_iso (e1 e2 : Equalizer) : (e1 ≃ e2)%isomorphism.
  Proof.
    apply (Build_Isomorphism _ _ _ (equalizer_morph_ex e2 _ (equalizer_morph e1) (equalizer_morph_com e1)) ((equalizer_morph_ex e1 _ (equalizer_morph e2) (equalizer_morph_com e2))));
    eapply equalizer_morph_unique; [| | simpl_ids; trivial| | |simpl_ids; trivial]; try apply equalizer_morph_com;
    rewrite <- assoc; repeat rewrite equalizer_morph_ex_com; auto.
  Qed.

End Equalizer.

Arguments equalizer_morph {_ _ _ _ _} _.
Arguments equalizer_morph_com {_ _ _ _ _} _.
Arguments equalizer_morph_ex {_ _ _ _ _} _ {_ _} _.
Arguments equalizer_morph_ex_com {_ _ _ _ _} _ {_ _} _.
Arguments equalizer_morph_unique {_ _ _ _ _} _ {_ _ _} _ _ _ _.

Arguments Equalizer _ {_ _} _ _, {_ _ _} _ _.

Definition Has_Equalizers (C : Category) : Type := ∀ (a b : C) (f g : a –≻ b), Equalizer f g.

Existing Class Has_Equalizers.

(** CoEqualizer is the dual of equalzier *)
Definition CoEqualizer {C : Category} := @Equalizer (C^op).

Arguments CoEqualizer _ {_ _} _ _, {_ _ _} _ _.

Definition Has_CoEqualizers (C : Category) : Type := Has_Equalizers (C^op).

Existing Class Has_CoEqualizers.


Inductive Var :=
| x : Var
| y : Var
| n : Var
| i : Var
| sum : Var.

Fixpoint var_eq (v1 v2 : Var) :=
  match v1, v2 with
  | x, x => true
  | y, y => true
  | n, n => true
  | i, i => true
  | sum, sum => true
  | _, _ => false
  end.

Inductive AExp :=
| anum : nat -> AExp
| avar : Var -> AExp
| aplus : AExp -> AExp -> AExp
| amul : AExp -> AExp -> AExp.

Notation "A +' B" := (aplus A B) (at level 50).
Notation "A *' B" := (amul A B) (at level 46).

Coercion anum : nat >-> AExp.
Check 5 +' 4 .
Coercion avar : Var >-> AExp.

Definition State := Var -> nat.
(* lookup:  *)
Definition sigma0 : State := fun n => 0.
Check sigma0.
Compute (sigma0 x).
Compute (sigma0 y).

(* update *)
Definition update (sigma : State)
           (v : Var) (val : nat) : State :=
  fun v' => if (var_eq v v')
            then val
            else (sigma v').
Definition sigma1 := (update sigma0 x 10).
Compute (sigma1 x).

Reserved Notation "A -[ S ]-> N" (at level 60).

Inductive aeval_small_step :
  AExp -> State -> AExp -> Prop :=
| aconst : forall n st, n -[ st ]-> n
| alookup : forall v st, avar v -[ st ]-> (st v)
| aadd_1 : forall a1 a2 a1' st n,
    a1 -[ st ]-> a1' ->
    n = a1' +' a2 ->
    a1 +' a2 -[ st ]-> n
| aadd_2 : forall a1 a2 a2' st n,
    a2 -[ st ]-> a2' ->
    n = a1 +' a2' ->
    a1 +' a2 -[ st ]-> n
| aadd : forall i1 i2 st,
    (anum i1) +' (anum i2) -[ st ]-> i1 + i2
| atimes_1 : forall a1 a2 a1' st n,
    a1 -[ st ]-> a1' ->
    n = a1' *' a2 ->
    a1 *' a2 -[ st ]-> n
| atimes_2 : forall a1 a2 a2' st n,
    a2 -[ st ]-> a2' ->
    n = a1 *' a2' ->
    a1 *' a2 -[ st ]-> n
| atimes : forall i1 i2 st,
    (anum i1) *' (anum i2) -[ st ]-> i1 * i2
where "A -[ S ]-> N" := (aeval_small_step A S N).

Compute sigma1 x.

Example e1 :
  2 +' x -[ sigma1 ]-> 2 +' 10.
Proof.
  apply aadd_2 with (a2' := 10); auto.
  apply alookup.
Qed.

Reserved Notation "A -[ S ]*> N" (at level 60).
Inductive aeval_steps :
  AExp -> State -> AExp -> Prop :=
| refl : forall a st, a -[ st ]*> a
| tran : forall a1 a2 a3 st,
    a1 -[ st ]-> a2 ->
    a2 -[ st ]*> a3 ->
    a1 -[ st ]*> a3
where "A -[ S ]*> N" := (aeval_steps A S N).

Example e2 :
  2 +' x -[ sigma1 ]*> 12.
Proof.
  eapply tran.
  - apply e1.
  - eapply tran.
    + Check aadd.
      apply aadd.
    + simpl.
      apply refl.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section IntLogic.

Variables A B C : Prop.

Lemma notTrue_iff_False : (~ True) <-> False.
Proof.
  rewrite /not.
  exact. Undo 1.
  by []. Undo 1.
  by split; exact; exact. Undo 1.
  split. exact. exact.

  Restart.

  rewrite /not.
  split.
  - apply. exact: I.
  exact.
Qed.

Lemma dne_False : ~ ~ False -> False.
Proof.
  rewrite /not.
  apply. exact. Undo 2.
  exact.
Qed.

Lemma dne_True : ~ ~ True -> True.
Proof.
  rewrite /not.
  by []. Undo 1.
  exact. Undo 1.
  by move=> //.
Qed.

Lemma weak_peirce : ((((A -> B) -> A) -> A) -> B) -> B.
Proof.
  move=> H1.
  apply: (H1).
  apply.
  move=> a.
  apply: H1.
  by [].
Qed.

Lemma imp_trans : (A -> B) -> (B -> C) -> (A -> C).
Proof.
  move=> H1 H2 a.
  by apply H2; apply H1.
Qed.

End IntLogic.

(** Let's get familiarize ourselves with some lemmas from [ssrbool] module.
    The proofs are very easy, so the lemma statements are more important here.
 *)
Section BooleanLogic.

Variables (A B : Type) (x : A) (f : A -> B) (a b : bool) (vT vF : A).

Lemma negbNE : ~~ ~~ b -> b.
Proof. by case b. Qed.

(** Figure out what [involutive] and [injective] mean
    using Coq's interactive queries. Prove the lemmas.
    Hint: to unfold a definition in the goal use [rewrite /definition] command.
*)
Lemma negbK : involutive negb.
Proof.
  rewrite /involutive. (* cancel negb negb *)
  rewrite /cancel.     (* ~~ ~~ x0 = x0 *)
  by case.
Qed.

Lemma negb_inj : injective negb.
Proof.
  rewrite /injective.
  by case; case.
Qed.

Lemma ifT : b -> (if b then vT else vF) = vT.
Proof. by case b. Qed.

Lemma ifF : b = false -> (if b then vT else vF) = vF.
Proof. by case b. Qed.

Lemma if_same : (if b then vT else vT) = vT.
Proof. by case b. Qed.

Lemma if_neg : (if ~~ b then vT else vF) = if b then vF else vT.
Proof. by case b. Qed.

Lemma fun_if : f (if b then vT else vF) = if b then f vT else f vF.
Proof. by case b. Qed.

Lemma if_arg (fT fF : A -> B) :
  (if b then fT else fF) x = if b then fT x else fF x.
Proof. by case b. Qed.

Lemma andbK : a && b || a = a.
Proof. by case a; case b. Qed.

(** Find out what [left_id], [right_id] mean
    using Coq's interactive queries. Prove the lemmas.
 *)
Lemma addFb : left_id false addb.
(* [addb] means XOR (eXclusive OR operation) *)
Proof.
  (* https://en.wikipedia.org/wiki/Identity_element *)

  (* Левая "единица" (нейтральный элемент) *)
  About  left_id. (* S -> (S -> T -> T)           *)
  Print  left_id. (* op (e : S) (x : T) = (x : T) *)

  (* Правая "единица" (нейтральный элемент) *)
  About right_id. (* T -> (S -> T -> S)           *)
  Print right_id. (* op (x : S) (e : T) = (x : T) *)

  (* Search _ ( left_id _ _). *)
  (* Search _ (right_id _ _). *)
  rewrite /left_id.
  move=> v. rewrite /addb. done.
  Undo 2.
  by [].
Qed.

Lemma addbF : right_id false addb.
Proof.
  by case.
  Undo.
  rewrite /addb.
  case.
  - rewrite /negb. done.
  - done.
Qed.

Lemma addbC : commutative addb.
Proof.
  by case; case.
  Undo.
  (* Если есть желание посмотреть что происходит под капотом,
     то можно прошагать вот эту дичь, которую я написал далее. *)
  rewrite /commutative.
  case. case.
  - rewrite /addb. done.
  - rewrite /addb. rewrite /negb. done.
  - case. rewrite /addb. rewrite /negb. done.
  - rewrite /addb. done.
Qed.

Lemma addbA : associative addb.
Proof.
  rewrite /associative.
  move=> m n k.
  (* Я тут уже не буду расписывать так же как выше,
     но тут происходит ровно тоже самое, только уже с 3 переменными. *)
  Undo 2.
  by case; case; case.
Qed.

(** Formulate analogous laws
    (left/right identity, commutativity, associativity)
    for boolean AND and OR and proove those.
    Find the names of corresponding lemmas in the standard library using
    [Search] command. For instance: [Search _ andb left_id.]
    Have you noticed the naming patterns?
 *)

Lemma orbF : right_id false orb.
Proof.
  by case.
  Undo.
  (* Оставил просто для того,
     чтобы пошагать и посмотреть что происходит *)
  rewrite /right_id.
  case.
  - done.
  - done.
Qed.

(* Аналогично и всё остальное *)

Lemma orFb : left_id false orb. Proof. by case. Qed.

Lemma andbT : right_id true andb. Proof. by case. Qed.
Lemma andTB : left_id true andb. Proof. by case. Qed.

Lemma orbC : commutative orb. Proof. by case; case. Qed.
Lemma andbC : commutative andb. Proof. by case; case. Qed.

Lemma orbA : associative orb. Proof. by case; case; case. Qed.
Lemma andbA : associative andb. Proof. by case; case; case. Qed.

End BooleanLogic.

Section NaturalNumbers.
(** Figure out what [cancel], [succn], [predn] mean
    using Coq's interactive queries. Prove the lemmas.
 *)
Lemma succnK : cancel succn predn.
Proof.
  About cancel.
  About succn. Print succn. Print predn.
  by [].
  Undo.
  rewrite /cancel.
  done.
Qed.

Lemma add0n : left_id 0 addn.
Proof. by []. Qed.

Lemma addSn m n : m.+1 + n = (m + n).+1.
Proof. by []. Qed.

Lemma add1n n : 1 + n = n.+1.
Proof. by []. Qed.

Lemma add2n m : 2 + m = m.+2.
Proof. by []. Qed.

Lemma subn0 : right_id 0 subn.
Proof.
  rewrite /right_id.
  by case.
Qed.

End NaturalNumbers.