53 lines
1.3 KiB
Lean4
53 lines
1.3 KiB
Lean4
namespace BidirTT
|
||
|
||
inductive Level where
|
||
| zero : Level
|
||
| succ : Level → Level
|
||
| max : Level → Level → Level
|
||
deriving Repr, Inhabited, BEq, DecidableEq
|
||
|
||
def Level.ofNat : Nat → Level
|
||
| 0 => .zero
|
||
| n + 1 => .succ (Level.ofNat n)
|
||
|
||
instance (n : Nat) : OfNat Level n where
|
||
ofNat := Level.ofNat n
|
||
|
||
partial def Level.eval : Level → Nat
|
||
| .zero => 0
|
||
| .succ l => l.eval + 1
|
||
| .max l r => Nat.max l.eval r.eval
|
||
|
||
def Level.normalise (l : Level) : Level :=
|
||
.ofNat l.eval
|
||
|
||
def Level.succ' (l : Level) : Level :=
|
||
.normalise (.succ l)
|
||
|
||
def Level.max' (l r : Level) : Level :=
|
||
.normalise (.max l r)
|
||
|
||
def Level.pretty (l : Level) : String :=
|
||
s!"{l.eval}"
|
||
|
||
abbrev LevelConstraint := Level × Level
|
||
|
||
def solveLevelConstraints (constraints : List LevelConstraint) : Except String Unit := do
|
||
match constraints.find? fun (lhs, rhs) => lhs.eval > rhs.eval with
|
||
| some (lhs, rhs) =>
|
||
throw s!"unsatisfiable level constraint {lhs.pretty} <= {rhs.pretty}"
|
||
| none =>
|
||
pure ()
|
||
|
||
def Level.leq (lhs rhs : Level) : Except String Bool := do
|
||
match solveLevelConstraints [(lhs, rhs)] with
|
||
| Except.ok _ => pure true
|
||
| Except.error _ => pure false
|
||
|
||
def Level.eqv (lhs rhs : Level) : Except String Bool := do
|
||
match solveLevelConstraints [(lhs, rhs), (rhs, lhs)] with
|
||
| Except.ok _ => pure true
|
||
| Except.error _ => pure false
|
||
|
||
end BidirTT
|