wip make qtys into polynomials
This commit is contained in:
parent
1d8a6bb325
commit
4c008577b4
22 changed files with 1650 additions and 1254 deletions
|
|
@ -29,20 +29,20 @@ tightenDScope f p (S names (N body)) = S names . N <$> f p body
|
|||
|
||||
mutual
|
||||
private
|
||||
tightenT : OPE n1 n2 -> Term d n2 -> Maybe (Term d n1)
|
||||
tightenT : {q : Nat} -> OPE n1 n2 -> Term q d n2 -> Maybe (Term q d n1)
|
||||
tightenT p s =
|
||||
let Element s' _ = pushSubsts s in
|
||||
tightenT' p $ assert_smaller s s'
|
||||
|
||||
private
|
||||
tightenE : OPE n1 n2 -> Elim d n2 -> Maybe (Elim d n1)
|
||||
tightenE : {q : Nat} -> OPE n1 n2 -> Elim q d n2 -> Maybe (Elim q d n1)
|
||||
tightenE p e =
|
||||
let Element e' _ = pushSubsts e in
|
||||
tightenE' p $ assert_smaller e e'
|
||||
|
||||
private
|
||||
tightenT' : OPE n1 n2 -> (t : Term d n2) -> (0 nt : NotClo t) =>
|
||||
Maybe (Term d n1)
|
||||
tightenT' : {q : Nat} -> OPE n1 n2 -> (t : Term q d n2) -> (0 nt : NotClo t) =>
|
||||
Maybe (Term q d n1)
|
||||
tightenT' p (TYPE l loc) = pure $ TYPE l loc
|
||||
tightenT' p (IOState loc) = pure $ IOState loc
|
||||
tightenT' p (Pi qty arg res loc) =
|
||||
|
|
@ -81,8 +81,9 @@ mutual
|
|||
E <$> assert_total tightenE p e
|
||||
|
||||
private
|
||||
tightenE' : OPE n1 n2 -> (e : Elim d n2) -> (0 ne : NotClo e) =>
|
||||
Maybe (Elim d n1)
|
||||
tightenE' : {q : Nat} ->
|
||||
OPE n1 n2 -> (e : Elim q d n2) -> (0 ne : NotClo e) =>
|
||||
Maybe (Elim q d n1)
|
||||
tightenE' p (F x u loc) =
|
||||
pure $ F x u loc
|
||||
tightenE' p (B i loc) =
|
||||
|
|
@ -140,34 +141,35 @@ mutual
|
|||
<*> pure loc
|
||||
|
||||
export
|
||||
tightenS : {s : Nat} -> OPE m n ->
|
||||
ScopeTermN s f n -> Maybe (ScopeTermN s f m)
|
||||
tightenS : {q, s : Nat} -> OPE m n ->
|
||||
ScopeTermN s q d n -> Maybe (ScopeTermN s q d m)
|
||||
tightenS = assert_total $ tightenScope tightenT
|
||||
|
||||
export
|
||||
tightenDS : OPE m n -> DScopeTermN s f n -> Maybe (DScopeTermN s f m)
|
||||
tightenDS = assert_total $ tightenDScope tightenT {f = \n, d => Term d n}
|
||||
tightenDS : {q : Nat} ->
|
||||
OPE m n -> DScopeTermN s q d n -> Maybe (DScopeTermN s q d m)
|
||||
tightenDS = assert_total $ tightenDScope tightenT {f = \n, d => Term q d n}
|
||||
|
||||
export Tighten (Elim d) where tighten p e = tightenE p e
|
||||
export Tighten (Term d) where tighten p t = tightenT p t
|
||||
export {q : Nat} -> Tighten (Elim q d) where tighten p e = tightenE p e
|
||||
export {q : Nat} -> Tighten (Term q d) where tighten p t = tightenT p t
|
||||
|
||||
|
||||
mutual
|
||||
export
|
||||
dtightenT : OPE d1 d2 -> Term d2 n -> Maybe (Term d1 n)
|
||||
dtightenT : {q : Nat} -> OPE d1 d2 -> Term q d2 n -> Maybe (Term q d1 n)
|
||||
dtightenT p s =
|
||||
let Element s' _ = pushSubsts s in
|
||||
dtightenT' p $ assert_smaller s s'
|
||||
|
||||
export
|
||||
dtightenE : OPE d1 d2 -> Elim d2 n -> Maybe (Elim d1 n)
|
||||
dtightenE : {q : Nat} -> OPE d1 d2 -> Elim q d2 n -> Maybe (Elim q d1 n)
|
||||
dtightenE p e =
|
||||
let Element e' _ = pushSubsts e in
|
||||
dtightenE' p $ assert_smaller e e'
|
||||
|
||||
private
|
||||
dtightenT' : OPE d1 d2 -> (t : Term d2 n) -> (0 nt : NotClo t) =>
|
||||
Maybe (Term d1 n)
|
||||
dtightenT' : {q : Nat} -> OPE d1 d2 -> (t : Term q d2 n) -> (0 nt : NotClo t) =>
|
||||
Maybe (Term q d1 n)
|
||||
dtightenT' p (TYPE l loc) =
|
||||
pure $ TYPE l loc
|
||||
dtightenT' p (IOState loc) =
|
||||
|
|
@ -208,8 +210,8 @@ mutual
|
|||
E <$> assert_total dtightenE p e
|
||||
|
||||
export
|
||||
dtightenE' : OPE d1 d2 -> (e : Elim d2 n) -> (0 ne : NotClo e) =>
|
||||
Maybe (Elim d1 n)
|
||||
dtightenE' : {q : Nat} -> OPE d1 d2 -> (e : Elim q d2 n) -> (0 ne : NotClo e) =>
|
||||
Maybe (Elim q d1 n)
|
||||
dtightenE' p (F x u loc) =
|
||||
pure $ F x u loc
|
||||
dtightenE' p (B i loc) =
|
||||
|
|
@ -258,17 +260,18 @@ mutual
|
|||
(traverse (dtightenS p) arms) (dtightenT p def) (pure loc)|]
|
||||
|
||||
export
|
||||
dtightenS : OPE d1 d2 -> ScopeTermN s d2 n -> Maybe (ScopeTermN s d1 n)
|
||||
dtightenS = assert_total $ tightenDScope dtightenT {f = Term}
|
||||
dtightenS : {q : Nat} -> OPE d1 d2 -> ScopeTermN s q d2 n ->
|
||||
Maybe (ScopeTermN s q d1 n)
|
||||
dtightenS = assert_total $ tightenDScope dtightenT {f = Term q}
|
||||
|
||||
export
|
||||
dtightenDS : {s : Nat} -> OPE d1 d2 ->
|
||||
DScopeTermN s d2 n -> Maybe (DScopeTermN s d1 n)
|
||||
dtightenDS : {q, s : Nat} -> OPE d1 d2 ->
|
||||
DScopeTermN s q d2 n -> Maybe (DScopeTermN s q d1 n)
|
||||
dtightenDS = assert_total $ tightenScope dtightenT
|
||||
|
||||
|
||||
export Tighten (\d => Term d n) where tighten p t = dtightenT p t
|
||||
export Tighten (\d => Elim d n) where tighten p e = dtightenE p e
|
||||
export {q : Nat} -> Tighten (\d => Term q d n) where tighten p t = dtightenT p t
|
||||
export {q : Nat} -> Tighten (\d => Elim q d n) where tighten p e = dtightenE p e
|
||||
|
||||
|
||||
parameters {auto _ : Tighten f} {s : Nat}
|
||||
|
|
@ -300,59 +303,64 @@ ST : Tighten f => {s : Nat} -> BContext s -> f (s + n) -> Scoped s f n
|
|||
ST names body = squeeze' $ SY names body
|
||||
|
||||
public export %inline
|
||||
DST : {s : Nat} -> BContext s -> Term (s + d) n -> DScopeTermN s d n
|
||||
DST names body = dsqueeze' {f = Term} $ SY names body
|
||||
DST : {s, q : Nat} -> BContext s -> Term q (s + d) n -> DScopeTermN s q d n
|
||||
DST names body = dsqueeze' {f = Term q} $ SY names body
|
||||
|
||||
public export %inline
|
||||
PiT : (qty : Qty) -> (x : BindName) ->
|
||||
(arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||
PiT : {q : Nat} -> (qty : Qty q) -> (x : BindName) ->
|
||||
(arg : Term q d n) -> (res : Term q d (S n)) -> (loc : Loc) -> Term q d n
|
||||
PiT {qty, x, arg, res, loc} = Pi {qty, arg, res = ST [< x] res, loc}
|
||||
|
||||
public export %inline
|
||||
LamT : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||
LamT : {q : Nat} ->
|
||||
(x : BindName) -> (body : Term q d (S n)) -> (loc : Loc) -> Term q d n
|
||||
LamT {x, body, loc} = Lam {body = ST [< x] body, loc}
|
||||
|
||||
public export %inline
|
||||
SigT : (x : BindName) -> (fst : Term d n) ->
|
||||
(snd : Term d (S n)) -> (loc : Loc) -> Term d n
|
||||
SigT : {q : Nat} -> (x : BindName) -> (fst : Term q d n) ->
|
||||
(snd : Term q d (S n)) -> (loc : Loc) -> Term q d n
|
||||
SigT {x, fst, snd, loc} = Sig {fst, snd = ST [< x] snd, loc}
|
||||
|
||||
public export %inline
|
||||
EqT : (i : BindName) -> (ty : Term (S d) n) ->
|
||||
(l, r : Term d n) -> (loc : Loc) -> Term d n
|
||||
EqT : {q : Nat} -> (i : BindName) -> (ty : Term q (S d) n) ->
|
||||
(l, r : Term q d n) -> (loc : Loc) -> Term q d n
|
||||
EqT {i, ty, l, r, loc} = Eq {ty = DST [< i] ty, l, r, loc}
|
||||
|
||||
public export %inline
|
||||
DLamT : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
|
||||
DLamT : {q : Nat} ->
|
||||
(i : BindName) -> (body : Term q (S d) n) -> (loc : Loc) -> Term q d n
|
||||
DLamT {i, body, loc} = DLam {body = DST [< i] body, loc}
|
||||
|
||||
public export %inline
|
||||
CoeT : (i : BindName) -> (ty : Term (S d) n) ->
|
||||
(p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n
|
||||
CoeT {i, ty, p, q, val, loc} = Coe {ty = DST [< i] ty, p, q, val, loc}
|
||||
CoeT : {q : Nat} -> (i : BindName) -> (ty : Term q (S d) n) ->
|
||||
(p, p' : Dim d) -> (val : Term q d n) -> (loc : Loc) -> Elim q d n
|
||||
CoeT {i, ty, p, p', val, loc} = Coe {ty = DST [< i] ty, p, p', val, loc}
|
||||
|
||||
public export %inline
|
||||
typeCase1T : Elim d n -> Term d n ->
|
||||
(k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
|
||||
typeCase1T : {q : Nat} ->
|
||||
Elim q d n -> Term q d n ->
|
||||
(k : TyConKind) -> BContext (arity k) -> Term q d (arity k + n) ->
|
||||
(loc : Loc) ->
|
||||
{default (NAT loc) def : Term d n} ->
|
||||
Elim d n
|
||||
{default (NAT loc) def : Term q d n} ->
|
||||
Elim q d n
|
||||
typeCase1T ty ret k ns body loc {def} =
|
||||
typeCase ty ret [(k ** ST ns body)] def loc
|
||||
|
||||
|
||||
public export %inline
|
||||
CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
|
||||
(r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
|
||||
CompH' {ty, p, q, val, r, zero, one, loc} =
|
||||
CompH' : {q : Nat} ->
|
||||
(ty : DScopeTerm q d n) -> (p, p' : Dim d) -> (val : Term q d n) ->
|
||||
(r : Dim d) -> (zero, one : DScopeTerm q d n) -> (loc : Loc) ->
|
||||
Elim q d n
|
||||
CompH' {ty, p, p', val, r, zero, one, loc} =
|
||||
let ty' = DST ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in
|
||||
Comp {
|
||||
ty = dsub1 ty q, p, q,
|
||||
val = E $ Coe ty p q val val.loc, r,
|
||||
ty = dsub1 ty p', p, p',
|
||||
val = E $ Coe ty p p' val val.loc, r,
|
||||
zero = DST zero.names $ E $
|
||||
Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
|
||||
Coe ty' (B VZ zero.loc) (weakD 1 p') zero.term zero.loc,
|
||||
one = DST one.names $ E $
|
||||
Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
|
||||
Coe ty' (B VZ one.loc) (weakD 1 p') one.term one.loc,
|
||||
loc
|
||||
}
|
||||
|
||||
|
|
@ -365,12 +373,12 @@ CompH' {ty, p, q, val, r, zero, one, loc} =
|
|||
||| 1 j ⇒ coe [i ⇒ A] @j @q t₁
|
||||
||| }
|
||||
public export %inline
|
||||
CompH : (i : BindName) -> (ty : Term (S d) n) ->
|
||||
(p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
|
||||
(j0 : BindName) -> (zero : Term (S d) n) ->
|
||||
(j1 : BindName) -> (one : Term (S d) n) ->
|
||||
CompH : {q : Nat} -> (i : BindName) -> (ty : Term q (S d) n) ->
|
||||
(p, p' : Dim d) -> (val : Term q d n) -> (r : Dim d) ->
|
||||
(j0 : BindName) -> (zero : Term q (S d) n) ->
|
||||
(j1 : BindName) -> (one : Term q (S d) n) ->
|
||||
(loc : Loc) ->
|
||||
Elim d n
|
||||
CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
|
||||
CompH' {ty = DST [< i] ty, p, q, val, r,
|
||||
Elim q d n
|
||||
CompH {i, ty, p, p', val, r, j0, zero, j1, one, loc} =
|
||||
CompH' {ty = DST [< i] ty, p, p', val, r,
|
||||
zero = DST [< j0] zero, one = DST [< j1] one, loc}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue