rhi/quox
rhi/quox
1
0
Fork 0
Code Issues 15 Pull requests 1 Releases Wiki Activity

remove src directories

Browse source
This commit is contained in:
rhiannon morris 2022-05-06 22:01:44 +02:00
parent 79211cff84
commit 804f1e3638
36 changed files with 0 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

106
lib/Quox/Syntax/Dim.idr Normal file
View file

@ -0,0 +1,106 @@
module Quox.Syntax.Dim
import Quox.Syntax.Var
import Quox.Syntax.Subst
import Quox.Pretty
import Decidable.Equality
import Control.Function
import Generics.Derive
%default total
%language ElabReflection
%hide SOP.from; %hide SOP.to
public export
data DimConst = Zero | One
%name DimConst e
private DCRepr : Type
DCRepr = Nat
%runElab derive "DimConst" [Generic, Meta, Eq, Ord, DecEq, Show]
public export
data Dim : Nat -> Type where
K : DimConst -> Dim d
B : Var d -> Dim d
%name Dim.Dim p, q
private %inline
drepr : Dim n -> Either DimConst (Var n)
drepr (K k) = Left k
drepr (B x) = Right x
export Eq (Dim n) where (==) = (==) `on` drepr
export Ord (Dim n) where compare = compare `on` drepr
export
PrettyHL DimConst where
prettyM Zero = hl Dim <$> ifUnicode "𝟬" "0"
prettyM One = hl Dim <$> ifUnicode "𝟭" "1"
export
PrettyHL (Dim n) where
prettyM (K e) = prettyM e
prettyM (B i) = prettyVar DVar DVarErr (!ask).dnames i
public export %inline
toConst : Dim 0 -> DimConst
toConst (K e) = e
public export
DSubst : Nat -> Nat -> Type
DSubst = Subst Dim
export %inline
prettyDSubst : Pretty.HasEnv m => DSubst from to -> m (Doc HL)
prettyDSubst th =
prettySubstM prettyM (!ask).dnames DVar
!(ifUnicode "⟨" "<") !(ifUnicode "⟩" ">") th
export FromVar Dim where fromVar = B
export
CanShift Dim where
K e // _ = K e
B i // by = B (i // by)
export
CanSubst Dim Dim where
K e // _ = K e
B i // th = th !! i
export Uninhabited (Zero = One) where uninhabited _ impossible
export Uninhabited (One = Zero) where uninhabited _ impossible
export Uninhabited (B i = K e) where uninhabited _ impossible
export Uninhabited (K e = B i) where uninhabited _ impossible
public export %inline Injective Dim.B where injective Refl = Refl
public export %inline Injective Dim.K where injective Refl = Refl
public export
DecEq DimConst where
decEq Zero Zero = Yes Refl
decEq Zero One = No absurd
decEq One Zero = No absurd
decEq One One = Yes Refl
public export
DecEq (Dim d) where
decEq (K e) (K f) with (decEq e f)
_ | Yes prf = Yes $ cong K prf
_ | No contra = No $ contra . injective
decEq (K e) (B j) = No absurd
decEq (B i) (K f) = No absurd
decEq (B i) (B j) with (decEq i j)
_ | Yes prf = Yes $ cong B prf
_ | No contra = No $ contra . injective

175
lib/Quox/Syntax/DimEq.idr Normal file
View file

