merge duplicate Nat LTE'

This commit is contained in:
rhiannon morris 2022-04-11 23:33:32 +02:00
parent 2446655b08
commit 25f4923fac
3 changed files with 38 additions and 54 deletions

View File

@ -2,6 +2,7 @@ module Quox.Context
import Quox.Syntax.Shift
import Quox.Pretty
import Quox.NatExtra
import Data.DPair
import Data.Nat
@ -151,38 +152,10 @@ export %inline
ftel <*> xtel = runIdentity $ (pure .) <$> ftel `app` xtel
-- ...but can't write pure without `from,to` being ω, so no idiom brackets ☹
namespace Nat
public export
data LTE' : Nat -> Nat -> Type where
LTERefl : n `LTE'` n
LTESuccR : m `LTE'` n -> m `LTE'` S n
%builtin Natural LTE'
export %hint
lteZero' : {n : Nat} -> 0 `LTE'` n
lteZero' {n = 0} = LTERefl
lteZero' {n = S n} = LTESuccR lteZero'
export
lteSucc' : m `LTE'` n -> S m `LTE'` S n
lteSucc' LTERefl = LTERefl
lteSucc' (LTESuccR p) = LTESuccR (lteSucc' p)
export
lteToLte' : {n : Nat} -> m `LTE` n -> m `LTE'` n
lteToLte' LTEZero = lteZero'
lteToLte' (LTESucc p) = lteSucc' (lteToLte' p)
export
lte'ToLte : {n : Nat} -> m `LTE'` n -> m `LTE` n
lte'ToLte LTERefl = reflexive
lte'ToLte (LTESuccR p) = lteSuccRight (lte'ToLte p)
export
teleLte' : Telescope tm from to -> from `LTE'` to
teleLte' [<] = LTERefl
teleLte' (tel :< _) = LTESuccR (teleLte' tel)
export
teleLte' : Telescope tm from to -> from `LTE'` to
teleLte' [<] = LTERefl
teleLte' (tel :< _) = LTESuccR (teleLte' tel)
export

30
src/Quox/NatExtra.idr Normal file
View File

@ -0,0 +1,30 @@
module Quox.NatExtra
import public Data.Nat
public export
data LTE' : Nat -> Nat -> Type where
LTERefl : LTE' n n
LTESuccR : LTE' m n -> LTE' m (S n)
%builtin Natural LTE'
public export
lteZero' : {n : Nat} -> LTE' 0 n
lteZero' {n = 0} = LTERefl
lteZero' {n = S n} = LTESuccR lteZero'
public export
lteSucc' : LTE' m n -> LTE' (S m) (S n)
lteSucc' LTERefl = LTERefl
lteSucc' (LTESuccR p) = LTESuccR $ lteSucc' p
public export
fromLTE : {n : Nat} -> LTE m n -> LTE' m n
fromLTE LTEZero = lteZero'
fromLTE (LTESucc p) = lteSucc' $ fromLTE p
public export
toLte : {n : Nat} -> m `LTE'` n -> m `LTE` n
toLte LTERefl = reflexive
toLte (LTESuccR p) = lteSuccRight (toLte p)

View File

@ -2,6 +2,8 @@
||| a smaller scope and part of a larger one.
module Quox.OPE
import Quox.NatExtra
import Data.Nat
@ -35,30 +37,9 @@ toLTE (Drop p) = lteSuccRight $ toLTE p
toLTE (Keep p) = LTESucc $ toLTE p
public export
data LTE' : Nat -> Nat -> Type where
LTERefl : (n : Nat) -> LTE' n n
LTESuccR : Lazy (LTE' m n) -> LTE' m (S n)
public export
lteZero' : {n : Nat} -> LTE' 0 n
lteZero' {n = 0} = LTERefl 0
lteZero' {n = S n} = LTESuccR $ delay lteZero'
public export
lteSucc' : LTE' m n -> LTE' (S m) (S n)
lteSucc' (LTERefl n) = LTERefl (S n)
lteSucc' (LTESuccR p) = LTESuccR $ delay $ lteSucc' p
public export
fromLTE : {n : Nat} -> LTE m n -> LTE' m n
fromLTE LTEZero = lteZero'
fromLTE (LTESucc p) = lteSucc' $ fromLTE p
public export
dropInner' : LTE' m n -> OPE m n
dropInner' (LTERefl n) = Id
dropInner' LTERefl = Id
dropInner' (LTESuccR p) = Drop $ dropInner' $ force p
public export