Pantograph/Test/Proofs.lean

import LSpec
import Pantograph.Meta
import Pantograph.Serial

namespace Pantograph.Test
open Pantograph

inductive Start where
  | copy (name: String) -- Start from some name in the environment
  | expr (expr: String) -- Start from some expression

abbrev M := Meta.M
abbrev TestM := StateRefT Meta.ProofTree M

def start_proof (start: Start): M (LSpec.TestSeq × Option Meta.ProofTree) := do
  let env ← Lean.MonadEnv.getEnv
  let mut testSeq := LSpec.TestSeq.done
  match start with
  | .copy name =>
    let cInfo? := str_to_name name |> env.find?
    testSeq := testSeq ++ LSpec.check s!"Symbol exists {name}" cInfo?.isSome
    match cInfo? with
    | .some cInfo =>
      let state ← Meta.ProofTree.create
        (name := str_to_name "TestExample")
        (expr := cInfo.type)
      return (testSeq, Option.some state)
    | .none =>
      return (testSeq, Option.none)
  | .expr expr =>
    let syn? := Serial.syntax_from_str env expr
    testSeq := testSeq ++ LSpec.check s!"Parsing {expr}" (syn?.isOk)
    match syn? with
    | .error error =>
      IO.println error
      return (testSeq, Option.none)
    | .ok syn =>
      let expr? ← Meta.syntax_to_expr syn
      testSeq := testSeq ++ LSpec.check s!"Elaborating" expr?.isOk
      match expr? with
      | .error error =>
        IO.println error
        return (testSeq, Option.none)
      | .ok expr =>
        let state ← Meta.ProofTree.create
          (name := str_to_name "TestExample")
          (expr := expr)
        return (testSeq, Option.some state)

deriving instance DecidableEq, Repr for Meta.TacticResult

def proof_step (stateId: Nat) (goalId: Nat) (tactic: String)
    (expected: Meta.TacticResult) : TestM LSpec.TestSeq := do
  let result: Meta.TacticResult ← Meta.ProofTree.execute stateId goalId tactic
  match expected, result with
  | .success (.some i) #[], .success (.some _) goals =>
    -- If the goals are omitted but the next state is specified, we imply that
    -- the tactic succeeded.
    let expected := .success (.some i) goals
    return LSpec.test s!"{stateId}.{goalId} {tactic}"   (result = expected)
  | _, _ =>
    return LSpec.test s!"{stateId}.{goalId} {tactic}"   (result = expected)

def proof_inspect (expected: Array String) : TestM LSpec.TestSeq := do
  let result := (← get).structure_array
  return LSpec.test s!"tree structure" (result = expected)

def proof_runner (env: Lean.Environment) (start: Start) (steps: List (TestM LSpec.TestSeq)): IO LSpec.TestSeq := do
  let termElabM := do
    let (testSeq, state?) ← start_proof start
    match state? with
    | .none => return testSeq
    | .some state => steps.foldlM (fun tests m => do pure $ tests ++ (← m)) testSeq |>.run' state

  let coreContext: Lean.Core.Context := {
    currNamespace := str_to_name "Aniva",
    openDecls := [],     -- No 'open' directives needed
    fileName := "<Pantograph>",
    fileMap := { source := "", positions := #[0], lines := #[1] }
  }
  let metaM := termElabM.run' (ctx := {
    declName? := some "_pantograph",
    errToSorry := false
  })
  let coreM := metaM.run'
  match ← (coreM.run' coreContext { env := env }).toBaseIO with
  | .error exception =>
    return LSpec.test "Exception" (s!"internal exception #{← exception.toMessageData.toString}" = "")
  | .ok a            => return a


example: ∀ (a b: Nat), a + b = b + a := by
  intro n m
  rw [Nat.add_comm]
def proof_nat_add_comm (env: Lean.Environment): IO LSpec.TestSeq :=
  let goal1 := "n m : Nat\n⊢ n + m = m + n"
  proof_runner env (.copy "Nat.add_comm") [
    proof_step 0 0 "intro n m"
      (.success (.some 1) #[goal1]),
    proof_step 1 0 "assumption"
      (.failure #[s!"tactic 'assumption' failed\n{goal1}"]),
    proof_step 1 0 "rw [Nat.add_comm]"
      (.success .none #[])
  ]
def proof_nat_add_comm_manual (env: Lean.Environment): IO LSpec.TestSeq := do
  let goal1 := "n m : Nat\n⊢ n + m = m + n"
  proof_runner env (.expr "∀ (a b: Nat), a + b = b + a") [
    proof_step 0 0 "intro n m"
      (.success (.some 1) #[goal1]),
    proof_step 1 0 "assumption"
      (.failure #[s!"tactic 'assumption' failed\n{goal1}"]),
    proof_step 1 0 "rw [Nat.add_comm]"
      (.success .none #[])
  ]

-- Two ways to write the same theorem
example: ∀ (p q: Prop), p ∨ q → q ∨ p := by
  intro p q h
  cases h
  apply Or.inr
  assumption
  apply Or.inl
  assumption
example: ∀ (p q: Prop), p ∨ q → q ∨ p := by
  intro p q h
  cases h
  . apply Or.inr
    assumption
  . apply Or.inl
    assumption
def proof_or_comm (env: Lean.Environment): IO LSpec.TestSeq := do
  proof_runner env (.expr "∀ (p q: Prop), p ∨ q → q ∨ p") [
    proof_step 0 0 "intro p q h"
      (.success (.some 1) #["p q : Prop\nh : p ∨ q\n⊢ q ∨ p"]),
    proof_step 1 0 "cases h"
      (.success (.some 2) #[]),
    proof_inspect #["", "0.0", "1.0"],
    proof_step 2 0 "apply Or.inr"
      (.success (.some 3) #[]),
    proof_inspect #["", "0.0", "1.0", "2.0"],
    proof_step 3 0 "assumption"
      (.success .none #[]),
    proof_step 2 1 "apply Or.inl"
      (.success (.some 4) #[]),
    proof_step 4 0 "assumption"
      (.success .none #[]),
    proof_inspect #["", "0.0", "1.0", "2.0", "2.1"]
  ]

example (w x y z : Nat) (p : Nat → Prop)
        (h : p (x * y + z * w * x)) : p (x * w * z + y * x) := by
  simp [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm, Nat.mul_comm, Nat.mul_assoc, Nat.mul_left_comm] at *
  assumption
def proof_arith_1 (env: Lean.Environment): IO LSpec.TestSeq := do
  proof_runner env (.expr "∀ (w x y z : Nat) (p : Nat → Prop) (h : p (x * y + z * w * x)), p (x * w * z + y * x)") [
    proof_step 0 0 "intros"
      (.success (.some 1) #[]),
    proof_step 1 0 "simp [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm, Nat.mul_comm, Nat.mul_assoc, Nat.mul_left_comm] at *"
      (.success (.some 2) #[]),
    proof_step 2 0 "assumption"
      (.success .none #[])
  ]

def test_proofs : IO LSpec.TestSeq := do
  let env: Lean.Environment ← Lean.importModules
    (imports := ["Init"].map (λ str => { module := str_to_name str, runtimeOnly := false }))
    (opts := {})
    (trustLevel := 1)

  return LSpec.group "Proofs" $
    (LSpec.group "Nat.add_comm" $ (← proof_nat_add_comm env)) ++
    (LSpec.group "Nat.add_comm manual" $ (← proof_nat_add_comm_manual env)) ++
    (LSpec.group "Or.comm" $ (← proof_or_comm env)) ++
    (LSpec.group "Arithmetic 1" $ (← proof_arith_1 env))

end Pantograph.Test