Write Nat/Unit/Empty/Id Eliminators Through NbE and Bidir Elaboration

BidirTT/Eval.lean

@@ -32,6 +32,41 @@ mutual
     | env, .snd t      => do
         let vt ← eval env t
         vSnd vt
+    | _,   .nat        => pure .nat
+    | _,   .zero       => pure .zero
+    | env, .succ t     => do
+        let vt ← eval env t
+        pure (.succ vt)
+    | env, .natElim m z s n => do
+        let vm ← eval env m
+        let vz ← eval env z
+        let vs ← eval env s
+        let vn ← eval env n
+        vNatElim vm vz vs vn
+    | _,   .unit       => pure .unit
+    | _,   .triv       => pure .triv
+    | env, .unitElim m t u => do
+        let vm ← eval env m
+        let vt ← eval env t
+        let vu ← eval env u
+        vUnitElim vm vt vu
+    | _,   .empty      => pure .empty
+    | env, .emptyElim m e => do
+        let vm ← eval env m
+        let ve ← eval env e
+        vEmptyElim vm ve
+    | env, .id a t u   => do
+        let va ← eval env a
+        let vt ← eval env t
+        let vu ← eval env u
+        pure (.id va vt vu)
+    | _,   .refl       => pure .refl
+    | env, .idElim m r y p => do
+        let vm ← eval env m
+        let vr ← eval env r
+        let vy ← eval env y
+        let vp ← eval env p
+        vIdElim vm vr vy vp
     | _,   .univ i     => pure (.univ i)
     | env, .letE _ t u => do
         let vt ← eval env t
@@ -49,6 +84,25 @@ mutual
     | .pair _ b => pure b
     | t         => pure (.snd t)
 
+  partial def vNatElim : Val → Val → Val → Val → EvalM Val
+    | _, z, _, .zero   => pure z
+    | m, z, s, .succ n => do
+        let ih ← vNatElim m z s n
+        let step ← vApp s n
+        vApp step ih
+    | m, z, s, n       => pure (.natElim m z s n)
+
+  partial def vUnitElim : Val → Val → Val → EvalM Val
+    | _, t, .triv => pure t
+    | m, t, u     => pure (.unitElim m t u)
+
+  partial def vEmptyElim : Val → Val → EvalM Val
+    | m, e => pure (.emptyElim m e)
+
+  partial def vIdElim : Val → Val → Val → Val → EvalM Val
+    | _, r, _, .refl => pure r
+    | m, r, y, p     => pure (.idElim m r y p)
+
   partial def cApp : Closure → Val → EvalM Val
     | .mk env body, v => eval (v :: env) body
 end
@@ -69,6 +123,41 @@ partial def quote : Lvl → Val → EvalM Tm
   | l, .snd t    => do
       let qt ← quote l t
       pure (.snd qt)
+  | _, .nat      => pure .nat
+  | _, .zero     => pure .zero
+  | l, .succ t   => do
+      let qt ← quote l t
+      pure (.succ qt)
+  | l, .natElim m z s n => do
+      let qm ← quote l m
+      let qz ← quote l z
+      let qs ← quote l s
+      let qn ← quote l n
+      pure (.natElim qm qz qs qn)
+  | _, .unit     => pure .unit
+  | _, .triv     => pure .triv
+  | l, .unitElim m t u => do
+      let qm ← quote l m
+      let qt ← quote l t
+      let qu ← quote l u
+      pure (.unitElim qm qt qu)
+  | _, .empty    => pure .empty
+  | l, .emptyElim m e => do
+      let qm ← quote l m
+      let qe ← quote l e
+      pure (.emptyElim qm qe)
+  | l, .id a t u => do
+      let qa ← quote l a
+      let qt ← quote l t
+      let qu ← quote l u
+      pure (.id qa qt qu)
+  | _, .refl     => pure .refl
+  | l, .idElim m r y p => do
+      let qm ← quote l m
+      let qr ← quote l r
+      let qy ← quote l y
+      let qp ← quote l p
+      pure (.idElim qm qr qy qp)
   | l, .lam c    => do
       let body ← cApp c (.var l)
       let qb ← quote (l + 1) body
@@ -107,6 +196,51 @@ partial def conv : Lvl → Val → Val → EvalM Bool
         let b  ← cApp c (.var l)
         let b' ← cApp c' (.var l)
         conv (l + 1) b b'
+  | _, .nat,        .nat        => pure true
+  | _, .zero,       .zero       => pure true
+  | l, .succ n,     .succ n'    => conv l n n'
+  | l, .natElim m z s n, .natElim m' z' s' n' =>
+      andThen (conv l m m') fun _ => do
+        let sameZ ← conv l z z'
+        if sameZ then
+          let sameS ← conv l s s'
+          if sameS then
+            conv l n n'
+          else
+            pure false
+        else
+          pure false
+  | _, .unit,       .unit       => pure true
+  | _, .triv,       .triv       => pure true
+  | l, .unitElim m t u, .unitElim m' t' u' =>
+      andThen (conv l m m') fun _ => do
+        let sameT ← conv l t t'
+        if sameT then
+          conv l u u'
+        else
+          pure false
+  | _, .empty,      .empty      => pure true
+  | l, .emptyElim m e, .emptyElim m' e' =>
+      andThen (conv l m m') fun _ => conv l e e'
+  | l, .id a t u,   .id a' t' u' =>
+      andThen (conv l a a') fun _ => do
+        let sameT ← conv l t t'
+        if sameT then
+          conv l u u'
+        else
+          pure false
+  | _, .refl,       .refl       => pure true
+  | l, .idElim m r y p, .idElim m' r' y' p' =>
+      andThen (conv l m m') fun _ => do
+        let sameR ← conv l r r'
+        if sameR then
+          let sameY ← conv l y y'
+          if sameY then
+            conv l p p'
+          else
+            pure false
+        else
+          pure false
   | l, .lam c,      .lam c'     =>
       do
         let body  ← cApp c (.var l)
@@ -147,4 +281,18 @@ partial def conv : Lvl → Val → Val → EvalM Bool
   | l, .snd t,      .snd t'     => conv l t t'
   | _, _,           _           => pure false
 
+partial def sub : Lvl → Val → Val → EvalM Bool
+  | _, .univ i,     .univ j     => pure (i <= j)
+  | l, .pi a c,     .pi a' c'   =>
+      andThen (sub l a' a) fun _ => do
+        let b  ← cApp c (.var l)
+        let b' ← cApp c' (.var l)
+        sub (l + 1) b b'
+  | l, .sig a c,    .sig a' c'  =>
+      andThen (sub l a a') fun _ => do
+        let b  ← cApp c (.var l)
+        let b' ← cApp c' (.var l)
+        sub (l + 1) b b'
+  | l, t,           t'          => conv l t t'
+
 end BidirTT