Require Import List Bool Lia Classical.

Import ListNotations.
From mathcomp Require Import ssreflect.

Variable var : Type.
Variable fls tru : var.

Inductive prop :=
  | Var : var -> prop
  | Not : prop -> prop
  | And : prop -> prop -> prop
  | Or : prop -> prop -> prop
  | Imp : prop -> prop -> prop
  (* | Top : prop *)
  (* | Bot : prop *)
  .

Notation "# p" := (Var p) (at level 1).
Notation "A ∨ B" := (Or A B) (at level 15, right associativity).
Notation "A ∧ B" := (And A B) (at level 15, right associativity).
Notation "A ⊃ B" := (Imp A B) (at level 16, right associativity).
Notation "¬ A" := (Not A) (at level 5).
(* Notation "⊥" := Bot (at level 0). *)
(* Notation "⊤" := ( Not Bot) (at level 0). *)
Notation "⊥" := (# fls).
Notation "⊤" := (# tru).

Definition assign := var -> bool.
Axiom fls_false : forall f : assign, f fls = false.
Axiom tru_true  : forall f : assign, f tru = true.

Fixpoint valuation (v : assign) (A : prop) :=
  match A with
  | # p => v p
  | ¬ A => negb (valuation v A)
  | A ∧ B => andb (valuation v A) (valuation v B)
  | A ∨ B => orb (valuation v A) (valuation v B)
  | A ⊃ B => implb (valuation v A) (valuation v B)
  (* | ⊤ => true *)
  (* | ⊥ => false *)
  end.

Definition tautology A :=
  forall v, valuation v A = true.

Definition equiv A B :=
  (A ⊃ B) ∧ (B ⊃ A).

Definition eqtot A B :=
  tautology (equiv A B).

Reserved Notation "Γ → Δ" (at level 80).
Inductive prv : list prop -> list prop -> Prop :=
  | init A : [A] → [A]
  | initTop : [] → [⊤]
  | initBot : [⊥] → []

  | weakL A Γ Δ : Γ → Δ -> (A :: Γ) → Δ
  | weakR A Γ Δ : Γ → Δ -> Γ → (Δ ++ [A])

  | contraL A Γ Δ : (A :: A :: Γ) → Δ -> (A :: Γ) → Δ
  | contraR A Γ Δ : Γ → (Δ ++ [A ; A]) -> Γ → (Δ ++ [A])

  | changeL A B Γ Π Δ : (Γ ++ A :: B :: Π) → Δ -> (Γ ++ B :: A :: Π) → Δ
  | changeR A B Γ Δ Σ : Γ → (Δ ++ A :: B :: Σ) -> Γ → (Δ ++ B :: A :: Σ)

  | cut A Γ Π Δ Σ : Γ → (Δ ++ [A]) -> A :: Π → Σ -> Γ ++ Π → Δ ++ Σ

  | andL1 A B Γ Δ : A :: Γ → Δ ->  A ∧ B :: Γ → Δ
  | andL2 A B Γ Δ : B :: Γ → Δ ->  A ∧ B :: Γ → Δ
  | andR A B Γ Δ : Γ → Δ ++ [A] -> Γ → Δ ++ [B] ->  Γ → Δ ++ [A ∧ B]

  | orL A B Γ Δ : A :: Γ → Δ -> B :: Γ → Δ -> A ∨ B :: Γ → Δ
  | orR1 A B Γ Δ : Γ → Δ ++ [A] -> Γ → Δ ++ [A ∨ B]
  | orR2 A B Γ Δ : Γ → Δ ++ [B] -> Γ → Δ ++ [A ∨ B]

  | impL A B Γ Π Δ Σ : Γ → Δ ++ [A] -> B :: Π → Σ -> A ⊃ B :: Γ ++ Π → Δ ++ Σ
  | impR A B Γ Δ : A :: Γ → Δ ++ [B] -> Γ → Δ ++ [A ⊃ B]

  | notL A Γ Δ : Γ → Δ ++ [A] -> ¬ A :: Γ → Δ
  | notR A Γ Δ : A :: Γ → Δ -> Γ → Δ ++ [¬ A]

  where "Γ → Δ" := (prv Γ Δ).

Lemma cons_app {A} (a : A) l :
  a :: l = [a] ++ l.
Proof.
  induction l => //=.
Qed.

(* 1.13 *)
Goal forall A, [] → [A ∨ ¬ A].
Proof.
  intro A.

  rewrite <- app_nil_l;
  apply contraR; simpl.

  rewrite cons_app;
  apply orR1; simpl.

  rewrite <- app_nil_l;
  apply changeR; simpl.

  rewrite cons_app;
  apply orR2.

  apply notR.
  apply init.
Qed.

(*　問1.14 *)
Goal forall A B, [(A ⊃ B)] → [¬ (A ∧ ¬ B)].
Proof.
  intros A B.
  rewrite <- app_nil_l;
  apply notR.

  rewrite <- (app_nil_l [_; _]);
  apply contraL.
  apply andL2.

  rewrite <- (app_nil_l [¬ B; A ∧ ¬ B; A ⊃ B]);
  apply changeL; simpl.
  apply andL1.

  rewrite cons_app;
  apply changeL; simpl.

  rewrite <- (app_nil_l ([A; A ⊃ B; ¬ B]));
  apply changeL; simpl.

  rewrite <- (app_nil_l nil);
  rewrite (cons_app A [¬ B]);
  eapply impL; simpl.
  - apply init.
  - rewrite <- (app_nil_l [B; ¬ B]);
    apply changeL; simpl.
    apply notL; simpl.
    apply init.
Qed.

Goal forall A B Γ Δ, A :: Γ → Δ ++ [B] -> Γ → Δ ++ [¬ A ∨ B].
Proof.
  intros A B Γ Δ H.
  apply contraR.
  assert (Δ ++ [¬ A ∨ B; ¬ A ∨ B] = (Δ ++ [¬ A ∨ B]) ++  [¬ A ∨ B]). {
    rewrite <- app_assoc; auto.
  }
  rewrite H0; clear H0.
  apply orR1.
  apply notR.
  apply orR2.
  apply H.
Qed.

(* 1.115.1 *)
Theorem cons_andor  A1 A2 B1 B2 :
  [A1; A2] → [B1; B2] -> [A1 ∧ A2] → [B1 ∨ B2].
Proof.
  intros H.
  apply contraL.
  apply andL2.
  rewrite <- (app_nil_l [_; _]);
  apply changeL; simpl.
  apply andL1.
  rewrite <- (app_nil_l [_ ∨ _]);
  apply contraR; simpl.
  assert ([B1 ∨ B2; B1 ∨ B2] = [B1 ∨ B2] ++ [B1 ∨ B2]) by auto;
  rewrite H0; clear H0;
  apply orR1; simpl.
  rewrite <- (app_nil_l [_; B1]);
  apply changeR; simpl.
  assert ([B1; B1 ∨ B2] = [B1] ++  [B1 ∨ B2]) by auto;
  rewrite H0; clear H0;
  apply orR2; simpl.
  auto.
Qed.

(* 1.115.2 *)
Theorem andor_imp A1 A2 B1 B2 :
  [A1 ∧ A2] → [B1 ∨ B2] -> [] → [A1 ∧ A2 ⊃ B1 ∨ B2].
Proof.
  intros H;
  rewrite <- (app_nil_l [_ ⊃ _]);
  apply impR; simpl.
  auto.
Qed.

(* 1.115.3 *)
Theorem imp_cons A1 A2 B1 B2 :
  [] → [A1 ∧ A2 ⊃ B1 ∨ B2] -> [A1 ; A2] → [B1 ; B2].
Proof.
  intro H.
  rewrite <- (app_nil_l [_; _]).
  rewrite <- (app_nil_l [B1;_]).
  apply cut with ( A := A1 ∧ A2 ⊃ B1 ∨ B2); simpl.
  - auto.
  - assert ([A1 ∧ A2 ⊃ B1 ∨ B2; A1; A2] = A1 ∧ A2 ⊃ B1 ∨ B2 ::  [A1; A2] ++ []) by auto;
    rewrite H0; clear H0;
    rewrite <- (app_nil_l [B1; B2]);
    apply impL; simpl.
    - rewrite <- (app_nil_l [_ ∧ _]);
      apply andR; simpl.
      - rewrite <- (app_nil_l [_ ; _]);
        apply changeL; simpl.
        apply weakL.
        apply init.
      - apply weakL.
        apply init.
    - apply orL.
      * rewrite (cons_app B1 [B2]);
        apply weakR.
        apply init.
      * rewrite <- app_nil_l;
        rewrite <- (app_nil_r [B1; B2]);
        apply changeR; simpl.
        rewrite (cons_app B2 [B1]);
        apply weakR.
        apply init.
Qed.

Fixpoint bigAnd l :=
  match l with
  | [] => ⊤
  | p :: l' => p ∧ bigAnd l'
  end.

Fixpoint bigOr l :=
  match l with
  | [] => ⊥
  | p :: l' => p ∨ bigOr l'
  end.

Notation "Γ ₊" := (bigAnd Γ)(at level 15).
Notation "Γ ⁺" := (bigOr Γ)(at level 15).

Lemma bigOr_app l r v :
  valuation v (bigOr (l ++ r)) = valuation v  (bigOr l ∨ bigOr r).
Proof.
  induction l => //=.
  rewrite fls_false => //=.
  rewrite IHl => /=.
  apply orb_assoc.
Qed.

Lemma bigAnd_app l r v :
  valuation v (bigAnd (l ++ r)) = valuation v  (bigAnd l ∧ bigAnd r).
Proof.
  induction l => //=.
  rewrite tru_true; simpl; auto .
  rewrite IHl => //=.
  apply andb_assoc.
Qed.

Theorem soundness Γ Δ :
  Γ → Δ -> tautology (bigAnd Γ ⊃ bigOr Δ).
Proof.
  induction 1; intro v; simpl;
    try repeat match goal with
    | [H : tautology _ |- _] => specialize (H v); simpl in H
    end;

    try rewrite bigOr_app in IHprv;
    try rewrite bigOr_app in IHprv1;
    try rewrite bigOr_app in IHprv2;
    try rewrite bigAnd_app in IHprv;
    try rewrite bigAnd_app in IHprv1;
    try rewrite bigAnd_app in IHprv2; simpl in *;

    try rewrite IHprv;
    try rewrite IHprv1;
    try rewrite IHprv2;
    try rewrite bigAnd_app;
    try rewrite bigOr_app;
    try rewrite fls_false;
    try rewrite tru_true; simpl; auto;

    try destruct (valuation v (bigAnd Γ));
    try destruct (valuation v (bigOr Δ));
    try destruct (valuation v (bigAnd Π));
    try destruct (valuation v (bigOr Σ));
    try destruct (valuation v A);
    try destruct (valuation v B); simpl; auto;

    try rewrite fls_false in IHprv;
    try rewrite fls_false in IHprv1;
    try rewrite fls_false in IHprv2; simpl in *; auto;
    inversion IHprv.
Qed.

Notation sqc := (prod (list prop) (list prop)).
Notation dcp :=( prod (option sqc) (option sqc)).

(* Inductive decomp : dcp -> sqc -> Prop :=
  | andRt A B Γ Δ1 Δ2 :
    decomp (Some (Γ, ( Δ1 ++ A :: Δ2)), (Some (Γ ,( Δ1 ++ B :: Δ2)))) (Γ, ( Δ1 ++ A ∧ B :: Δ2))
  | andLt A B Γ1 Γ2 Δ :
     decomp ((Some (Γ1 ++ A :: B :: Γ2, Δ)), None) ((Γ1 ++ A ∧ B :: Γ2 ), Δ)
  | orRt A B Γ Δ1 Δ2 :
    decomp (Some (Γ, ( Δ1 ++ A :: B :: Δ2)), None) (Γ, ( Δ1 ++ A ∨ B :: Δ2))
  | orLt A B Γ1 Γ2 Δ :
    decomp (Some ((Γ1 ++ A :: Γ2 ), Δ), Some ((Γ1 ++ B :: Γ2 ),Δ )) ((Γ1 ++ A ∨ B :: Γ2 ), Δ)
  | impRt A B Γ Δ1 Δ2 :
    decomp (Some ((A :: Γ ), ( Δ1 ++ B :: Δ2)), None) (Γ, ( Δ1 ++ A ⊃ B :: Δ2))
  | impLt A B Γ1 Γ2 Δ :
    decomp (Some ((Γ1 ++  Γ2 ), ( Δ ++ [A])), Some ((Γ1 ++ B :: Γ2 ), Δ)) ((Γ1 ++ A ⊃ B :: Γ2 ), Δ)
  | notRt A Γ Δ1 Δ2 :
    decomp (Some ((A :: Γ ), ( Δ1 ++ Δ2)), None) (Γ, ( Δ1 ++ ¬ A :: Δ2))
  | notLt A Γ1 Γ2 Δ :
    decomp (Some ((Γ1 ++ Γ2 ), ( Δ ++ [A])), None) ((Γ1 ++ ¬ A :: Γ2 ), Δ). *)

Inductive decomp : list prop -> list prop -> list prop -> list prop -> Prop :=
  | andR1P A B Γ Δ1 Δ2 : decomp Γ ( Δ1 ++ A :: Δ2) Γ ( Δ1 ++ A ∧ B :: Δ2)
  | andR2P A B Γ Δ1 Δ2 : decomp Γ ( Δ1 ++ B :: Δ2) Γ ( Δ1 ++ A ∧ B :: Δ2)
  | andLP A B Γ1 Γ2 Δ : decomp (Γ1 ++ A :: B :: Γ2 ) Δ (Γ1 ++ A ∧ B :: Γ2 ) Δ

  | orRP A B Γ Δ1 Δ2 : decomp Γ ( Δ1 ++ A :: B :: Δ2) Γ ( Δ1 ++ A ∨ B :: Δ2)
  | orLP1 A B Γ1 Γ2 Δ : decomp (Γ1 ++ A :: Γ2 ) Δ (Γ1 ++ A ∨ B :: Γ2 ) Δ
  | orLP2 A B Γ1 Γ2 Δ : decomp (Γ1 ++ B :: Γ2 ) Δ (Γ1 ++ A ∨ B :: Γ2 ) Δ

  | impRP A B Γ Δ1 Δ2 : decomp (A :: Γ ) ( Δ1 ++ B :: Δ2) Γ ( Δ1 ++ A ⊃ B :: Δ2)
  | impLP1 A B Γ1 Γ2 Δ : decomp (Γ1 ++  Γ2 ) ( Δ ++ [A]) (Γ1 ++ A ⊃ B :: Γ2 ) Δ
  | impLP2 A B Γ1 Γ2 Δ : decomp (Γ1 ++ B :: Γ2 ) Δ (Γ1 ++ A ⊃ B :: Γ2 ) Δ

  | notRP A Γ Δ1 Δ2 : decomp (A :: Γ ) ( Δ1 ++ Δ2) Γ ( Δ1 ++ ¬ A :: Δ2)
  | notLP A Γ1 Γ2 Δ : decomp (Γ1 ++ Γ2 ) ( Δ ++ [A]) (Γ1 ++ ¬ A :: Γ2 ) Δ.

Fixpoint count (A : prop) : nat :=
  match A with
  | # p => 0

  (* | ⊥ => 0 *)
  | ¬ B => 1 + count B
  | B ∧ C => 1 + count B + count C
  | B ∨ C => 1 + count B + count C
  | B ⊃ C => 1 + count B + count C
  end.

Fixpoint sum l : nat :=
  match l with
  | [] => 0
  | a :: l' => a + sum l'
  end.

Definition counts (l : list prop) := sum (map count l).
Definition counts' p := counts (fst p) + counts (snd p).

Theorem sum_app l r :
  sum (l ++ r) = sum l + sum r.
Proof.
  induction l => //=.
  rewrite IHl.
  rewrite PeanoNat.Nat.add_assoc; auto.
Qed.

(* Theorem decomp_lt pp p :
  decomp pp p ->
  match pp with
  | (Some pl, None) => counts' pl < counts' p
  | (Some pl, Some pr) => counts' pl < counts' p /\ counts' pr < counts' p
  | _ => False
  end.
Proof.
  move => H; induction H; try split;
  rewrite /counts' /counts;
  repeat rewrite  map_app sum_app => //=; lia.
Qed. *)

Theorem decomp_lt Γ Δ Γ' Δ' :
  decomp Γ' Δ' Γ Δ -> counts Γ' + counts Δ' < counts Γ + counts Δ.
Proof.
  induction 1;
  repeat rewrite /counts map_app sum_app //=; try lia.
Qed.

Definition tautology' p := tautology (((fst p)₊ ⊃ (snd p)⁺)).

(* Theorem decomp_tautology pp p :
  decomp pp p -> tautology' p ->
  match pp with
  | (Some pl, None) => tautology' p
  | (Some pl, Some pr) => tautology' pl /\ tautology' pr
  | _ => False
  end.
Proof.
  inversion_clear 1 => H; try split;
  move => f;
  specialize (H f);
  simpl in *;
  try rewrite bigOr_app;
  try rewrite bigAnd_app;
  try rewrite bigOr_app in H;
  try rewrite bigAnd_app in H;
  simpl in *;
  try destruct (valuation f A);
  try destruct (valuation f B);
  try destruct (valuation f (bigAnd Γ));
  try destruct (valuation f (bigAnd Γ1));
  try destruct (valuation f (bigAnd Γ2));
  try destruct (valuation f (bigOr Δ));
  try destruct (valuation f (bigOr Δ1));
  try destruct (valuation f (bigOr Δ2));
  simpl in *; auto; inversion H.
Qed. *)

(* 1.10.2 *)
Theorem decomp_tautology Γ Δ Γ' Δ' :
  decomp Γ' Δ' Γ Δ -> tautology (Γ₊⊃Δ⁺) -> tautology (Γ'₊⊃Δ'⁺).
Proof.
  move => H;
    inversion_clear H => H f;
    specialize (H f);
    simpl in *;
    try rewrite bigOr_app;
    try rewrite bigAnd_app;
    try rewrite bigOr_app in H;
    try rewrite bigAnd_app in H;
    simpl in *;
    try destruct (valuation f A);
    try destruct (valuation f B);
    try destruct (valuation f (bigAnd Γ));
    try destruct (valuation f (bigAnd Γ1));
    try destruct (valuation f (bigAnd Γ2));
    try destruct (valuation f (bigOr Δ));
    try destruct (valuation f (bigOr Δ1));
    try destruct (valuation f (bigOr Δ2));
    simpl in *; auto; inversion H.
Qed.

Theorem in_ex {A} (a : A) (l : list A) :
  In a l -> exists h t, l = h ++ a :: t.
Proof.
  induction l => H //=.
  induction H; subst.
  - exists [], l; auto.
  - move : (IHl H) => [h [t Hl]]; subst.
    exists (a0 :: h), t; auto.
Qed.

Definition allf := fun _ : var => false.

Definition allt := fun _ : var => true.

Reserved Notation "Γ ⟶ Δ" (at level 80).
Inductive prv' : list prop -> list prop -> Prop :=
  | initc A : [A] ⟶ [A]
  | initTopc : [] ⟶ [⊤]
  | initBotc : [⊥] ⟶ []

  | weakLc A Γ Δ : Γ ⟶ Δ -> (A :: Γ) ⟶ Δ
  | weakRc A Γ Δ : Γ ⟶ Δ -> Γ ⟶ (Δ ++ [A])

  | contraLc A Γ Δ : (A :: A :: Γ) ⟶ Δ -> (A :: Γ) ⟶ Δ
  | contraRc A Γ Δ : Γ ⟶ (Δ ++ [A ; A]) -> Γ ⟶ (Δ ++ [A])

  | changeLc A B Γ Π Δ : (Γ ++ A :: B :: Π) ⟶ Δ -> (Γ ++ B :: A :: Π) ⟶ Δ
  | changeRc A B Γ Δ Σ : Γ ⟶ (Δ ++ A :: B :: Σ) -> Γ ⟶ (Δ ++ B :: A :: Σ)

  | andL1c A B Γ Δ : A :: Γ ⟶ Δ ->  A ∧ B :: Γ ⟶ Δ
  | andL2c A B Γ Δ : B :: Γ ⟶ Δ ->  A ∧ B :: Γ ⟶ Δ
  | andRc A B Γ Δ : Γ ⟶ Δ ++ [A] -> Γ ⟶ Δ ++ [B] ->  Γ ⟶ Δ ++ [A ∧ B]

  | orLc A B Γ Δ : A :: Γ ⟶ Δ -> B :: Γ ⟶ Δ -> A ∨ B :: Γ ⟶ Δ
  | orR1c A B Γ Δ : Γ ⟶ Δ ++ [A] -> Γ ⟶ Δ ++ [A ∨ B]
  | orR2c A B Γ Δ : Γ ⟶ Δ ++ [B] -> Γ ⟶ Δ ++ [A ∨ B]

  | impLc A B Γ Π Δ Σ : Γ ⟶ Δ ++ [A] -> B :: Π ⟶ Σ -> A ⊃ B :: Γ ++ Π ⟶ Δ ++ Σ
  | impRc A B Γ Δ : A :: Γ ⟶ Δ ++ [B] -> Γ ⟶ Δ ++ [A ⊃ B]

  | notLc A Γ Δ : Γ ⟶ Δ ++ [A] -> ¬ A :: Γ ⟶ Δ
  | notRc A Γ Δ : A :: Γ ⟶ Δ -> Γ ⟶ Δ ++ [¬ A]
  where "Γ ⟶ Δ" := (prv' Γ Δ).

Theorem changeL' A l1 l2 r :
  l1 ++ l2 ++ [A] ⟶ r -> l1 ++ A :: l2 ⟶ r.
Proof.
  move : l1; induction l2 => //= l1 H.
  apply changeLc.
  assert (a :: A :: l2 = [a] ++ A :: l2) by induction l2 => //=.
  rewrite H0; clear H0.
  rewrite app_assoc.
  apply IHl2.
  rewrite <- app_assoc.
  assert ([a] ++ l2 ++ [A] = a :: l2 ++ [A]) by induction l2 => //=.
  rewrite H0; clear H0; auto.
Qed.

Theorem changeL'' A l1 l2 r :
  l1 ++ A :: l2 ⟶ r -> l1 ++ l2 ++ [A] ⟶ r.
Proof.
  move : l1.
  induction l2 => /= l1 H //=.
  rewrite app_comm_cons.
  rewrite app_assoc.
  assert (l1 ++ a :: l2 = (l1 ++ [a]) ++ l2). {
    clear H.
    induction l1 => //=.
    rewrite IHl1; auto.
  }
  rewrite H0; clear H0.
  rewrite <- app_assoc.
  apply IHl2.
  assert ((l1 ++ [a]) ++ A :: l2 = l1 ++ a :: A :: l2). {
    clear H; induction l1 => //=; rewrite IHl1; auto.
  }
  rewrite H0; clear H0.
  apply changeLc; auto.
Qed.

Theorem changeR' A l r1 r2 :
  l ⟶ r1 ++ r2 ++ [A] -> l ⟶ r1 ++ A :: r2.
Proof.
  move : r1; induction r2 => //= r1 H.
  apply changeRc.
  assert (a :: A :: r2 = [a] ++ A :: r2) by induction r2 => //=.
  rewrite H0; clear H0.
  rewrite app_assoc.
  apply IHr2.
  rewrite <- app_assoc.
  assert ([a] ++ r2 ++ [A] = a :: r2 ++ [A]) by induction r2 => //=.
  rewrite H0; clear H0; auto.
Qed.

Theorem changeR'' A l r1 r2 :
l ⟶ r1 ++ A :: r2 ->  l ⟶ r1 ++ r2 ++ [A] .
Proof.
  move : r1; induction r2 => r1 H //=.
  rewrite app_comm_cons.
  rewrite app_assoc.
  assert (r1 ++ a :: r2 = (r1 ++ [a]) ++ r2). {
    clear H.
    induction r1 => //=.
    rewrite IHr1; auto.
  }
  rewrite H0; clear H0.
  rewrite <- app_assoc.
  apply IHr2.
  assert ((r1 ++ [a]) ++ A :: r2 = r1 ++ a :: A :: r2). {
    clear H; induction r1 => //=; rewrite IHr1; auto.
  }
  rewrite H0; clear H0.
  apply changeRc; auto.
Qed.

Theorem swapL l1 l2 r :
  (l1 ++ l2) ⟶ r -> (l2 ++ l1) ⟶ r.
Proof.
  move : l1; induction l2 => l1 //= H.
  - rewrite app_nil_r in H; auto.
  - rewrite cons_app app_assoc in H.
    apply IHl2 in H.
    rewrite app_comm_cons.
    assert (a :: l2 = [a] ++ l2) by (induction l2 => //=).
    rewrite H0; clear H0.
    rewrite <- app_assoc.
    rewrite <- (app_nil_l (_ ++ _)).
    apply changeL'; simpl.
    rewrite <- app_assoc; auto.
Qed.

Theorem swapR l r1 r2 :
  l ⟶ r1 ++ r2 -> l ⟶ r2 ++ r1.
Proof.
  move : r1; induction r2 => r1 //= H.
  - rewrite app_nil_r in H; auto.
  - rewrite cons_app app_assoc in H.
    apply IHr2 in H.
    rewrite app_comm_cons.
    rewrite cons_app.
    rewrite <- app_assoc.
    rewrite <- (app_nil_l (_ ++ _)).
    apply changeR'; simpl.
    rewrite <- app_assoc; auto.
Qed.

Theorem changeL''' A l1 l2 r :
  A :: (l1 ++ l2) ⟶ r -> l1 ++ A :: l2 ⟶ r.
Proof.
  move : r l2; induction l1 => //= r l2 H.
  rewrite <- (app_nil_l (a :: _)).
  apply changeL'; simpl.
  rewrite <- app_assoc.
  rewrite cons_app.
  rewrite <- app_assoc.
  rewrite <- (cons_app A).
  apply IHl1.
  rewrite cons_app.
  apply swapL.
  repeat rewrite <- app_assoc.
  rewrite app_assoc; simpl.
  apply changeLc.
  apply swapL; simpl; auto.
Qed.

Theorem weakL' A l r :
  [A] ⟶ r -> A :: l ⟶ r .
Proof.
  move : A r; induction l => // A r H.
  rewrite <- (app_nil_l (A :: _)).
  apply changeLc; simpl.
  apply weakLc.
  apply IHl; auto.
Qed.

Theorem weakR' A l r :
  l ⟶ [A] -> l ⟶ r ++ [A].
Proof.
  move : A l; induction r => //= A l H.
  rewrite <- (app_nil_l (a :: _)).
  apply changeR'; simpl.
  apply weakRc.
  apply IHr; auto.
Qed.

(* 1.11.2 *)
Theorem same_elm A Γ1 Γ2 Δ1 Δ2 :
  Γ1 ++ A :: Γ2 ⟶ Δ1 ++ A :: Δ2.
Proof.
  apply changeL'''.
  apply changeR'.
  apply weakL'.
  rewrite app_assoc.
  apply weakR'.
  apply initc.
Qed.

Theorem contraR' l r1 r2 :
  l ⟶ r1 ++ r2 ++ r2 -> l ⟶ r1 ++ r2.
Proof.
  move : r1; induction r2 => r1 H //=.
  rewrite cons_app app_assoc.
  apply IHr2.
  rewrite <- app_assoc.
  apply changeR'.
  rewrite app_assoc.
  apply contraRc.
  rewrite cons_app in H.
  rewrite <- app_assoc in H.
  apply changeR'' in H.
  rewrite app_assoc in H.
  rewrite (app_assoc r1 r2) in H.
  rewrite <- app_assoc in H.
  assert (([a] ++ r2) ++ [a] = [a] ++ r2 ++ [a]).
    rewrite app_assoc; auto.
  rewrite H0 in H.
  apply changeR'' in H.
  repeat rewrite <- app_assoc in H.
  simpl in H.
  repeat rewrite <- app_assoc; auto.
Qed.

Theorem contraL' l1 l2 r :
  l1 ++ l2 ++ l2 ⟶ r -> l1 ++ l2 ⟶ r.
Proof.
  move : l1; induction l2 => l1 H //=.
  rewrite cons_app app_assoc.
  apply IHl2.
  rewrite <- app_assoc.
  apply swapL.
  repeat rewrite  <- app_assoc.
  rewrite <- cons_app.
  apply contraLc.
  repeat rewrite app_comm_cons.
  rewrite app_assoc.
  apply swapL.
  repeat rewrite <- app_comm_cons.
  apply changeL'.
  rewrite <- app_comm_cons.
  apply changeL'.
  repeat rewrite <- app_assoc.
  rewrite <- app_comm_cons in H.
  apply changeL'' in H.
  repeat rewrite app_assoc in H.
  rewrite <- app_assoc in H.
  rewrite <- app_comm_cons in H.
  apply changeL'' in H.
  repeat rewrite <- app_assoc in H; auto.
Qed.

Definition prv'' (pp : dcp) :=
    match pp with
    | (Some p, None) => fst p ⟶ snd p
    | (Some pl, Some pr) => fst pl ⟶ snd pl /\ fst pr ⟶ snd pr
    | _ => False
    end.

Theorem decomp_prv A B X Y :
  (* decomp X Y A B <==> X ⟶ Y が A ⟶ B の分解 *)
  (forall X Y, decomp X Y A B -> X ⟶ Y) ->
  decomp X Y A B ->
  X ⟶ Y -> A ⟶ B.
Proof.
  move => H0 Hd XY.
  inversion Hd; subst.
  - apply changeR'.
    rewrite app_assoc.
    apply andRc;
      rewrite <- app_assoc;
      eapply changeR'' => //.
    apply H0; constructor.
  - apply changeR'.
    rewrite app_assoc.
    apply andRc;
      rewrite <- app_assoc;
      eapply changeR'' => //.
    apply H0; constructor.
  - apply swapL.
    rewrite <- app_comm_cons.
    apply contraLc.
    apply andL1c.
    rewrite <- (app_nil_l (_ :: _)); apply changeL'; simpl.
    apply andL2c.
    rewrite <- (app_nil_l (_ :: _)); apply changeL'; simpl.
    repeat rewrite <- app_assoc.
    apply swapL.
    repeat rewrite <- app_assoc.
    repeat rewrite <- cons_app; auto.
  - apply swapR.
    rewrite cons_app.
    rewrite <- app_assoc.
    rewrite <- (app_nil_l).
    apply changeR'; simpl.
    apply contraRc.
    rewrite cons_app app_assoc.
    apply orR1c.
    rewrite <- app_assoc.
    apply changeR'.
    rewrite app_assoc.
    apply orR2c.
    repeat rewrite <- app_assoc.
    apply swapR.
    repeat rewrite <- app_assoc.
    repeat rewrite <- cons_app; auto.
  - apply swapL.
    rewrite <- app_comm_cons.
    apply orLc.
    - rewrite <- (app_nil_l (_ :: _)). apply changeL'; simpl.
      rewrite <- app_assoc.
      apply swapL.
      rewrite <- app_assoc, <- cons_app; auto.
    - rewrite <- (app_nil_l (_ :: _)). apply changeL'; simpl.
      rewrite <- app_assoc.
      apply swapL.
      rewrite <- app_assoc, <- cons_app.
      apply H0; constructor.
  - apply swapL.
    rewrite <- app_comm_cons.
    apply orLc.
    - rewrite <- (app_nil_l (_ :: _)). apply changeL'; simpl.
      rewrite <- app_assoc.
      apply swapL.
      rewrite <- app_assoc, <- cons_app.
      apply H0; constructor.
    - rewrite <- (app_nil_l (_ :: _)). apply changeL'; simpl.
      rewrite <- app_assoc.
      apply swapL.
      rewrite <- app_assoc, <- cons_app; auto.
  - rewrite cons_app.
    apply swapR.
    rewrite <- app_assoc, <- app_nil_l.
    apply changeR'; simpl.
    apply impRc.
    rewrite <- app_assoc.
    apply swapR.
    rewrite <- app_assoc.
    rewrite <- cons_app; auto.
  - apply swapL.
    rewrite <- app_comm_cons.
    rewrite <- app_nil_l.
    apply contraR'; simpl.
    rewrite cons_app.
    apply contraL'.
    rewrite <- cons_app.
    apply impLc.
    - apply swapL; auto.
    - rewrite cons_app app_assoc.
      apply swapL.
      rewrite <- cons_app.
      apply H0; constructor.
  { apply swapL.
    rewrite <- app_comm_cons;
    rewrite <- app_nil_l;
    apply contraR'; simpl.
    rewrite cons_app;
    apply contraL'.
    rewrite <- cons_app;
    apply impLc.
    - apply swapL.
      apply H0.
      constructor.
    - rewrite cons_app app_assoc;
      apply swapL.
      rewrite <- cons_app.
      auto.
  }
  - apply changeR'.
    rewrite app_assoc.
    apply notRc; auto.
  - apply swapL.
    rewrite cons_app.
    rewrite  <- app_assoc.
    rewrite <- cons_app.
    apply notLc.
    apply swapL; auto.
Qed.

Section computability.

Variable A B : prop.
Definition S:= [A ⊃ B; A ⊃ B; A ⊃ B; A ⊃ B; A] → [B].

Goal S.
Proof.
  unfold S.

  rewrite <- (app_nil_l [B]).
  apply contraR; simpl.
  rewrite (cons_app B _).
  rewrite <- (app_nil_r (cons _ _)).
  eapply impL; [|apply init].
  apply weakR.

  rewrite <- (app_nil_l [B]).
  apply contraR; simpl.
  rewrite (cons_app B _).
  rewrite <- (app_nil_r (cons _ _)).
  eapply impL; [|apply init].
  apply weakR.

  rewrite <- (app_nil_l [B]).
  apply contraR; simpl.
  rewrite (cons_app B _).
  rewrite <- (app_nil_r (cons _ _)).
  eapply impL; [|apply init].
  apply weakR.

  simpl.
  rewrite <- app_nil_l.
  rewrite <- (app_nil_r [A ⊃ B;A]).
  apply impL; simpl ;apply init.
Qed.

End computability.

Lemma op_ex l :
  counts l > 1 ->
    (exists A B, In (A ∧ B) l) \/
    (exists A B, In (A ∨ B) l) \/
    (exists A B, In (A ⊃ B) l) \/
    (exists A, In (¬ A) l).
Proof.
  induction l => H; [inversion H|].
  destruct a; try (
    rewrite /counts in H;
    move : (IHl H) => [[A [B H']] | [[A [B H']] | [[A [B H']] | [A  H']]]];
    [left | right; left | right; right; left | right; right; right];
    try (exists A, B; right; auto );
    exists A; right; auto);
    [right; right; right | left | right; left | right; right; left];
    try (exists a; left; auto);
    exists a1, a2; left; auto.
Qed.

Inductive tree : list prop -> list prop -> Type :=
  | leaf l r : counts l = 0 -> counts r = 0 -> tree l r
  | andRt A B Γ Δ1 Δ2 :
    tree Γ ( Δ1 ++ A :: Δ2) -> tree Γ ( Δ1 ++ B :: Δ2) -> tree Γ ( Δ1 ++ A ∧ B :: Δ2)
  | andLt A B Γ1 Γ2 Δ :
    tree (Γ1 ++ A :: B :: Γ2 ) Δ -> tree (Γ1 ++ A ∧ B :: Γ2 ) Δ
  | orRt A B Γ Δ1 Δ2 :
    tree Γ ( Δ1 ++ A :: B :: Δ2) -> tree  Γ ( Δ1 ++ A ∨ B :: Δ2)
  | orLt A B Γ1 Γ2 Δ :
    tree (Γ1 ++ A :: Γ2 ) Δ -> tree  (Γ1 ++ B :: Γ2 ) Δ ->  tree (Γ1 ++ A ∨ B :: Γ2 ) Δ
  | impRt A B Γ Δ1 Δ2 :
    tree (A :: Γ ) ( Δ1 ++ B :: Δ2) -> tree Γ ( Δ1 ++ A ⊃ B :: Δ2)
  | impLt A B Γ1 Γ2 Δ :
    tree (Γ1 ++  Γ2 ) ( Δ ++ [A]) -> tree (Γ1 ++ B :: Γ2 ) Δ  ->tree (Γ1 ++ A ⊃ B :: Γ2 ) Δ
  | notRt A Γ Δ1 Δ2 :
    tree (A :: Γ ) ( Δ1 ++ Δ2) -> tree Γ ( Δ1 ++ ¬ A :: Δ2)
  | notLt A Γ1 Γ2 Δ :
    tree (Γ1 ++ Γ2 ) ( Δ ++ [A]) -> tree (Γ1 ++ ¬ A :: Γ2 ) Δ
  .

Fixpoint leaves {l r} (t : tree l r) : list (list prop * list prop):=
  match t with
  | andRt _ _ _ _ _ l' r' => leaves l' ++ leaves r'
  | andLt _ _ _ _ _ t' => leaves t'
  | orRt _ _ _ _ _ t' => leaves t'
  | orLt _ _ _ _ _ l' r' => leaves l' ++ leaves r'
  | impRt _ _ _ _ _ t' => leaves t'
  | impLt _ _ _ _ _ l' r' => leaves l' ++ leaves r'
  | notRt _ _ _ _ t' => leaves t'
  | notLt _ _ _ _ t' => leaves t'
  | leaf l' r' _ _ => [(l',r')]
  (* | _ => [] *)
  end.

Theorem leaves_counts0 l r (t : tree l r) :
  Forall (fun p => counts' p = 0) (leaves t).
Proof.
  induction t => //=; try (rewrite Forall_app; split; auto).
  constructor => //=.
  rewrite  /counts' => //=.
  rewrite e e0; auto.
Qed.

Inductive path (p : list prop * list prop) : (list prop * list prop) -> Prop :=
  | here : path p p
  | step A B X Y : decomp X Y A B -> path p (A,B) -> path p (X,Y).

Theorem path_taut p X Y :
  tautology' p ->  path p (X, Y) -> tautology' (X,Y).
Proof.
  move => H H0.
  induction H0; subst => //=.
  eapply decomp_tautology; eauto.
Qed.

Theorem leaves_path l r (t : tree l r) :
  forall p, In p (leaves t) -> path (l,r) p.
Proof.
  induction t => /= p Hp;
  try (case : Hp; [move ->; constructor| move => F; inversion F] );
  try (apply in_app_or in Hp; case : Hp; [
       move /IHt1 | move /IHt2] => H;
       induction H; econstructor; eauto; constructor);
  try (apply IHt in Hp; induction Hp; (econstructor; eauto); constructor).
Qed.

Theorem leaves_taut l r (t : tree l r) :
  tautology' (l,r) -> forall p, In p (leaves t) -> tautology' p.
Proof.
  move => H [l' r'] /leaves_path /path_taut.
  apply; auto.
Qed.

Theorem tree_taut l r (t : tree l r) :
  (forall l' r', In (l',r') (leaves t) -> l' ⟶ r') -> l ⟶ r.
Proof.
  move => H.
  induction t.
  -apply H; left => //.
  - apply changeR';
    rewrite app_assoc;
    apply andRc;
    rewrite <- app_assoc;
    apply swapR;
    rewrite <- app_assoc;
    apply changeR';
    apply swapR;
    rewrite <- app_assoc;
    rewrite <- cons_app;
    [apply IHt1| apply IHt2];
    move => l' r' Hp; apply H => /=;
    apply in_or_app;
    [left| right]; auto.
Admitted.

Theorem ex_tree l r :
  counts l + counts r <> 0 -> tree l r.
Proof.
Admitted.

Theorem completeness l r :
  tautology' (l,r) -> l ⟶ r.
Proof.
  move => H.
Admitted.

Fixpoint subform A B :=
  match B with
  | L ∧ R => A = B \/ subform A L \/ subform A R
  | L ∨ R => A = B \/ subform A L \/ subform A R
  | L ⊃ R => A = B \/ subform A L \/ subform A R
  | ¬ B' => A = B \/ subform A B'
  | _ => A = B
  end.

Fixpoint noImp (A : prop) : Prop :=
  match A with
  | L ∧ R => noImp L /\ noImp R
  | L ∨ R => noImp L /\ noImp R
  | _ ⊃ _ => False
  | ¬ A' => noImp A'
  | _ => True
  end.

Fixpoint dual (A : prop) : prop :=
  match A with
  | L ∧ R => dual L ∨ dual R
  | L ∨ R => dual L ∧ dual R
  | L ⊃ R => dual L ⊃ dual R
  | _ => A
  end.

Axiom entail_imp :
  forall A B, A → B <-> [] → [bigAnd A ⊃ bigOr B].

Axiom dummy : assign.
(* Axiom dummy_bot : dummy fls = false. *)
(* Axiom dummy_top : dummy tru = true. *)

Theorem nil_entail_nil :
  ~ ([] → []).
Proof.
  move /entail_imp => /= /soundness F.
  move : (F dummy); simpl.
  repeat rewrite fls_false tru_true; simpl.
  move => f; inversion f.
Qed.

Theorem to_entail A :
  [] → A -> In ⊤ A.
Proof.
  induction A.
  - move => F; case (nil_entail_nil F).
  - move => H.
    inversion a.
Admitted.

Theorem dual_entail_extension L R:
  Forall noImp L -> Forall noImp R -> L → R -> map dual L → map dual R.
Proof.
  move : R; induction L => R HL HR H; simpl.
Admitted.

Theorem cut_elim A B :
  A → B -> A ⟶ B.
Proof.
  move /soundness => H.
  apply completeness; auto.
Qed.

Theorem cut_intro A B :
  A ⟶ B -> A → B.
Proof.
Admitted.

Axiom entail_top :
  forall v, [] → [# v] -> # v = ⊤.

Axiom bot_entail :
  forall v, [# v] → [] -> # v = ⊥.

Lemma var_entail v A :
  [# v] → [A] -> A = # v \/ A = ⊤ \/ # v = ⊥.
Proof.
  move : v.
  induction A => u H.
  { admit. }
  {
    admit.
  }
  {

  }

Admitted.

Theorem prv_prop_ind (P : prop -> prop -> Prop) :
  (forall v B, # v = B -> P #v B) ->
  (forall B, P ⊥ B) ->
  (forall Al Ar B, [Al ∧ Ar] ⟶ [B] -> P (Al ∧ Ar) B) ->
  (forall Al Ar B, [Al ∨ Ar] ⟶ [B] -> P (Al ∨ Ar) B) ->
  (forall Al Ar B, [Al ⊃ Ar] ⟶ [B] -> P (Al ⊃ Ar) B) ->
  (forall A B, [¬ A] ⟶ [B] -> P (¬ A) B) ->
  forall A B, [A] ⟶ [B] -> P A B.
Proof.
  intros.
  destruct A; eauto.
Qed.

Theorem dual_entail A B :
  noImp A -> noImp B -> [A] → [B] -> [dual B] → [dual A].
Proof.
  move  => HA HB /cut_elim H.
  apply prv_prop_ind with (P := fun A B => [dual B] → [dual A]); intros; auto; simpl.
  Check prv'_ind.
  - admit.
  - admit.
  - apply cut_intro; apply completeness.
Restart.
  move => HA HB /soundness H.
  apply cut_intro.
  apply completeness => f.
  move : (H f); clear H; simpl.
  repeat rewrite andb_true_r orb_false_r.
  induction A; simpl; auto => H.
Restart.
  move => HA HB /cut_elim H.
  (* apply cut_intro. *)
  inversion H; subst.
  - constructor.
  - apply cut_intro.
    apply completeness => f.
    apply cut_intro in H; apply soundness in H; move : (H f); clear H .
    apply cut_intro in H3; apply soundness in H3; move : (H3 f); clear H3.
    simpl.
    repeat rewrite andb_true_r orb_false_r => fB.
    rewrite andb_true_r orb_false_r.
    rewrite fB.
    rewrite implb_true_r => _.

Restart.
  move => HA HB.
  move /cut_elim.
  eapply (prv_prop_ind (fun )).
  induction A; simpl.
  try match goal with
  | [ F : noImp (_ ⊃ _) |- _] => inversion F
  end.
  apply prv'_ind; intros; try solve [constructor].
  -


(* Exercise 22 *)

Require Import BenB.

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

Theorem exercise_022 : (exists x : D, R x x /\ P x) -> ~ (forall x : D, P x -> ~ (exists y : D, R x y)).
Proof.
imp_i a1.
exi_e (exists x:D, R x x /\ P x) a a3.
hyp a1.
neg_i (exists y:D, R a y) a2.
imp_e (P a).
all_e (forall x : D, P x -> ~ (exists y : D, R x y)) a.
hyp a2.
con_e2 (R a a).
hyp a3.
exi_i a.
con_e1 (P a).
hyp a3.
Qed.


(** * MoreCoq: More About Coq *)

Require Export Poly.

(** This chapter introduces several more Coq tactics that,
    together, allow us to prove many more theorems about the
    functional programs we are writing. *)

(* ###################################################### *)
(** * The [apply] Tactic *)

(** We often encounter situations where the goal to be proved is
    exactly the same as some hypothesis in the context or some
    previously proved lemma. *)

Theorem silly1 : forall (n m o p : nat),
     n = m  ->
     [n,o] = [n,p] ->
     [n,o] = [m,p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  (* At this point, we could finish with
     "[rewrite -> eq2. reflexivity.]" as we have
     done several times above. But we can achieve the
     same effect in a single step by using the
     [apply] tactic instead: *)
  apply eq2.  Qed.

(** The [apply] tactic also works with _conditional_ hypotheses
    and lemmas: if the statement being applied is an implication, then
    the premises of this implication will be added to the list of
    subgoals needing to be proved. *)

Theorem silly2 : forall (n m o p : nat),
     n = m  ->
     (forall (q r : nat), q = r -> [q,o] = [r,p]) ->
     [n,o] = [m,p].
Proof.
  intros n m o p eq1 eq2.
  apply eq2. apply eq1.  Qed.

(** You may find it instructive to experiment with this proof
    and see if there is a way to complete it using just [rewrite]
    instead of [apply]. *)

(** Typically, when we use [apply H], the statement [H] will
    begin with a [forall] binding some _universal variables_.  When
    Coq matches the current goal against the conclusion of [H], it
    will try to find appropriate values for these variables.  For
    example, when we do [apply eq2] in the following proof, the
    universal variable [q] in [eq2] gets instantiated with [n] and [r]
    gets instantiated with [m]. *)

Theorem silly2a : forall (n m : nat),
     (n,n) = (m,m)  ->
     (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
     [n] = [m].
Proof.
  intros n m eq1 eq2.
  apply eq2. apply eq1.  Qed.

(** **** Exercise: 2 stars, optional (silly_ex) *)
(** Complete the following proof without using [simpl]. *)

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     evenb 3 = true ->
     oddb 4 = true.
Proof.
intros eq1 eq2.
apply eq1. apply eq2.
Qed.

(** [] *)

Theorem silly6 : forall (n : nat),
     S n = O ->
     2 + 2 = 5.
Proof.
  intros n contra. inversion contra. Qed.

Theorem silly7 : forall (n m : nat),
     false = true ->
     [n] = [m].
Proof.
  intros n m contra. inversion contra.  Qed.

(** **** Exercise: 1 star (sillyex2) *)
Example sillyex2 : forall (X : Type) (x y z : X) (l j : list X),
     x :: y :: l = [] ->
     y :: l = z :: j ->
     x = z.
Proof.
intros X x y z l j contra.
inversion contra.
Qed.
  (* FILL IN HERE *)
(** [] *)

(** While the injectivity of constructors allows us to reason
    [forall (n m : nat), S n = S m -> n = m], the reverse direction of
    the implication, provable by standard equational reasoning, is a
    useful fact to record for cases we will see several times. *)

Lemma eq_remove_S : forall n m,
  n = m -> S n = S m.
Proof. intros n m eq. rewrite -> eq. reflexivity. Qed.

(** Here's another illustration of [inversion].  This is a slightly
    roundabout way of stating a fact that we have already proved
    above.  The extra equalities force us to do a little more
    equational reasoning and exercise some of the tactics we've seen
    recently. *)

Theorem length_snoc' : forall (X : Type) (v : X)
                              (l : list X) (n : nat),
     length l = n ->
     length (snoc l v) = S n.
Proof.
  intros X v l. induction l as [| v' l'].
  Case "l = []". intros n eq. rewrite <- eq. reflexivity.
  Case "l = v' :: l'". intros n eq. simpl. destruct n as [| n'].
    SCase "n = 0". inversion eq.
    SCase "n = S n'".
      apply eq_remove_S. apply IHl'. inversion eq. reflexivity. Qed.

(** **** Exercise: 2 stars, optional (practice) *)
(** A couple more nontrivial but not-too-complicated proofs to work
    together in class, or for you to work as exercises.  They may
    involve applying lemmas from earlier lectures or homeworks. *)

Theorem beq_nat_0_l : forall n,
  true = beq_nat 0 n -> 0 = n.
Proof.
intros n eq1. destruct n.
Case "n = 0". reflexivity.
Case "n = S n'". inversion eq1.
Qed.
  (* FILL IN HERE *)

Theorem beq_nat_0_r : forall n,
  true = beq_nat 0 n -> 0 = n.
Proof.
  intros n eq1. destruct n.
  Case "n = 0". reflexivity.
  Case "n = S n'". inversion eq1.
  Qed.
  (* FILL IN HERE *)
(** [] *)

(* ###################################################### *)
(** * Using Tactics on Hypotheses *)

(** By default, most tactics work on the goal formula and leave
    the context unchanged.  However, most tactics also have a variant
    that performs a similar operation on a statement in the context.

    For example, the tactic [simpl in H] performs simplification in
    the hypothesis named [H] in the context. *)

Theorem S_inj : forall (n m : nat) (b : bool),
     beq_nat (S n) (S m) = b  ->
     beq_nat n m = b.
Proof.
  intros n m b H. simpl in H. apply H.  Qed.

(** Similarly, the tactic [apply L in H] matches some
    conditional statement [L] (of the form [L1 -> L2], say) against a
    hypothesis [H] in the context.  However, unlike ordinary
    [apply] (which rewrites a goal matching [L2] into a subgoal [L1]),
    [apply L in H] matches [H] against [L1] and, if successful,
    replaces it with [L2].

    In other words, [apply L in H] gives us a form of "forward
    reasoning" -- from [L1 -> L2] and a hypothesis matching [L1], it
    gives us a hypothesis matching [L2].  By contrast, [apply L] is
    "backward reasoning" -- it says that if we know [L1->L2] and we
    are trying to prove [L2], it suffices to prove [L1].

    Here is a variant of a proof from above, using forward reasoning
    throughout instead of backward reasoning. *)

Theorem silly3' : forall (n : nat),
  (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
     true = beq_nat n 5  ->
     true = beq_nat (S (S n)) 7.
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H.  Qed.

(** Forward reasoning starts from what is _given_ (premises,
    previously proven theorems) and iteratively draws conclusions from
    them until the goal is reached.  Backward reasoning starts from
    the _goal_, and iteratively reasons about what would imply the
    goal, until premises or previously proven theorems are reached.
    If you've seen informal proofs before (for example, in a math or
    computer science class), they probably used forward reasoning.  In
    general, Coq tends to favor backward reasoning, but in some
    situations the forward style can be easier to use or to think
    about.  *)

(** **** Exercise: 3 stars (plus_n_n_injective) *)
(** Practice using "in" variants in this exercise. *)

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
  intros m eq1. destruct m.
    SCase "m = 0". reflexivity.
    SCase "m = S m'". inversion eq1.
  Case "n = S n'".
  intros m eq2. destruct m.
    SCase "m = 0". inversion eq2.
    SCase "m = S m'". inversion eq2.
    rewrite <- plus_n_Sm in H0.
    symmetry in H0. rewrite <- plus_n_Sm in H0. inversion H0.
    symmetry in H1. apply IHn' in H1. rewrite H1. reflexivity.
    (* Hint: use the plus_n_Sm lemma *)
    (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** * Varying the Induction Hypothesis *)

(** In the previous chapter, we noticed the importance of
    controlling the exact form of the induction hypothesis when
    carrying out inductive proofs in Coq.  In particular, we need to
    be careful about which of the assumptions we move (using [intros])
    from the goal to the context before invoking the [induction]
    tactic.  In this short chapter, we consider this point in a little
    more depth and introduce one new tactic, called [generalize
    dependent], that is sometimes useful in helping massage the
    induction hypothesis into the required form.

    First, let's review the basic issue.  Suppose we want to show that
    the [double] function is injective -- i.e., that it always maps
    different arguments to different results.  The way we _start_ this
    proof is a little bit delicate: if we begin it with
      intros n. induction n.
]]
    all is well.  But if we begin it with
      intros n m. induction n.
    we get stuck in the middle of the inductive case... *)

Theorem double_injective_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction n as [| n'].
  Case "n = O". simpl. intros eq. destruct m as [| m'].
    SCase "m = O". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'". intros eq. destruct m as [| m'].
    SCase "m = O". inversion eq.
    SCase "m = S m'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
      (* Here we are stuck.  We need the assertion in order to
         rewrite the final goal (subgoal 2 at this point) to an
         identity.  But the induction hypothesis, [IHn'], does
         not give us [n' = m'] -- there is an extra [S] in the
         way -- so the assertion is not provable. *)
      Admitted.

(** What went wrong? *)

(** The problem is that, at the point we invoke the induction
    hypothesis, we have already introduced [m] into the context --
    intuitively, we have told Coq, "Let's consider some particular
    [n] and [m]..." and we now have to prove that, if [double n =
    double m] for _this particular_ [n] and [m], then [n = m].

    The next tactic, [induction n] says to Coq: We are going to show
    the goal by induction on [n].  That is, we are going to prove that
    the proposition

      - [P n]  =  "if [double n = double m], then [n = m]"

    holds for all [n] by showing

      - [P O]

         (i.e., "if [double O = double m] then [O = m]")

      - [P n -> P (S n)]

        (i.e., "if [double n = double m] then [n = m]" implies "if
        [double (S n) = double m] then [S n = m]").

    If we look closely at the second statement, it is saying something
    rather strange: it says that, for a _particular_ [m], if we know

      - "if [double n = double m] then [n = m]"

    then we can prove

       - "if [double (S n) = double m] then [S n = m]".

    To see why this is strange, let's think of a particular [m] --
    say, [5].  The statement is then saying that, if we know

      - [Q] = "if [double n = 10] then [n = 5]"

    then we can prove

      - [R] = "if [double (S n) = 10] then [S n = 5]".

    But knowing [Q] doesn't give us any help with proving [R]!  (If we
    tried to prove [R] from [Q], we would say something like "Suppose
    [double (S n) = 10]..." but then we'd be stuck: knowing that
    [double (S n)] is [10] tells us nothing about whether [double n]
    is [10], so [Q] is useless at this point.) *)

(** To summarize: Trying to carry out this proof by induction on [n]
    when [m] is already in the context doesn't work because we are
    trying to prove a relation involving _every_ [n] but just a
    _single_ [m]. *)

(** The good proof of [double_injective] leaves [m] in the goal
    statement at the point where the [induction] tactic is invoked on
    [n]: *)

Theorem double_injective' : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = O". simpl. intros m eq. destruct m as [| m'].
    SCase "m = O". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'".
    (* Notice that both the goal and the induction
       hypothesis have changed: the goal asks us to prove
       something more general (i.e., to prove the
       statement for _every_ [m]), but the IH is
       correspondingly more flexible, allowing us to
       choose any [m] we like when we apply the IH.  *)
    intros m eq.
    (* Now we choose a particular [m] and introduce the
       assumption that [double n = double m].  Since we
       are doing a case analysis on [n], we need a case
       analysis on [m] to keep the two "in sync." *)
    destruct m as [| m'].
    SCase "m = O".
      (* The 0 case is trivial *)
      inversion eq.
    SCase "m = S m'".
      (* At this point, since we are in the second
         branch of the [destruct m], the [m'] mentioned
         in the context at this point is actually the
         predecessor of the one we started out talking
         about.  Since we are also in the [S] branch of
         the induction, this is perfect: if we
         instantiate the generic [m] in the IH with the
         [m'] that we are talking about right now (this
         instantiation is performed automatically by
         [apply]), then [IHn'] gives us exactly what we
         need to finish the proof. *)
      assert (n' = m') as H.
      SSCase "Proof of assertion". apply IHn'.
        inversion eq. reflexivity.
      rewrite -> H. reflexivity.  Qed.

(** What this teaches us is that we need to be careful about using
    induction to try to prove something too specific: If we're proving
    a property of [n] and [m] by induction on [n], we may need to
    leave [m] generic. *)

(** **** Exercise: 2 stars (beq_nat_eq) *)
Theorem beq_nat_eq : forall n m,
  true = beq_nat n m -> n = m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, advanced (beq_nat_eq_informal) *)
(** Give a careful informal proof of [beq_nat_eq], being as explicit
    as possible about quantifiers. *)

(* FILL IN HERE *)
(** [] *)

(** The strategy of doing fewer [intros] before an [induction] doesn't
    always work directly; sometimes a little _rearrangement_ of
    quantified variables is needed.  Suppose, for example, that we
    wanted to prove [double_injective] by induction on [m] instead of
    [n]. *)

Theorem double_injective_take2_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction m as [| m'].
  Case "m = O". simpl. intros eq. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". inversion eq.
  Case "m = S m'". intros eq. destruct n as [| n'].
    SCase "n = O". inversion eq.
    SCase "n = S n'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
        (* Stuck again here, just like before. *)
Admitted.

(** The problem is that, to do induction on [m], we must first
    introduce [n].  (If we simply say [induction m] without
    introducing anything first, Coq will automatically introduce
    [n] for us!)   *)

(** What can we do about this?  One possibility is to rewrite the
    statement of the lemma so that [m] is quantified before [n].  This
    will work, but it's not nice: We don't want to have to mangle the
    statements of lemmas to fit the needs of a particular strategy for
    proving them -- we want to state them in the most clear and
    natural way. *)

(**  What we can do instead is to first introduce all the
    quantified variables and then _re-generalize_ one or more of
    them, taking them out of the context and putting them back at
    the beginning of the goal.  The [generalize dependent] tactic
    does this. *)

Theorem double_injective_take2 : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m.
  (* [n] and [m] are both in the context *)
  generalize dependent n.
  (* Now [n] is back in the goal and we can do induction on
     [m] and get a sufficiently general IH. *)
  induction m as [| m'].
  Case "m = O". simpl. intros n eq. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". inversion eq.
  Case "m = S m'". intros n eq. destruct n as [| n'].
    SCase "n = O". inversion eq.
    SCase "n = S n'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
        apply IHm'. inversion eq. reflexivity.
      rewrite -> H. reflexivity.  Qed.

(** Let's look at an informal proof of this theorem.  Note that
    the proposition we prove by induction leaves [n] quantified,
    corresponding to the use of generalize dependent in our formal
    proof.

_Theorem_: For any nats [n] and [m], if [double n = double m], then
  [n = m].

_Proof_: Let [m] be a [nat]. We prove by induction on [m] that, for
  any [n], if [double n = double m] then [n = m].

  - First, suppose [m = 0], and suppose [n] is a number such
    that [double n = double m].  We must show that [n = 0].

    Since [m = 0], by the definition of [double] we have [double n =
    0].  There are two cases to consider for [n].  If [n = 0] we are
    done, since this is what we wanted to show.  Otherwise, if [n = S
    n'] for some [n'], we derive a contradiction: by the definition of
    [double] we would have [n = S (S (double n'))], but this
    contradicts the assumption that [double n = 0].

  - Otherwise, suppose [m = S m'] and that [n] is again a number such
    that [double n = double m].  We must show that [n = S m'], with
    the induction hypothesis that for every number [s], if [double s =
    double m'] then [s = m'].

    By the fact that [m = S m'] and the definition of [double], we
    have [double n = S (S (double m'))].  There are two cases to
    consider for [n].

    If [n = 0], then by definition [double n = 0], a contradiction.
    Thus, we may assume that [n = S n'] for some [n'], and again by
    the definition of [double] we have [S (S (double n')) = S (S
    (double m'))], which implies by inversion that [double n' = double
    m'].

    Instantiating the induction hypothesis with [n'] thus allows us to
    conclude that [n' = m'], and it follows immediately that [S n' = S
    m'].  Since [S n' = n] and [S m' = m], this is just what we wanted
    to show. [] *)

(** **** Exercise: 3 stars (gen_dep_practice) *)

(** Prove this by induction on [l]. *)

Theorem index_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     index (S n) l = None.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced, optional (index_after_last_informal) *)
(** Write an informal proof corresponding to your Coq proof
    of [index_after_last]:

     _Theorem_: For all sets [X], lists [l : list X], and numbers
      [n], if [length l = n] then [index (S n) l = None].

     _Proof_:
     (* FILL IN HERE *)
[]
*)

(** **** Exercise: 3 stars, optional (gen_dep_practice_more) *)
(** Prove this by induction on [l]. *)

Theorem length_snoc''' : forall (n : nat) (X : Type)
                              (v : X) (l : list X),
     length l = n ->
     length (snoc l v) = S n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (app_length_cons) *)
(** Prove this by induction on [l1], without using [app_length]. *)

Theorem app_length_cons : forall (X : Type) (l1 l2 : list X)
                                  (x : X) (n : nat),
     length (l1 ++ (x :: l2)) = n ->
     S (length (l1 ++ l2)) = n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, optional (app_length_twice) *)
(** Prove this by induction on [l], without using app_length. *)

Theorem app_length_twice : forall (X:Type) (n:nat) (l:list X),
     length l = n ->
     length (l ++ l) = n + n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** * Using [destruct] on Compound Expressions *)

(** We have seen many examples where the [destruct] tactic is
    used to perform case analysis of the value of some variable.  But
    sometimes we need to reason by cases on the result of some
    _expression_.  We can also do this with [destruct].

    Here are some examples: *)

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (beq_nat n 3).
    Case "beq_nat n 3 = true". reflexivity.
    Case "beq_nat n 3 = false". destruct (beq_nat n 5).
      SCase "beq_nat n 5 = true". reflexivity.
      SCase "beq_nat n 5 = false". reflexivity.  Qed.

(** After unfolding [sillyfun] in the above proof, we find that
    we are stuck on [if (beq_nat n 3) then ... else ...].  Well,
    either [n] is equal to [3] or it isn't, so we use [destruct
    (beq_nat n 3)] to let us reason about the two cases. *)

(** **** Exercise: 1 star (override_shadow) *)
Theorem override_shadow : forall {X:Type} x1 x2 k1 k2 (f : nat->X),
  (override (override f k1 x2) k1 x1) k2 = (override f k1 x1) k2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (combine_split) *)
(** Remove the comment brackets (needed because [split] was defined in
    a previous exercise) and complete the proof. *)

(*
Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  (* FILL IN HERE *) Admitted.
*)
(** [] *)

(** **** Exercise: 3 stars, advanced (split_combine) *)
(** We have just proven that for all lists of pairs, [combine] is the
    inverse of [split].  How would you formalize the statement that
    [split] is the inverse of [combine]?

    State this as a theorem in Coq, and prove it. (Be sure to leave
    your induction hypothesis general by not doing [intros] on more
    things than necessary.  Hint: what property do you need of [l1]
    and [l2] for [split] [combine l1 l2 = (l1,l2)] to be true?) *)

(* FILL IN HERE *)
(** [] *)

(* ###################################################### *)
(** * The [remember] Tactic *)

(** We have seen how the [destruct] tactic can be used to
    perform case analysis of the results of arbitrary computations.
    If [e] is an expression whose type is some inductively defined
    type [T], then, for each constructor [c] of [T], [destruct e]
    generates a subgoal in which all occurrences of [e] (in the goal
    and in the context) are replaced by [c].

    Sometimes, however, this substitution process loses information
    that we need in order to complete the proof.  For example, suppose
    we define a function [sillyfun1] like this: *)

Definition sillyfun1 (n : nat) : bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
  else false.

(** And suppose that we want to convince Coq of the rather
    obvious observation that [sillyfun1 n] yields [true] only when [n]
    is odd.  By analogy with the proofs we did with [sillyfun] above,
    it is natural to start the proof like this: *)

Theorem sillyfun1_odd_FAILED : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (beq_nat n 3).
  (* stuck... *)
Admitted.

(** We get stuck at this point because the context does not
    contain enough information to prove the goal!  The problem is that
    the substitution peformed by [destruct] is too brutal -- it threw
    away every occurrence of [beq_nat n 3], but we need to keep at
    least one of these because we need to be able to reason that
    since, in this branch of the case analysis, [beq_nat n 3 = true],
    it must be that [n = 3], from which it follows that [n] is odd.

    What we would really like is not to use [destruct] directly on
    [beq_nat n 3] and substitute away all occurrences of this
    expression, but rather to use [destruct] on something else that is
    _equal_ to [beq_nat n 3].  For example, if we had a variable that
    we knew was equal to [beq_nat n 3], we could [destruct] this
    variable instead.

    The [remember] tactic allows us to introduce such a variable. *)

Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  remember (beq_nat n 3) as e3.
  (* At this point, the context has been enriched with a new
     variable [e3] and an assumption that [e3 = beq_nat n 3].
     Now if we do [destruct e3]... *)
  destruct e3.
  (* ... the variable [e3] gets substituted away (it
    disappears completely) and we are left with the same
     state as at the point where we got stuck above, except
     that the context still contains the extra equality
     assumption -- now with [true] substituted for [e3] --
     which is exactly what we need to make progress. *)
    Case "e3 = true". apply beq_nat_eq in Heqe3.
      rewrite -> Heqe3. reflexivity.
    Case "e3 = false".
     (* When we come to the second equality test in the
       body of the function we are reasoning about, we can
        use [remember] again in the same way, allowing us
        to finish the proof. *)
      remember (beq_nat n 5) as e5. destruct e5.
        SCase "e5 = true".
          apply beq_nat_eq in Heqe5.
          rewrite -> Heqe5. reflexivity.
        SCase "e5 = false". inversion eq.  Qed.

(** **** Exercise: 2 stars *)
Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (override_same) *)
Theorem override_same : forall {X:Type} x1 k1 k2 (f : nat->X),
  f k1 = x1 ->
  (override f k1 x1) k2 = f k2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** * The [apply ... with ...] Tactic *)

(** The following silly example uses two rewrites in a row to
    get from [[a,b]] to [[e,f]]. *)

Example trans_eq_example : forall (a b c d e f : nat),
     [a,b] = [c,d] ->
     [c,d] = [e,f] ->
     [a,b] = [e,f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity.  Qed.

(** Since this is a common pattern, we might
    abstract it out as a lemma recording once and for all
    the fact that equality is transitive. *)

Theorem trans_eq : forall {X:Type} (n m o : X),
  n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2.
  reflexivity.  Qed.

(** Now, we should be able to use [trans_eq] to
    prove the above example.  However, to do this we need
    a slight refinement of the [apply] tactic. *)

Example trans_eq_example' : forall (a b c d e f : nat),
     [a,b] = [c,d] ->
     [c,d] = [e,f] ->
     [a,b] = [e,f].
Proof.
  intros a b c d e f eq1 eq2.
  (* If we simply tell Coq [apply trans_eq] at this point,
     it can tell (by matching the goal against the
     conclusion of the lemma) that it should instantiate [X]
     with [[nat]], [n] with [[a,b]], and [o] with [[e,f]].
     However, the matching process doesn't determine an
     instantiation for [m]: we have to supply one explicitly
     by adding [with (m:=[c,d])] to the invocation of
     [apply]. *)
  apply trans_eq with (m:=[c,d]). apply eq1. apply eq2.   Qed.

(**  Actually, we usually don't have to include the name [m]
    in the [with] clause; Coq is often smart enough to
    figure out which instantiation we're giving. We could
    instead write: apply trans_eq with [c,d]. *)

(** **** Exercise: 3 stars (apply_with_exercise3) *)
Theorem override_permute : forall {X:Type} x1 x2 k1 k2 k3 (f : nat->X),
  false = beq_nat k2 k1 ->
  (override (override f k2 x2) k1 x1) k3 = (override (override f k1 x1) k2 x2) k3.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (apply_with_exercise1) *)
Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (apply_with_exercise2) *)
Theorem beq_nat_trans : forall n m p,
  true = beq_nat n m ->
  true = beq_nat m p ->
  true = beq_nat n p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

(** We've now seen a bunch of Coq's fundamental tactics.  We'll
    introduce a few more as we go along through the coming lectures,
    and later in the course we'll introduce some more powerful
    _automation_ tactics that make Coq do more of the low-level work
    in many cases.  But basically we've got what we need to get work
    done.

    Here are the ones we've seen:

      - [intros]:
        move hypotheses/variables from goal to context

      - [reflexivity]:
        finish the proof (when the goal looks like [e = e])

      - [apply]:
        prove goal using a hypothesis, lemma, or constructor

      - [apply... in H]:
        apply a hypothesis, lemma, or constructor to a hypothesis in
        the context (forward reasoning)

      - [apply... with...]:
        explicitly specify values for variables that cannot be
        determined by pattern matching

      - [simpl]:
        simplify computations in the goal

      - [simpl in H]:
        ... or a hypothesis

      - [rewrite]:
        use an equality hypothesis (or lemma) to rewrite the goal

      - [rewrite ... in H]:
        ... or a hypothesis

      - [symmetry]:
        changes a goal of the form [t=u] into [u=t]

      - [symmetry in H]:
        changes a hypothesis of the form [t=u] into [u=t]

      - [unfold]:
        replace a defined constant by its right-hand side in the goal

      - [unfold... in H]:
        ... or a hypothesis

      - [destruct... as...]:
        case analysis on values of inductively defined types

      - [induction... as...]:
        induction on values of inductively defined types

      - [inversion]:
        reason by injectivity and distinctness of constructors

      - [remember (e) as x]:
        give a name ([x]) to an expression ([e]) so that we can
        destruct [x] without "losing" [e]

      - [assert (e) as H]:
        introduce a "local lemma" [e] and call it [H]

      - [generalize dependent x]:
        move the variable [x] (and anything else that depends on it)
        from the context back to an explicit hypothesis in the goal
        formula
*)
Check [1 :: nil].

(* ###################################################### *)
(** * Additional Exercises *)

(** **** Exercise: 3 stars (beq_nat_sym) *)
Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced, optional (beq_nat_sym_informal) *)
(** Give an informal proof of this lemma that corresponds to your
    formal proof above:

   Theorem: For any [nat]s [n] [m], [beq_nat n m = beq_nat m n].

   Proof:
   (* FILL IN HERE *)
[]
 *)

(** **** Exercise: 3 stars, advanced (filter_exercise) *)
(** This one is a bit challenging.  Pay attention to the form of your IH. *)

Theorem filter_exercise : forall (X : Type) (test : X -> bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced (forall_exists_challenge) *)
(** Define two recursive [Fixpoints], [forallb] and [existsb].  The
    first checks whether every element in a list satisfies a given
    predicate:
      forallb oddb [1,3,5,7,9] = true

      forallb negb [false,false] = true

      forallb evenb [0,2,4,5] = false

      forallb (beq_nat 5) [] = true
    The second checks whether there exists an element in the list that
    satisfies a given predicate:
      existsb (beq_nat 5) [0,2,3,6] = false

      existsb (andb true) [true,true,false] = true

      existsb oddb [1,0,0,0,0,3] = true

      existsb evenb [] = false
    Next, define a _nonrecursive_ version of [existsb] -- call it
    [existsb'] -- using [forallb] and [negb].

    Prove that [existsb'] and [existsb] have the same behavior.
*)

(* FILL IN HERE *)
(** [] *)

(* $Date: 2013-01-30 18:38:07 -0500 (Wed, 30 Jan 2013) $ *)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf2 : natural) (x : natural) : natural :=
  plus y (mult (Succ y) x).


(** * 6.822 Formal Reasoning About Programs, Spring 2022 - Pset 5 *)

Require Import Frap.Frap.
Require Import Pset5Sig.

Module Impl.
  (* In this pset, we will explore different ways of defining semantics for the
     simple imperative language we used in Chapter 4 (Interpreters.v) and
     Chapter 7 (OperationalSemantics.v).
     Make sure to reread these two files, because many definitions we ask you
     to come up with in this pset are similar to definitions in these two files.

     Pset5Sig.v contains the number of points you get for each definition and
     proof. Note that since we ask you to come up with some definitions
     yourself, all proofs being accepted by Coq does not necessarily guarantee a
     full score: you also need to make sure that your definitions correspond to
     what we ask for in the instructions. *)

  (* Our language has arithmetic expressions (note that we removed Times and Minus,
     because they don't add anything interesting for this pset): *)
  Inductive arith: Set :=
  | Const (n: nat)
  | Var (x: var)
  | Plus (e1 e2: arith).

  (* And it has commands, some of which contain arithmetic expressions: *)
  Inductive cmd :=
  | Skip
  | Assign (x: var) (e: arith)
  | Sequence (c1 c2: cmd)
  | If (e: arith) (thn els: cmd)
  | While (e: arith) (body: cmd).

  (* As in the lecture, we use a finite map to store the values of the variables: *)
  Definition valuation := fmap var nat.

  (** * Part 1: Using a recursive function **)

  (* To make it a bit more interesting, we add a twist:
     If an arithmetic expression reads an undefined variable, instead of just
     returning 0, we specify that an arbitrary value can be returned.
     Therefore, the signature we used in class,

       Fixpoint interp (e: arith) (v: valuation): nat :=
         ...

     will not work any more, because that one can only return one value.
     Instead, we will use the following definition: *)

  Fixpoint interp (e: arith) (v: valuation) (retval: nat): Prop :=
    match e with
    | Const n => retval = n
    | Var x =>
      match v $? x with
      | None => True (* any retval is possible! *)
      | Some n => retval = n
      end
    | Plus e1 e2 =>
      exists a1 a2,
      interp e1 v a1 /\
      interp e2 v a2 /\
      retval = a1 + a2
    end.
  (* You can read [interp e v retval] as the claim that "interpreting expression
     e under the valuation v can return the value retval".
     And if we don't provide the last argument, we can think of "interp e v",
     which has type "nat -> Prop", as "the set of all possible values e could
     return". *)

  (* Let's look at some examples: *)

  (* The only result allowed by [Const 3] is [3]: *)
  Compute interp (Const 3) _.

  (* If we interpret the expression "y + z" in a valuation where
     y is 2 and z is 3, then the only possible result is 5. *)

  Goal forall retval,
      interp (Plus (Var "y") (Var "z"))
             ($0 $+ ("y", 2) $+ ("z", 3))
             retval <->
      retval = 5.
  Proof.
    simplify; propositional.
    - cases H; cases H.
      linear_arithmetic.
    - exists 2, 3.
      propositional.
  Qed.

  (* We can also look at this in terms of a partial application: *)

  Goal interp (Plus (Var "y") (Var "z"))
              ($0 $+ ("y", 2) $+ ("z", 3)) =
       (fun retval => retval = 5).
  Proof.
    simplify.
    apply sets_equal; simplify; propositional.
    - cases H; cases H.
      linear_arithmetic.
    - exists 2, 3.
      propositional.
  Qed.

  (* But if we leave [z] unset in the valuation, then [Var "z"] can return any
     value, and hence the complete program can return any value greater than or
     equal to 2. *)
  Goal interp (Plus (Var "y") (Var "z")) ($0 $+ ("y", 2)) = (fun retval => 2 <= retval).
  Proof.
    simplify.
    apply sets_equal.
    propositional.
    - cases H. cases H. linear_arithmetic.
    - exists 2, (x - 2). linear_arithmetic.
  Qed.

  (* Hint that will be useful later:
     In the above proof, you can see how you can deal with existentials:
     - If you have an [H: exists x, P] above the line, you can "cases H"
       to obtain such an "x" and "H: P".
     - If you have an [exists x, P] below the line, you can use "exists x0" to
       provide the value [x0] for which you want to prove the existential.
     Instead of repeating [cases], you can also use [first_order]. *)

  (** * Part 2: Using an inductive relation **)

  (* An alternative way of specifying how arithmetic expressions are evaluated
     is by using inference rules, where we put preconditions above the line,
     the conclusion below the line, and a name of the rule to the right of
     the line, using "Oxford brackets" to write statements of the form
     "a ∈ ⟦e⟧ᵥ" which we read as "the natural number a is in the set of
     values to which e can evaluate under the valuation v".
     If we were to write this on a blackboard, it might look like this:

                           n1 = n2
                        ------------ ValuesConst
                         n1 ∈ ⟦n2⟧ᵥ

                         (x ↦ a) ∈ v
                        -------------- ValuesVarDefined
                           a ∈ ⟦x⟧ᵥ

                         x ∉ dom(v)
                       ------------- ValuesVarUndefined
                         a ∈ ⟦x⟧ᵥ

            a1 ∈ ⟦e1⟧ᵥ   a2 ∈ ⟦e2⟧ᵥ   a=a1+a2
            ----------------------------------- ValuesPlus
                       a ∈ ⟦e1+e2⟧ᵥ

     Let's translate this to an Inductive Prop in Coq called "values". That is,
     [values e v a] should mean “the natural number a is in the set of
     values to which e can evaluate under the valuation v”.

     Define an Inductive with four constructors, one for each of the four rules
     above, using the names written to the rights of the lines above as the
     constructor names.  We have included ValuesConst to give you a hint.
  *)
  Inductive values: arith -> valuation -> nat -> Prop :=
  | ValuesConst: forall v n1 n2,
      n1 = n2 ->
      values (Const n1) v n2
  .

  (* Note that the following alternative would also work for ValuesConst and
     ValuesPlus:

                    ---------- ValuesConst
                     n ∈ ⟦n⟧ᵥ

            a1 ∈ ⟦e1⟧ᵥ     a2 ∈ ⟦e2⟧ᵥ
            --------------------------- ValuesPlus
                a1+a2 ∈ ⟦e1+e2⟧ᵥ

     But in Coq, this would be a bit less convenient, because the tactic
     [eapply ValuesPlus] would only work if the goal is of the shape
     [values _ _ (_ + _)], whereas if we add this extra equality,
     [eapply ValuesPlus] works no matter what the last argument to [values] is,
     and similarly for [ValuesConst]. *)

  (* Contrary to the Fixpoint-based definition "interp", we can't do simplification
     of the kind "replace interp by its body and substitute the arguments in it",
     because an Inductive Prop describes a family of proof trees and isn't a
     function with a right-hand side you could plug in somewhere else.
     In order to prove the example Goal from above for "values", we need to construct
     the following proof tree:

    ("y"↦2) ∈ {"y"↦2}              "z" ∉ dom({"y"↦2})
   -------------------- Defined    ----------------------- Undefined
    2 ∈ ⟦"y"⟧_{"y"↦2}               a-2 ∈ ⟦"z"⟧_{"y"↦2}              a=2+a-2
   ---------------------------------------------------------------------------- ValuesPlus
                        a ∈ ⟦"y"+"z"⟧_{"y"↦2}
  *)
  Example values_example: forall a,
      2 <= a ->
      values (Plus (Var "y") (Var "z")) ($0 $+ ("y", 2)) a.
  Proof.
    (* "simplify" only introduces the hypotheses but can't really simplify
       anything here. This is not a limitation of "simplify"; it's due to the
       way [values] is defined. *)
    simplify.
    (* Once you define the four constructors for "values", you can uncomment
       the script below. Make sure you understand how it relates to the proof
       tree above! *)
    (*
    eapply ValuesPlus with (a1 := 2) (a2 := a - 2).
    - eapply ValuesVarDefined. simplify. equality.
    - eapply ValuesVarUndefined. simplify. equality.
    - linear_arithmetic.
      *)
  Admitted.

  (* Now, let's prove that "interp" and "values" are equivalent.
     First, [interp -> values]: *)
  Theorem interp_to_values: forall e v a,
      interp e v a -> values e v a.
  Proof.
  Admitted.

  (* To prove the other direction, we have a choice: we can either induct on
     [e] or directly on the proof of [values e v a], because [values] is an
     inductively defined predicate.

     Let's do both proofs.  In general, inducting on the proof tree is the right
     approach, so let's start with that: *)
  Theorem values_to_interp: forall e v a,
      values e v a -> interp e v a.
  Proof.
    induct 1; (* ← do not change this line *)
      simplify.
  Admitted.

  (* Now let's see how things look with an induction on e.  In this simple case,
     it's very similar: *)
  Theorem values_to_interp_induction_on_e: forall e v a,
      values e v a -> interp e v a.
  Proof.
    induct e; (* ← not the best, but for the sake of the exercise do not change this line *)
      simplify.
  Admitted.

  (* Let's define nondeterministic big-step semantics for evaluating a command.
     Define [eval] as an Inductive Prop such that [eval v1 c v2] means
     "If we run command c on valuation v1, we can obtain valuation v2".
     Whenever you encounter an arithmetic expression, use [values] to obtain a
     value it can step to.
     Hint: This will be quite similar to [eval] in OperationalSemantics.v! *)
  Inductive eval: valuation -> cmd -> valuation -> Prop :=
  | EvalSkip: forall v,
      eval v Skip v
  .

  (* Hint: Many of the proofs below will depend on definitions we ask you to
     find yourself, and if you get these definitions wrong, the proofs will
     not work, so keep in mind that you might have to go back and adapt your
     definitions!
     Also, it can happen that many proofs go through and you become (overly)
     confident that your definitions are correct, even though they aren't. *)

  (* Here's an example program. If we run it on the empty valuation, reading the
     variable "oops" can return any value, but after that, no matter whether
     "oops" was zero or not, we assign a nonzero value to "tmp", so the answer
     will always be 42. *)
  Example the_answer_is_42 :=
    Sequence (Assign "x" (Var "oops"))
             (Sequence (If (Var "x")
                           (Assign "tmp" (Plus (Var "x") (Var "x")))
                           (Assign "tmp" (Const 1)))
                       (If (Var "tmp")
                           (Assign "answer" (Const 42))
                           (Assign "answer" (Const 24)))).

  (* To prove that this sample program always returns 42, we first prove a handy
     helper lemma (the [simplify] tactic will help with [$+]): *)
  Lemma read_last_value: forall x v c n,
      values (Var x) (v $+ (x, c)) n -> n = c.
  Proof.
  Admitted.

  (* Hint: This next theorem is a bit boring -- it's about 30 lines of "invert",
     "simplify", "discriminate", "equality", "linear_arithmetic" and
     "apply read_last_value in H", "subst" in our solution.

     But it's a good test case to make sure you got the definition of "eval"
     right! And note that inverting the hypotheses in the right order, i.e. in
     the order the program is executed, as well as using "read_last_value"
     whenever possible, will make your proof less long.

     (Or, you could use automation — our automated proof is 8 lines long.) *)
  Theorem the_answer_is_indeed_42:
    forall v, eval $0 the_answer_is_42 v -> v $? "answer" = Some 42.
  Proof.
  Admitted.

  (* Here's another example program. If we run it on a valuation that is
     undefined for "x", it will read the undefined variable "x" to decide
     whether to abort the loop, so any number of loop iterations is possible. *)
  Example loop_of_unknown_length :=
    (While (Var "x") (Assign "counter" (Plus (Var "counter") (Const 1)))).

  (* Hint: you might need the "maps_equal" tactic to prove that two maps are the same. *)
  Theorem eval_loop_of_unknown_length: forall n initialCounter,
      eval ($0 $+ ("counter", initialCounter))
           loop_of_unknown_length
           ($0 $+ ("counter", initialCounter + n)).
  Proof.
    unfold loop_of_unknown_length.
    induct n; simplify.
  Admitted.

  (* Wherever this TODO_FILL_IN is used, you should replace it with your own code *)
  Axiom TODO_FILL_IN: Prop.

  (** * Part 3: Fixpoints with fuel **)

  (* You might wonder whether we can use "Fixpoint" instead of "Inductive" to define
     such nondeterministic big-step evaluation of commands, and indeed we can.
     But we need some trick to convince Coq that this Fixpoint will always terminate,
     even though there could be infinite loops.

     We achieve this by using a "fuel" argument that limits the recursion depth.
     This does not exclude any possible final valuations, because for every final
     valuation, there exists a recursion depth sufficient to reach it.

     So let's define a Fixpoint [run] such that [run fuel v1 c v2] means
     "if we run command c on valuation v1 and limit the recursion depth to fuel,
     we can obtain valuation v2".

     We already defined all cases for you except the [While] case, but all the
     building blocks you need can be found in the other cases, too.
   *)
  Fixpoint run (fuel: nat) (v1: valuation) (c: cmd) (v2: valuation): Prop :=
    match fuel with
    | O => False
    | S fuel' =>
      match c with
      | Skip => v1 = v2
      | Assign x e => exists a, interp e v1 a /\ v2 = (v1 $+ (x, a))
      | Sequence c1 c2 => exists vmid, run fuel' v1 c1 vmid /\ run fuel' vmid c2 v2
      | If e c1 c2 =>
        (exists r, interp e v1 r /\ r <> 0 /\ run fuel' v1 c1 v2) \/
        (interp e v1 0 /\ run fuel' v1 c2 v2)
      | While e c1 =>
        TODO_FILL_IN
      end
    end.

  (* Now let's prove that [run] and [eval] are equivalent! *)

  Local Hint Constructors eval : core.

  Theorem run_to_eval: forall fuel v1 c v2,
      run fuel v1 c v2 ->
      eval v1 c v2.
  Proof.
  Admitted.

  (* To prove the other direction, we will need the following lemma, which shows
     that excess fuel isn't an issue.

     Hint: Here, some proof automation might pay off!

     You could try writing a [repeat match goal] loop, to do all possible
     simplifications on your hypotheses and then use [eauto] to solve
     the goal. Maybe you need to increase the maximum search depth of eauto;
     in our solution, we had to write [eauto 9] instead of just [eauto],
     which defaults to [eauto 5].

     Some useful documentation pointers:
     - https://coq.inria.fr/refman/proofs/automatic-tactics/auto.html#coq:tacn.eauto
     - https://coq.inria.fr/refman/proof-engine/ltac.html?highlight=repeat#pattern-matching-on-goals-and-hypotheses-match-goal

     And note that [eauto] does not know about linear arithmetic by default,
     so you could consider registering it as a [Hint Extern], but a simpler
     way here would be to use the lemma "le_S_n" to turn "S fuel1 <= S fuel2"
     into "fuel1 <= fuel2", which will be needed for the IH. *)

  Lemma run_monotone: forall fuel1 fuel2 v1 c v2,
      fuel1 <= fuel2 ->
      run fuel1 v1 c v2 ->
      run fuel2 v1 c v2.
  Proof.
  Admitted.

  (* For the other direction, we could naively start proving it like this: *)
  Theorem eval_to_run: forall v1 c v2,
      eval v1 c v2 -> exists fuel, run fuel v1 c v2.
  Proof.
    induct 1; simplify.
    (* This proof is relatively short and straightforward, but dealing with
       existentials is not very pleasant!

       This problem becomes worse if we make many proofs about "run".  So, instead,
       let's look at a nicer formulation of this theorem. *)
  Abort. (* <-- do not change this line *)

  (* We will first define a wrapper around "run" that hides the existential: *)
  Definition wrun (v1: valuation) (c: cmd) (v2: valuation): Prop :=
    exists fuel, run fuel v1 c v2.

  (* The idea is that in the run_to_eval proof above, using the constructors of
     "eval", i.e. doing "eapply EvalAssign", "eapply EvalSeq", "eapply EvalIfTrue",
     was quite convenient, so let's expose the same "API" for constructing proofs
     of "run" (or actually, proofs of the slightly nicer "wrun"). *)

  (* Now let's define proof rules to get the same "API" for "wrun" as for "eval".
     Hint: Again, some proof automation might simplify the task (but manual proofs are
     possible too, of course).  You may find the `max` function useful. *)

  Definition WRunSkip_statement : Prop :=
    forall v,
      wrun v Skip v.
  Lemma WRunSkip: WRunSkip_statement.
  Proof.
  Admitted.

  Definition WRunAssign_statement : Prop :=
    forall v x e a,
      interp e v a ->
      wrun v (Assign x e) (v $+ (x, a)).
  Lemma WRunAssign: WRunAssign_statement.
  Proof.
  Admitted.

  Definition WRunSeq_statement : Prop :=
    forall v c1 v1 c2 v2,
      wrun v c1 v1 ->
      wrun v1 c2 v2 ->
      wrun v (Sequence c1 c2) v2.
  Lemma WRunSeq: WRunSeq_statement.
  Proof.
  Admitted.

  (* For the next few lemmas, we've left you the job of stating the theorem as
     well as proving it. *)

  Definition WRunIfTrue_statement : Prop. Admitted.
  Lemma WRunIfTrue: WRunIfTrue_statement.
  Proof.
  Admitted.

  Definition WRunIfFalse_statement : Prop. Admitted.
  Lemma WRunIfFalse: WRunIfFalse_statement.
  Proof.
  Admitted.

  Definition WRunWhileTrue_statement : Prop. Admitted.
  Lemma WRunWhileTrue: WRunWhileTrue_statement.
  Proof.
  Admitted.

  Definition WRunWhileFalse_statement : Prop. Admitted.
  Lemma WRunWhileFalse: WRunWhileFalse_statement.
  Proof.
  Admitted.

  (* Now, thanks to these helper lemmas, proving the direction from eval to wrun
     becomes easy: *)
  Theorem eval_to_wrun: forall v1 c v2,
      eval v1 c v2 ->
      wrun v1 c v2.
  Proof.
  Admitted.

  (* Remember when we said earlier that [induct 1] does induction on the proof
     of [eval], whereas [induct c] does induction on the program itself?  Try
     proving the above with [induct c] instead of [induct 1], skipping straight
     to the [While] cases.  Why isn't the theorem provable this way? *)

  (* The following definitions are needed because of a limitation of Coq
     (the kernel does not recognize that a parameter can be instantiated by an
     inductive type).
     Please do not remove them! *)
  Definition values_alias_for_grading := values.
  Definition eval_alias_for_grading := eval.

  (* You've reached the end of this pset, congratulations! *)

  (* ****** Everything below this line is optional ****** *)

  (* Many of the proofs above can be automated.  A good way to test your
     automation is to make small changes to the language.

     For example, you could add an [Unset: string -> cmd] constructor to the
     definition of [cmd]; the semantics of that command should be to remove a
     variable from the current valuation (use [v $- "x"] to remove ["x"] from
     [v]).

     In our solution, adding [Unset] and updating definitions and proofs
     accordingly takes just a few extra lines.  Try it in yours! *)

  (* Let's take the deterministic semantics we used in OperationalSemantics.v but
     prefix them with "d" to mark them as deterministic: *)

  Fixpoint dinterp (e: arith) (v: valuation): nat :=
    match e with
    | Const n => n
    | Var x =>
      match v $? x with
      | None => 0
      | Some n => n
      end
    | Plus e1 e2 => dinterp e1 v + dinterp e2 v
    end.

  Inductive deval: valuation -> cmd -> valuation -> Prop :=
  | DEvalSkip: forall v,
      deval v Skip v
  | DEvalAssign: forall v x e,
      deval v (Assign x e) (v $+ (x, dinterp e v))
  | DEvalSeq: forall v c1 v1 c2 v2,
      deval v c1 v1 ->
      deval v1 c2 v2 ->
      deval v (Sequence c1 c2) v2
  | DEvalIfTrue: forall v e thn els v',
      dinterp e v <> 0 ->
      deval v thn v' ->
      deval v (If e thn els) v'
  | DEvalIfFalse: forall v e thn els v',
      dinterp e v = 0 ->
      deval v els v' ->
      deval v (If e thn els) v'
  | DEvalWhileTrue: forall v e body v' v'',
      dinterp e v <> 0 ->
      deval v body v' ->
      deval v' (While e body) v'' ->
      deval v (While e body) v''
  | DEvalWhileFalse: forall v e body,
      dinterp e v = 0 ->
      deval v (While e body) v.

  (* Now let's prove that if a program evaluates to a valuation according to the
     deterministic semantics, it also evaluates to that valuation according to
     the nondeterministic semantics (the other direction does not hold, though). *)
  Theorem deval_to_eval: forall v1 v2 c,
      deval v1 c v2 ->
      eval v1 c v2.
  Proof.
  Admitted.

  (* In deterministic semantics, Fixpoints work a bit better, because they
     can return just one value, and let's use "option" to indicate whether
     we ran out of fuel: *)
  Fixpoint drun(fuel: nat) (v: valuation) (c: cmd): option valuation. Admitted.

  (* More open-ended exercise:
     Now we have six different definitions of semantics:

                          deterministic     nondeterministic

     Inductive            deval             eval

     Wrapped Fixpoint     dwrun             wrun

     Fixpoint             drun              run

     We have proved that all the nondeterministic semantics are equivalent among
     each other.
     If you want, you could also prove that all the deterministic semantics are
     equivalent among each other and experiment whether it's worth creating an
     "Inductive"-like API for "dwrun", or whether you're ok dealing with drun's
     existentials when proving deval_to_drun.
     Moreover, we have proved that "deval" implies "eval", so every definition in
     the left column of the above table implies every definition in the right
     column of the table.
     If you're curious to learn more about the trade-offs between Inductive Props
     and Fixpoints, you can try to prove some of these implications directly
     and see how much harder than "deval_to_eval" it is (we believe that
     "deval_to_eval" is the simplest one).
   *)

End Impl.

Module ImplCorrect : Pset5Sig.S := Impl.

(* Authors:
   Samuel Gruetter
   Clément Pit-Claudel *)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (x : natural) : natural := mult (Succ x) lf2.


(** Calculation of an abstract machine for arithmetic expressions +
 state + unbounded loops. *)

Require Import List.
Require Import ListIndex.
Require Import Tactics.

(** * Syntax *)

Inductive Expr : Set :=
| Val : nat -> Expr
| Add : Expr -> Expr -> Expr
| Get : Expr.

Inductive Stmt : Set :=
| Put : Expr -> Stmt
| Seqn : Stmt -> Stmt -> Stmt
| While : Expr -> Stmt -> Stmt.

(** * Semantics *)

Definition State := nat.
Reserved Notation "x ⇓[ q ] y" (at level 80, no associativity).

Inductive eval : Expr -> State -> nat -> Prop :=
| eval_val q n : Val n ⇓[q] n
| eval_add q x y m n : x ⇓[q] n -> y ⇓[q] m -> Add x y ⇓[q] (n + m)
| eval_get q : Get ⇓[q] q
where "x ⇓[ q ] y" := (eval x q y).

Reserved Notation "x ↓[ q ] q'" (at level 80, no associativity).

Inductive run : Stmt -> State -> State -> Prop :=
| run_put x q v : x ⇓[q] v -> Put x ↓[q] v
| run_seqn x1 x2 q1 q2 q3 : x1 ↓[q1] q2 -> x2 ↓[q2] q3 -> Seqn x1 x2 ↓[q1] q3
| run_while_exit x1 x2 q : x1 ⇓[q] 0 -> While x1 x2 ↓[q] q
| run_while_cont v x1 x2 q1 q2 q3 : x1 ⇓[q1] v -> v > 0 -> x2 ↓[q1] q2 -> While x1 x2 ↓[q2] q3
                   -> While x1 x2 ↓[q1] q3
where "x ↓[ q ] y" := (run x q y).

(** * Abstract machine *)

Inductive CONT : Set :=
| NEXT : Expr -> State -> CONT -> CONT
| ADD : nat -> CONT -> CONT
| PUT : CONT -> CONT
| SEQN : Stmt -> CONT -> CONT
| CHECK : Expr -> Stmt -> State -> CONT -> CONT
| WHILE : Expr -> Stmt -> CONT -> CONT
| HALT : CONT
.

Inductive Conf : Set :=
| eval'' : Expr -> State -> CONT -> Conf
| run'' : Stmt -> State -> CONT -> Conf
| exec : CONT -> nat -> Conf
| exec' : CONT -> State -> Conf
.

Notation "⟨ x , q , c ⟩" := (eval'' x q c).
Notation "⟨| x , q , c |⟩" := (run'' x q c).
Notation "⟪ c , v ⟫" := (exec c v).
Notation "⟪| c , q |⟫" := (exec' c q).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive AM : Conf -> Conf -> Prop :=
| am_val n q c : ⟨Val n, q, c⟩ ==> ⟪c, n⟫
| am_add x y c q : ⟨Add x y, q, c⟩ ==> ⟨x, q, NEXT y q c⟩
| am_get q c : ⟨Get, q, c ⟩ ==> ⟪c, q ⟫
| am_put x q c : ⟨|Put x, q, c|⟩ ==> ⟨x, q, PUT c⟩
| am_seqn x1 x2 q1 c : ⟨|Seqn x1 x2, q1, c|⟩ ==> ⟨|x1, q1, SEQN x2 c|⟩
| am_while x1 x2 q c : ⟨|While x1 x2, q, c |⟩ ==> ⟨x1, q, CHECK x1 x2 q c⟩
| am_NEXT y c n q : ⟪NEXT y q c, n⟫ ==> ⟨y, q, ADD n c⟩
| am_ADD c n m : ⟪ADD n c, m⟫ ==> ⟪c, n+m⟫
| am_PUT c n : ⟪PUT c, n⟫ ==> ⟪|c, n|⟫
| am_SEQN x2 c q2 : ⟪| SEQN x2 c, q2|⟫ ==> ⟨|x2, q2, c |⟩
| am_CHECK_0 c q x1 x2 : ⟪CHECK x1 x2 q c, 0⟫ ==> ⟪|c, q|⟫
| am_CHECK_S c q v x1 x2 : v > 0 -> ⟪CHECK x1 x2 q c, v⟫ ==> ⟨|x2, q, WHILE x1 x2 c|⟩
| am_WHILE x1 x2 c q2 : ⟪|WHILE x1 x2 c, q2 |⟫ ==> ⟨|While x1 x2, q2, c|⟩
where "x ==> y" := (AM x y).

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module AM <: Preorder.
Definition Conf := Conf.
Definition VM := AM.
End AM.
Module AMCalc := Calculation AM.
Import AMCalc.

(** Specification of the abstract machine for expressions *)

Theorem specExpr x q v c : x ⇓[q] v -> ⟨x, q, c⟩ =>> ⟪c, v⟫.
(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  induction H;intros.

(** Calculation of the abstract machine *)

  begin
  ⟪c, n⟫.
  <== { apply am_val }
  ⟨Val n, q, c⟩.
  [].

  begin
    ⟪c, n + m ⟫.
  <== { apply am_ADD }
    ⟪ADD n c, m ⟫.
  <<= { apply IHeval2 }
    ⟨y, q, ADD n c⟩.
  <<= { apply am_NEXT }
    ⟪NEXT y q c , n⟫.
  <<= { apply IHeval1 }
      ⟨x, q, NEXT y q c⟩.
  <== {apply am_add}
      ⟨Add x y, q, c⟩.
  [].

  begin
    ⟪c, q⟫.
  <== {apply am_get}
    ⟨Get, q, c ⟩.
  [].
Qed.

Theorem specStmt x q q' c : x ↓[q] q' -> ⟨| x, q, c|⟩ =>> ⟪|c, q'|⟫.
(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  induction H;intros.

(** Calculation of the abstract machine *)

  begin
    ⟪|c, v|⟫.
  <<= { apply am_PUT }
    ⟪PUT c, v⟫.
  <<= { apply specExpr }
    ⟨x, q, PUT c⟩.
  <<= { apply am_put }
    ⟨|Put x, q, c|⟩.
  [].

  begin
    ⟪|c, q3 |⟫.
  <<= {apply IHrun2}
    ⟨|x2, q2, c |⟩.
  <== {apply am_SEQN}
    ⟪| SEQN x2 c, q2|⟫.
  <<= {apply IHrun1}
    ⟨|x1, q1, SEQN x2 c |⟩.
  <== {apply am_seqn}
    ⟨|Seqn x1 x2, q1, c |⟩.
  [].

  begin
    ⟪|c, q|⟫.
  <== {apply am_CHECK_0}
    ⟪CHECK x1 x2 q c, 0⟫.
  <<= {apply specExpr}
    ⟨x1, q, CHECK x1 x2 q c⟩.
  <== {apply am_while}
    ⟨|While x1 x2, q, c |⟩.
  [].

  begin
    ⟪|c, q3 |⟫.
  <<= {apply IHrun2}
    ⟨|While x1 x2, q2, c|⟩.
  <== {apply am_WHILE}
    ⟪|WHILE x1 x2 c, q2|⟫.
  <<= {apply IHrun1}
    ⟨|x2, q1, WHILE x1 x2 c|⟩.
  <== {apply am_CHECK_S}
    ⟪CHECK x1 x2 q1 c, v⟫.
  <<= {apply specExpr}
    ⟨x1, q1, CHECK x1 x2 q1 c⟩.
  <== {apply am_while}
    ⟨|While x1 x2, q1, c |⟩.
  [].
Qed.

(** * Soundness *)

Lemma determ_am : determ AM.
Proof.
  intros C c1 c2 V.
  induction V; intro V'; inversion V'; subst; try congruence;
  match goal with
  | [H : 0>0 |- _]  => inversion H
  end.
Qed.

Definition terminates (p : Stmt) : Prop := exists r, p ↓[0] r.

Theorem sound x C : terminates x -> ⟨|x, 0, HALT|⟩ =>>! C ->
                    exists r, C = ⟪|HALT, r|⟫ /\ x ↓[0] r.
Proof.
  unfold terminates. intros. destruct H as [r T].

  pose (specStmt x 0 r HALT) as H'. exists r. split. pose (determ_trc determ_am) as D.
  unfold determ in D. eapply D. eassumption. split. eauto. intro. destruct H.
  inversion H. assumption.
Qed.


Require Import Arith.

Compute 16.

Compute 15+23.

Compute 17*5.

Search nat.

Check 5.
Check nat.
Check gt.

Compute gt 4.
Compute gt 4 5.

Check gt 4.

Compute Nat.double 8.

Check Nat.double.

Definition tres:nat := 3.

Compute tres*5.

Definition mas (a:nat)(b:nat) := a+b+tres.

(* Compute 4 mas 5. *)

Compute mas 4 2.
Check mas.
Check mas 4 tres.

Search nat.

Definition uno := S 0.

Compute uno.
Print uno.
Check uno.

Compute S.

Definition five := S(S(S(S(S(0))))).
Compute five.

Definition double (m:nat) := plus m m.

Compute double 8.

Compute plus.

Inductive NoTieneSentido : Set :=
|carita_feliz : NoTieneSentido
|carita_triste : NoTieneSentido
|emociones : nat->NoTieneSentido.

Compute emociones 4.

Check nat.