import data.stream

import util.data.bijection
import util.data.perm
import util.data.nat
import util.data.minimum

import unitb.models.simple
import unitb.scheduling.basic

local attribute [-simp] or.comm or.left_comm or.assoc and.comm and.left_comm and.assoc

namespace scheduling.infinite

open predicate (var) scheduling.unitb unitb scheduling

open nat function simple

@[reducible]
def rrobin (lbl : Type) [infinite lbl] : Type :=
bijection ℕ lbl

@[reducible]
def index_t (lbl : Type) [infinite lbl] := ℕ

section

parameter {lbl : Type}
parameter [infinite lbl]
parameter t : target_mch lbl

local attribute [instance] classical.prop_decidable

noncomputable def first (req : set lbl)
  (l : rrobin lbl)
: index_t lbl :=
(↓ x, l.f x ∈ req )

noncomputable def sch.current (r : set lbl) (queue : rrobin lbl) : lbl :=
queue.f (first r queue)

structure sch_state :=
  (target : t.σ)
  (q_len : ℕ)
  (queue : rrobin lbl)
  (inv : sch.current (t.req.apply target) queue ∈ t.req.apply target)

def req : var sch_state (set lbl) :=
t.req ∘' (sch_state.target : var sch_state t.σ)

lemma first_mem {s : t.σ}
  (l : rrobin lbl)
: l.f (first (t.req.apply s) l) ∈ t.req.apply s :=
begin
  unfold first, apply @minimum_mem _ _ { x | l.f x ∈ t.req.apply s },
  cases set.exists_mem_of_ne_empty (t.req_nemp s) with x h,
  apply @set.ne_empty_of_mem _ _ (l.g x),
  change l.f (l.g x) ∈ t.req.apply s,
  rw l.g_inv, apply h
end

noncomputable def shift (s : sch_state)
: rrobin lbl :=
if h : first (req.apply s) s.queue < succ s.q_len
then s.queue ∘ bijection.rotate_right' (first (req.apply s) s^.queue) (succ s.q_len) h
else s.queue

lemma sch.select_inv
  (s : t.σ)
  (q : rrobin lbl)
: sch.current (t.req.apply s) q ∈ t.req.apply s :=
begin
  unfold sch.current,
  apply first_mem _,
end

def sch.first : sch_state :=
{ q_len := 0
, target := t.s₀
, queue := bijection.rev (infinite.to_nat _)
, inv := sch.select_inv _ _ }

noncomputable def sch.step (s : sch_state) : sch_state :=
{ q_len := s.q_len + 1
, target := t.next (sch.current (_) s.queue) s.target s.inv
, queue := shift s
, inv := sch.select_inv _ _ }

noncomputable def scheduler : program sch_state :=
  { first := sch.first
  , step  := sch.step }

open has_mem

noncomputable def current : var sch_state lbl :=
sch.current <$> req <*> sch_state.queue

def rank (l : lbl) : var sch_state ℕ :=
λ (s : sch_state), s.queue.g l + (s.queue.g l - s.q_len)

lemma pending_not_move (s : sch_state) (l : lbl)
  (h : succ s.q_len ≤ s.queue.g l)
