remove Tighten stuff
This commit is contained in:
parent
f00c802336
commit
2bfe3250cf
15 changed files with 84 additions and 506 deletions
|
|
@ -14,7 +14,7 @@ coeScoped : {s : Nat} -> DScopeTerm d n -> Dim d -> Dim d -> Loc ->
|
|||
coeScoped ty p q loc (S names (N body)) =
|
||||
S names $ N $ E $ Coe ty p q body loc
|
||||
coeScoped ty p q loc (S names (Y body)) =
|
||||
ST names $ E $ Coe (weakDS s ty) p q body loc
|
||||
SY names $ E $ Coe (weakDS s ty) p q body loc
|
||||
where
|
||||
weakDS : (by : Nat) -> DScopeTerm d n -> DScopeTerm d (by + n)
|
||||
weakDS by (S names (Y body)) = S names $ Y $ weakT by body
|
||||
|
|
@ -38,11 +38,11 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
|
|||
let ctx1 = extendDim i ctx
|
||||
Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
|
||||
(arg, res) <- tycasePi defs ctx1 ty
|
||||
let s0 = CoeT i arg q p s s.loc
|
||||
let s0 = CoeY i arg q p s s.loc
|
||||
body = E $ App (Ann val (ty // one p) val.loc) (E s0) loc
|
||||
s1 = CoeT i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc)
|
||||
s1 = CoeY i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc)
|
||||
(s // shift 1) s.loc
|
||||
whnf defs ctx sg $ CoeT i (sub1 res s1) p q body loc
|
||||
whnf defs ctx sg $ CoeY i (sub1 res s1) p q body loc
|
||||
|
||||
||| reduce a pair elimination `CasePair pi (Coe ty p q val) ret body loc`
|
||||
export covering
|
||||
|
|
@ -63,13 +63,13 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
|
|||
Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
|
||||
(tfst, tsnd) <- tycaseSig defs ctx1 ty
|
||||
let [< x, y] = body.names
|
||||
a' = CoeT i (weakT 2 tfst) p q (BVT 1 x.loc) x.loc
|
||||
a' = CoeY i (weakT 2 tfst) p q (BVT 1 x.loc) x.loc
|
||||
tsnd' = tsnd.term //
|
||||
(CoeT i (weakT 2 $ tfst // (B VZ tsnd.loc ::: shift 2))
|
||||
(CoeY i (weakT 2 $ tfst // (B VZ tsnd.loc ::: shift 2))
|
||||
(weakD 1 p) (B VZ i.loc) (BVT 1 tsnd.loc) y.loc ::: shift 2)
|
||||
b' = CoeT i tsnd' p q (BVT 0 y.loc) y.loc
|
||||
b' = CoeY i tsnd' p q (BVT 0 y.loc) y.loc
|
||||
whnf defs ctx sg $ CasePair qty (Ann val (ty // one p) val.loc) ret
|
||||
(ST body.names $ body.term // (a' ::: b' ::: shift 2)) loc
|
||||
(SY body.names $ body.term // (a' ::: b' ::: shift 2)) loc
|
||||
|
||||
||| reduce a pair projection `Fst (Coe ty p q val) loc`
|
||||
export covering
|
||||
|
|
@ -85,7 +85,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
|
|||
Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
|
||||
(tfst, _) <- tycaseSig defs ctx1 ty
|
||||
whnf defs ctx sg $
|
||||
Coe (ST [< i] tfst) p q
|
||||
Coe (SY [< i] tfst) p q
|
||||
(E (Fst (Ann val (ty // one p) val.loc) val.loc)) loc
|
||||
|
||||
||| reduce a pair projection `Snd (Coe ty p q val) loc`
|
||||
|
|
@ -103,8 +103,8 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
|
|||
Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
|
||||
(tfst, tsnd) <- tycaseSig defs ctx1 ty
|
||||
whnf defs ctx sg $
|
||||
Coe (ST [< i] $ sub1 tsnd $
|
||||
Coe (ST [< !(fresh i)] $ tfst // (BV 0 i.loc ::: shift 2))
|
||||
Coe (SY [< i] $ sub1 tsnd $
|
||||
Coe (SY [< !(fresh i)] $ tfst // (BV 0 i.loc ::: shift 2))
|
||||
(weakD 1 p) (BV 0 loc)
|
||||
(E (Fst (Ann (dweakT 1 val) ty val.loc) val.loc)) loc)
|
||||
p q
|
||||
|
|
@ -142,9 +142,9 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
|
|||
Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty
|
||||
ta <- tycaseBOX defs ctx1 ty
|
||||
let xloc = body.name.loc
|
||||
let a' = CoeT i (weakT 1 ta) p q (BVT 0 xloc) xloc
|
||||
let a' = CoeY i (weakT 1 ta) p q (BVT 0 xloc) xloc
|
||||
whnf defs ctx sg $ CaseBox qty (Ann val (ty // one p) val.loc) ret
|
||||
(ST body.names $ body.term // (a' ::: shift 1)) loc
|
||||
(SY body.names $ body.term // (a' ::: shift 1)) loc
|
||||
|
||||
|
||||
-- new params block to call the above functions at different `n`
|
||||
|
|
@ -195,12 +195,12 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
|
|||
-- ∷ ((x : A) × B)‹q/𝑖›
|
||||
Sig tfst tsnd tyLoc => do
|
||||
let Pair fst snd sLoc = s
|
||||
fst' = CoeT i tfst p q fst fst.loc
|
||||
fst' = CoeY i tfst p q fst fst.loc
|
||||
fstInSnd =
|
||||
CoeT !(fresh i)
|
||||
CoeY !(fresh i)
|
||||
(tfst // (BV 0 loc ::: shift 2))
|
||||
(weakD 1 p) (BV 0 loc) (dweakT 1 fst) fst.loc
|
||||
snd' = CoeT i (sub1 tsnd fstInSnd) p q snd snd.loc
|
||||
snd' = CoeY i (sub1 tsnd fstInSnd) p q snd snd.loc
|
||||
whnf defs ctx sg $
|
||||
Ann (Pair (E fst') (E snd') sLoc) (ty // one q) loc
|
||||
|
||||
|
|
|
|||
|
|
@ -206,25 +206,18 @@ CanWhnf Elim Interface.isRedexE where
|
|||
Element a anf <- whnf defs ctx SZero a
|
||||
pure $ Element (Ann s a annLoc) (ne `orNo` snf `orNo` anf)
|
||||
|
||||
whnfNoLog defs ctx sg (Coe sty p q val coeLoc) =
|
||||
-- 𝑖 ∉ fv(A)
|
||||
-- -------------------------------
|
||||
-- coe (𝑖 ⇒ A) @p @q s ⇝ s ∷ A
|
||||
--
|
||||
-- [fixme] needs a real equality check between A‹0/𝑖› and A‹1/𝑖›
|
||||
case dsqueeze sty {f = Term} of
|
||||
([< i], Left ty) =>
|
||||
case p `decEqv` q of
|
||||
-- coe (𝑖 ⇒ A) @p @p s ⇝ (s ∷ A‹p/𝑖›)
|
||||
Yes _ => whnf defs ctx sg $ Ann val (dsub1 sty p) coeLoc
|
||||
No npq => do
|
||||
Element ty tynf <- whnf defs (extendDim i ctx) SZero ty
|
||||
case nchoose $ canPushCoe sg ty val of
|
||||
Left pc => pushCoe defs ctx sg i ty p q val coeLoc
|
||||
Right npc => pure $ Element (Coe (SY [< i] ty) p q val coeLoc)
|
||||
(tynf `orNo` npc `orNo` notYesNo npq)
|
||||
(_, Right ty) =>
|
||||
whnf defs ctx sg $ Ann val ty coeLoc
|
||||
whnfNoLog defs ctx sg (Coe sty@(S [< i] ty) p q val coeLoc) =
|
||||
-- reduction if A‹0/𝑖› = A‹1/𝑖› lives in Equal
|
||||
case p `decEqv` q of
|
||||
-- coe (𝑖 ⇒ A) @p @p s ⇝ (s ∷ A‹p/𝑖›)
|
||||
Yes _ => whnf defs ctx sg $ Ann val (dsub1 sty p) coeLoc
|
||||
No npq => do
|
||||
let ty = getTerm ty
|
||||
Element ty tynf <- whnf defs (extendDim i ctx) SZero ty
|
||||
case nchoose $ canPushCoe sg ty val of
|
||||
Left pc => pushCoe defs ctx sg i ty p q val coeLoc
|
||||
Right npc => pure $ Element (Coe (SY [< i] ty) p q val coeLoc)
|
||||
(tynf `orNo` npc `orNo` notYesNo npq)
|
||||
|
||||
whnfNoLog defs ctx sg (Comp ty p q val r zero one compLoc) =
|
||||
case p `decEqv` q of
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
|
|||
arg = E $ typeCase1Y e ty KPi [< !narg, !nret] (BVT 1 loc) loc
|
||||
res' = typeCase1Y e (Arr Zero arg ty loc) KPi [< !narg, !nret]
|
||||
(BVT 0 loc) loc
|
||||
res = ST [< !narg] $ E $ App (weakE 1 res') (BVT 0 loc) loc
|
||||
res = SY [< !narg] $ E $ App (weakE 1 res') (BVT 0 loc) loc
|
||||
pure (arg, res)
|
||||
tycasePi t = throw $ ExpectedPi t.loc ctx.names t
|
||||
|
||||
|
|
@ -63,7 +63,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
|
|||
fst = E $ typeCase1Y e ty KSig [< !nfst, !nsnd] (BVT 1 loc) loc
|
||||
snd' = typeCase1Y e (Arr Zero fst ty loc) KSig [< !nfst, !nsnd]
|
||||
(BVT 0 loc) loc
|
||||
snd = ST [< !nfst] $ E $ App (weakE 1 snd') (BVT 0 loc) loc
|
||||
snd = SY [< !nfst] $ E $ App (weakE 1 snd') (BVT 0 loc) loc
|
||||
pure (fst, snd)
|
||||
tycaseSig t = throw $ ExpectedSig t.loc ctx.names t
|
||||
|
||||
|
|
@ -93,7 +93,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT}
|
|||
a0 = E $ typeCase1Y e ty KEq !names (BVT 4 loc) loc
|
||||
a1 = E $ typeCase1Y e ty KEq !names (BVT 3 loc) loc
|
||||
a' = typeCase1Y e (Eq0 ty a0 a1 loc) KEq !names (BVT 2 loc) loc
|
||||
a = DST [< !(mnb "i" loc)] $ E $ DApp (dweakE 1 a') (B VZ loc) loc
|
||||
a = SY [< !(mnb "i" loc)] $ E $ DApp (dweakE 1 a') (B VZ loc) loc
|
||||
l = E $ typeCase1Y e a0 KEq !names (BVT 1 loc) loc
|
||||
r = E $ typeCase1Y e a1 KEq !names (BVT 0 loc) loc
|
||||
pure (a0, a1, a, l, r)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue