(* --------------------------------------------------------||
||                                                         ||
||                   HILBERT SYSTEMS                       ||
||                                                         ||
||           Logic and Functional Programming              ||
||                 Florent Schaffhauser                    ||
||                                                         ||
||                 Heidelberg University                   ||
||                   (Summer 2026)                         ||
||                                                         ||
||-------------------------------------------------------- *)

From Coq Require Import Utf8.

Definition ℕ := nat.

(* In this file *)

(* ---------------------||
||     WELL-FORMED      ||
||       FORMULAS       ||
||--------------------- *)

(* We use a minimal definition of well-formed formulas, with 
only one binary constructor (implication). *)

Inductive Wff {atoms : Set} :=
| P      : atoms → Wff
| Impl   : Wff → Wff → Wff.

Notation "F ⇒ F'" := 
  (Impl F F') (at level 99, right associativity).

(* ---------------------||
||     AXIOMS AND       ||
||     DERIVATIONS      ||
||--------------------- *)

(* In order to define the `KS+MP` system, we first declare 
the axioms `K` and `S`. Note that this is an *inductive 
predicate* on well-formed formulas.  

It can be observed that all we need here is a type `W` with 
a binary operation `⇒` on it. We will not use atomic formulas 
at all until we go into semantics. *)

Inductive IsAxiom {atoms : Set} : @Wff atoms → Prop :=
| K (A B : Wff)  : IsAxiom (A ⇒ B ⇒ A)
| S (A B C: Wff) : IsAxiom ((A ⇒ B ⇒ C) ⇒ (A ⇒ B) ⇒ (A ⇒ C)).

(* We now have enough to declare an inductive predicate 
stating what it means for a well-formed formula `F` to be 
**derivable from a family of well-formed formulas** 
`Γ : J → Wff`, where `J` is a set. *)

Inductive IsDerivableFrom {atoms : Set} {J : Set} 
  (Γ : J → @Wff atoms) : @Wff atoms → Prop :=
| axiom (a : Wff) (ha : IsAxiom a) : IsDerivableFrom Γ a
| premise (j : J)                  : IsDerivableFrom Γ (Γ j)
| mp (F F' : Wff)                  : IsDerivableFrom Γ F → IsDerivableFrom Γ (F ⇒ F') → IsDerivableFrom Γ F'.

Infix "⊢" := IsDerivableFrom (at level 70, no associativity).

(* Making certain arguments implicit will be convenient later 
in proofs. *)

Arguments premise {atoms J Γ}.
Arguments mp {atoms J Γ}.

(* In order to define what it means to be a theorem in `KS+MP`, 
let us define the empty family. 

Recall that, in Rocq, the type `Empty_set` is declared as an 
inductive type with no constructors, and note that the pattern 
matching clause is indeed empty in the declaration below (no 
constructors to pattern match on). *)

Definition empty_family {atoms : Set} : Empty_set → @Wff atoms :=
  fun i => match i with end.

(* We can then prove our first theorem, known as `I`. *)

Theorem I {atoms : Set} (F : @Wff atoms) : empty_family ⊢ (F ⇒ F).
Proof.
  apply (mp (F ⇒ F ⇒ F)).
  - apply axiom. apply K.
  - apply (mp (F ⇒ (F ⇒ F) ⇒ F)).
    + apply axiom. apply K.
    + apply axiom. apply S.
Qed.

(* Here is another proof of `I`, where we 'reason forward'. *)

Theorem I' {atoms : Set} (F : @Wff atoms) : empty_family ⊢ (F ⇒ F).
Proof.
  pose proof (S F (F ⇒ F) F) as s.
  pose proof (axiom empty_family _ s) as s'.
  pose proof (K F F) as k1.
  pose proof (axiom empty_family _ k1) as k1'.
  pose proof (K F (F ⇒ F)) as k2.
  pose proof (axiom empty_family _ k2) as k2'.
  pose proof (mp _ _ k2' s') as H.
  pose proof (mp _ _ k1' H) as H1.
  exact H1.
Qed.

(* Intuitively, if we can derive a formula from the empty family, 
we can derive it from any family. The next result gives a formal 
proof of that fact. *)

Theorem derive_from_empty {atoms : Set} {J : Set} 
  (F : @Wff atoms) : 
  empty_family ⊢ F → ∀ (Γ : J → @Wff atoms), Γ ⊢ F.
Proof.
  intros HF Γ.
  induction HF.
  + apply axiom; assumption.
  + destruct j. 
    (* we can, in fact, never be in this case, 
    since the family is empty! *)
  + apply (mp F). all: assumption.
Qed.

(* ---------------------||
||    THE DEDUCTION     ||
||      THEOREM         ||
||--------------------- *)

(* The sum of two types is declared inductively. To define a 
function *out of* a sum by primitive recursion, one 
pattern-matches on the constructors `inl` and `inr`. *)

Definition sum_family {atoms : Set} {J₁ J₂ : Set} 
    (Γ₁ : J₁ → @Wff atoms) (Γ₂ : J₂ → @Wff atoms) 
      : J₁ + J₂ → @Wff atoms :=
  fun j => match j with
  | inl j₁ => Γ₁ j₁
  | inr j₂ => Γ₂ j₂
  end.

(* The following notation will be convenient for us. *)

Declare Scope family_scope.
Notation "Γ₁ + Γ₂" := (sum_family Γ₁ Γ₂) 
  (at level 50, left associativity) : family_scope.
Open Scope family_scope.

(* The next result will be used in the proof of the
deduction theorem. It says that if a formula `F` is derivable 
from a family `Γ₁`, then for all family `Γ₂`, the formula 
`F` is derivable from the family `Γ₁ + Γ₂`. *)

Theorem derivable_from_sum_family {atoms : Set} {J₁ J₂ : Set} 
  (Γ₁ : J₁ → @Wff atoms) (F : @Wff atoms) :
    Γ₁ ⊢ F → ∀ (Γ₂ : J₂ → @Wff atoms), (Γ₁ + Γ₂) ⊢ F.
Proof.
  intros Fder1 Γ₂.
  induction Fder1.
  + apply axiom. exact ha.
  + exact (premise (inl j)).
  + apply (mp F). all: assumption.
Qed.

(* It is tempting to think that Theorem `derivable_from_empty` is 
a special case of Theorem `derivable_from_sum_family`, with 
`Γ₁ = empty_family`. However, if you try to apply Theorem 
`derivable_from_sum_family` to prove Theorem `derivable_from_empty` 
you will run into the issue that `empty_family + Γ` does not 
automatically reduce to `Γ`, blocking the unification necessary for 
Theorem `derivable_from_empty` to be applied. So additional properties 
will be required to make this work.

Let us now introduce a definition for a family consisting of 
just one formula, and notation for it. *)

Definition family_of_one {atoms : Set} (F : @Wff atoms) :
  unit -> @Wff atoms := fun _ => F.

Notation "[ F ]" := (family_of_one F) (at level 45) : family_scope.

(* We can now prove the deduction theorem. *)

Theorem deduction {atoms : Set} {J : Set} 
  (Γ : J → @Wff atoms) (F G : @Wff atoms) :
  Γ ⊢ (F ⇒ G) ↔ (Γ + [F]) ⊢ G.
Proof.
  split.
  + intro H.
    apply (mp F).
    - exact (premise (inr tt)).
    - apply derivable_from_sum_family. exact H.
  + intro H.
    induction H.
    - apply (mp a).
      * apply axiom. exact ha.
      * apply axiom. apply K.
    - destruct j.
      * simpl. apply (mp (Γ j)).
        apply premise.
        apply axiom. apply K.
      * simpl.
        apply derive_from_empty.
        apply I.
    - apply (mp (F ⇒ F0)).
      * assumption.
      * apply (mp (F ⇒ F0 ⇒ F')). 
        assumption.
        apply axiom. apply S.
Qed.

(* We give two corollaries. *)

Theorem K' {atoms : Set} (F G : @Wff atoms) :
  empty_family ⊢ (F ⇒ G ⇒ G).
Proof.
  apply deduction.
  apply derive_from_empty.
  apply I.
Qed.

(* The next corollary shows that, in our deductive system,
we can derive a transitivity property for the constructor 
`⇒`. *)

Theorem conj_trans {atoms : Set} (F G H : @Wff atoms) :
  empty_family ⊢ ((F ⇒ G) ⇒ (G ⇒ H) ⇒ (F ⇒ H)).
Proof.
  apply deduction.
  apply deduction.
  apply deduction.
  apply (mp G).
  + apply (mp F).
    - exact (premise (inr tt)).
    - apply (derivable_from_sum_family); apply (derivable_from_sum_family).
      exact (premise (inr tt)).
  + apply derivable_from_sum_family.
    exact (premise (inr tt)).
Qed.

(* ---------------------||
||      SOUNDNESS       ||
||--------------------- *)

(* Recall the following notation from Boolean semantics *)

Notation "b ≼ b'" := 
    (implb b b') (at level 99, right associativity).

Fixpoint eval {atoms : Set} (v : atoms → bool) (F : Wff) 
  : bool :=
match F with
| P i    => v i
| F ⇒ F' => (eval v F) ≼ (eval v F')
end.

(* We also recall the concept of entailment. *)

Definition Entails {atoms : Set} {I : Set} 
    (Γ : I → Wff) (F : Wff) :=
  ∀ v : atoms → bool, 
    (∀ i : I, eval v (Γ i) = true) → eval v F = true.

Infix "⊨" := Entails (at level 110, right associativity).

(* Then we can prove that if a well-formed formula `F` is 
derivable from a family `Γ` on the syntactic side, then `Γ` 
entails `F`, meaning that for all valuations such that the 
formulas in `Γ` evaluate to `true`, the formula `F` also 
evaluates to `true`.

If we did not have that, then our logic would not be not very 
useful: soundness is usually considered a minimal requirement 
for a deductive system and its proposed semantics to have. *)

Theorem soundness {atoms : Set} {J : Set} : 
  ∀ Γ : J → @Wff atoms, ∀ F : Wff, (Γ ⊢ F) → Γ ⊨ F.
Proof.
  intros Γ F HF.
  unfold Entails.
  intros v Hv. 
  induction HF. (* as [a | j | F1 F2 IF1 IH1 IF2 IH2]. *)
  + induction ha.
    (* Works because all the axioms in our deductive system 
    are semantically valid formulas *)
    all: simpl. 
    - destruct (eval v A), (eval v B).
      all: reflexivity.
    - destruct (eval v A), (eval v B), (eval v C).
      all: reflexivity.
  + exact (Hv j).
  + revert IHHF1 IHHF2.
    simpl.
    destruct (eval v F), (eval v F').
    all: auto.
Qed.