: ((sch.step s).queue).g l = s.queue.g l :=
begin
  dunfold sch.step sch_state.queue shift,
  cases decidable.em (first ((req t).apply s) s.queue < succ s.q_len) with h' h',
  { rw [dif_pos h',comp_g],
    unfold comp,
    rw bijection.rotate_right'_g_eq_of_ge_j _ h' h, },
  { rw dif_neg h', },
end

lemma shift_down (s : sch_state) (l : lbl)
  (h₀ : first (req.apply s) s.queue < s.queue.g l)
  (h₁ : s.queue.g l < succ s.q_len)
: succ (((sch.step s).queue).g l) = s.queue.g l :=
begin
  dunfold sch.step sch_state.queue shift,
  have h : first ((req t).apply s) s.queue < succ s.q_len := lt_trans h₀ h₁,
  rw [dif_pos h,comp_g], unfold comp,
  rw bijection.succ_rotate_right'_g_eq_self (s.queue.g l) _ h₀ h₁,
end

lemma q_len_inc (s : sch_state)
: (sch.step s).q_len = succ s.q_len :=
by { rw ← add_one, refl }

lemma not_req_not_move (s : sch_state) (l : lbl)
  (h : s.queue.g l < first (req.apply s) s.queue)
: (sch.step s).queue.g l = s.queue.g l :=
begin
  dunfold sch.step sch_state.queue shift,
  cases decidable.em (first ((req t).apply s) s.queue < succ s.q_len) with h' h',
  { rw [dif_pos h',comp_g],
    unfold comp,
    rw [bijection.rotate_right'_g_eq_of_lt_i _ _ h], },
  { rw [dif_neg h'] },
end

lemma not_mem_req {s : sch_state} {l : lbl}
  (h : first (req.apply s) s.queue > s.queue.g l)
: l ∉ req.apply s :=
begin
  intro h',
  revert h,
  apply not_lt_of_ge,
  unfold first,
  apply minimum_le,
  unfold mem set.mem,
  rw bijection.g_inv,
  apply h'
end

lemma le_rank_of_lt_first {s : sch_state} {l : lbl}
  (Hgt : s.queue.g l < first (req.apply s) s.queue)
: (rank l).apply (sch.step s) ≤ (rank l).apply s :=
begin
  unfold rank,
  cases le_or_gt (s.queue.g l) (s.q_len) with h h,
  { have h' : s.queue.g l ≤ succ s.q_len := le_succ_of_le h,
    simp [not_req_not_move _ _ _ Hgt,q_len_inc
         ,sub_eq_zero_of_le h,sub_eq_zero_of_le h'] },
  { simp [pending_not_move _ _ _ h,q_len_inc],
    apply nat.sub_le_sub_left,
    apply le_succ, },
end

lemma lt_rank_of_gt_first {s : sch_state} {l : lbl}
  (Hlt : first (req.apply s) (s.queue) < (s.queue).g l)
: (rank l).apply (sch.step s) < (rank l).apply s :=
begin
  unfold rank,
  cases le_or_gt s.q_len (first ((req t).apply s) s.queue) with h h,
    -- h : s.q_len ≤ first (sch_state.req s) (s.queue)
  { have h' : s.q_len < s.queue.g l := lt_of_le_of_lt h Hlt,
    simp [pending_not_move _ _ _ h'],
    dunfold sch.step sch_state.q_len,
    rw [sub_succ],
    apply pred_lt_self_of_pos,
    apply nat.sub_pos_of_lt,
    apply lt_of_lt_of_le h',
    refl },
    -- h : s.q_len > first (sch_state.req s) (s.queue)
  { cases lt_or_ge (s.queue.g l) (succ s.q_len) with Hlt_len Hge_len,
      -- Hlt_len : (s.queue).g l < succ (s.q_len)
    { simp,
      rw [← shift_down _ s _ Hlt Hlt_len,q_len_inc],
      { apply add_lt_add_of_lt_of_le,
        { apply lt_succ_self },
        { apply nat.sub_le_sub
          ; apply le_succ, } }, },
      -- Hge_len : (s.queue).g l ≥ succ (s.q_len)
    { unfold gt at h,
      simp [pending_not_move _ _ _ Hge_len,q_len_inc],
      { apply nat.sub_lt_sub_left Hge_len,
        apply lt_succ_self, }, } }
end
variable {s : sch_state}

lemma eq_next_or_rank_eq_or_rank_lt {l : lbl} (v : ℕ)
  (h : s ⊨ rank l ≃ v)
: s ⊨ current ≃ l ∨
  ( s ⊨ -(↑l ∊ req) ∧ sch.step s ⊨ rank l ≃ v ) ∨
  sch.step s ⊨ rank l ≺ v :=
begin
  rw or_iff_not_imp,
  intro Hnnext,
  simp [current,sch.current,req] at Hnnext ⊢,
  simp at h,
  rw bijection.inverse at Hnnext,
  cases lt_or_gt_of_ne Hnnext with Hlt Hgt ; clear  Hnnext,
  { right,
    rw ← h,
    apply lt_rank_of_gt_first t _ ,
    simp [req,Hlt] },
  { unfold gt at Hgt,
    subst v,
    have := le_rank_of_lt_first _, simp [req] at this,
    specialize this Hgt,
    cases lt_or_eq_of_le this with Hlt Heq,
    { right, apply Hlt },
    { left,
      split,
      { have := not_mem_req _ , simp [req] at this,
        apply this, assumption },
      { apply Heq, }, } },
end

lemma fair_schedule_step  (l : lbl) (v : ℕ)
:  ↑l ∊ req ⋀ (rank l ≃ ↑v) ↦ (rank l ≺ v) ⋁ (current ≃ l) in scheduler :=
begin
  unfold scheduler,
  apply leads_to_step,
  intros σ Heq Hnnext,
  simp, simp at Heq,
  cases Heq with Hmem Heq,
  have HH := eq_next_or_rank_eq_or_rank_lt t v,
  -- simp [rank,current,req] at HH,
  specialize HH Heq,
  rw or_iff_not_imp at HH,
  simp [not_or_iff_not_and_not] at Hnnext,
  have Hnnext' : ¬ (current t).apply σ = l := Hnnext.right,
  have HH' := HH Hnnext',
  rw [or_iff_not_imp] at HH',
  left, apply HH', clear HH' HH,
  simp [classical.not_and_iff_not_or_not],
  apply or.intro_left _ Hmem,
end

lemma stable_queue_ranking (l : lbl) (v : ℕ)
: unless scheduler (rank l ≃ v) (rank l ≺ v ⋁ current ≃ l) :=
begin
  unfold scheduler,
  apply unless_step,
  intros σ Heq Hnnext,
  simp,
  simp [not_or_iff_not_and_not] at Hnnext,
  have := eq_next_or_rank_eq_or_rank_lt _ _ Heq, simp at this,
  cases this with h h,
  { cases Hnnext.right h },
  cases h with h h,
  { replace Hnnext := Hnnext.right,
    left, rw h.right, },
  { right, left, assumption },
end

lemma INIT
: system.init scheduler (↑sch_state.target ≃ (t.s₀ : var sch_state t.σ)) :=
by simp [system.init,program.init,scheduler,sch.first]

lemma STEP
: co' scheduler
    (λ (σ σ' : sch_state),
       ∃P, σ'.target = t.next (sch.current (req.apply σ) σ.queue) σ.target P) :=
begin
  unfold co',
  intros σ σ',
  unfold step has_safety.step is_step,
  intros H,
  have := σ.inv,
  simp [req],
  -- existsi σ.inv,
  split,
  { rw H,
    unfold scheduler program.step subtype.val sch.step },
  { simp [req,this], }
end

lemma INV
: ∀ σ, σ ⊨ current ∊ t.req ∘' sch_state.target :=
by { assume σ, simp [current,req], apply σ.inv, }

lemma PROG (l : lbl)
:     ↑l ∊ req  >~>  current ≃ l
  in scheduler :=
begin
  apply often_imp_often.induct ℕ _ _ ,
  apply stable_queue_ranking _ l,
  apply fair_schedule_step _ l,
end

end

variable {lbl : Type}
variable [infinite lbl]
variable t : scheduling.unitb.target_mch lbl

noncomputable def scheduler_spec
: @scheduling.unitb.scheduler lbl t :=
  { s := program $ sch_state t
  , sem := _
  , F := @scheduler _ _ t
  , ch := current t
  , object := ↑sch_state.target
  , INIT := INIT t
  , STEP := STEP t
  , INV  := INV t
  , PROG := PROG t }

noncomputable instance : unitb.system_sem ((scheduler_spec t).s) :=
(scheduler_spec t).sem

lemma sched' {lbl : Type} [s : infinite lbl] [nonempty lbl]
  (t : target_mch lbl)
: ∃ τ : stream t.σ, fair t τ :=
unitb.scheduling t (scheduling.infinite.scheduler_spec t)

end scheduling.infinite


import MLIR.Dialects.ScfSemantics
import MLIR.Dialects.ArithSemantics
open MLIR.AST

namespace SCF_SELECT
abbrev Δ := scf + arith

def LHS: Op Δ := [mlir_op|
  %x = "scf.if" (%b) ({
    "scf.yield"(%n): (i32) -> ()
  }, {
    "scf.yield"(%m): (i32) -> ()
  }): (i1) -> i32
]
def RHS: Op Δ := [mlir_op|
  %x = "arith.select"(%b, %n, %m): (i1, i32, i32) -> i32
]
def INPUT (b: FinInt 1) (n m: FinInt 32): SSAEnv Δ := SSAEnv.One [
  ⟨"b", .i1, b⟩,
  ⟨"n", .i32, n⟩,
  ⟨"m", .i32, m⟩]

theorem denoteYieldRegion:
  denoteRegion Δ (Region.mk
    [BasicBlock.mk bbname []
      [Op.mk "scf.yield" [] [(valuename, .int .Signless 32)] [] [] (.mk [])]]) =
  fun (args: TypedArgs Δ) =>
    Fitree.bind (Fitree.trigger <| SSAEnvE.Get MLIRType.i32 valuename) fun x =>
    Fitree.ret (BlockResult.Ret [⟨.i32, x⟩]) := by
  funext args
  simp [denoteRegion, denoteBB, denoteOps, denoteOp, denoteOpBase]
  simp [List.zip, List.mapM, List.map]
  simp [Semantics.semantics_op]
  simp [HOrElse.hOrElse, OrElse.orElse, Option.orElse, Option.map]
  simp [scf_semantics_op]
  simp [denoteTypedArgs]; cases args <;> simp

theorem equivalent (b: FinInt 1) (n m: FinInt 32):
    (run (denoteOp _ LHS) (INPUT b n m)) =
    (run (denoteOp _ RHS) (INPUT b n m)) := by
  simp [LHS, RHS, INPUT]
  simp [coeMLIRTypeList, coeRegionList, coeOpList]
  simp [denoteOp, denoteOpBase, List.zip, List.mapM, denoteRegions]
  simp [Semantics.semantics_op]
  simp [HOrElse.hOrElse, OrElse.orElse, Option.orElse, Option.map]
  simp [scf_semantics_op, arith_semantics_op]
  rw [denoteYieldRegion]
  rw [denoteYieldRegion]
  save

  conv in Fitree.translate _ (Fitree.trigger _) => simp [Fitree.translate]
  conv in Fitree.interp (interpRegion Δ) (Fitree.Vis _ _) =>
    simp [Fitree.interp, interpRegion]
  simp [run, interpSSA'_bind, SSAEnvE.handle, cast_eq]
  simp [Fitree.translate]
  simp [interpRegion, Member.inject, interpSSA'_bind]
  save

  cases b.bool_cases <;> subst b <;> simp [List.get!, interpSSA'_bind]
  . simp [Fitree.trigger, Fitree.interp'_bind, SSAEnvE.handle]
    simp [Fitree.translate, Semantics.handle, cast_eq]
  . simp [Fitree.trigger, Fitree.interp'_bind, SSAEnvE.handle]
    simp [Fitree.translate, Semantics.handle, cast_eq]
end SCF_SELECT


def works (l : List α) : List α :=
  match l with
  | [] => []
  | _::tail =>
    works tail
decreasing_by decreasing_tactic -- to force well-founded recursion

-- Both of these appear in mathlib

@[simp]
theorem add_zero (n : Nat) : n + 0 = n := by sorry

@[simp]
theorem lt_add_iff_pos_left (a : Nat) {b : Nat} :
  a < b + a ↔ 0 < b
  := by sorry

-- Breaking this:

def should_still_work (l : List α) : List α :=
  match l with
  | [] => []
  | _::tail =>
    should_still_work tail
decreasing_by decreasing_tactic


import doubleround

open doubleround

namespace doubleround_examples

/-
  Examples from the spec.

  https://cr.yp.to/snuffle/spec.pdf
-/

-- example 1

def input : matrixType :=
  (
    (0x00000001, 0x00000000, 0x00000000, 0x00000000),
    (0x00000000, 0x00000000, 0x00000000, 0x00000000),
    (0x00000000, 0x00000000, 0x00000000, 0x00000000),
    (0x00000000, 0x00000000, 0x00000000, 0x00000000)
  )

def output : matrixType :=
  (
    (0x8186a22d, 0x0040a284, 0x82479210, 0x06929051),
    (0x08000090, 0x02402200, 0x00004000, 0x00800000),
    (0x00010200, 0x20400000, 0x08008104, 0x00000000),
    (0x20500000, 0xa0000040, 0x0008180a, 0x612a8020)
  )

--#eval if doubleround input = output then "pass" else "fail"

-- example 2

def input' : matrixType :=
  (
    (0xde501066, 0x6f9eb8f7, 0xe4fbbd9b, 0x454e3f57),
    (0xb75540d3, 0x43e93a4c, 0x3a6f2aa0, 0x726d6b36),
    (0x9243f484, 0x9145d1e8, 0x4fa9d247, 0xdc8dee11),
    (0x054bf545, 0x254dd653, 0xd9421b6d, 0x67b276c1)
  )

def output' : matrixType :=
  (
    (0xccaaf672, 0x23d960f7, 0x9153e63a, 0xcd9a60d0),
    (0x50440492, 0xf07cad19, 0xae344aa0, 0xdf4cfdfc),
    (0xca531c29, 0x8e7943db, 0xac1680cd, 0xd503ca00),
    (0xa74b2ad6, 0xbc331c5c, 0x1dda24c7, 0xee928277)
  )

--#eval if doubleround input' = output' then "pass" else "fail"

-- Inverse examples, we use the same test vectors as the spec but going backwards.

-- example 1
--#eval if doubleround_inv output = input then "pass" else "fail"

-- example 2
--#eval if doubleround_inv output' = input' then "pass" else "fail"

end doubleround_examples


import Lean

section utils
open Lean

/-- True Notation -/
notation "⊤" => True

/-- False Notation -/
notation "⊥" => False

/- plain numbers can't be used as identifiers so line number identifiers are prefixed with `L` -/
private abbrev mkLineId (n : Nat) : TSyntax [] := TSyntax.mk (mkIdent s!"L{n}")

/- theorem names are mildly obfuscated to avoid name clashes -/
private abbrev mkThmId (n : Name) : TSyntax [] := TSyntax.mk (mkIdent s!"T@{n}")

end utils

/-- Theorem Declaration

    Syntax: `thm <name> <vars> : <hyps> ⊢ <goal>`

    - `name` is the theorem name to be used in the `THM` proof command
    - `vars` is a space separated list of propositional variables
    - `hyps` is a comma separated list of hypotheses for the theorem
    - `goal` is the main theorem statement
-/
macro doc?:(docComment)? "thm " name:ident vars:ident* " : " hyps:term,* " ⊢ " goal:term " := " prf:term : command =>
  -- TODO: make docstrings work in a meaningful way
  -- TODO: can we get rid of the walrus?
  let ln := mkThmId name.getId
  `($[$doc?]? theorem $ln $[($vars : Prop)]* $[(_ : $hyps := by first | assumption | fail "missing hypothesis")]* : $goal := $prf)

/-- Basic Hilbert Proof Commands -/
declare_syntax_cat hbasic

/-- Proof Command

  Syntax: `proof <cmds> qed`

  - `cmds` is a sequence of proof commands on separate numbered lines

  Proof commands are of the shape `<lnum> <cmd> <args>` where `lnum` is the line number, `cmd` is the command name and `args` are the command arguments.
  Line numbers must be positive and increasing at each step.
  The last line of the proof should match the main statement of the theorem being proved.
-/
syntax "proof" (noWs "[" num "]")? withPosition(colGe hbasic)* "qed" : term

/- Syntax Checking -/
abbrev checkCMD := Lean.Parser.checkLineEq "command (MP, DT, HYP, LEM)"
abbrev checkTHM := Lean.Parser.checkLineEq "theorem name"
abbrev checkARG := Lean.Parser.checkColGt "proposition"
abbrev checkREF := Lean.Parser.checkLineEq "line number"

open Lean.Parser (semicolonOrLinebreak)

/-- Modus Ponens

  Syntax: `<lnum> MP <lref>`

  - `lnum` is the current line number
  - `lref` is a line reference for a conditional statement

  When the statement referred to by `lref` is `A → B` then this proof command searches for the hypothesis `A` among the previous lines.
  If `A` is found then it assigns `B` to the current line number.
-/
syntax num ws (checkCMD "MP ") (checkREF num) semicolonOrLinebreak : hbasic

/-- Deduction Theorem

  Syntax: `<lnum> DT`

  When the current goal is `A → B` then this proof command assigns `A` to the current line number and sets the goal to `B`.
-/
syntax num ws (checkCMD "DT ") semicolonOrLinebreak : hbasic

/-- Recall Hypothesis

  Syntax: `<lnum> HYP <prop>`

  - `lnum` is the current line number
  - `prop` is a propositional statement

  This proof command searches for `prop` among the theorem hypotheses and previous lines.
  If `prop` is found then it assigns `prop` to the current line number.
-/
syntax num ws (checkCMD "HYP ") (checkARG term:max) semicolonOrLinebreak : hbasic

/-- Invoke Theorem

  Syntax: `<lnum> THM <name> <args>`

  - `lnum` is the current line number
  - `name` is the name of the theorem invoked
  - `args` is a space separated list of propositions

  This proof command searches a theorem `name` declared using the `thm` command and then assigns `args` to the propositional variables of the theorem.
  If the theorem has hypotheses, it searches for each one among previous lines.
  Then it assigns the theorem's main proposition to the current line number.
-/
syntax num ws (checkCMD "THM ") (checkTHM ident) (colGt term:max)* semicolonOrLinebreak : hbasic

/- TODO: document implementation -/
open Lean in macro_rules
| `(proof qed%$tk) => withRef tk `(by done)
| `(proof[$m] qed%$tk) =>
  let lm := mkLineId m.getNat
  withRef tk `(by first | exact $lm | done)
| `(proof$[[$m]]? $n:num MP%$tk $ref; $rest* qed) =>
  let m := match m with | some m => m.getNat | none => 0
  if m < n.getNat then
    let ln := mkLineId n.getNat
    let lref := mkLineId ref.getNat
    withRef n `(have $ln : (_ : Prop) := $lref (by first | assumption | fail "missing hypothesis"); proof[$n] $rest* qed)
  else
    Macro.throwErrorAt n "line numbers must be positive and increasing"
| `(proof$[[$m]]? $n:num DT%$tk; $rest* qed) =>
  let m := match m with | some m => m.getNat | none => 0
  if m < n.getNat then
    let ln := mkLineId n.getNat
    withRef n `(fun $ln : (_ : Prop) => proof[$n] $rest* qed)
  else
    Macro.throwErrorAt n "line numbers must be positive and increasing"
| `(proof$[[$m]]? $n:num HYP%$tk $h; $rest* qed) =>
  let m := match m with | some m => m.getNat | none => 0
  if m < n.getNat then
    let ln := mkLineId n.getNat
    withRef n `(have $ln : ($h : Prop) := (by assumption); proof[$n] $rest* qed)
  else
    Macro.throwErrorAt n "line numbers must be positive and increasing"
| `(proof$[[$m]]? $n:num THM%$tk $name:ident $args:term*; $rest* qed) =>
  let m := match m with | some m => m.getNat | none => 0
  if m < n.getNat then
    let ln := mkLineId n.getNat
    let tn := mkThmId name.getId
    withRef n `(have $ln : (_ : Prop) := $tn $args*; proof[$n] $rest* qed)
  else
    Macro.throwErrorAt n "line numbers must be positive and increasing"

/- Basic Theorems

The two deduction rules Modus Ponens (`MP`) and Deduction Theorem (`DT`) only characterize implication.
The basic axioms below are necessary to define the other logical connectives:

- True (⊤)
- False (⊥)
- Negation (¬·)
- Conjunction (·∧·)
- Disjunction (·∨·)
- Biconditional (·↔·)

The proofs involve Lean core theorems since they can't be proved using only the basic rules of this system.

In addition to these basic axioms, the basic implication axioms S, K, I are defined.
This is because the DT is not actually necessary in the presence of these axioms, so we make them available to users who wish to avoid DT.

Also, Pierce's Law is presented as the only axiom from classical logic.
It is sufficient to derive all classical theorems and it has the advantage of being formulated only using implication.
Users that wish to work in intuitionistic logic should avoid this axiom.
The Lean `#print axioms` command is useful to determine whether Pierce's Law is used, even indirectly, in a proof.
-/
section basic_theorems

/-- Axiom I: a → a -/
thm AXI a : ⊢ a → a :=
proof
10 DT
qed

/-- Axiom K: a → b → a -/
thm AXK a b : ⊢ a → b → a :=
proof
10 DT
20 DT
30 HYP a
qed

/-- Axiom S: (a → b → c) → (a → b) → a → c -/
thm AXS a b c : ⊢ (a → b → c) → (a → b) → a → c :=
proof
10 DT
20 DT
30 DT
40 MP 20
50 MP 10
60 MP 50
qed

/-- Trivial: ⊤ -/
thm TRIV :
⊢ ⊤ := True.intro

/-- True Elimination: (⊤ → a) → a -/
thm THUS a :
⊢ (⊤ → a) → a :=
proof
10 DT
20 THM TRIV;
30 MP 10
qed

/-- Ex Falso Quodlibet: ⊥ → a -/
thm EXFALSO a :
⊢ ⊥ → a := False.elim

/-- Negation Introduction: (a → ⊥) → ¬ a -/
thm NOTI a :
⊢ (a → ⊥) → ¬ a := id

/-- Negation Elimination: ¬ a → a → ⊥ -/
thm NOTE a :
⊢ ¬ a → a → ⊥ := id

/-- Conjunction Introduction: a → b → a ∧ b -/
thm ANDI a b :
⊢ a → b → a ∧ b := And.intro

/-- Conjunction Elimination: (a → b → c) → a ∧ b → c -/
thm ANDE a b c :
⊢ (a → b → c) → a ∧ b → c := And.rec

/-- Conjunction Elimination (Left): a ∧ b → a -/
thm ANDL a b :
⊢ a ∧ b → a := -- And.left
proof
10 THM AXK a b
20 THM ANDE a b a
30 MP 20
qed

/-- Conjunction Elimination (Right): a ∧ b → b -/
thm ANDR a b :
⊢ a ∧ b → b := -- And.right
proof
10 THM AXK (b → b) a
20 THM AXI b
30 MP 10
40 THM ANDE a b b
50 MP 40
qed

/-- Disjunction Elimination: (a → c) → (b → c) → a ∨ b → c -/
thm ORE a b c :
⊢ (a → c) → (b → c) → a ∨ b → c := Or.rec

/-- Disjunction Introduction (Left): a → a ∨ b -/
thm ORL a b :
⊢ a → a ∨ b := Or.inl

/-- Disjunction Introduction (Right): b → a ∨ b -/
thm ORR a b :
⊢ b → a ∨ b := Or.inr

/-- Biconditional Introduction: (a → b) → (b → a) → (a ↔ b) -/
thm IFFI a b :
⊢ (a → b) → (b → a) → (a ↔ b) := Iff.intro

/-- Biconditional Elimination (Left): (a ↔ b) → a → b -/
thm IFFL a b :
⊢ (a ↔ b) → a → b := Iff.mp

/-- Biconditional Elimination (Right): (a ↔ b) → b → a -/
thm IFFR a b :
⊢ (a ↔ b) → b → a := Iff.mpr

/-- Pierce's Law: ((a → b) → a) → a -/
thm PIERCE a b :
⊢ ((a → b) → a) → a :=
fun h => match Classical.em a with
| .inl ha => ha
| .inr na => h fun ha => absurd ha na

end basic_theorems

/- Testing Zone -/
section test_theorems

thm IFTRANS a b c :
⊢ (a → b) → (b → c) → a → c :=
proof
10 DT
20 DT
30 DT
40 MP 10
50 MP 20
qed

thm IFLCOMM a b c :
⊢ (a → b → c) → b → a → c :=
proof
10 DT
20 DT
30 DT
40 MP 10
50 MP 40
qed

thm ANDIDEMR a :
⊢ a → a ∧ a :=
proof
10 DT
20 THM ANDI a a
30 MP 20
40 MP 30
qed

thm ANDIDEM a :
⊢ a ∧ a ↔ a :=
proof
10 THM ANDL a a
20 THM ANDIDEMR a
30 THM IFFI (a ∧ a) a
40 MP 30
50 MP 40
qed

thm ANDCOMM a b :
⊢ a ∧ b → b ∧ a :=
proof
10 THM ANDE a b (b ∧ a)
20 THM IFLCOMM b a (b ∧ a)
30 THM ANDI b a
40 MP 20
50 MP 10
qed

thm ANDASSOCL a b c :
⊢ a ∧ (b ∧ c) → (a ∧ b) ∧ c :=
proof
10 DT
20 THM ANDL a (b ∧ c)
30 MP 20
40 THM ANDR a (b ∧ c)
50 MP 40
60 THM ANDL b c
70 MP 60
80 THM ANDR b c
90 MP 80
100 THM ANDI a b
110 MP 100
120 MP 110
130 THM ANDI (a ∧ b) c
140 MP 130
150 MP 140
qed

thm ANDASSOCR a b c :
⊢ (a ∧ b) ∧ c → a ∧ (b ∧ c) :=
proof
10 DT
20 THM ANDR (a ∧ b) c
30 MP 20
40 THM ANDL (a ∧ b) c
50 MP 40
60 THM ANDR a b
70 MP 60
80 THM ANDL a b
90 MP 80
100 THM ANDI b c
110 MP 100
120 MP 110
130 THM ANDI a (b ∧ c)
140 MP 130
150 MP 140
qed

thm ANDASSOC a b c :
⊢ (a ∧ b) ∧ c ↔ a ∧ (b ∧ c) :=
proof
10 THM ANDASSOCL a b c
20 THM ANDASSOCR a b c
30 THM IFFI ((a ∧ b) ∧ c) (a ∧ (b ∧ c))
40 MP 30
50 MP 40
qed

thm ANDTRUEL a :
⊢ ⊤ ∧ a ↔ a :=
proof
10 THM TRIV;
20 THM ANDR ⊤ a
30 THM ANDI ⊤ a
40 MP 30
50 THM IFFI (⊤ ∧ a) a
60 MP 50
70 MP 60
qed

thm ORIDEML a :
⊢ a ∨ a → a :=
proof
10 THM AXI a
20 THM ORE a a a
30 MP 20
40 MP 30
qed

thm ORIDEM :
⊢ a ∨ a ↔ a :=
proof
10 THM ORIDEML a
20 THM ORL a a
30 THM IFFI (a ∨ a) a
40 MP 30
50 MP 40
qed

thm ORCOMM a b :
⊢ a ∨ b → b ∨ a :=
proof
10 THM ORL b a
20 THM ORR b a
30 THM ORE a b (b ∨ a)
40 MP 30
50 MP 40
qed

thm ORASSOCL a b c :
⊢ a ∨ (b ∨ c) → (a ∨ b) ∨ c :=
proof
10 DT
20 THM ORE a (b ∨ c) ((a ∨ b) ∨ c)
30 THM ORL a b
40 THM ORL (a ∨ b) c
50 THM IFTRANS a (a ∨ b) ((a ∨ b) ∨ c)
60 MP 50
70 MP 60
80 MP 20
90 THM ORE b c ((a ∨ b) ∨ c)
100 THM ORR a b
110 THM ORL (a ∨ b) c
120 THM ORR (a ∨ b) c
130 THM IFTRANS b (a ∨ b) ((a ∨ b) ∨ c)
140 MP 130
150 MP 140
160 MP 90
170 MP 160
180 MP 80
190 MP 180
qed

thm ORASSOCR a b c :
⊢ (a ∨ b) ∨ c → a ∨ (b ∨ c) :=
proof
10 DT
20 THM ORE a b (a ∨ (b ∨ c))
30 THM ORL a (b ∨ c)
40 THM ORL b c
50 THM ORR a (b ∨ c)
60 THM IFTRANS b (b ∨ c) (a ∨ (b ∨ c))
70 MP 60
80 MP 70
90 MP 20
100 MP 90
110 THM ORR b c
120 THM IFTRANS c (b ∨ c) (a ∨ (b ∨ c))
130 MP 120
140 MP 130
150 THM ORE (a ∨ b) c (a ∨ (b ∨ c))
160 MP 150
170 MP 160
180 MP 170
qed

thm ORASSOC a b c :
⊢ (a ∨ b) ∨ c ↔ a ∨ (b ∨ c) :=
proof
10 THM ORASSOCL a b c
20 THM ORASSOCR a b c
30 THM IFFI ((a ∨ b) ∨ c) (a ∨ (b ∨ c))
40 MP 30
50 MP 40
qed

thm ORRESL a b :
⊢ a ∨ b → ¬a → b :=
proof
10 DT
20 DT
30 THM ORE a b b
40 THM IFTRANS a ⊥ b
50 THM NOTE a
60 MP 50
70 MP 40
80 THM EXFALSO b
90 MP 70
100 MP 30
110 THM AXI b
120 MP 100
130 MP 120
qed

thm ORRESR a b :
⊢ a ∨ b → ¬b → a :=
proof
10 DT
20 DT
30 THM ORE a b a
40 THM AXI a
50 MP 30
60 THM IFTRANS b ⊥ a
70 THM NOTE b
80 MP 70
90 MP 60
100 THM EXFALSO a
110 MP 90
120 MP 50
130 MP 120
qed

thm ANDDISTRIBL a b c :
⊢ a ∧ (b ∨ c) → (a ∧ b) ∨ (a ∧ c) :=
proof
10 DT
20 THM ANDL a (b ∨ c)
30 MP 20
40 THM ANDR a (b ∨ c)
50 MP 40
60 THM ORE b c ((a ∧ b) ∨ (a ∧ c))
70 THM IFTRANS b (a ∧ b) ((a ∧ b) ∨ (a ∧ c))
80 THM ANDI a b
90 MP 80
100 MP 70
110 THM ORL (a ∧ b) (a ∧ c)
120 MP 100
130 THM IFTRANS c (a ∧ c) ((a ∧ b) ∨ (a ∧ c))
140 THM ANDI a c
150 MP 140
160 MP 130
170 THM ORR (a ∧ b) (a ∧ c)
180 MP 160
190 MP 60
200 MP 190
210 MP 200
qed

end test_theorems