@ -0,0 +1,175 @@
module Quox.Syntax.DimEq
import public Quox.Syntax.Var
import public Quox.Syntax.Dim
import public Quox.Syntax.Subst
import public Quox.Context
import Data.Maybe
import Data.Nat
import Data.DPair
import Data.Fun.Graph
import Decidable.Decidable
import Decidable.Equality
%default total
public export
DimEq' : Nat -> Type
DimEq' = Context (Maybe . Dim)
public export
data DimEq : Nat -> Type where
ZeroIsOne : DimEq d
C : (eqs : DimEq' d) -> DimEq d
%name DimEq eqs
export
zeroEq : DimEq 0
zeroEq = C [<]
export
new' : {d : Nat} -> DimEq' d
new' {d = 0} = [<]
new' {d = S d} = new' :< Nothing
export %inline
new : {d : Nat} -> DimEq d
new = C new'
private %inline
shiftMay : Maybe (Dim from) -> Shift from to -> Maybe (Dim to)
shiftMay p by = map (// by) p
export %inline
get' : DimEq' d -> Var d -> Maybe (Dim d)
get' = getWith shiftMay
private %inline
getShift' : Shift len out -> DimEq' len -> Var len -> Maybe (Dim out)
getShift' = getShiftWith shiftMay
export %inline
get : DimEq' d -> Dim d -> Dim d
get _ (K e) = K e
get eqs (B i) = fromMaybe (B i) $ get' eqs i
export %inline
equal : DimEq d -> (p, q : Dim d) -> Bool
equal ZeroIsOne p q = True
equal (C eqs) p q = get eqs p == get eqs q
infixl 5 :<?
export %inline
(:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
ZeroIsOne :<? d = ZeroIsOne
C eqs :<? d = C $ eqs :< d
private %inline
ifVar : Var d -> Dim d -> Maybe (Dim d) -> Maybe (Dim d)
ifVar i p = map $ \q => if isYes $ q `decEq` B i then p else q
private %inline
checkConst : (e, f : DimConst) -> (eqs : Lazy (DimEq' d)) -> DimEq d
checkConst Zero Zero eqs = C eqs
checkConst One One eqs = C eqs
checkConst _ _ _ = ZeroIsOne
export
setConst : Var d -> DimConst -> DimEq' d -> DimEq d
setConst VZ e (eqs :< Nothing) = C $ eqs :< Just (K e)
setConst VZ e (eqs :< Just (K f)) = checkConst e f $ eqs :< Just (K f)
setConst VZ e (eqs :< Just (B i)) = setConst i e eqs :<? Just (K e)
setConst (VS i) e (eqs :< p) = setConst i e eqs :<? ifVar i (K e) p
mutual
private
setVar' : (i, j : Var d) -> i `LT` j -> DimEq' d -> DimEq d
setVar' VZ (VS i) LTZ (eqs :< Nothing) =
C $ eqs :< Just (B i)
setVar' VZ (VS i) LTZ (eqs :< Just (K e)) =
setConst i e eqs :<? Just (K e)
setVar' VZ (VS i) LTZ (eqs :< Just (B j)) =
setVar i j eqs :<? Just (B (max i j))
setVar' (VS i) (VS j) (LTS lt) (eqs :< p) =
setVar' i j lt eqs :<? ifVar i (B j) p
export %inline
setVar : (i, j : Var d) -> DimEq' d -> DimEq d
setVar i j eqs with (compareP i j)
_ | IsLT lt = setVar' i j lt eqs
setVar i i eqs | IsEQ = C eqs
_ | IsGT gt = setVar' j i gt eqs
export %inline
set : (p, q : Dim d) -> DimEq d -> DimEq d
set _ _ ZeroIsOne = ZeroIsOne
set (K e) (K f) (C eqs) = checkConst e f eqs
set (K e) (B i) (C eqs) = setConst i e eqs
set (B i) (K e) (C eqs) = setConst i e eqs
set (B i) (B j) (C eqs) = setVar i j eqs
public export %inline
Split : Nat -> Type
Split d = (DimEq' d, DSubst (S d) d)
export %inline
split1 : DimConst -> DimEq' (S d) -> Maybe (Split d)
split1 e eqs = case setConst VZ e eqs of
ZeroIsOne => Nothing
C (eqs :< _) => Just (eqs, K e ::: id)
export %inline
split : DimEq' (S d) -> List (Split d)
split eqs = toList (split1 Zero eqs) <+> toList (split1 One eqs)
export
splits' : DimEq' d -> List (DSubst d 0)
splits' [<] = [id]
splits' eqs@(_ :< _) = [th . ph | (eqs', th) <- split eqs, ph <- splits' eqs']
export %inline
splits : DimEq d -> List (DSubst d 0)
splits ZeroIsOne = []
splits (C eqs) = splits' eqs
private
0 newGetShift : (d : Nat) -> (i : Var d) -> (by : Shift d d') ->
getShift' by (new' {d}) i = Nothing
newGetShift (S d) VZ by = Refl
newGetShift (S d) (VS i) by = newGetShift d i (drop1 by)
export
0 newGet' : (d : Nat) -> (i : Var d) -> get' (new' {d}) i = Nothing
newGet' d i = newGetShift d i SZ
export
0 newGet : (d : Nat) -> (p : Dim d) -> get (new' {d}) p = p
newGet d (K e) = Refl
newGet d (B i) = rewrite newGet' d i in Refl
export
0 setSelf : (p : Dim d) -> (eqs : DimEq d) -> set p p eqs = eqs
setSelf p ZeroIsOne = Refl
setSelf (K Zero) (C eqs) = Refl
setSelf (K One) (C eqs) = Refl
setSelf (B i) (C eqs) = rewrite comparePSelf i in Refl
-- [todo] "well formed" dimeqs
-- [todo] operations maintain well-formedness
-- [todo] if 'Wf eqs' then 'equal eqs' is an equivalence
-- [todo] 'set' never breaks existing equalities

80
lib/Quox/Syntax/Qty.idr Normal file
View file

@ -0,0 +1,80 @@
module Quox.Syntax.Qty
import Quox.Pretty
import Data.Fin
import Generics.Derive
%default total
%language ElabReflection
public export
data Qty = Zero | One | Any
%name Qty.Qty pi, rh
%runElab derive "Qty" [Generic, Meta, Eq, Ord, DecEq, Show]
export
PrettyHL Qty where
prettyM pi = hl Qty <$>
case pi of
Zero => ifUnicode "𝟬" "0"
One => ifUnicode "𝟭" "1"
Any => ifUnicode "𝛚" "*"
private
commas : List (Doc HL) -> List (Doc HL)
commas [] = []
commas [x] = [x]
commas (x::xs) = (x <+> hl Delim ",") :: commas xs
export %inline
prettyQtyBinds : Pretty.HasEnv m => List Qty -> m (Doc HL)
prettyQtyBinds =
map ((hl Delim "@" <++>) . align . sep . commas) . traverse pretty0M
public export
plus : Qty -> Qty -> Qty
plus Zero rh = rh
plus pi Zero = pi
plus _ _ = Any
public export
times : Qty -> Qty -> Qty
times Zero _ = Zero
times _ Zero = Zero
times One rh = rh
times pi One = pi
times Any Any = Any
infix 6 <=.
public export
compat : Qty -> Qty -> Bool
compat pi rh = rh == Any || pi == rh
public export
interface IsQty q where
zero, one : q
(+), (*) : q -> q -> q
(<=.) : q -> q -> Bool
public export
IsQty Qty where
zero = Zero; one = One
(+) = plus; (*) = times
(<=.) = compat
public export
data IsSubj : Qty -> Type where
SZero : IsSubj Zero
SOne : IsSubj One
public export
data IsGlobal : Qty -> Type where
GZero : IsGlobal Zero
GAny : IsGlobal Any

235
lib/Quox/Syntax/Shift.idr Normal file
View file

@ -0,0 +1,235 @@
module Quox.Syntax.Shift
import public Quox.Syntax.Var
import Quox.Pretty
import Data.Nat
import Data.So
%default total
||| represents the difference between a smaller scope and a larger one.
public export
data Shift : (0 from, to : Nat) -> Type where
SZ : Shift from from
SS : Shift from to -> Shift from (S to)
%name Shift by, bz
%builtin Natural Shift
public export
(.nat) : Shift from to -> Nat
(SZ).nat = Z
(SS by).nat = S by.nat
%transform "Shift.(.nat)" Shift.(.nat) = believe_me
public export Cast (Shift from to) Nat where cast = (.nat)
public export Cast (Shift from to) Integer where cast = cast . cast {to = Nat}
export Eq (Shift from to) where (==) = (==) `on` (.nat)
export Ord (Shift from to) where compare = compare `on` (.nat)
||| shift equivalence, ignoring indices
public export
data Eqv : Shift from1 to1 -> Shift from2 to2 -> Type where
EqSZ : SZ `Eqv` SZ
EqSS : by `Eqv` bz -> SS by `Eqv` SS bz
%name Eqv e
||| two equivalent shifts are equal if they have the same indices.
export
0 fromEqv : by `Eqv` bz -> by = bz
fromEqv EqSZ = Refl
fromEqv (EqSS e) = cong SS $ fromEqv e
||| two equal shifts are equivalent.
export
0 toEqv : by = bz -> by `Eqv` bz
toEqv Refl {by = SZ} = EqSZ
toEqv Refl {by = (SS by)} = EqSS $ toEqv Refl
export
0 shiftDiff : (by : Shift from to) -> to = by.nat + from
shiftDiff SZ = Refl
shiftDiff (SS by) = cong S $ shiftDiff by
export
0 shiftVarLT : (by : Shift from to) -> (i : Var from) ->
by.nat + i.nat `LT` to
shiftVarLT by i =
rewrite plusSuccRightSucc by.nat i.nat in
transitive
(plusLteMonotoneLeft by.nat (S i.nat) from (toNatLT i))
(replace {p=(`LTE` to)} (shiftDiff by) reflexive)
public export
fromNat : (by : Nat) -> Shift from (by + from)
fromNat Z = SZ
fromNat (S by) = SS $ fromNat by
%transform "Shift.fromNat" Shift.fromNat x = believe_me x
public export
fromNat0 : (by : Nat) -> Shift 0 by
fromNat0 by = rewrite sym $ plusZeroRightNeutral by in fromNat by
export
0 fromToNat : (by : Shift from to) -> by `Eqv` fromNat by.nat {from}
fromToNat SZ = EqSZ
fromToNat (SS by) = EqSS $ fromToNat by
export
0 toFromNat : (from, by : Nat) -> by = (fromNat by {from}).nat
toFromNat from 0 = Refl
toFromNat from (S k) = cong S $ toFromNat from k
export
0 toNatInj' : (by : Shift from1 to1) -> (bz : Shift from2 to2) ->
by.nat = bz.nat -> by `Eqv` bz
toNatInj' SZ SZ prf = EqSZ
toNatInj' (SS by) (SS bz) prf = EqSS $ toNatInj' by bz $ injective prf
toNatInj' (SS by) SZ Refl impossible
export
0 toNatInj : {by, bz : Shift from to} -> by.nat = bz.nat -> by = bz
toNatInj {by, bz} e = fromEqv $ toNatInj' by bz e
export %inline
Injective Shift.(.nat) where injective eq = irrelevantEq $ toNatInj eq
public export
ssDown : Shift (S from) to -> Shift from to
ssDown SZ = SS SZ
ssDown (SS by) = SS (ssDown by)
export
0 ssDownEqv : (by : Shift (S from) to) -> ssDown by `Eqv` SS by
ssDownEqv SZ = EqSS EqSZ
ssDownEqv (SS by) = EqSS $ ssDownEqv by
%transform "Shift.ssDown" ssDown by = believe_me (SS by)
public export
shift : Shift from to -> Var from -> Var to
shift SZ i = i
shift (SS by) i = VS $ shift by i
private
shiftViaNat' : (by : Shift from to) -> (i : Var from) ->
(0 p : by.nat + i.nat `LT` to) -> Var to
shiftViaNat' by i p = V $ by.nat + i.nat
private
shiftViaNat : Shift from to -> Var from -> Var to
shiftViaNat by i = shiftViaNat' by i $ shiftVarLT by i
private
0 shiftViaNatCorrect : (by : Shift from to) -> (i : Var from) ->
(0 p : by.nat + i.nat `LT` to) ->
shiftViaNat' by i p = shift by i
shiftViaNatCorrect SZ i (LTESucc p) = fromToNat i _
shiftViaNatCorrect (SS by) i (LTESucc p) = cong VS $ shiftViaNatCorrect by i p
%transform "Shift.shift" shift = shiftViaNat
infixl 9 .
public export
(.) : Shift from mid -> Shift mid to -> Shift from to
by . SZ = by
by . SS bz = SS $ by . bz
private
0 compNatProof : (by : Shift from mid) -> (bz : Shift mid to) ->
to = by.nat + bz.nat + from
compNatProof by bz =
shiftDiff bz >>>
cong (bz.nat +) (shiftDiff by) >>>
plusAssociative bz.nat by.nat from >>>
cong (+ from) (plusCommutative bz.nat by.nat)
where
infixr 0 >>>
0 (>>>) : a = b -> b = c -> a = c
x >>> y = trans x y
private
compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
Shift from (by.nat + bz.nat + from)
compViaNat' by bz = fromNat $ by.nat + bz.nat
private
compViaNat : (by : Shift from mid) -> (bz : Shift mid to) -> Shift from to
compViaNat by bz = rewrite compNatProof by bz in compViaNat' by bz
private
0 compViaNatCorrect : (by : Shift from mid) -> (bz : Shift mid to) ->
by . bz `Eqv` compViaNat' by bz
compViaNatCorrect by SZ =
rewrite plusZeroRightNeutral by.nat in fromToNat by
compViaNatCorrect by (SS bz) =
rewrite sym $ plusSuccRightSucc by.nat bz.nat in
EqSS $ compViaNatCorrect by bz
%transform "Shift.(.)" Shift.(.) = compViaNat
||| `prettyShift bnd unicode prec by` pretty-prints the shift `by`, with the
||| following arguments:
|||
||| * `by : Shift from to`
||| * `bnd : HL` is the highlight used for bound variables of this kind
||| * `unicode : Bool` is whether to use unicode characters in the output
||| * `prec : PPrec` is the surrounding precedence level
export
prettyShift : Pretty.HasEnv m => (bnd : HL) -> Shift from to -> m (Doc HL)
prettyShift bnd by =
parensIfM Outer $ hsep $
[hl bnd !(ifUnicode "𝑖" "i"), hl Delim !(ifUnicode "≔" ":="),
hl bnd $ !(ifUnicode "𝑖+" "i+") <+> pretty by.nat]
||| prints using the `TVar` highlight for variables
export PrettyHL (Shift from to) where prettyM = prettyShift TVar
||| Drops the innermost variable from the input scope.
public export
drop1 : Shift (S from) to -> Shift from to
drop1 SZ = SS SZ
drop1 (SS by) = SS (drop1 by)
private
drop1ViaNat : Shift (S from) to -> Shift from to
drop1ViaNat by =
rewrite shiftDiff by in
rewrite sym $ plusSuccRightSucc by.nat from in
fromNat (S by.nat)
private
0 drop1ViaNatCorrect : (by : Shift (S from) to) -> drop1ViaNat by = drop1 by
drop1ViaNatCorrect SZ = Refl
drop1ViaNatCorrect (SS by) =
rewrite plusSuccRightSucc by.nat from in
rewrite sym $ shiftDiff by in
cong SS $ drop1ViaNatCorrect by
%transform "Shift.drop1" drop1 by = drop1ViaNat by
infixl 8 //
public export
interface CanShift f where
(//) : f from -> Shift from to -> f to
export CanShift Var where i // by = shift by i
namespace CanShift
public export
[Map] (Functor f, CanShift tm) => CanShift (f . tm) where
x // by = map (// by) x
public export
[Const] CanShift (\_ => a) where x // _ = x

129
lib/Quox/Syntax/Subst.idr Normal file
View file

@ -0,0 +1,129 @@
module Quox.Syntax.Subst
import public Quox.Syntax.Shift
import Quox.Syntax.Var
import Quox.Name
import Quox.Pretty
import Data.List
%default total
infixr 5 :::
public export
data Subst : (Nat -> Type) -> Nat -> Nat -> Type where
Shift : Shift from to -> Subst env from to
(:::) : (t : Lazy (env to)) -> Subst env from to -> Subst env (S from) to
%name Subst th, ph, ps
private
Repr : (Nat -> Type) -> Nat -> Type
Repr f to = (List (f to), Nat)
private
repr : Subst f from to -> Repr f to
repr (Shift by) = ([], by.nat)
repr (t ::: th) = let (ts, i) = repr th in (t::ts, i)
export Eq (f to) => Eq (Subst f from to) where (==) = (==) `on` repr
export Ord (f to) => Ord (Subst f from to) where compare = compare `on` repr
infixl 8 //
public export
interface FromVar env => CanSubst env term where
(//) : term from -> Lazy (Subst env from to) -> term to
public export
CanSubst1 : (Nat -> Type) -> Type
CanSubst1 f = CanSubst f f
infixl 8 !!
public export
(!!) : FromVar term => Subst term from to -> Var from -> term to
(Shift by) !! i = fromVar $ shift by i
(t ::: th) !! VZ = t
(t ::: th) !! (VS i) = th !! i
public export
CanSubst Var Var where
i // Shift by = shift by i
VZ // (t ::: th) = t
VS i // (t ::: th) = i // th
public export %inline
shift : (by : Nat) -> Subst env from (by + from)
shift by = Shift $ fromNat by
infixl 9 .
public export
(.) : CanSubst1 f => Subst f from mid -> Subst f mid to -> Subst f from to
Shift by . Shift bz = Shift $ by . bz
Shift SZ . ph = ph
Shift (SS by) . (t ::: th) = Shift by . th
(t ::: th) . ph = (t // ph) ::: (th . ph)
public export %inline
id : Subst f n n
id = shift 0
public export
map : (f to -> g to) -> Subst f from to -> Subst g from to
map f (Shift by) = Shift by
map f (t ::: th) = f t ::: map f th
public export %inline
push : CanSubst1 f => Subst f from to -> Subst f (S from) (S to)
push th = fromVar VZ ::: (th . shift 1)
public export
drop1 : Subst f (S from) to -> Subst f from to
drop1 (Shift by) = Shift $ drop1 by
drop1 (t ::: th) = th
public export %inline
one : f n -> Subst f (S n) n
one x = x ::: id
||| `prettySubst pr names bnd op cl th` pretty-prints the substitution `th`,
||| with the following arguments:
|||
||| * `th : Subst f from to`
||| * `pr : f to -> m (Doc HL)` prints a single element
||| * `names : List Name` is a list of known bound var names
||| * `bnd : HL` is the highlight to use for bound variables being subsituted
||| * `op, cl : Doc HL` are the opening and closing brackets
export
prettySubstM : Pretty.HasEnv m =>
(pr : f to -> m (Doc HL)) ->
(names : List Name) -> (bnd : HL) -> (op, cl : Doc HL) ->
Subst f from to -> m (Doc HL)
prettySubstM pr names bnd op cl th =
encloseSep (hl Delim op) (hl Delim cl) (hl Delim "; ") <$>
withPrec Outer (go 0 th)
where
go1 : Nat -> f to -> m (Doc HL)
go1 i t = pure $ hang 2 $ sep
[hsep [!(prettyVar' bnd bnd names i),
hl Delim !(ifUnicode "≔" ":=")],
!(pr t)]
go : forall from. Nat -> Subst f from to -> m (List (Doc HL))
go _ (Shift SZ) = pure []
go _ (Shift by) = [|pure (prettyShift bnd by)|]
go i (t ::: th) = [|go1 i t :: go (S i) th|]
||| prints with [square brackets] and the `TVar` highlight for variables
export
PrettyHL (f to) => PrettyHL (Subst f from to) where
prettyM th = prettySubstM prettyM (!ask).tnames TVar "[" "]" th

7
lib/Quox/Syntax/Term.idr Normal file
View file

@ -0,0 +1,7 @@
module Quox.Syntax.Term
import public Quox.Syntax.Term.Base
import public Quox.Syntax.Term.Split
import public Quox.Syntax.Term.Subst
import public Quox.Syntax.Term.Reduce
import public Quox.Syntax.Term.Pretty

110
lib/Quox/Syntax/Term/Base.idr Normal file
View file

@ -0,0 +1,110 @@
module Quox.Syntax.Term.Base
import public Quox.Syntax.Var
import public Quox.Syntax.Shift
import public Quox.Syntax.Subst
import public Quox.Syntax.Universe
import public Quox.Syntax.Qty
import public Quox.Syntax.Dim
import public Quox.Name
import public Quox.OPE
import Quox.Pretty
import public Data.DPair
import Data.List
import Data.Maybe
import Data.Nat
import public Data.So
import Data.String
import Data.Vect
%default total
infixl 8 :#
infixl 9 :@
mutual
public export
TSubst : Nat -> Nat -> Nat -> Type
TSubst d = Subst (\n => Elim d n)
||| first argument `d` is dimension scope size, second `n` is term scope size
public export
data Term : (d, n : Nat) -> Type where
||| type of types
TYPE : (l : Universe) -> Term d n
||| function type
Pi : (qty : Qty) -> (x : Name) ->
(arg : Term d n) -> (res : ScopeTerm d n) -> Term d n
||| function term
Lam : (x : Name) -> (body : ScopeTerm d n) -> Term d n
||| elimination
E : (e : Elim d n) -> Term d n
||| term closure/suspended substitution
CloT : (tm : Term d from) -> (th : Lazy (TSubst d from to)) -> Term d to
||| dimension closure/suspended substitution
DCloT : (tm : Term dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Term dto n
||| first argument `d` is dimension scope size, second `n` is term scope size
public export
data Elim : (d, n : Nat) -> Type where
||| free variable
F : (x : Name) -> Elim d n
||| bound variable
B : (i : Var n) -> Elim d n
||| term application
(:@) : (fun : Elim d n) -> (arg : Term d n) -> Elim d n
||| type-annotated term
(:#) : (tm, ty : Term d n) -> Elim d n
||| term closure/suspended substitution
CloE : (el : Elim d from) -> (th : Lazy (TSubst d from to)) -> Elim d to
||| dimension closure/suspended substitution
DCloE : (el : Elim dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Elim dto n
||| a scope with one more bound variable
public export
data ScopeTerm : (d, n : Nat) -> Type where
||| variable is used
TUsed : (body : Term d (S n)) -> ScopeTerm d n
||| variable is unused
TUnused : (body : Term d n) -> ScopeTerm d n
||| a scope with one more bound dimension variable
public export
data DScopeTerm : (d, n : Nat) -> Type where
||| variable is used
DUsed : (body : Term (S d) n) -> DScopeTerm d n
||| variable is unused
DUnused : (body : Term d n) -> DScopeTerm d n
%name Term s, t, r
%name Elim e, f
%name ScopeTerm body
%name DScopeTerm body
public export %inline
Arr : Qty -> Term d n -> Term d n -> Term d n
Arr pi a b = Pi {qty = pi, x = "_", arg = a, res = TUnused b}
||| same as `F` but as a term
public export %inline
FT : Name -> Term d n
FT = E . F
||| abbreviation for a bound variable like `BV 4` instead of
||| `B (VS (VS (VS (VS VZ))))`
public export %inline
BV : (i : Nat) -> (0 _ : LT i n) => Elim d n
BV i = B $ V i
||| same as `BV` but as a term
public export %inline
BVT : (i : Nat) -> (0 _ : LT i n) => Term d n
BVT i = E $ BV i

86
lib/Quox/Syntax/Term/Pretty.idr Normal file
View file

@ -0,0 +1,86 @@
module Quox.Syntax.Term.Pretty
import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Split
import Quox.Syntax.Term.Subst
import Quox.Pretty
import Data.Vect
%default total
parameters {auto _ : Pretty.HasEnv m}
private %inline arrowD : m (Doc HL)
arrowD = hlF Syntax $ ifUnicode "→" "->"
private %inline lamD : m (Doc HL)
lamD = hlF Syntax $ ifUnicode "λ" "fun"
private %inline annD : m (Doc HL)
annD = hlF Syntax $ ifUnicode "⦂" "::"
private %inline typeD : Doc HL
typeD = hl Syntax "Type"
private %inline colonD : Doc HL
colonD = hl Syntax ":"
mutual
export covering
PrettyHL (Term d n) where
prettyM (TYPE l) =
parensIfM App $ typeD <//> !(withPrec Arg $ prettyM l)
prettyM (Pi qty x s t) =
parensIfM Outer $ hang 2 $
!(prettyBinder [qty] x s) <++> !arrowD
<//> !(under T x $ prettyM t)
prettyM (Lam x t) =
parensIfM Outer $
sep [!lamD, hl TVar !(prettyM x), !arrowD]
<//> !(under T x $ prettyM t)
prettyM (E e) =
prettyM e
prettyM (CloT s th) =
parensIfM SApp . hang 2 =<<
[|withPrec SApp (prettyM s) </> prettyTSubst th|]
prettyM (DCloT s th) =
parensIfM SApp . hang 2 =<<
[|withPrec SApp (prettyM s) </> prettyDSubst th|]
export covering
PrettyHL (Elim d n) where
prettyM (F x) =
hl' Free <$> prettyM x
prettyM (B i) =
prettyVar TVar TVarErr (!ask).tnames i
prettyM (e :@ s) =
let GotArgs f args _ = getArgs' e [s] in
parensIfM App =<< withPrec Arg
[|prettyM f <//> (align . sep <$> traverse prettyM args)|]
prettyM (s :# a) =
parensIfM Ann $ hang 2 $
!(withPrec AnnL $ prettyM s) <++> !annD
<//> !(withPrec Ann $ prettyM a)
prettyM (CloE e th) =
parensIfM SApp . hang 2 =<<
[|withPrec SApp (prettyM e) </> prettyTSubst th|]
prettyM (DCloE e th) =
parensIfM SApp . hang 2 =<<
[|withPrec SApp (prettyM e) </> prettyDSubst th|]
export covering
PrettyHL (ScopeTerm d n) where
prettyM body = prettyM $ fromScopeTerm body
export covering
prettyTSubst : Pretty.HasEnv m => TSubst d from to -> m (Doc HL)
prettyTSubst s = prettySubstM prettyM (!ask).tnames TVar "[" "]" s
export covering
prettyBinder : Pretty.HasEnv m => List Qty -> Name -> Term d n -> m (Doc HL)
prettyBinder pis x a =
pure $ parens $ hang 2 $
hsep [hl TVar !(prettyM x),
sep [!(prettyQtyBinds pis),
hsep [colonD, !(withPrec Outer $ prettyM a)]]]

164
lib/Quox/Syntax/Term/Reduce.idr Normal file
View file

@ -0,0 +1,164 @@
module Quox.Syntax.Term.Reduce
import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Subst
%default total
mutual
||| true if a term has a closure or dimension closure at the top level,
||| or is `E` applied to such an elimination
public export %inline
topCloT : Term d n -> Bool
topCloT (CloT _ _) = True
topCloT (DCloT _ _) = True
topCloT (E e) = topCloE e
topCloT _ = False
||| true if an elimination has a closure or dimension closure at the top level
public export %inline
topCloE : Elim d n -> Bool
topCloE (CloE _ _) = True
topCloE (DCloE _ _) = True
topCloE _ = False
public export IsNotCloT : Term d n -> Type
IsNotCloT = So . not . topCloT
||| a term which is not a top level closure
public export NotCloTerm : Nat -> Nat -> Type
NotCloTerm d n = Subset (Term d n) IsNotCloT
public export IsNotCloE : Elim d n -> Type
IsNotCloE = So . not . topCloE
||| an elimination which is not a top level closure
public export NotCloElim : Nat -> Nat -> Type
NotCloElim d n = Subset (Elim d n) IsNotCloE
public export %inline
ncloT : (t : Term d n) -> (0 _ : IsNotCloT t) => NotCloTerm d n
ncloT t @{p} = Element t p
public export %inline
ncloE : (t : Elim d n) -> (0 _ : IsNotCloE t) => NotCloElim d n
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
pushSubstsT : Term d n -> NotCloTerm d n
pushSubstsT s = pushSubstsTWith id id s
||| if the input elimination has any top-level closures, push them under one
||| layer of syntax
export %inline
pushSubstsE : Elim d n -> NotCloElim d n
pushSubstsE e = pushSubstsEWith id id e
export
pushSubstsTWith : DSubst dfrom dto -> TSubst dto from to ->
Term dfrom from -> NotCloTerm dto to
pushSubstsTWith th ph (TYPE l) =
ncloT $ TYPE l
pushSubstsTWith th ph (Pi qty x a body) =
ncloT $ Pi qty x (subs a th ph) (subs body th ph)
pushSubstsTWith th ph (Lam x body) =
ncloT $ Lam x $ subs body th ph
pushSubstsTWith th ph (E e) =
let Element e _ = pushSubstsEWith th ph e in ncloT $ E e
pushSubstsTWith th ph (CloT s ps) =
pushSubstsTWith th (comp' th ps ph) s
pushSubstsTWith th ph (DCloT s ps) =
pushSubstsTWith (ps . th) ph s
export
pushSubstsEWith : DSubst dfrom dto -> TSubst dto from to ->
Elim dfrom from -> NotCloElim dto to
pushSubstsEWith th ph (F x) =
ncloE $ F x
pushSubstsEWith th ph (B i) =
assert_total pushSubstsE $ ph !! i
pushSubstsEWith th ph (f :@ s) =
ncloE $ subs f th ph :@ subs s th ph
pushSubstsEWith th ph (s :# a) =
ncloE $ subs s th ph :# subs a th ph
pushSubstsEWith th ph (CloE e ps) =
pushSubstsEWith th (comp' th ps ph) e
pushSubstsEWith th ph (DCloE e ps) =
pushSubstsEWith (ps . th) ph e
parameters (th : DSubst dfrom dto) (ph : TSubst dto from to)
public export %inline
pushSubstsTWith' : Term dfrom from -> Term dto to
pushSubstsTWith' s = (pushSubstsTWith th ph s).fst
public export %inline
pushSubstsEWith' : Elim dfrom from -> Elim dto to
pushSubstsEWith' e = (pushSubstsEWith th ph e).fst
public export %inline
pushSubstsT' : Term d n -> Term d n
pushSubstsT' s = (pushSubstsT s).fst
public export %inline
pushSubstsE' : Elim d n -> Elim d n
pushSubstsE' e = (pushSubstsE e).fst
mutual
-- tightening a term/elim also causes substitutions to be pushed through.
-- this is because otherwise a variable in an unused part of the subst
-- would cause it to incorrectly fail
export covering
Tighten (Term d) where
tighten p (TYPE l) =
pure $ TYPE l
tighten p (Pi qty x arg res) =
Pi qty x <$> tighten p arg
<*> tighten p res
tighten p (Lam x body) =
Lam x <$> tighten p body
tighten p (E e) =
E <$> tighten p e
tighten p (CloT tm th) =
tighten p $ pushSubstsTWith' id th tm
tighten p (DCloT tm th) =
tighten p $ pushSubstsTWith' th id tm
export covering
Tighten (Elim d) where
tighten p (F x) =
pure $ F x
tighten p (B i) =
B <$> tighten p i
tighten p (fun :@ arg) =
[|tighten p fun :@ tighten p arg|]
tighten p (tm :# ty) =
[|tighten p tm :# tighten p ty|]
tighten p (CloE el th) =
tighten p $ pushSubstsEWith' id th el
tighten p (DCloE el th) =
tighten p $ pushSubstsEWith' th id el
export covering
Tighten (ScopeTerm d) where
tighten p (TUsed body) = TUsed <$> tighten (Keep p) body
tighten p (TUnused body) = TUnused <$> tighten p body
public export %inline
weakT : Term d n -> Term d (S n)
weakT t = t //. shift 1
public export %inline
weakE : Elim d n -> Elim d (S n)
weakE t = t //. shift 1

82
lib/Quox/Syntax/Term/Split.idr Normal file
View file

@ -0,0 +1,82 @@
module Quox.Syntax.Term.Split
import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Subst
import Data.So
import Data.Vect
%default total
public export %inline
isLam : Term d n -> Bool
isLam (Lam {}) = True
isLam _ = False
public export
NotLam : Term d n -> Type
NotLam = So . not . isLam
public export %inline
isApp : Elim d n -> Bool
isApp ((:@) {}) = True
isApp _ = False
public export
NotApp : Elim d n -> Type
NotApp = So . not . isApp
infixl 9 :@@
||| apply multiple arguments at once
public export %inline
(:@@) : Elim d n -> List (Term d n) -> Elim d n
f :@@ ss = foldl (:@) f ss
public export
record GetArgs (d, n : Nat) where
constructor GotArgs
fun : Elim d n
args : List (Term d n)
0 notApp : NotApp fun
export
getArgs' : Elim d n -> List (Term d n) -> GetArgs d n
getArgs' fun args with (choose $ isApp fun)
getArgs' (f :@ a) args | Left yes = getArgs' f (a :: args)
_ | Right no = GotArgs {fun, args, notApp = no}
||| splits an application into its head and arguments. if it's not an
||| application then the list is just empty
export %inline
getArgs : Elim d n -> GetArgs d n
getArgs e = getArgs' e []
infixr 1 :\\
public export
(:\\) : Vect m Name -> Term d (m + n) -> Term d n
[] :\\ t = t
x :: xs :\\ t = let t' = replace {p = Term _} (plusSuccRightSucc {}) t in
Lam x $ TUsed $ xs :\\ t'
public export
record GetLams (d, n : Nat) where
constructor GotLams
names : Vect lams Name
body : Term d rest
0 eq : lams + n = rest
0 notLam : NotLam body
public export
getLams : Term d n -> GetLams d n
getLams s with (choose $ isLam s)
getLams s@(Lam x body) | Left yes =
let inner = getLams $ assert_smaller s $ fromScopeTerm body in
GotLams {names = x :: inner.names,
body = inner.body,
eq = plusSuccRightSucc {} `trans` inner.eq,
notLam = inner.notLam}
_ | Right no = GotLams {names = [], body = s, eq = Refl, notLam = no}

135
lib/Quox/Syntax/Term/Subst.idr Normal file
View file

@ -0,0 +1,135 @@
module Quox.Syntax.Term.Subst
import Quox.Syntax.Term.Base
%default total
export FromVar (Elim d) where fromVar = B
export FromVar (Term d) where fromVar = E . fromVar
||| does the minimal reasonable work:
||| - deletes the closure around a free name since it doesn't do anything
||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level closure
||| - immediately looks up a bound variable
||| - otherwise, wraps in a new closure
export
CanSubst (Elim d) (Elim d) where
F x // _ = F x
B i // th = th !! i
CloE e ph // th = assert_total CloE e $ ph . th
e // th = case force th of
Shift SZ => e
th => CloE e th
||| does the minimal reasonable work:
||| - deletes the closure around an atomic constant like `TYPE`
||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level closure
||| - goes inside `E` in case it is a simple variable or something
||| - otherwise, wraps in a new closure
export
CanSubst (Elim d) (Term d) where
TYPE l // _ = TYPE l
E e // th = E $ e // th
CloT s ph // th = CloT s $ ph . th
s // th = case force th of
Shift SZ => s
th => CloT s th
export
CanSubst (Elim d) (ScopeTerm d) where
TUsed body // th = TUsed $ body // push th
TUnused body // th = TUnused $ body // th
export CanSubst Var (Term d) where s // th = s // map (B {d}) th
export CanSubst Var (Elim d) where e // th = e // map (B {d}) th
export CanSubst Var (ScopeTerm d) where s // th = s // map (B {d}) th
infixl 8 //., ///
mutual
namespace Term
||| applies a term substitution with a less ambiguous type
export
(//.) : Term d from -> TSubst d from to -> Term d to
t //. th = t // th
||| applies a dimension substitution with the same behaviour as `(//)`
||| above
export
(///) : Term dfrom n -> DSubst dfrom dto -> Term dto n
TYPE l /// _ = TYPE l
E e /// th = E $ e /// th
DCloT s ph /// th = DCloT s $ ph . th
s /// Shift SZ = s
s /// th = DCloT s th
||| applies a term and dimension substitution
public export %inline
subs : Term dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
Term dto to
subs s th ph = s /// th // ph
namespace Elim
||| applies a term substitution with a less ambiguous type
export
(//.) : Elim d from -> TSubst d from to -> Elim d to
e //. th = e // th
||| applies a dimension substitution with the same behaviour as `(//)`
||| above
export
(///) : Elim dfrom n -> DSubst dfrom dto -> Elim dto n
F x /// _ = F x
B i /// _ = B i
DCloE e ph /// th = DCloE e $ ph . th
e /// Shift SZ = e
e /// th = DCloE e th
||| applies a term and dimension substitution
public export %inline
subs : Elim dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
Elim dto to
subs e th ph = e /// th // ph
namespace ScopeTerm
||| applies a term substitution with a less ambiguous type
export
(//.) : ScopeTerm d from -> TSubst d from to -> ScopeTerm d to
body //. th = body // th
||| applies a dimension substitution with the same behaviour as `(//)`
||| above
export
(///) : ScopeTerm dfrom n -> DSubst dfrom dto -> ScopeTerm dto n
TUsed body /// th = TUsed $ body /// th
TUnused body /// th = TUnused $ body /// th
||| applies a term and dimension substitution
public export %inline
subs : ScopeTerm dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
ScopeTerm dto to
subs body th ph = body /// th // ph
export CanShift (Term d) where s // by = s //. Shift by
export CanShift (Elim d) where e // by = e //. Shift by
export CanShift (ScopeTerm d) where s // by = s //. Shift by
export %inline
comp' : DSubst dfrom dto -> TSubst dfrom from mid -> TSubst dto mid to ->
TSubst dto from to
comp' th ps ph = map (/// th) ps . ph
export
fromDScopeTerm : DScopeTerm d n -> Term (S d) n
fromDScopeTerm (DUsed body) = body
fromDScopeTerm (DUnused body) = body /// shift 1
export
fromScopeTerm : ScopeTerm d n -> Term d (S n)
fromScopeTerm (TUsed body) = body
fromScopeTerm (TUnused body) = body //. shift 1

23
lib/Quox/Syntax/Universe.idr Normal file
View file

@ -0,0 +1,23 @@
module Quox.Syntax.Universe
import Quox.Pretty
import Data.Fin
import Generics.Derive
%default total
%language ElabReflection
||| `UAny` doesn't show up in programs, but when checking something is
||| just some type (e.g. in a signature) it's checked against `Star UAny`
public export
data Universe = U Nat | UAny
%name Universe l
%runElab derive "Universe" [Generic, Meta, Eq, Ord, DecEq, Show]
export
PrettyHL Universe where
prettyM UAny = pure $ hl Delim "_"
prettyM (U l) = pure $ hl Free $ pretty l

273
lib/Quox/Syntax/Var.idr Normal file
View file

@ -0,0 +1,273 @@
module Quox.Syntax.Var
import Quox.Name
import Quox.Pretty
import Quox.OPE
import Data.Nat
import Data.List
import Decidable.Equality
import Data.Bool.Decidable
%default total
public export
data Var : Nat -> Type where
VZ : Var (S n)
VS : Var n -> Var (S n)
%name Var i, j
%builtin Natural Var
public export
(.nat) : Var n -> Nat
(VZ).nat = 0
(VS i).nat = S i.nat
%transform "Var.(.nat)" Var.(.nat) i = believe_me i
public export %inline Cast (Var n) Nat where cast = (.nat)
public export %inline Cast (Var n) Integer where cast = cast . cast {to = Nat}
export %inline Eq (Var n) where i == j = i.nat == j.nat
export %inline Ord (Var n) where compare i j = compare i.nat j.nat
export %inline Show (Var n) where showPrec d i = showCon d "V" $ showArg i.nat
public export %inline Injective VS where injective Refl = Refl
parameters {auto _ : Pretty.HasEnv m}
private
prettyIndex : Nat -> m (Doc a)
prettyIndex i =
ifUnicode (pretty $ pack $ map sup $ unpack $ show i) (":" <+> pretty i)
where
sup : Char -> Char
sup c = case c of
'0' => '⁰'; '1' => '¹'; '2' => '²'; '3' => '³'; '4' => '⁴'
'5' => '⁵'; '6' => '⁶'; '7' => '⁷'; '8' => '⁸'; '9' => '⁹'; _ => c
||| `prettyVar hlok hlerr names i` pretty prints the de Bruijn index `i`.
|||
||| If it is within the bounds of `names`, then it uses the name at that index,
||| highlighted as `hlok`. Otherwise it is just printed as a number highlighted
||| as `hlerr`.
export
prettyVar' : HL -> HL -> List Name -> Nat -> m (Doc HL)
prettyVar' hlok hlerr names i =
case inBounds i names of
Yes _ => hlF' hlok [|prettyM (index i names) <+> prettyIndex i|]
No _ => pure $ hl hlerr $ pretty i
export %inline
prettyVar : HL -> HL -> List Name -> Var n -> m (Doc HL)
prettyVar hlok hlerr names i = prettyVar' hlok hlerr names i.nat
public export
fromNatWith : (i : Nat) -> (0 p : i `LT` n) -> Var n
fromNatWith Z (LTESucc _) = VZ
fromNatWith (S i) (LTESucc p) = VS $ fromNatWith i p
%transform "Var.fromNatWith" fromNatWith i p = believe_me i
public export %inline
V : (i : Nat) -> {auto 0 p : i `LT` n} -> Var n
V i {p} = fromNatWith i p
export %inline
tryFromNat : Alternative f => (n : Nat) -> Nat -> f (Var n)
tryFromNat n i =
case i `isLT` n of
Yes p => pure $ fromNatWith i p
No _ => empty
export
0 toNatLT : (i : Var n) -> i.nat `LT` n
toNatLT VZ = LTESucc LTEZero
toNatLT (VS i) = LTESucc $ toNatLT i
public export
toNatInj : {i, j : Var n} -> i.nat = j.nat -> i = j
toNatInj {i = VZ} {j = VZ} Refl = Refl
toNatInj {i = VZ} {j = (VS i)} Refl impossible
toNatInj {i = (VS i)} {j = VZ} Refl impossible
toNatInj {i = (VS i)} {j = (VS j)} prf = cong VS $ toNatInj $ injective prf
public export %inline Injective (.nat) where injective = toNatInj
export
0 fromToNat : (i : Var n) -> (p : i.nat `LT` n) -> fromNatWith i.nat p = i
fromToNat VZ (LTESucc p) = Refl
fromToNat (VS i) (LTESucc p) = rewrite fromToNat i p in Refl
export
0 toFromNat : (i : Nat) -> (p : i `LT` n) -> (fromNatWith i p).nat = i
toFromNat 0 (LTESucc x) = Refl
toFromNat (S k) (LTESucc x) = cong S $ toFromNat k x
-- not using %transform like other things because weakSpec requires the proof
-- to be relevant. but since only `LTESucc` is ever possible that seems
-- to be an instance of <https://github.com/idris-lang/Idris2/issues/1259>?
export
weak : (0 p : m `LTE` n) -> Var m -> Var n
weak p i = fromNatWith i.nat $ transitive (toNatLT i) p
public export
0 weakSpec : m `LTE` n -> Var m -> Var n
weakSpec LTEZero _ impossible
weakSpec (LTESucc p) VZ = VZ
weakSpec (LTESucc p) (VS i) = VS $ weakSpec p i
export
0 weakSpecCorrect : (p : m `LTE` n) -> (i : Var m) -> (weakSpec p i).nat = i.nat
weakSpecCorrect LTEZero _ impossible
weakSpecCorrect (LTESucc x) VZ = Refl
weakSpecCorrect (LTESucc x) (VS i) = cong S $ weakSpecCorrect x i
export
0 weakCorrect : (p : m `LTE` n) -> (i : Var m) -> (weak p i).nat = i.nat
weakCorrect LTEZero _ impossible
weakCorrect (LTESucc p) VZ = Refl
weakCorrect (LTESucc p) (VS i) = cong S $ weakCorrect p i
export
0 weakIsSpec : (p : m `LTE` n) -> (i : Var m) -> weak p i = weakSpec p i
weakIsSpec p i = toNatInj $ trans (weakCorrect p i) (sym $ weakSpecCorrect p i)
public export
interface FromVar f where %inline fromVar : Var n -> f n
public export FromVar Var where fromVar = id
public export
data LT : Var n -> Var n -> Type where
LTZ : VZ `LT` VS i
LTS : i `LT` j -> VS i `LT` VS j
%builtin Natural Var.LT
%name Var.LT lt
public export %inline
GT : Var n -> Var n -> Type
i `GT` j = j `LT` i
export
Transitive (Var n) LT where
transitive LTZ (LTS _) = LTZ
transitive (LTS p) (LTS q) = LTS $ transitive p q
export Uninhabited (i `Var.LT` i) where uninhabited (LTS p) = uninhabited p
export Uninhabited (VS i `LT` VZ) where uninhabited _ impossible
export
isLT : (i, j : Var n) -> Dec (i `LT` j)
isLT VZ VZ = No uninhabited
isLT VZ (VS j) = Yes LTZ
isLT (VS i) VZ = No uninhabited
isLT (VS i) (VS j) with (isLT i j)
_ | Yes prf = Yes (LTS prf)
_ | No contra = No (\case LTS p => contra p)
public export
data Compare : (i, j : Var n) -> Type where
IsLT : (lt : i `LT` j) -> Compare i j
IsEQ : Compare i i
IsGT : (gt : i `GT` j) -> Compare i j
%name Compare cmp
export
compareS : Compare i j -> Compare (VS i) (VS j)
compareS (IsLT lt) = IsLT (LTS lt)
compareS IsEQ = IsEQ
compareS (IsGT gt) = IsGT (LTS gt)
export
compareP : (i, j : Var n) -> Compare i j
compareP VZ VZ = IsEQ
compareP VZ (VS j) = IsLT LTZ
compareP (VS i) VZ = IsGT LTZ
compareP (VS i) (VS j) = compareS $ compareP i j
export
0 compareSelf : (c : Compare i i) -> c = IsEQ
compareSelf (IsLT lt) = absurd lt
compareSelf IsEQ = Refl
compareSelf (IsGT gt) = absurd gt
export
0 comparePSelf : (i : Var n) -> compareP i i = IsEQ
comparePSelf i = compareSelf {}
public export
data LTE : Var n -> Var n -> Type where
LTEZ : VZ `LTE` j
LTES : i `LTE` j -> VS i `LTE` VS j
export
Reflexive (Var n) LTE where
reflexive {x = VZ} = LTEZ
reflexive {x = VS i} = LTES reflexive
export
Transitive (Var n) LTE where
transitive LTEZ q = LTEZ
transitive (LTES p) (LTES q) = LTES $ transitive p q
export
Antisymmetric (Var n) LTE where
antisymmetric LTEZ LTEZ = Refl
antisymmetric (LTES p) (LTES q) = cong VS $ antisymmetric p q
export
splitLTE : {j : Var n} -> i `LTE` j -> Either (i = j) (i `LT` j)
splitLTE {j = VZ} LTEZ = Left Refl
splitLTE {j = VS _} LTEZ = Right LTZ
splitLTE (LTES p) with (splitLTE p)
_ | (Left eq) = Left $ cong VS eq
_ | (Right lt) = Right $ LTS lt
export Uninhabited (VZ = VS i) where uninhabited _ impossible
export Uninhabited (VS i = VZ) where uninhabited _ impossible
public export
eqReflect : (i, j : Var n) -> (i = j) `Reflects` (i == j)
eqReflect VZ VZ = RTrue Refl
eqReflect VZ (VS i) = RFalse absurd
eqReflect (VS i) VZ = RFalse absurd
eqReflect (VS i) (VS j) with (eqReflect i j)
eqReflect (VS i) (VS j) | r with (i == j)
eqReflect (VS i) (VS j) | RTrue yes | True = RTrue $ cong VS yes
eqReflect (VS i) (VS j) | RFalse no | False = RFalse $ no . injective
public export
reflectToDec : p `Reflects` b -> Dec p
reflectToDec (RTrue y) = Yes y
reflectToDec (RFalse n) = No n
public export %inline
varDecEq : (i, j : Var n) -> Dec (i = j)
varDecEq i j = reflectToDec $ eqReflect i j
-- justified by eqReflect [citation needed]
private %inline
decEqFromBool : (i, j : Var n) -> Dec (i = j)
decEqFromBool i j =
if i == j then Yes $ believe_me $ Refl {x = 0}
else No $ id . believe_me
%transform "Var.decEq" varDecEq = decEqFromBool
public export %inline DecEq (Var n) where decEq = varDecEq
export
Tighten Var where
tighten Id i = pure i
tighten (Drop q) VZ = empty
tighten (Drop q) (VS i) = tighten q i
tighten (Keep q) VZ = pure VZ
tighten (Keep q) (VS i) = VS <$> tighten q i