quox/lib/Quox/Syntax/Term/Reduce.idr

339 lines
12 KiB
Idris
Raw Normal View History

2022-04-23 18:21:30 -04:00
module Quox.Syntax.Term.Reduce
import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Subst
2022-05-02 16:38:37 -04:00
%default total
2022-04-23 18:21:30 -04:00
mutual
2023-01-08 14:44:25 -05:00
public export
data NotCloT : Term {} -> Type where
NCTYPE : NotCloT $ TYPE _
NCPi : NotCloT $ Pi {}
NCLam : NotCloT $ Lam {}
2023-01-20 20:34:28 -05:00
NCEq : NotCloT $ Eq {}
NCDLam : NotCloT $ DLam {}
2023-01-08 14:44:25 -05:00
NCE : NotCloE e -> NotCloT $ E e
2022-04-23 18:21:30 -04:00
2023-01-08 14:44:25 -05:00
public export
data NotCloE : Elim {} -> Type where
2023-01-20 20:34:28 -05:00
NCF : NotCloE $ F _
NCB : NotCloE $ B _
NCApp : NotCloE $ _ :@ _
NCDApp : NotCloE $ _ :% _
NCAnn : NotCloE $ _ :# _
2022-04-23 18:21:30 -04:00
2023-01-08 14:44:25 -05:00
mutual
export
notCloT : (t : Term {}) -> Dec (NotCloT t)
2023-01-20 20:34:28 -05:00
notCloT (TYPE _) = Yes NCTYPE
notCloT (Pi {}) = Yes NCPi
notCloT (Lam {}) = Yes NCLam
notCloT (Eq {}) = Yes NCEq
notCloT (DLam {}) = Yes NCDLam
notCloT (E e) = case notCloE e of
Yes nc => Yes $ NCE nc
No c => No $ \case NCE nc => c nc
2023-01-08 14:44:25 -05:00
notCloT (CloT {}) = No $ \case _ impossible
notCloT (DCloT {}) = No $ \case _ impossible
2022-04-23 18:21:30 -04:00
2023-01-08 14:44:25 -05:00
export
notCloE : (e : Elim {}) -> Dec (NotCloE e)
notCloE (F _) = Yes NCF
notCloE (B _) = Yes NCB
notCloE (_ :@ _) = Yes NCApp
2023-01-20 20:34:28 -05:00
notCloE (_ :% _) = Yes NCDApp
2023-01-08 14:44:25 -05:00
notCloE (_ :# _) = Yes NCAnn
notCloE (CloE {}) = No $ \case _ impossible
notCloE (DCloE {}) = No $ \case _ impossible
2022-04-23 18:21:30 -04:00
||| a term which is not a top level closure
2023-01-08 14:44:25 -05:00
public export
2023-01-20 20:34:28 -05:00
NonCloTerm : Type -> Nat -> Nat -> Type
NonCloTerm q d n = Subset (Term q d n) NotCloT
2022-04-23 18:21:30 -04:00
||| an elimination which is not a top level closure
2023-01-08 14:44:25 -05:00
public export
2023-01-20 20:34:28 -05:00
NonCloElim : Type -> Nat -> Nat -> Type
NonCloElim q d n = Subset (Elim q d n) NotCloE
2022-04-23 18:21:30 -04:00
public export %inline
2023-01-20 20:34:28 -05:00
ncloT : (t : Term q d n) -> (0 _ : NotCloT t) => NonCloTerm q d n
2022-04-23 18:21:30 -04:00
ncloT t @{p} = Element t p
public export %inline
2023-01-20 20:34:28 -05:00
ncloE : (e : Elim q d n) -> (0 _ : NotCloE e) => NonCloElim q d n
2022-04-23 18:21:30 -04:00
ncloE e @{p} = Element e p
mutual
||| if the input term has any top-level closures, push them under one layer of
||| syntax
export %inline
2023-01-20 20:34:28 -05:00
pushSubstsT : Term q d n -> NonCloTerm q d n
2022-04-23 18:21:30 -04:00
pushSubstsT s = pushSubstsTWith id id s
||| if the input elimination has any top-level closures, push them under one
||| layer of syntax
export %inline
2023-01-20 20:34:28 -05:00
pushSubstsE : Elim q d n -> NonCloElim q d n
2022-04-23 18:21:30 -04:00
pushSubstsE e = pushSubstsEWith id id e
export
2023-01-08 14:44:25 -05:00
pushSubstsTWith : DSubst dfrom dto -> TSubst q dto from to ->
2023-01-20 20:34:28 -05:00
Term q dfrom from -> NonCloTerm q dto to
2022-04-23 18:21:30 -04:00
pushSubstsTWith th ph (TYPE l) =
ncloT $ TYPE l
2022-04-27 15:58:09 -04:00
pushSubstsTWith th ph (Pi qty x a body) =
ncloT $ Pi qty x (subs a th ph) (subs body th ph)
2022-04-23 18:21:30 -04:00
pushSubstsTWith th ph (Lam x body) =
ncloT $ Lam x $ subs body th ph
2023-01-20 20:34:28 -05:00
pushSubstsTWith th ph (Eq i ty l r) =
ncloT $ Eq i (subs ty th ph) (subs l th ph) (subs r th ph)
pushSubstsTWith th ph (DLam i body) =
ncloT $ DLam i $ subs body th ph
2022-04-23 18:21:30 -04:00
pushSubstsTWith th ph (E e) =
2023-01-20 20:34:28 -05:00
let Element e nc = pushSubstsEWith th ph e in ncloT $ E e
pushSubstsTWith th ph (CloT s ps) =
pushSubstsTWith th (comp th ps ph) s
2022-04-23 18:21:30 -04:00
pushSubstsTWith th ph (DCloT s ps) =
pushSubstsTWith (ps . th) ph s
export
2023-01-08 14:44:25 -05:00
pushSubstsEWith : DSubst dfrom dto -> TSubst q dto from to ->
2023-01-20 20:34:28 -05:00
Elim q dfrom from -> NonCloElim q dto to
2022-04-23 18:21:30 -04:00
pushSubstsEWith th ph (F x) =
ncloE $ F x
pushSubstsEWith th ph (B i) =
2022-05-25 10:10:19 -04:00
let res = ph !! i in
2023-01-08 14:44:25 -05:00
case notCloE res of
Yes _ => ncloE res
No _ => assert_total pushSubstsE res
2022-04-23 18:21:30 -04:00
pushSubstsEWith th ph (f :@ s) =
ncloE $ subs f th ph :@ subs s th ph
2023-01-20 20:34:28 -05:00
pushSubstsEWith th ph (f :% d) =
ncloE $ subs f th ph :% (d // th)
2022-04-23 18:21:30 -04:00
pushSubstsEWith th ph (s :# a) =
ncloE $ subs s th ph :# subs a th ph
2023-01-20 20:34:28 -05:00
pushSubstsEWith th ph (CloE e ps) =
pushSubstsEWith th (comp th ps ph) e
2022-04-23 18:21:30 -04:00
pushSubstsEWith th ph (DCloE e ps) =
pushSubstsEWith (ps . th) ph e
2023-01-08 14:44:25 -05:00
parameters (th : DSubst dfrom dto) (ph : TSubst q dto from to)
2022-04-23 18:21:30 -04:00
public export %inline
2023-01-08 14:44:25 -05:00
pushSubstsTWith' : Term q dfrom from -> Term q dto to
2022-04-23 18:21:30 -04:00
pushSubstsTWith' s = (pushSubstsTWith th ph s).fst
public export %inline
2023-01-08 14:44:25 -05:00
pushSubstsEWith' : Elim q dfrom from -> Elim q dto to
2022-04-23 18:21:30 -04:00
pushSubstsEWith' e = (pushSubstsEWith th ph e).fst
public export %inline
2023-01-08 14:44:25 -05:00
weakT : Term q d n -> Term q d (S n)
2022-04-23 18:21:30 -04:00
weakT t = t //. shift 1
public export %inline
2023-01-08 14:44:25 -05:00
weakE : Elim q d n -> Elim q d (S n)
2022-04-23 18:21:30 -04:00
weakE t = t //. shift 1
2022-05-25 09:59:58 -04:00
mutual
public export
2023-01-08 14:44:25 -05:00
data IsRedexT : Term q d n -> Type where
2022-05-25 09:59:58 -04:00
IsUpsilonT : IsRedexT $ E (_ :# _)
IsCloT : IsRedexT $ CloT {}
IsDCloT : IsRedexT $ DCloT {}
IsERedex : IsRedexE e -> IsRedexT $ E e
public export
2023-01-08 14:44:25 -05:00
data IsRedexE : Elim q d n -> Type where
2022-05-25 09:59:58 -04:00
IsUpsilonE : IsRedexE $ E _ :# _
2023-01-20 20:34:28 -05:00
IsBetaLam : IsRedexE $ (Lam {} :# Pi {}) :@ _
IsBetaDLam : IsRedexE $ (DLam {} :# Eq {}) :% _
2022-05-25 09:59:58 -04:00
IsCloE : IsRedexE $ CloE {}
IsDCloE : IsRedexE $ DCloE {}
2023-01-20 20:34:28 -05:00
public export %inline
NotRedexT : Term q d n -> Type
NotRedexT = Not . IsRedexT
public export %inline
NotRedexE : Elim q d n -> Type
NotRedexE = Not . IsRedexE
2022-05-25 09:59:58 -04:00
mutual
2023-01-20 20:34:28 -05:00
-- [todo] PLEASE replace these with macros omfg
export
2023-01-08 14:44:25 -05:00
isRedexT : (t : Term {}) -> Dec (IsRedexT t)
2022-05-25 09:59:58 -04:00
isRedexT (E (tm :# ty)) = Yes IsUpsilonT
isRedexT (CloT {}) = Yes IsCloT
isRedexT (DCloT {}) = Yes IsDCloT
isRedexT (E (CloE {})) = Yes $ IsERedex IsCloE
isRedexT (E (DCloE {})) = Yes $ IsERedex IsDCloE
isRedexT (E e@(_ :@ _)) with (isRedexE e)
_ | Yes yes = Yes $ IsERedex yes
2023-01-08 14:44:25 -05:00
_ | No no = No $ \case IsERedex p => no p
2023-01-20 20:34:28 -05:00
isRedexT (E e@(_ :% _)) with (isRedexE e)
_ | Yes yes = Yes $ IsERedex yes
_ | No no = No $ \case IsERedex p => no p
2023-01-08 09:44:20 -05:00
isRedexT (TYPE {}) = No $ \case _ impossible
isRedexT (Pi {}) = No $ \case _ impossible
isRedexT (Lam {}) = No $ \case _ impossible
2023-01-20 20:34:28 -05:00
isRedexT (Eq {}) = No $ \case _ impossible
isRedexT (DLam {}) = No $ \case _ impossible
2023-01-08 09:44:20 -05:00
isRedexT (E (F _)) = No $ \case IsERedex _ impossible
isRedexT (E (B _)) = No $ \case IsERedex _ impossible
2022-05-25 09:59:58 -04:00
2023-01-20 20:34:28 -05:00
export
2023-01-08 14:44:25 -05:00
isRedexE : (e : Elim {}) -> Dec (IsRedexE e)
2022-05-25 09:59:58 -04:00
isRedexE (E _ :# _) = Yes IsUpsilonE
2023-01-20 20:34:28 -05:00
isRedexE ((Lam {} :# Pi {}) :@ _) = Yes IsBetaLam
isRedexE ((DLam {} :# Eq {}) :% _) = Yes IsBetaDLam
2022-05-25 09:59:58 -04:00
isRedexE (CloE {}) = Yes IsCloE
isRedexE (DCloE {}) = Yes IsDCloE
2023-01-08 09:44:20 -05:00
isRedexE (F x) = No $ \case _ impossible
isRedexE (B i) = No $ \case _ impossible
isRedexE (F _ :@ _) = No $ \case _ impossible
isRedexE (B _ :@ _) = No $ \case _ impossible
isRedexE (_ :@ _ :@ _) = No $ \case _ impossible
2023-01-20 20:34:28 -05:00
isRedexE (_ :% _ :@ _) = No $ \case _ impossible
isRedexE (CloE {} :@ _) = No $ \case _ impossible
isRedexE (DCloE {} :@ _) = No $ \case _ impossible
2023-01-08 09:44:20 -05:00
isRedexE ((TYPE _ :# _) :@ _) = No $ \case _ impossible
isRedexE ((Pi {} :# _) :@ _) = No $ \case _ impossible
2023-01-20 20:34:28 -05:00
isRedexE ((Eq {} :# _) :@ _) = No $ \case _ impossible
isRedexE ((DLam {} :# _) :@ _) = No $ \case _ impossible
2023-01-08 09:44:20 -05:00
isRedexE ((Lam {} :# TYPE _) :@ _) = No $ \case _ impossible
2023-01-20 20:34:28 -05:00
isRedexE ((Lam {} :# Lam {}) :@ _) = No $ \case _ impossible
isRedexE ((Lam {} :# Eq {}) :@ _) = No $ \case _ impossible
isRedexE ((Lam {} :# DLam {}) :@ _) = No $ \case _ impossible
2023-01-08 09:44:20 -05:00
isRedexE ((Lam {} :# E _) :@ _) = No $ \case _ impossible
2023-01-20 20:34:28 -05:00
isRedexE ((Lam {} :# CloT {}) :@ _) = No $ \case _ impossible
2023-01-08 09:44:20 -05:00
isRedexE ((Lam {} :# DCloT {}) :@ _) = No $ \case _ impossible
isRedexE ((E _ :# _) :@ _) = No $ \case _ impossible
isRedexE ((CloT {} :# _) :@ _) = No $ \case _ impossible
isRedexE ((DCloT {} :# _) :@ _) = No $ \case _ impossible
2023-01-20 20:34:28 -05:00
isRedexE ((TYPE _ :# _) :% _) = No $ \case _ impossible
isRedexE ((Pi {} :# _) :% _) = No $ \case _ impossible
isRedexE ((Eq {} :# _) :% _) = No $ \case _ impossible
isRedexE ((Lam {} :# _) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# TYPE _) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# Pi {}) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# Lam {}) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# DLam {}) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# E _) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# CloT {}) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# DCloT {}) :% _) = No $ \case _ impossible
isRedexE ((E _ :# _) :% _) = No $ \case _ impossible
isRedexE ((CloT {} :# _) :% _) = No $ \case _ impossible
isRedexE ((DCloT {} :# _) :% _) = No $ \case _ impossible
isRedexE (F _ :% _) = No $ \case _ impossible
isRedexE (B _ :% _) = No $ \case _ impossible
isRedexE (_ :@ _ :% _) = No $ \case _ impossible
isRedexE (_ :% _ :% _) = No $ \case _ impossible
isRedexE (CloE {} :% _) = No $ \case _ impossible
isRedexE (DCloE {} :% _) = No $ \case _ impossible
2023-01-08 09:44:20 -05:00
isRedexE (TYPE _ :# _) = No $ \case _ impossible
isRedexE (Pi {} :# _) = No $ \case _ impossible
isRedexE (Lam {} :# _) = No $ \case _ impossible
2023-01-20 20:34:28 -05:00
isRedexE (Eq {} :# _) = No $ \case _ impossible
isRedexE (DLam {} :# _) = No $ \case _ impossible
2023-01-08 09:44:20 -05:00
isRedexE (CloT {} :# _) = No $ \case _ impossible
isRedexE (DCloT {} :# _) = No $ \case _ impossible
2022-05-25 09:59:58 -04:00
public export %inline
2023-01-08 14:44:25 -05:00
RedexTerm : Type -> Nat -> Nat -> Type
RedexTerm q d n = Subset (Term q d n) IsRedexT
2022-05-25 09:59:58 -04:00
public export %inline
2023-01-08 14:44:25 -05:00
NonRedexTerm : Type -> Nat -> Nat -> Type
NonRedexTerm q d n = Subset (Term q d n) NotRedexT
2022-05-25 09:59:58 -04:00
public export %inline
2023-01-08 14:44:25 -05:00
RedexElim : Type -> Nat -> Nat -> Type
RedexElim q d n = Subset (Elim q d n) IsRedexE
2022-05-25 09:59:58 -04:00
public export %inline
2023-01-08 14:44:25 -05:00
NonRedexElim : Type -> Nat -> Nat -> Type
NonRedexElim q d n = Subset (Elim q d n) NotRedexE
2022-05-25 09:59:58 -04:00
||| substitute a term with annotation for the bound variable of a `ScopeTerm`
export %inline
2023-01-08 14:44:25 -05:00
substScope : (arg, argTy : Term q d n) -> (body : ScopeTerm q d n) -> Term q d n
2023-01-20 20:34:28 -05:00
substScope arg argTy body = sub1 body (arg :# argTy)
2022-05-25 09:59:58 -04:00
mutual
export %inline
2023-01-08 14:44:25 -05:00
stepT' : (s : Term q d n) -> IsRedexT s -> Term q d n
2022-05-25 09:59:58 -04:00
stepT' (E (s :# _)) IsUpsilonT = s
stepT' (CloT s th) IsCloT = pushSubstsTWith' id th s
stepT' (DCloT s th) IsDCloT = pushSubstsTWith' th id s
stepT' (E e) (IsERedex p) = E $ stepE' e p
export %inline
2023-01-08 14:44:25 -05:00
stepE' : (e : Elim q d n) -> IsRedexE e -> Elim q d n
2022-05-25 09:59:58 -04:00
stepE' (E e :# _) IsUpsilonE = e
stepE' ((Lam {body, _} :# Pi {arg, res, _}) :@ s) IsBetaLam =
2023-01-20 20:34:28 -05:00
let s = s :# arg in sub1 body s :# sub1 res s
stepE' ((DLam {body, _} :# Eq {ty, l, r, _}) :% dim) IsBetaDLam =
case dim of
K Zero => l :# ty.zero
K One => r :# ty.one
B _ => dsub1 body dim :# dsub1 ty dim
2022-05-25 09:59:58 -04:00
stepE' (CloE e th) IsCloE = pushSubstsEWith' id th e
stepE' (DCloE e th) IsDCloE = pushSubstsEWith' th id e
export %inline
2023-01-08 14:44:25 -05:00
stepT : (s : Term q d n) -> Either (NotRedexT s) (Term q d n)
2022-05-25 09:59:58 -04:00
stepT s = case isRedexT s of Yes y => Right $ stepT' s y; No n => Left n
export %inline
2023-01-08 14:44:25 -05:00
stepE : (e : Elim q d n) -> Either (NotRedexE e) (Elim q d n)
2022-05-25 09:59:58 -04:00
stepE e = case isRedexE e of Yes y => Right $ stepE' e y; No n => Left n
export covering
2023-01-08 14:44:25 -05:00
whnfT : Term q d n -> NonRedexTerm q d n
2023-01-20 20:34:28 -05:00
whnfT s = case stepT s of Right s' => whnfT s'; Left done => Element s done
2022-05-25 09:59:58 -04:00
export covering
2023-01-08 14:44:25 -05:00
whnfE : Elim q d n -> NonRedexElim q d n
2023-01-20 20:34:28 -05:00
whnfE e = case stepE e of Right e' => whnfE e'; Left done => Element e done
export
notRedexNotCloE : (e : Elim {}) -> NotRedexE e -> NotCloE e
notRedexNotCloE (F x) f = NCF
notRedexNotCloE (B i) f = NCB
notRedexNotCloE (fun :@ arg) f = NCApp
notRedexNotCloE (fun :% arg) f = NCDApp
notRedexNotCloE (tm :# ty) f = NCAnn
notRedexNotCloE (CloE el th) f = absurd $ f IsCloE
notRedexNotCloE (DCloE el th) f = absurd $ f IsDCloE
export
notRedexNotCloT : (t : Term {}) -> NotRedexT t -> NotCloT t
notRedexNotCloT (TYPE _) _ = NCTYPE
notRedexNotCloT (Pi {}) _ = NCPi
notRedexNotCloT (Lam {}) _ = NCLam
notRedexNotCloT (Eq {}) _ = NCEq
notRedexNotCloT (DLam {}) _ = NCDLam
notRedexNotCloT (E e) f = NCE $ notRedexNotCloE e $ f . IsERedex
notRedexNotCloT (CloT {}) f = absurd $ f IsCloT
notRedexNotCloT (DCloT {}) f = absurd $ f IsDCloT
export
toNotCloE : NonRedexElim q d n -> NonCloElim q d n
toNotCloE (Element e prf) = Element e $ notRedexNotCloE e prf
export
toNotCloT : NonRedexTerm q d n -> NonCloTerm q d n
toNotCloT (Element t prf) = Element t $ notRedexNotCloT t prf