----------------------------------------------------------------------
-- A very simple theorem prover, using the technique of proof by
-- reflection
--
-- Nils Anders Danielsson
----------------------------------------------------------------------

open import Prelude

module Proof-by-reflection

  -- The module is parametrised by a monoid; a type and some
  -- operations satisfying certain properties.

  {A              : Set}

  (identity       : A)
  (_∙_            : A → A → A)

  (left-identity  : ∀ x → (identity ∙ x) ≡ x)
  (right-identity : ∀ x → (x ∙ identity) ≡ x)
  (assoc          : ∀ x y z → (x ∙ (y ∙ z)) ≡ ((x ∙ y) ∙ z))

  -- Some elements of the type, only used in examples.

  (x y            : A)
  where

-- The goal is to automatically prove equality of monoid expressions.

----------------------------------------------------------------------
-- Monoid expressions

-- There is one constructor for every operation, plus one for
-- variables; there may be at most n variables.

data Expr (n : ℕ) : Set where
  var : Fin n → Expr n
  id  : Expr n
  _⊕_ : Expr n → Expr n → Expr n

-- An environment contains one value for every variable.

Env : ℕ → Set
Env n = Vec A n

-- The semantics of an expression is a map from an environment to a
-- value.

⟦_⟧ : ∀ {n} → Expr n → Env n → A
⟦ var x   ⟧ ρ = lookup x ρ
⟦ id      ⟧ ρ = identity
⟦ e₁ ⊕ e₂ ⟧ ρ = ⟦ e₁ ⟧ ρ ∙ ⟦ e₂ ⟧ ρ

-- Examples.

e₁ : Expr 
e₁ = (var zero ⊕ id) ⊕ var (suc zero)

e₂ : Expr 
e₂ = id ⊕ (var zero ⊕ (var (suc zero) ⊕ id))

ρ : Vec A 
ρ = x ∷ y ∷ []

ex₁ = ⟦ e₁ ⟧ ρ

----------------------------------------------------------------------
-- Normal forms

-- A normal form is a list of variables.

Normal : ℕ → Set
Normal n = List (Fin n)

-- The semantics of a normal form.

⟦_⟧′ : ∀ {n} → Normal n → Env n → A
⟦ []     ⟧′ ρ = identity
⟦ x ∷ nf ⟧′ ρ = lookup x ρ ∙ ⟦ nf ⟧′ ρ

-- A normaliser.

normalise : ∀ {n} → Expr n → Normal n
normalise (var x)   = x ∷ []
normalise id        = []
normalise (e₁ ⊕ e₂) = normalise e₁ ++ normalise e₂

-- The normaliser is homomorphic with respect to _++_/_∙_.

homomorphic : ∀ {n} (nf₁ nf₂ : Normal n) (ρ : Env n) →
              ⟦ nf₁ ++ nf₂ ⟧′ ρ ≡ (⟦ nf₁ ⟧′ ρ ∙ ⟦ nf₂ ⟧′ ρ)
homomorphic []        nf₂ ρ = sym (left-identity (⟦ nf₂ ⟧′ ρ))
homomorphic (x ∷ nf₁) nf₂ ρ =
  trans (cong (λ y → lookup x ρ ∙ y) (homomorphic nf₁ nf₂ ρ))
        (assoc (lookup x ρ) (⟦ nf₁ ⟧′ ρ) (⟦ nf₂ ⟧′ ρ))

-- The normaliser preserves the semantics of the expression.

normalise-correct :
  ∀ {n} (e : Expr n) (ρ : Env n) → ⟦ normalise e ⟧′ ρ ≡ ⟦ e ⟧ ρ
normalise-correct (var x)   ρ = right-identity (lookup x ρ)
normalise-correct id        ρ = refl
normalise-correct (e₁ ⊕ e₂) ρ =
  trans (homomorphic (normalise e₁) (normalise e₂) ρ)
        (cong₂ _∙_ (normalise-correct e₁ ρ) (normalise-correct e₂ ρ))

-- Thus one can prove that two expressions are equal by proving that
-- their normal forms are equal.

normalisation-theorem :
  ∀ {n} (e₁ e₂ : Expr n) (ρ : Env n) →
  ⟦ normalise e₁ ⟧′ ρ ≡ ⟦ normalise e₂ ⟧′ ρ →
  ⟦ e₁ ⟧ ρ ≡ ⟦ e₂ ⟧ ρ
normalisation-theorem e₁ e₂ ρ eq =
  trans (sym (normalise-correct e₁ ρ)) (
  trans eq
        (normalise-correct e₂ ρ))

ex₂ = normalisation-theorem e₁ e₂ ρ refl

----------------------------------------------------------------------
-- The prover

-- We can decide if two normal forms are equal.

infix  _≟_

_≟_ : ∀ {n} (nf₁ nf₂ : Normal n) → Maybe (nf₁ ≡ nf₂)
[]         ≟ []         = just refl
(x₁ ∷ nf₁) ≟ (x₂ ∷ nf₂) = cong₂ _∷_ <$> x₁ ≟-Fin x₂ ⊛ nf₁ ≟ nf₂
_          ≟ _          = nothing

-- Thus we can also decide if two expressions have the same semantics.
--
-- Note that this decision procedure must be /sound/, because it
-- returns a proof. However, we have not proved that it is /complete/.
-- Proving this, or finding a counterexample, is left as an exercise.

prove : ∀ {n} (e₁ e₂ : Expr n) → Maybe (∀ ρ → ⟦ e₁ ⟧ ρ ≡ ⟦ e₂ ⟧ ρ)
prove e₁ e₂ =
  (λ eq ρ →
     normalisation-theorem e₁ e₂ ρ (cong (λ nf → ⟦ nf ⟧′ ρ) eq))
  <$> normalise e₁ ≟ normalise e₂

ex₃ = prove e₁ e₂

-- We can also prove things "at compile time".

ex₄ : (x ∙ identity) ∙ y ≡ identity ∙ (x ∙ (y ∙ identity))
ex₄ = fromJust (prove e₁ e₂) ρ

-- The following definition does not, and should not, type check.

-- ex₅ : (x ∙ identity) ∙ y ≡ identity
-- ex₅ = fromJust (prove e₁ id) ρ

-- Another exercise: Extend the algorithm above to other algebraic
-- structures.