├── Dumb ├── readme.md └── HMTS │ ├── Names.agda │ ├── Syntax.agda │ ├── Main.agda │ ├── Types.agda │ ├── Substitutions.agda │ ├── Annotated.agda │ ├── Alpha.agda │ ├── Tests.agda │ ├── Terms.agda │ ├── Bind.agda │ ├── AlgorithmM.agda │ └── Prelude.agda ├── Nary ├── readme.md ├── Naive.agda ├── Simple.agda ├── Power.agda ├── Dependent.agda └── Comps.agda ├── tie-the-knot.agda ├── Inhabits.agda ├── MonoEff ├── Effect │ ├── HState.agda │ ├── State.agda │ └── IState.agda └── Prelude.agda ├── eqclasses.hs ├── DisplayInfix.agda ├── Lists ├── zipWith-via-elim.agda ├── ChurchVector.agda ├── ChurchScott.hs ├── PList.hs └── elimChurchList.agda ├── System-F ├── Prelude.agda ├── Sets.agda ├── TypeEval.agda └── Subst.agda ├── NaryDec ├── Basic.agda ├── Examples.agda └── Nary.agda ├── Eff ├── Freer.agda ├── Union1.agda ├── Core.agda ├── Tests.agda ├── Prelude.agda └── Map.agda ├── NaryJigger.agda ├── EqType.agda ├── matches.hs ├── ThrowOnZero.agda ├── PathOver.agda ├── Kitchen ├── Kitchen.agda ├── FreerKitchen.agda └── FreeKitchen.agda ├── Nested.hs ├── TT └── Prelude.agda ├── arity.agda ├── CSTLC.agda ├── TypedJigger.agda ├── RecN-challenge.agda ├── applicative-parser.hs ├── bfs.hs ├── Normalization ├── PHOAS.agda ├── Dependent.agda ├── NbE_BSN.agda ├── DecNfSpines.agda ├── SpinePHOAS.agda ├── DecNf.agda └── Readback.agda ├── normal-forms.agda ├── PolyMonadUnify.agda ├── Desc ├── ParamDesc.agda ├── Prop.agda ├── IRDesc.agda ├── Elim.agda └── IRPropDesc.agda ├── Fin-neq-Nat.agda ├── adder.hs ├── IndIndEx.agda ├── Indexed.agda ├── SizedMonoid.hs ├── DefCheck.agda ├── division.agda ├── Fin-injective.agda ├── Categories ├── Examples.agda ├── Category.agda ├── Setoid.agda ├── Monoid.agda └── Morphism.agda ├── VanillaTypedJigger.agda ├── TABA.agda ├── Yoneda.agda ├── Diff.agda ├── HomoFree.hs ├── UncurryN.agda ├── Rose └── NonGADT.agda ├── liftA.agda ├── pigeonhole.agda ├── Dependent types and runtime data.hs ├── IsNat.agda ├── PolyMonad.agda ├── IFreerIFree.agda ├── Omega.agda ├── maybe-elim.agda ├── Extensionality'.agda ├── PEG-lemma ├── one.agda └── two.agda ├── Incremental2.agda ├── Modal └── NoTermSem.agda └── lib.agda /Dumb/readme.md: -------------------------------------------------------------------------------- 1 | It's a dumb version of [this](https://github.com/effectfully/HMTS-in-Agda) development. -------------------------------------------------------------------------------- /Nary/readme.md: -------------------------------------------------------------------------------- 1 | Related to http://stackoverflow.com/questions/29179508/arity-generic-programming-in-agda 2 | -------------------------------------------------------------------------------- /Nary/Naive.agda: -------------------------------------------------------------------------------- 1 | module Nary.Naive where 2 | 3 | open import Data.Nat.Base 4 | open import Data.Product 5 | 6 | open import Nary.Power 7 | 8 | _->ⁿ_ : ∀ {n} -> Set ^ n -> Set -> Set 9 | _->ⁿ_ {0} _ B = B 10 | _->ⁿ_ {suc _} (A , R) B = A -> R ->ⁿ B 11 | -------------------------------------------------------------------------------- /Dumb/HMTS/Names.agda: -------------------------------------------------------------------------------- 1 | module HMTS.Names where 2 | 3 | open import Data.Nat 4 | 5 | open import HMTS.Types 6 | 7 | a = Var 0 8 | b = Var 1 9 | c = Var 2 10 | d = Var 3 11 | e = Var 4 12 | f = Var 5 13 | g = Var 6 14 | h = Var 7 15 | i = Var 8 16 | j = Var 9 17 | k = Var 10 18 | -------------------------------------------------------------------------------- /tie-the-knot.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Data.Nat 3 | open import Data.Product 4 | open import Data.Vec 5 | 6 | {-# NON_TERMINATING #-} 7 | fix : ∀ {α} {A : Set α} -> (A -> A) -> A 8 | fix f = f (fix f) 9 | 10 | 3∷3∷3∷[] : Vec ℕ _ 11 | 3∷3∷3∷[] = proj₂ (fix (uncurry (const ∘ f))) where 12 | f : ℕ -> ∃ (Vec ℕ) 13 | f m = 3 , replicate m 14 | -------------------------------------------------------------------------------- /Inhabits.agda: -------------------------------------------------------------------------------- 1 | -- The idea is due to http://stackoverflow.com/a/26921233/3237465 2 | 3 | infix 0 _::_ 4 | 5 | data _::_ {α} {A : Set α} (x : A) : Set α -> Set α where 6 | reveal : x :: A 7 | 8 | open import Data.Nat.Base 9 | open import Data.Fin hiding (_+_) 10 | open import Data.Nat.Properties.Simple 11 | 12 | drop-0 : ∀ n -> (i : Fin (n + 0)) -> i :: Fin n 13 | drop-0 n i rewrite +-right-identity n = reveal 14 | -------------------------------------------------------------------------------- /MonoEff/Effect/HState.agda: -------------------------------------------------------------------------------- 1 | module Effect.HState where 2 | 3 | open import Prelude 4 | 5 | open import Data.Maybe.Base 6 | 7 | Effect : ∀ {ρ ψ φ} 8 | -> (F : Set ρ -> Set ψ) 9 | -> (∀ {R} -> F R -> Set φ) 10 | -> ∀ ε 11 | -> Set (ψ ⊔ φ ⊔ lsuc (ρ ⊔ ε)) 12 | Effect {ρ} F G ε = (R : Set ρ) -> (A : F R) -> (G A -> Set ρ) -> Set ε 13 | 14 | Constr : ∀ {ρ} -> Set ρ -> Set (lsuc ρ) 15 | Constr R = Maybe (R ≡ ⊤) 16 | 17 | State : ∀ {ρ} -> Effect Constr (λ {R} _ -> R) ρ 18 | State R nothing R′ = ⊤ 19 | State _ (just refl) R′ = R′ _ 20 | -------------------------------------------------------------------------------- /eqclasses.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | 3 | set :: Int -> a -> [a] -> [a] 4 | set 0 y (x:xs) = y : xs 5 | set n y (x:xs) = x : set (n - 1) y xs 6 | 7 | sets :: [Int] -> a -> [a] -> [a] 8 | sets is x xs = foldr (flip set x) xs is 9 | 10 | eqclasses :: [(Int, Int)] -> [[Int]] 11 | eqclasses ps = nub $ go ps (map (:[]) [0 .. maximum $ ps >>= \(x, y) -> [x, y]]) where 12 | go :: [(Int, Int)] -> [[Int]] -> [[Int]] 13 | go [] cs = cs 14 | go ((i, j):ps) cs = go ps $ 15 | if i `elem` cs !! j 16 | then cs 17 | else let ks = (cs !! i) ++ (cs !! j) in sets ks ks cs -------------------------------------------------------------------------------- /Dumb/HMTS/Syntax.agda: -------------------------------------------------------------------------------- 1 | module HMTS.Syntax where 2 | 3 | open import Data.Nat 4 | open import Data.Fin hiding (_+_) 5 | 6 | infixl 4 _·_ 7 | 8 | data Syntax n : Set where 9 | varˢ : Fin n -> Syntax n 10 | ƛˢ_ : Syntax (suc n) -> Syntax n 11 | _·_ : Syntax n -> Syntax n -> Syntax n 12 | 13 | Syntax⁽⁾ : Set 14 | Syntax⁽⁾ = Syntax 0 15 | 16 | weaken : ∀ {n m} -> Syntax n -> Syntax (n + m) 17 | weaken (varˢ i) = varˢ (inject+ _ i) 18 | weaken (ƛˢ b) = ƛˢ weaken b 19 | weaken (f · x) = weaken f · weaken x 20 | 21 | Pure : Set 22 | Pure = ∀ {n} -> Syntax n 23 | 24 | pure : Syntax⁽⁾ -> Pure 25 | pure e = weaken e 26 | -------------------------------------------------------------------------------- /DisplayInfix.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Relation.Binary.PropositionalEquality 3 | open import Data.Nat.Base 4 | 5 | record R : Set where 6 | infixl 6 _⊕_ 7 | 8 | field 9 | _⊕_ : ℕ -> ℕ -> ℕ 10 | comm-⊕ : ∀ n m -> n ⊕ m ≡ m ⊕ n 11 | 12 | private open module Display-⊕ {r} = R r using (_⊕_) public 13 | {-# DISPLAY R._⊕_ _ n m = n ⊕ m #-} 14 | 15 | flipR : R -> R 16 | flipR r = record 17 | { _⊕_ = flip (R._⊕_ r) 18 | -- The type of the hole is `(n m : ℕ) → m ⊕ n ≡ n ⊕ m` after normalization. 19 | -- It would be `(n m : ℕ) → (r R.⊕ m) n ≡ (r R.⊕ n) m` without the `DISPLAY` pragma. 20 | ; comm-⊕ = {!!} 21 | } 22 | -------------------------------------------------------------------------------- /Nary/Simple.agda: -------------------------------------------------------------------------------- 1 | module Nary.Simple where 2 | 3 | open import Level renaming (zero to lzero; suc to lsuc) 4 | open import Function 5 | open import Data.Unit.Base 6 | open import Data.Nat.Base 7 | open import Data.Product hiding (map) 8 | open import Data.Vec 9 | 10 | open import Nary.Power 11 | 12 | infixr 0 _->ⁿ_ 13 | 14 | Sets : ∀ {n} -> (αs : Level ^ n) -> Set (mono-^ (map lsuc) αs ⊔ⁿ lzero) 15 | Sets {0} _ = ⊤ 16 | Sets {suc _} (α , αs) = Σ (Set α) λ A -> A -> Sets αs 17 | 18 | _->ⁿ_ : ∀ {n} {αs : Level ^ n} {β} -> Sets αs -> Set β -> Set (αs ⊔ⁿ β) 19 | _->ⁿ_ {0} _ B = B 20 | _->ⁿ_ {suc _} (_ , F) B = ∀ x -> F x ->ⁿ B 21 | 22 | 23 | -------------------------------------------------------------------------------- /Lists/zipWith-via-elim.agda: -------------------------------------------------------------------------------- 1 | open import Data.List hiding (zipWith) 2 | 3 | elimList : ∀ {α γ} {A : Set α} 4 | -> (C : List A -> Set γ) -> C [] -> (∀ {xs} x -> C xs -> C (x ∷ xs)) -> ∀ xs -> C xs 5 | elimList C z f [] = z 6 | elimList C z f (x ∷ xs) = f x (elimList C z f xs) 7 | 8 | caseList : ∀ {α γ} {A : Set α} 9 | -> (C : List A -> Set γ) -> C [] -> (∀ x xs -> C (x ∷ xs)) -> ∀ xs -> C xs 10 | caseList C z f = elimList C z (λ {xs} x _ -> f x xs) 11 | 12 | zipWith : ∀ {α β γ} {A : Set α} {B : Set β} {C : Set γ} 13 | -> (A -> B -> C) -> List A -> List B -> List C 14 | zipWith f = elimList _ (λ ys -> []) (λ x r ys -> caseList _ [] (λ y ys -> f x y ∷ r ys) ys) 15 | -------------------------------------------------------------------------------- /Dumb/HMTS/Main.agda: -------------------------------------------------------------------------------- 1 | module HMTS.Main where 2 | 3 | open import HMTS.Prelude 4 | open import HMTS.AlgorithmM 5 | open import HMTS.Annotated 6 | open import HMTS.Terms 7 | open import HMTS.Alpha 8 | 9 | term : ∀ eᵘ -> 10 | infer eᵘ >>=ᵀ λ Ψ -> 11 | typifyᵃ (annotate Ψ eᵘ) >>=ᵀ λ _ -> 12 | _ 13 | term eᵘ = 14 | infer eᵘ >>=⊤ λ Ψ -> 15 | typifyᵃ (annotate Ψ eᵘ) >>=⊤ λ e -> 16 | alpha e 17 | 18 | open import Data.Nat public 19 | 20 | open import HMTS.Prelude public 21 | open import HMTS.Syntax public 22 | open import HMTS.Bind public 23 | open import HMTS.Types public 24 | open import HMTS.Names public 25 | open import HMTS.Terms public 26 | -------------------------------------------------------------------------------- /System-F/Prelude.agda: -------------------------------------------------------------------------------- 1 | module System-F.Prelude where 2 | 3 | open import Level renaming (zero to zeroₗ; suc to sucₗ) public 4 | open import Function public 5 | open import Relation.Binary.PropositionalEquality hiding ([_]) public 6 | open import Data.Empty public 7 | open import Data.Unit.Base hiding (_≤_) public 8 | open import Data.Nat.Base hiding (_⊔_) public 9 | open import Data.Fin using (Fin; zero; suc) public 10 | open import Data.Product public 11 | open import Data.Vec using (lookup) public 12 | 13 | cong₃ : ∀ {α β γ δ} {A : Set α} {B : Set β} {C : Set γ} {D : Set δ} {x y v w s t} 14 | -> (f : A -> B -> C -> D) -> x ≡ y -> v ≡ w -> s ≡ t -> f x v s ≡ f y w t 15 | cong₃ f refl refl refl = refl 16 | -------------------------------------------------------------------------------- /Dumb/HMTS/Types.agda: -------------------------------------------------------------------------------- 1 | module HMTS.Types where 2 | 3 | open import Relation.Nullary 4 | open import Relation.Binary.PropositionalEquality 5 | open import Data.Nat 6 | open import Data.Maybe 7 | open import Data.List as List 8 | open import Data.Vec hiding (_⊛_) 9 | 10 | open import HMTS.Prelude 11 | 12 | infixr 1 _⇒_ 13 | 14 | data Type : Set where 15 | Var : ℕ -> Type 16 | _⇒_ : Type -> Type -> Type 17 | 18 | Con : ℕ -> Set 19 | Con = Vec Type 20 | 21 | -- We need `Data.Set'. 22 | ftv : Type -> List ℕ 23 | ftv (Var i) = i ∷ [] 24 | ftv (σ ⇒ τ) = union (ftv σ) (ftv τ) 25 | 26 | _≟ᵀ_ : (σ τ : Type) -> Maybe (σ ≡ τ) 27 | Var i ≟ᵀ Var j with i ≟ j 28 | ... | yes r rewrite r = just refl 29 | ... | no _ = nothing 30 | (σ ⇒ τ) ≟ᵀ (σ' ⇒ τ') = cong₂ _⇒_ <$> (σ ≟ᵀ σ') ⊛ (τ ≟ᵀ τ') 31 | _ ≟ᵀ _ = nothing 32 | -------------------------------------------------------------------------------- /NaryDec/Basic.agda: -------------------------------------------------------------------------------- 1 | module NaryDec.Basic where 2 | 3 | open import Relation.Binary 4 | open import Relation.Binary.PropositionalEquality 5 | open import Data.Unit.Base 6 | open import Data.Empty 7 | open import Data.Nat.Base 8 | 9 | data DecY {α} (A : Set α) : Set α where 10 | yes : A -> DecY A 11 | no : DecY A 12 | 13 | _≤?_ : ℕ -> ℕ -> Set 14 | 0 ≤? _ = ⊤ 15 | _ ≤? 0 = ⊥ 16 | suc n ≤? suc m = n ≤? m 17 | 18 | _≢0 : ℕ -> Set 19 | _≢0 = _≤?_ 1 20 | 21 | record Is {α} {A : Set α} (x : A) : Set α where 22 | 23 | ! : ∀ {α} {A : Set α} -> (x : A) -> Is x 24 | ! _ = _ 25 | 26 | IsDecPropEq : ∀ {α} -> Set α -> Set α 27 | IsDecPropEq A = IsDecEquivalence {A = A} _≡_ 28 | 29 | mkDecPropEq : ∀ {α} {A : Set α} -> Decidable {A = A} _≡_ -> IsDecPropEq A 30 | mkDecPropEq _≟_ = record { isEquivalence = isEquivalence ; _≟_ = _≟_ } 31 | -------------------------------------------------------------------------------- /Dumb/HMTS/Substitutions.agda: -------------------------------------------------------------------------------- 1 | module HMTS.Substitutions where 2 | 3 | open import Function 4 | open import Relation.Nullary.Decidable 5 | open import Data.Bool 6 | open import Data.Nat as Nat 7 | open import Data.Maybe 8 | open import Data.Product 9 | open import Data.List as List 10 | 11 | open import HMTS.Prelude 12 | open import HMTS.Types 13 | 14 | Subst : Set 15 | Subst = List (ℕ × Type) 16 | 17 | apply : Subst -> Type -> Type 18 | apply Ψ (Var i) = maybe′ id (Var i) (lookup i Ψ) 19 | apply Ψ (σ ⇒ τ) = apply Ψ σ ⇒ apply Ψ τ 20 | 21 | -- We really need `Data.Set'. 22 | _∘ˢ_ : Subst -> Subst -> Subst 23 | Φ ∘ˢ Ψ = filter (λ { (i , _) -> not (i ∈? List.map proj₁ Φ) }) Ψ 24 | ++ List.map (λ{ (i , σ) -> (i , apply Ψ σ) }) Φ 25 | 26 | subst : ℕ -> Type -> Maybe Subst 27 | subst i σ = if i ∈? ftv σ then nothing else just ((i , σ) ∷ []) 28 | -------------------------------------------------------------------------------- /Eff/Freer.agda: -------------------------------------------------------------------------------- 1 | module Eff.Freer where 2 | 3 | open import Eff.Prelude 4 | 5 | infixl 2 _>>=_ 6 | infixr 1 _>>_ 7 | infixl 5 _<$>_ 8 | 9 | data Freer {α β ψ} (F : Set α -> Set ψ) (B : Set β) : Set (lsuc α ⊔ β ⊔ ψ) where 10 | return : B -> Freer F B 11 | call : ∀ {A} -> F A -> (A -> Freer F B) -> Freer F B 12 | 13 | _>>=_ : ∀ {α β γ ψ} {F : Set α -> Set ψ} {B : Set β} {C : Set γ} 14 | -> Freer F B -> (B -> Freer F C) -> Freer F C 15 | return y >>= g = g y 16 | call a f >>= g = call a λ x -> f x >>= g 17 | 18 | _>>_ : ∀ {α β γ ψ} {F : Set α -> Set ψ} {B : Set β} {C : Set γ} 19 | -> Freer F B -> Freer F C -> Freer F C 20 | b >> c = b >>= const c 21 | 22 | _<$>_ : ∀ {α β γ ψ} {F : Set α -> Set ψ} {B : Set β} {C : Set γ} 23 | -> (B -> C) -> Freer F B -> Freer F C 24 | g <$> b = b >>= return ∘ g 25 | 26 | perform : ∀ {α ψ} {F : Set α -> Set ψ} {A : Set α} -> F A -> Freer F A 27 | perform a = call a return 28 | -------------------------------------------------------------------------------- /Nary/Power.agda: -------------------------------------------------------------------------------- 1 | module Nary.Power where 2 | 3 | open import Level hiding (suc) 4 | open import Function 5 | open import Data.Unit.Base 6 | open import Data.Nat.Base hiding (_⊔_) 7 | open import Data.Product 8 | open import Data.Vec 9 | 10 | infixl 6 _^_ 11 | infixl 6 _⊔ⁿ_ 12 | 13 | _^_ : ∀ {α} -> Set α -> ℕ -> Set α 14 | A ^ 0 = Lift ⊤ 15 | A ^ suc n = A × A ^ n 16 | 17 | to-^ : ∀ {n α} {A : Set α} -> Vec A n -> A ^ n 18 | to-^ = foldr (_^_ _) _,_ _ 19 | 20 | from-^ : ∀ {n α} {A : Set α} -> A ^ n -> Vec A n 21 | from-^ {0} _ = [] 22 | from-^ {suc _} (x , xs) = x ∷ from-^ xs 23 | 24 | on-^ : ∀ {α β n} {A : Set α} {B : Vec A n -> Set β} 25 | -> (∀ xs -> B xs) -> ∀ xs -> B (from-^ xs) 26 | on-^ f = f ∘ from-^ 27 | 28 | mono-^ : ∀ {α n m} {A : Set α} -> (Vec A n -> Vec A m) -> A ^ n -> A ^ m 29 | mono-^ f = to-^ ∘ on-^ f 30 | 31 | _⊔ⁿ_ : ∀ {n} -> Level ^ n -> Level -> Level 32 | _⊔ⁿ_ = on-^ $ flip $ foldr _ _⊔_ 33 | -------------------------------------------------------------------------------- /NaryDec/Examples.agda: -------------------------------------------------------------------------------- 1 | module NaryDec.Examples where 2 | 3 | open import Function 4 | open import Relation.Nullary 5 | open import Relation.Binary.PropositionalEquality 6 | open import Data.Nat hiding (_≤?_) renaming (_≟_ to _≟ℕ_) 7 | open import Data.Product 8 | open import Data.Vec 9 | 10 | open import NaryDec.Main 11 | 12 | dec-suc : Dec-Of-form 1 suc 13 | dec-suc = , λ{ 0 -> no ; (suc _) -> yes (, refl) } 14 | 15 | dec-2+ : Dec-Of-form 1 (_+_ 2) 16 | dec-2+ = extend 1 dec-suc dec-suc 17 | 18 | dec-n+ : ∀ n -> Dec-Of-form 1 (_+_ n) 19 | dec-n+ 0 = , λ _ -> yes (, refl) 20 | dec-n+ (suc n) = extend 1 dec-suc (dec-n+ n) 21 | 22 | data Foo : Set₁ where 23 | foo : ∀ n -> Vec Set n -> Foo 24 | 25 | dec-foo : Dec-Of-form 2 foo 26 | dec-foo = , λ{ (foo _ _) -> yes (, , refl) } 27 | 28 | instance 29 | isDecPropEq-ℕ : IsDecPropEq ℕ 30 | isDecPropEq-ℕ = mkDecPropEq _≟ℕ_ 31 | 32 | dec-2 : Dec-Of-form 0 2 33 | dec-2 = bound 1 dec-2+ 0 34 | -------------------------------------------------------------------------------- /NaryJigger.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Data.Nat.Base 3 | open import Data.Fin hiding (_+_; #_) 4 | 5 | data Syntax n : Set where 6 | var : Fin n -> Syntax n 7 | ƛ_ : Syntax (suc n) -> Syntax n 8 | _·_ : Syntax n -> Syntax n -> Syntax n 9 | 10 | shift : ∀ {m} n -> Fin (suc (n + m)) 11 | shift 0 = fromℕ _ 12 | shift (suc n) = inject₁ (shift n) 13 | 14 | Bound : ℕ -> Set 15 | Bound n = ∀ {m} -> Syntax (suc (n + m)) 16 | 17 | Bindᶜ : (ℕ -> ℕ) -> ℕ -> Set 18 | Bindᶜ k 0 = Syntax (k 0) 19 | Bindᶜ k (suc n) = Bound (k 0) -> Bindᶜ (k ∘ suc) n 20 | 21 | bindᶜ : ∀ k n -> Bindᶜ k n -> Syntax (k n) 22 | bindᶜ k 0 b = b 23 | bindᶜ k (suc n) b = bindᶜ (k ∘ suc) n (b (var (shift (k 0)))) 24 | 25 | ƛⁿ : ∀ {m} n -> Syntax (n + m) -> Syntax m 26 | ƛⁿ 0 e = e 27 | ƛⁿ (suc n) e = ƛⁿ n (ƛ e) 28 | 29 | _#_ : ∀ {n} m -> Bindᶜ (flip _+_ n) m -> Syntax n 30 | _#_ {n} m b = ƛⁿ m (bindᶜ (flip _+_ n) m b) 31 | 32 | example : Syntax 0 33 | example = 3 # λ h f x → (1 # λ t → t · h) · (f · x) 34 | -------------------------------------------------------------------------------- /EqType.agda: -------------------------------------------------------------------------------- 1 | open import Relation.Binary.PropositionalEquality 2 | open import Data.Unit.Base 3 | open import Data.Bool.Base 4 | open import Data.Nat.Base 5 | open import Data.List.Base 6 | 7 | infix 5 _==ᵗ_ _==ᵀ_ 8 | 9 | data Type : Set where 10 | unit : Type 11 | bool : Type 12 | nat : Type 13 | list : Type -> Type 14 | 15 | ⟦_⟧ : Type -> Set 16 | ⟦ unit ⟧ = ⊤ 17 | ⟦ bool ⟧ = Bool 18 | ⟦ nat ⟧ = ℕ 19 | ⟦ list a ⟧ = List ⟦ a ⟧ 20 | 21 | _==ᵗ_ : Type -> Type -> Bool 22 | unit ==ᵗ unit = true 23 | bool ==ᵗ bool = true 24 | nat ==ᵗ nat = true 25 | list a ==ᵗ list b = a ==ᵗ b 26 | _ ==ᵗ _ = false 27 | 28 | data Code : Set -> Set where 29 | instance code : ∀ a -> Code ⟦ a ⟧ 30 | 31 | _==ᵀ_ : ∀ A B {{_ : Code A}} {{_ : Code B}} -> Bool 32 | _==ᵀ_ _ _ {{code a}} {{code b}} = a ==ᵗ b 33 | 34 | test-bool : Bool ==ᵀ Bool ≡ true 35 | test-bool = refl 36 | 37 | test-list : List ℕ ==ᵀ List ℕ ≡ true 38 | test-list = refl 39 | 40 | test-unit-bool : ⊤ ==ᵀ Bool ≡ false 41 | test-unit-bool = refl 42 | -------------------------------------------------------------------------------- /matches.hs: -------------------------------------------------------------------------------- 1 | import Data.Either 2 | import Data.List 3 | import Data.Maybe 4 | import Data.Functor 5 | 6 | subst :: Char -> String -> Either Char String -> Either Char String 7 | subst p xs (Left q) | p == q = Right xs 8 | subst p xs q = q 9 | 10 | matches :: String -> String -> Bool 11 | matches = go . map Left where 12 | go [] [] = True 13 | go (Left p : ps) xs = or [ go (map (subst p ixs) ps) txs 14 | | (ixs, txs) <- tail $ zip (inits xs) (tails xs) ] 15 | go (Right s : ps) xs = fromMaybe False $ go ps <$> stripPrefix s xs 16 | go _ _ = False 17 | 18 | main = mapM_ (print . uncurry matches) 19 | [ ("abba" , "redbluebluered" ) -- True 20 | , ("abba" , "redblueblue" ) -- False 21 | , ("abb" , "redblueblue" ) -- True 22 | , ("aab" , "redblueblue" ) -- False 23 | , ("cbccadbd", "greenredgreengreenwhiteblueredblue") -- True 24 | ] 25 | -------------------------------------------------------------------------------- /Dumb/HMTS/Annotated.agda: -------------------------------------------------------------------------------- 1 | module HMTS.Annotated where 2 | 3 | open import Function 4 | open import Data.Nat 5 | open import Data.Fin 6 | open import Data.Product 7 | 8 | open import HMTS.Prelude 9 | open import HMTS.Syntax 10 | open import HMTS.Types 11 | open import HMTS.Substitutions 12 | 13 | data Annotated n : Set where 14 | varᵃ : Fin n -> Annotated n 15 | ƛᵃ : Type -> Annotated (suc n) -> Annotated n 16 | _·ᵃ_ : Annotated n -> Annotated n -> Annotated n 17 | 18 | Annotated⁽⁾ : Set 19 | Annotated⁽⁾ = Annotated 0 20 | 21 | annotateWith : ∀ {n} -> ℕ -> Subst -> Syntax n -> ℕ × Annotated n 22 | annotateWith new Ψ (varˢ i) = new , varᵃ i 23 | annotateWith new Ψ (ƛˢ bˢ) = 24 | case annotateWith (next (next new)) Ψ bˢ of λ{ (new' , b) -> 25 | new' , ƛᵃ (apply Ψ (Var new)) b 26 | } 27 | annotateWith new Ψ (fˢ · xˢ) = 28 | case annotateWith (next new) Ψ fˢ of λ{ (new' , f) -> 29 | case annotateWith new' Ψ xˢ of λ{ (new'' , x) -> 30 | new'' , f ·ᵃ x 31 | }} 32 | 33 | annotate : Subst -> Syntax⁽⁾ -> Annotated⁽⁾ 34 | annotate Ψ e = proj₂ (annotateWith 1 Ψ e) 35 | -------------------------------------------------------------------------------- /ThrowOnZero.agda: -------------------------------------------------------------------------------- 1 | open import Reflection 2 | open import Relation.Binary.PropositionalEquality 3 | open import Data.Empty 4 | open import Data.Unit.Base 5 | open import Data.Nat.Base 6 | open import Data.List.Base 7 | 8 | _`div-suc`_ : ℕ -> ℕ -> ℕ 9 | n `div-suc` m = go n m where 10 | go : ℕ -> ℕ -> ℕ 11 | go 0 m = 0 12 | go (suc n) 0 = suc (go n m) 13 | go (suc n) (suc m) = go n m 14 | 15 | throwOnZero : ℕ -> Term -> TC ⊤ 16 | throwOnZero zero _ = typeError (strErr "A divisor can't be zero" ∷ []) 17 | throwOnZero _ hole = bindTC (quoteTC tt) (unify hole) 18 | 19 | _≢0 : ℕ -> Set 20 | _≢0 0 = ⊥ 21 | _≢0 _ = ⊤ 22 | 23 | _`div`_ : ℕ -> ∀ m {@(tactic throwOnZero m) _ : m ≢0} -> ℕ 24 | _`div`_ n zero {()} 25 | _`div`_ n (suc m) = n `div-suc` m 26 | 27 | _ : map (λ n -> n `div` 3) (0 ∷ 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ 12 ∷ []) 28 | ≡ (0 ∷ 0 ∷ 0 ∷ 1 ∷ 1 ∷ 1 ∷ 2 ∷ 2 ∷ 2 ∷ 3 ∷ 3 ∷ 3 ∷ 4 ∷ []) 29 | _ = refl 30 | 31 | -- A divisor can't be zero 32 | -- when checking that 0 is a valid argument to a function of type 33 | -- (m : ℕ) {@(tactic throwOnZero m) _ : m ≢0} → ℕ 34 | _ : ∀ n -> n `div` 0 ≡ n `div` 0 35 | _ = λ n -> refl 36 | -------------------------------------------------------------------------------- /System-F/Sets.agda: -------------------------------------------------------------------------------- 1 | module System-F.Sets where 2 | 3 | open import Level as L 4 | open import Function 5 | open import Data.Unit.Base 6 | open import Data.Nat.Base 7 | open import Data.Fin 8 | open import Data.Product hiding (map) 9 | open import Data.Vec 10 | 11 | infixl 6 _^_ 12 | 13 | _^_ : ∀ {α} -> Set α -> ℕ -> Set α 14 | A ^ 0 = Lift ⊤ 15 | A ^ suc n = A × A ^ n 16 | 17 | to-^ : ∀ {n α} {A : Set α} -> Vec A n -> A ^ n 18 | to-^ = foldr (_^_ _) _,_ _ 19 | 20 | from-^ : ∀ {n α} {A : Set α} -> A ^ n -> Vec A n 21 | from-^ {0} _ = [] 22 | from-^ {suc _} (x , xs) = x ∷ from-^ xs 23 | 24 | on-^ : ∀ {α β n} {A : Set α} {B : Vec A n -> Set β} -> (∀ xs -> B xs) -> ∀ xs -> B (from-^ xs) 25 | on-^ f = f ∘ from-^ 26 | 27 | mono-^ : ∀ {α n m} {A : Set α} -> (Vec A n -> Vec A m) -> A ^ n -> A ^ m 28 | mono-^ f = to-^ ∘ on-^ f 29 | 30 | _⊔ⁿ_ : ∀ {n} -> Level ^ n -> Level -> Level 31 | _⊔ⁿ_ = on-^ $ flip $ foldr _ L._⊔_ 32 | 33 | Sets : ∀ {n} -> (αs : Level ^ n) -> Set (mono-^ (map L.suc) αs ⊔ⁿ L.zero) 34 | Sets {0} _ = ⊤ 35 | Sets {suc _} (α , αs) = Set α × Sets αs 36 | 37 | Lookup : ∀ {n} {αs : Level ^ n} i -> Sets αs -> Set (on-^ (lookup i) αs) 38 | Lookup zero (A , As) = A 39 | Lookup (suc i) (A , As) = Lookup i As 40 | -------------------------------------------------------------------------------- /Nary/Dependent.agda: -------------------------------------------------------------------------------- 1 | module Nary.Dependent where 2 | 3 | open import Level renaming (zero to lzero; suc to lsuc) 4 | open import Function 5 | open import Data.Unit.Base 6 | open import Data.Nat.Base hiding (_⊔_) 7 | open import Data.Product hiding (map) 8 | open import Data.Vec 9 | 10 | open import Nary.Power 11 | 12 | infixr 0 _->ⁿ_ _⋯>ⁿ_ 13 | 14 | Sets : ∀ {n} -> (αs : Level ^ n) -> ∀ β -> Set (mono-^ (map lsuc) αs ⊔ⁿ lsuc β) 15 | Sets {0} _ β = Set β 16 | Sets {suc _} (α , αs) β = Σ (Set α) λ X -> X -> Sets αs β 17 | 18 | Fold : ∀ {n} {αs : Level ^ n} {β} -> Sets αs β -> Set (αs ⊔ⁿ β) 19 | Fold {0} Y = Y 20 | Fold {suc _} (_ , F) = ∀ x -> Fold (F x) 21 | 22 | _->ⁿ_ : ∀ {n} {αs : Level ^ n} {β γ} 23 | -> Sets αs β -> Set γ -> Set (αs ⊔ⁿ β ⊔ γ) 24 | _->ⁿ_ {0} Y Z = Y -> Z 25 | _->ⁿ_ {suc _} (_ , F) Z = ∀ x -> F x ->ⁿ Z 26 | 27 | _⋯>ⁿ_ : ∀ {n} {αs : Level ^ n} {β γ} 28 | -> Sets αs β -> Set γ -> Set (αs ⊔ⁿ β ⊔ γ) 29 | _⋯>ⁿ_ {0} Y Z = Y -> Z 30 | _⋯>ⁿ_ {suc _} (_ , F) Z = ∀ {x} -> F x ⋯>ⁿ Z 31 | 32 | Πⁿ : ∀ {n} {αs : Level ^ n} {β γ} 33 | -> (Xs : Sets αs β) -> (Xs ⋯>ⁿ Set γ) -> Set (αs ⊔ⁿ β ⊔ γ) 34 | Πⁿ {0} Y Z = (y : Y) -> Z y 35 | Πⁿ {suc _} (_ , F) Z = ∀ {x} -> Πⁿ (F x) Z 36 | -------------------------------------------------------------------------------- /PathOver.agda: -------------------------------------------------------------------------------- 1 | infix 3 [_]_≅_ 2 | 3 | data [_]_≅_ {ι α} {I : Set ι} {i} (A : I -> Set α) (x : A i) : ∀ {j} -> A j -> Set where 4 | refl : [ A ] x ≅ x 5 | 6 | cong : ∀ {ι α β} {I : Set ι} {A : I -> Set α} {B : I -> Set β} {i j} {x : A i} {y : A j} 7 | -> (f : ∀ {i} -> A i -> B i) -> [ A ] x ≅ y -> [ B ] f x ≅ f y 8 | cong f refl = refl 9 | 10 | congᵏ : ∀ {ι α β} {I : Set ι} {A : I -> Set α} {B : I -> Set β} 11 | {k : I -> I} {i j} {x : A i} {y : A j} 12 | -> (f : ∀ {i} -> A i -> B (k i)) -> [ A ] x ≅ y -> [ B ] f x ≅ f y 13 | congᵏ f refl = refl 14 | 15 | subst : ∀ {ι α β} {I : Set ι} {A : I -> Set α} {i j} {x : A i} {y : A j} 16 | -> (B : ∀ {i} -> A i -> Set β) -> [ A ] x ≅ y -> B x -> B y 17 | subst B refl z = z 18 | 19 | open import Data.Nat.Base 20 | open import Data.Vec 21 | 22 | assoc : ∀ {α n m p} {A : Set α} {zs : Vec A p} 23 | -> (xs : Vec A n) -> (ys : Vec A m) -> [ Vec A ] (xs ++ ys) ++ zs ≅ xs ++ ys ++ zs 24 | assoc [] ys = refl 25 | assoc (x ∷ xs) ys = congᵏ (x ∷_) (assoc xs ys) 26 | 27 | example : ∀ {n} 28 | -> (C : ∀ {n} -> Vec ℕ n -> Set) 29 | -> (xs ys {zs} : Vec ℕ n) 30 | -> C ((xs ++ ys) ++ zs) 31 | -> C (xs ++ ys ++ zs) 32 | example C xs ys = subst C (assoc xs ys) 33 | -------------------------------------------------------------------------------- /Dumb/HMTS/Alpha.agda: -------------------------------------------------------------------------------- 1 | module HMTS.Alpha where 2 | 3 | open import Level 4 | open import Function 5 | open import Data.Product 6 | open import Data.List as List 7 | 8 | open import HMTS.Prelude 9 | open import HMTS.Types 10 | open import HMTS.Substitutions 11 | open import HMTS.Terms 12 | 13 | specialize-var : ∀ {Γ σ Ψ} -> σ ∈ Γ -> apply Ψ σ ∈ List.map (apply Ψ) Γ 14 | specialize-var vz = vz 15 | specialize-var (vs v) = vs (specialize-var v) 16 | 17 | specialize : ∀ {Γ σ Ψ} -> Γ ⊢ σ -> List.map (apply Ψ) Γ ⊢ apply Ψ σ 18 | specialize (var v) = var (specialize-var v) 19 | specialize (ƛ b) = ƛ (specialize b) 20 | specialize (f ∙ x) = specialize f ∙ specialize x 21 | 22 | Generalize : ∀ {γ α β} {A : Set α} {B : Set β} 23 | -> List A -> (List (A × B) -> Set (β ⊔ γ)) -> Set (β ⊔ γ) 24 | Generalize [] C = C [] 25 | Generalize {γ} (x ∷ xs) C = ∀ {y} -> Generalize {γ} xs (C ∘ _∷_ (x , y)) 26 | 27 | generalize : ∀ {Γ σ} {c : Subst -> Subst} is -> Γ ⊢ σ -> Generalize is λ Ψ 28 | -> let Φ = c Ψ in List.map (apply Φ) Γ ⊢ apply Φ σ 29 | generalize [] e = specialize e 30 | generalize (i ∷ is) e = generalize is e 31 | 32 | alpha : ∀ {Γ σ} -> Γ ⊢ σ -> Generalize (ftv σ) λ Ψ -> List.map (apply Ψ) Γ ⊢ apply Ψ σ 33 | alpha {σ = σ} = generalize (ftv σ) 34 | -------------------------------------------------------------------------------- /Kitchen/Kitchen.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Relation.Nullary.Decidable 3 | open import Data.Empty 4 | open import Data.Unit.Base 5 | open import Data.Bool.Base hiding (_≟_) 6 | open import Data.Nat.Base 7 | open import Data.List.Base 8 | 9 | record Sing {α} {A : Set α} (x : A) : Set where 10 | 11 | _==_ : ℕ -> ℕ -> Bool 12 | n == m = ⌊ n ≟ m ⌋ 13 | 14 | _∈?_ : ℕ -> List ℕ -> Set 15 | n ∈? ns = foldr (λ m r -> if n == m then ⊤ else r) ⊥ ns 16 | 17 | remove : ∀ n ns -> n ∈? ns -> List ℕ 18 | remove n [] () 19 | remove n (m ∷ ns) p with n == m 20 | ... | true = ns 21 | ... | false = m ∷ remove n ns p 22 | 23 | data Kitchen {α} (A : Set α) m is : List ℕ -> Set α where 24 | stop : Kitchen A m is is 25 | bake : ∀ {os} -> (Sing m -> Kitchen A (suc m) (m ∷ is) os) -> Kitchen A m is os 26 | eat : ∀ {i os} {p : i ∈? is} 27 | -> Sing i -> Kitchen A m (remove i is p) os -> Kitchen A m is os 28 | keep : ∀ {i os} {p : i ∈? is} 29 | -> Sing i -> Kitchen A m (remove i is p) os -> Kitchen A m is (i ∷ os) 30 | 31 | postulate Cake : Set 32 | 33 | ok : Kitchen Cake 0 [] (_ ∷ _ ∷ []) 34 | ok = bake λ brownie -> 35 | bake λ muffin -> 36 | bake λ cupcake -> 37 | keep muffin $ 38 | eat brownie $ 39 | keep cupcake $ 40 | stop 41 | -------------------------------------------------------------------------------- /Nested.hs: -------------------------------------------------------------------------------- 1 | -- A lightweight and not very expressive alternative to monad transformers. 2 | 3 | {-# LANGUAGE ConstraintKinds #-} 4 | 5 | import Data.Foldable as F 6 | import Data.Traversable as T 7 | import Control.Monad 8 | import Control.Applicative 9 | import Text.Read hiding (lift) 10 | 11 | type NestedMonads m t = (Monad m, Traversable t, Monad t) 12 | 13 | rereturn :: (Monad m, Monad n) => a -> m (n a) 14 | rereturn = return . return 15 | 16 | liliftM :: (Monad m, Monad n) => (a -> b) -> m (n a) -> m (n b) 17 | liliftM = liftM . liftM 18 | 19 | jojoin :: NestedMonads m t => m (t (m (t a))) -> m (t a) 20 | jojoin = (>>= liftM join . T.sequence) 21 | 22 | bibind :: NestedMonads m t => m (t a) -> (a -> m (t b)) -> m (t b) 23 | bibind x f = jojoin (liliftM f x) 24 | 25 | newtype Nested f g a = Nested { getNested :: f (g a) } 26 | 27 | instance NestedMonads m t => Monad (Nested m t) where 28 | return = Nested . rereturn 29 | x >>= f = Nested $ getNested x `bibind` (getNested . f) 30 | 31 | tfil :: Monad m => t a -> Nested m t a 32 | tfil = Nested . return 33 | 34 | lift :: (Monad m, Monad t) => m a -> Nested m t a 35 | lift = Nested . liftM return 36 | 37 | main :: IO (Maybe ()) 38 | main = getNested $ do 39 | x <- Nested $ readMaybe <$> getLine :: Nested IO Maybe Int 40 | lift $ print x 41 | -------------------------------------------------------------------------------- /TT/Prelude.agda: -------------------------------------------------------------------------------- 1 | module TT.Prelude where 2 | 3 | open import Function public 4 | open import Data.Empty public 5 | open import Data.Bool.Base public 6 | open import Data.Nat.Base hiding (erase; _≤_; module _≤_) public 7 | open import Data.Fin hiding (_+_; _<_; _≤_; fold; pred) public 8 | open import Relation.Binary.PropositionalEquality hiding ([_]) public 9 | open import Data.Maybe.Base public 10 | open import Data.Product renaming (map to pmap) public 11 | 12 | open import Level using (Lift) 13 | open import Data.Unit.Base 14 | import Data.Fin.Properties as FinProp 15 | import Data.Maybe as Maybe 16 | open import Category.Monad 17 | 18 | private open module Dummy {α} = RawMonad {α} Maybe.monad hiding (pure; zipWith) public 19 | 20 | From-Maybe : ∀ {α β} {A : Set α} -> (A -> Set β) -> Maybe A -> Set β 21 | From-Maybe B nothing = Lift ⊤ 22 | From-Maybe B (just x) = B x 23 | 24 | from-Maybe : ∀ {α β} {A : Set α} {B : A -> Set β} -> (∀ x -> B x) -> (x : Maybe A) -> From-Maybe B x 25 | from-Maybe f nothing = _ 26 | from-Maybe f (just x) = f x 27 | 28 | record MEq {α} (A : Set α) : Set α where 29 | infix 5 _≟_ 30 | field _≟_ : (x y : A) -> Maybe (x ≡ y) 31 | open MEq {{...}} public 32 | 33 | instance 34 | Fin-MEq : ∀ {n} -> MEq (Fin n) 35 | Fin-MEq = record { _≟_ = λ i j -> decToMaybe (i FinProp.≟ j) } 36 | -------------------------------------------------------------------------------- /arity.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Data.Bool 3 | open import Data.Nat 4 | open import Data.List 5 | open import Reflection 6 | 7 | toℕ : Bool -> ℕ 8 | toℕ true = 1 9 | toℕ false = 0 10 | 11 | isVisible : Visibility -> Bool 12 | isVisible visible = true 13 | isVisible _ = false 14 | 15 | isVisibleArg : ∀ {A} -> Arg A -> Bool 16 | isVisibleArg (arg (arg-info v _) _) = isVisible v 17 | 18 | arityType : Type -> ℕ 19 | arityType (el s (pi σ τ)) = toℕ (isVisibleArg σ) + arityType τ 20 | arityType _ = 0 21 | 22 | arityName : Name -> ℕ 23 | arityName = arityType ∘ type 24 | 25 | arityTerm : Term -> ℕ 26 | arityTerm (con c as) = arityName c ∸ length (filter isVisibleArg as) 27 | arityTerm (def f as) = arityName f ∸ length (filter isVisibleArg as) 28 | arityTerm (lam v t) = toℕ (isVisible v) + arityTerm t 29 | arityTerm (pat-lam cs as) = something where postulate something : _ 30 | arityTerm _ = 0 31 | 32 | open import Relation.Binary.PropositionalEquality 33 | 34 | test-1 : arityTerm (quoteTerm suc) ≡ 1 35 | test-1 = refl 36 | 37 | test-1' : arityName (quote suc) ≡ 1 38 | test-1' = refl 39 | 40 | test-2 : arityTerm (quoteTerm (zipWith _+_)) ≡ 2 41 | test-2 = refl 42 | 43 | test-3 : arityTerm (quoteTerm (λ {α} A -> _∷_ {α} {A})) ≡ 3 44 | test-3 = refl 45 | -------------------------------------------------------------------------------- /System-F/TypeEval.agda: -------------------------------------------------------------------------------- 1 | module System-F.TypeEval where 2 | 3 | open import System-F.Prelude 4 | open import System-F.Sets 5 | open import System-F.Kits 6 | open import System-F.Core 7 | 8 | Levels : ∀ {Θ σ} -> Θ ⊢ᵗ σ -> Set 9 | Levels (Var v) = ⊤ 10 | Levels (f ·ᵗ α) = ⊥ 11 | Levels (α ⇒ β) = Levels α × Levels β 12 | Levels (π σ β) = Level × Levels β 13 | Levels list = ⊥ 14 | 15 | ⟦_⟧ᵗˡ : ∀ {Θ} -> (α : Type Θ) -> Levels α -> Level ^ lengthᶜ Θ -> Level 16 | ⟦ Var v ⟧ᵗˡ _ bs = on-^ (lookup (∈-to-Fin v)) bs 17 | ⟦ f ·ᵗ α ⟧ᵗˡ () 18 | ⟦ α ⇒ β ⟧ᵗˡ (fs₁ , fs₂) bs = ⟦ α ⟧ᵗˡ fs₁ bs ⊔ ⟦ β ⟧ᵗˡ fs₂ bs 19 | ⟦ π σ β ⟧ᵗˡ (f , fs) bs = sucₗ f ⊔ ⟦ β ⟧ᵗˡ fs (f , bs) 20 | 21 | ⟦_⟧ᵗ : ∀ {Θ} {bs : Level ^ lengthᶜ Θ} 22 | -> (α : Type Θ) -> (fs : Levels α) -> Sets bs -> Set (⟦ α ⟧ᵗˡ fs bs) 23 | ⟦ Var v ⟧ᵗ _ As = Lookup (∈-to-Fin v) As 24 | ⟦ f ·ᵗ α ⟧ᵗ () 25 | ⟦ α ⇒ β ⟧ᵗ (fs₁ , fs₂) As = ⟦ α ⟧ᵗ fs₁ As -> ⟦ β ⟧ᵗ fs₂ As 26 | ⟦ π σ β ⟧ᵗ (f , fs) As = {A : Set f} -> ⟦ β ⟧ᵗ fs (A , As) 27 | 28 | evalᵗ : (α : Type ε) {fs : Levels α} -> Set (⟦ α ⟧ᵗˡ fs _) 29 | evalᵗ α {fs} = ⟦ α ⟧ᵗ fs _ 30 | 31 | 32 | 33 | ex : Type⁺ 34 | ex = π ⋆ $ π ⋆ $ Var (vs vz) ⇒ π ⋆ (Var (vs vs vz) ⇒ Var vz) ⇒ Var vz 35 | 36 | test : ∀ {α β γ} -> evalᵗ ex ≡ ({A : Set α} {B : Set β} -> A -> ({C : Set γ} -> A -> C) -> B) 37 | test = refl 38 | -------------------------------------------------------------------------------- /CSTLC.agda: -------------------------------------------------------------------------------- 1 | -- A categorical view of STLC. 2 | 3 | open import Data.Unit.Base 4 | open import Data.Product 5 | 6 | infixr 6 _⇒_ 7 | infixr 7 _&_ 8 | infix 4 _⊢_ 9 | 10 | data Type : Set where 11 | ⋆ : Type 12 | _⇒_ : Type -> Type -> Type 13 | _&_ : Type -> Type -> Type 14 | 15 | data _⊢_ : Type -> Type -> Set where 16 | ƛ_ : ∀ {Γ σ τ} -> Γ & σ ⊢ τ -> Γ ⊢ σ ⇒ τ 17 | _·_ : ∀ {Γ σ τ} -> Γ ⊢ σ ⇒ τ -> Γ ⊢ σ -> Γ ⊢ τ 18 | unit : ∀ {Γ} -> Γ ⊢ ⋆ 19 | pair : ∀ {Γ σ τ} -> Γ ⊢ σ -> Γ ⊢ τ -> Γ ⊢ σ & τ 20 | fst : ∀ {Γ σ τ} -> Γ ⊢ σ & τ -> Γ ⊢ σ 21 | snd : ∀ {Γ σ τ} -> Γ ⊢ σ & τ -> Γ ⊢ τ 22 | vz : ∀ {Γ σ} -> Γ & σ ⊢ σ 23 | ↑ : ∀ {Γ σ} -> Γ & σ ⊢ Γ 24 | _[_] : ∀ {Δ Γ σ} -> Γ ⊢ σ -> Δ ⊢ Γ -> Δ ⊢ σ 25 | 26 | ⟦_⟧ : Type -> Set 27 | ⟦ ⋆ ⟧ = ⊤ 28 | ⟦ σ ⇒ τ ⟧ = ⟦ σ ⟧ -> ⟦ τ ⟧ 29 | ⟦ Γ & σ ⟧ = ⟦ Γ ⟧ × ⟦ σ ⟧ 30 | 31 | ⟦_/_⟧ : ∀ {Γ σ} -> ⟦ Γ ⟧ -> Γ ⊢ σ -> ⟦ σ ⟧ 32 | ⟦ ρ / ƛ b ⟧ = λ x -> ⟦ ρ , x / b ⟧ 33 | ⟦ ρ / f · x ⟧ = ⟦ ρ / f ⟧ ⟦ ρ / x ⟧ 34 | ⟦ ρ / unit ⟧ = tt 35 | ⟦ ρ / pair t s ⟧ = ⟦ ρ / t ⟧ , ⟦ ρ / s ⟧ 36 | ⟦ ρ / fst p ⟧ = proj₁ ⟦ ρ / p ⟧ 37 | ⟦ ρ / snd p ⟧ = proj₂ ⟦ ρ / p ⟧ 38 | ⟦ ρ , x / vz ⟧ = x 39 | ⟦ ρ , x / ↑ ⟧ = ρ 40 | ⟦ ρ / t [ ψ ] ⟧ = ⟦ ⟦ ρ / ψ ⟧ / t ⟧ 41 | 42 | eval : ∀ {σ} -> ⋆ ⊢ σ -> ⟦ σ ⟧ 43 | eval t = ⟦ tt / t ⟧ 44 | -------------------------------------------------------------------------------- /TypedJigger.agda: -------------------------------------------------------------------------------- 1 | infixr 5 _⇒_ 2 | infixl 6 _▻_ 3 | infix 3 _⊢_ _∈_ _⊑_ 4 | infixr 5 vs_ 5 | infixr 4 ƛ_ 6 | infixl 6 _·_ 7 | 8 | data Type : Set where 9 | ⋆ : Type 10 | _⇒_ : Type -> Type -> Type 11 | 12 | data Con : Set where 13 | ε : Con 14 | _▻_ : Con -> Type -> Con 15 | 16 | data _∈_ σ : Con -> Set where 17 | vz : ∀ {Γ} -> σ ∈ Γ ▻ σ 18 | vs_ : ∀ {Γ τ} -> σ ∈ Γ -> σ ∈ Γ ▻ τ 19 | 20 | data _⊢_ Γ : Type -> Set where 21 | var : ∀ {σ} -> σ ∈ Γ -> Γ ⊢ σ 22 | ƛ_ : ∀ {σ τ} -> Γ ▻ σ ⊢ τ -> Γ ⊢ σ ⇒ τ 23 | _·_ : ∀ {σ τ} -> Γ ⊢ σ ⇒ τ -> Γ ⊢ σ -> Γ ⊢ τ 24 | 25 | Term : Type -> Set 26 | Term σ = ε ⊢ σ 27 | 28 | data _⊑_ Γ : Con -> Set where 29 | instance 30 | stop : Γ ⊑ Γ 31 | skip : ∀ {Δ σ} -> Γ ⊑ Δ -> Γ ⊑ Δ ▻ σ 32 | 33 | fit : ∀ {Δ Γ σ} -> Γ ▻ σ ⊑ Δ -> σ ∈ Δ 34 | fit stop = vz 35 | fit (skip emb) = vs (fit emb) 36 | 37 | lam : ∀ {Γ σ τ} -> ((∀ {Δ} {{_ : Γ ▻ σ ⊑ Δ}} -> Δ ⊢ σ) -> Γ ▻ σ ⊢ τ) -> Γ ⊢ σ ⇒ τ 38 | lam k = ƛ k λ {{emb}} -> var (fit emb) 39 | 40 | 41 | 42 | I : Term (⋆ ⇒ ⋆) 43 | I = lam λ x -> x 44 | 45 | K : Term (⋆ ⇒ ⋆ ⇒ ⋆) 46 | K = lam λ x -> lam λ y -> x 47 | 48 | A : Term ((⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆) 49 | A = lam λ f -> lam λ x -> f · x 50 | 51 | O : Term (((⋆ ⇒ ⋆) ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆) 52 | O = lam λ g -> lam λ f -> f · (g · f) 53 | 54 | O-η : Term (((⋆ ⇒ ⋆) ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆) 55 | O-η = lam λ g -> lam λ f -> f · (g · lam λ x -> f · x) 56 | -------------------------------------------------------------------------------- /RecN-challenge.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} -- Just for convenience, not essential. 2 | 3 | open import Function 4 | open import Relation.Binary.PropositionalEquality 5 | open import Data.Nat.Base 6 | 7 | coerce : ∀ {A B} -> A ≡ B -> A -> B 8 | coerce refl = id 9 | 10 | record KitRecN : Set where 11 | field 12 | RecN : ℕ -> Set 13 | recN : ∀ n -> RecN n 14 | 15 | Rec0-correct 16 | : RecN 0 17 | ≡ ∀ {R} -> (∀ {Q} -> Q -> Q) -> R -> R 18 | Rec1-correct 19 | : RecN 1 20 | ≡ ∀ {A R} -> (∀ {Q} -> (A -> Q) -> Q) -> (A -> R) -> R 21 | Rec2-correct 22 | : RecN 2 23 | ≡ ∀ {A B R} -> (∀ {Q} -> (A -> B -> Q) -> Q) -> (A -> B -> R) -> R 24 | Rec3-correct 25 | : RecN 3 26 | ≡ ∀ {A B C R} -> (∀ {Q} -> (A -> B -> C -> Q) -> Q) -> (A -> B -> C -> R) -> R 27 | 28 | rec0-correct 29 | : (λ {R} -> coerce Rec0-correct (recN 0) {R}) 30 | ≡ λ k f -> f 31 | rec1-correct 32 | : (λ {A R} -> coerce Rec1-correct (recN 1) {A} {R}) 33 | ≡ λ k f -> f (k λ x -> x) 34 | rec2-correct 35 | : (λ {A B R} -> coerce Rec2-correct (recN 2) {A} {B} {R}) 36 | ≡ λ k f -> f (k λ x y -> x) (k λ x y -> y) 37 | rec3-correct 38 | : (λ {A B C R} -> coerce Rec3-correct (recN 3) {A} {B} {C} {R}) 39 | ≡ λ k f -> f (k λ x y z -> x) (k λ x y z -> y) (k λ x y z -> z) 40 | 41 | postulate 42 | kitRecN : KitRecN 43 | -------------------------------------------------------------------------------- /applicative-parser.hs: -------------------------------------------------------------------------------- 1 | import Data.Maybe 2 | import Data.List 3 | import Control.Applicative 4 | import Control.Monad 5 | import Control.Arrow 6 | import Control.Monad.Trans.State 7 | 8 | lookupDelete k [] = Nothing 9 | lookupDelete k ((x, y):xys) 10 | | k == x = Just (y, xys) 11 | | otherwise = second ((x, y):) <$> lookupDelete k xys 12 | 13 | finish (x, []) = Just x 14 | finish _ = Nothing 15 | 16 | type Parser a = StateT [(String, String)] Maybe a 17 | 18 | option :: (String -> Maybe a) -> String -> Parser a 19 | option f str = StateT $ \xs -> do 20 | (v, xs') <- lookupDelete str xs 21 | v' <- f v 22 | return (v', xs') 23 | 24 | string :: String -> Parser String 25 | string = option Just 26 | 27 | value :: Read a => String -> Parser a 28 | value = option $ reads >>> listToMaybe >=> finish 29 | 30 | optPairs [] = Just [] 31 | optPairs (('-':'-':x1):x2:xs) = ((x1, x2) :) <$> optPairs xs 32 | optPairs _ = Nothing 33 | 34 | parse :: Parser a -> String -> Maybe a 35 | parse p = words >>> optPairs >=> runStateT p >=> finish 36 | 37 | -- An example. 38 | 39 | data User = User 40 | { userName :: String 41 | , userId :: Integer 42 | , userDbls :: (Double, Double) 43 | } deriving Show 44 | 45 | userParser :: Parser User 46 | userParser = User <$> string "name" <*> value "id" <*> value "dbls" 47 | 48 | main = interact $ unlines . map (show . parse userParser) . lines 49 | -------------------------------------------------------------------------------- /MonoEff/Effect/State.agda: -------------------------------------------------------------------------------- 1 | module Effect.State where 2 | 3 | open import Prelude 4 | open import Core 5 | 6 | data State {α} (A : Set α) : Effectful α α α where 7 | Get : State A A (const A) 8 | Put : A -> State A ⊤ (const A) 9 | 10 | get : ∀ {n α} {Ψs : Effects α α α n} {Rs : Resources α n} 11 | {A : Set α} {{p : State , A ∈ Ψs , Rs}} 12 | -> Eff Ψs A Rs _ 13 | get = invoke Get 14 | 15 | put : ∀ {n α} {Ψs : Effects α α α n} {Rs : Resources α n} 16 | {A : Set α} {{p : State , A ∈ Ψs , Rs}} 17 | -> A -> Eff Ψs ⊤ Rs _ 18 | put {{p}} = invoke {{p}} ∘ Put 19 | 20 | execState : ∀ {n α β} {Ψs : Effects α α α n} {B : Set β} 21 | {Rs : Resources α (suc n)} {Rs′ : B -> Resources α (suc n)} 22 | -> head Rs 23 | -> Eff (State ∷ Ψs) B Rs Rs′ 24 | -> Eff Ψs (Σ B (head ∘ Rs′)) (tail Rs) (tail ∘ Rs′ ∘ proj₁) 25 | execState s (return y) = return (y , s) 26 | execState {Rs = _ ∷ _} s (call zero Get f) = execState s (f s) 27 | execState {Rs = _ ∷ _} _ (call zero (Put s) f) = execState s (f tt) 28 | execState {Rs = _ ∷ _} s (call (suc i) a f) = call i a λ x -> execState s (f x) 29 | 30 | open import Data.Bool.Base 31 | 32 | eff : Eff (State ∷ State ∷ []) ℕ (ℕ ∷ ⊤ ∷ []) (λ _ -> ℕ ∷ ⊤ ∷ []) 33 | eff = get >>= λ n -> put n >> return (suc n) 34 | 35 | -- 4 , 3 36 | test : ℕ × ℕ 37 | test = proj₁ $ runEff $ execState tt $ execState 3 eff 38 | -------------------------------------------------------------------------------- /bfs.hs: -------------------------------------------------------------------------------- 1 | data Tree a = Leaf a | Node a (Tree a) (Tree a) 2 | 3 | data Shift a = None | Some a | Shift (Shift a) 4 | newtype Crescendo a = Crescendo (Shift (a, Crescendo a)) 5 | 6 | shift :: Crescendo a -> Crescendo a 7 | shift (Crescendo c) = Crescendo (Shift c) 8 | 9 | fromCrescendo :: Crescendo a -> [a] 10 | fromCrescendo (Crescendo s) = fromShift s 11 | 12 | fromShift :: Shift (a, Crescendo a) -> [a] 13 | fromShift None = [] 14 | fromShift (Some (x, c)) = x : fromCrescendo c 15 | fromShift (Shift s) = fromShift s 16 | 17 | mergeCrescendo :: Crescendo a -> Crescendo a -> Crescendo a 18 | mergeCrescendo (Crescendo s1) (Crescendo s2) = Crescendo (mergeShift s1 s2) 19 | 20 | mergeShift :: Shift (a, Crescendo a) -> Shift (a, Crescendo a) -> Shift (a, Crescendo a) 21 | mergeShift None s2 = s2 22 | mergeShift s1 None = s1 23 | mergeShift (Some (x, c1)) s2 = Some (x, mergeCrescendo c1 (Crescendo s2)) 24 | mergeShift s1 (Some (x, c2)) = Some (x, mergeCrescendo (Crescendo s1) c2) 25 | mergeShift (Shift s1) (Shift s2) = Shift (mergeShift s1 s2) 26 | 27 | ifSome :: (a -> Bool) -> a -> Crescendo a -> Crescendo a 28 | ifSome p x c 29 | | p x = Crescendo (Some (x, c)) 30 | | otherwise = c 31 | 32 | cbfs :: (a -> Bool) -> Tree a -> Crescendo a 33 | cbfs p (Leaf x) = ifSome p x (Crescendo None) 34 | cbfs p (Node x l r) = ifSome p x (shift (mergeCrescendo (cbfs p l) (cbfs p r))) 35 | 36 | bfs :: (a -> Bool) -> Tree a -> [a] 37 | bfs p t = fromCrescendo (cbfs p t) 38 | -------------------------------------------------------------------------------- /Normalization/PHOAS.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | 3 | record Tag {α β} {A : Set α} (B : (x : A) -> Set β) (x : A) : Set β where 4 | constructor tag 5 | field detag : B x 6 | open Tag 7 | 8 | tagWith : ∀ {α β} {A : Set α} {B : (x : A) -> Set β} -> (x : A) -> B x -> Tag B x 9 | tagWith _ = tag 10 | 11 | infixr 5 _⇒_ 12 | 13 | data Type : Set where 14 | ⋆ : Type 15 | _⇒_ : Type -> Type -> Type 16 | 17 | data PTerm (V : Type -> Set) : Type -> Set where 18 | val : ∀ {σ} -> Tag V σ -> PTerm V σ 19 | lam : ∀ {σ τ} -> (Tag V σ -> PTerm V τ) -> PTerm V (σ ⇒ τ) 20 | app : ∀ {σ τ} -> PTerm V (σ ⇒ τ) -> PTerm V σ -> PTerm V τ 21 | 22 | ⟦_/_⟧ : (Type -> Set) -> Type -> Set 23 | ⟦ V / ⋆ ⟧ = V ⋆ 24 | ⟦ V / σ ⇒ τ ⟧ = ⟦ V / σ ⟧ -> ⟦ V / τ ⟧ 25 | 26 | mutual 27 | ↑ : ∀ {σ V} -> PTerm V σ -> ⟦ PTerm V / σ ⟧ 28 | ↑ {⋆} t = t 29 | ↑ {σ ⇒ τ} f = ↑ ∘ app f ∘ ↓ 30 | 31 | ↓ : ∀ {σ V} -> ⟦ PTerm V / σ ⟧ -> PTerm V σ 32 | ↓ {⋆} t = t 33 | ↓ {σ ⇒ τ} f = lam (↓ ∘ f ∘ ↑ ∘ val) 34 | 35 | Term : Type -> Set₁ 36 | Term σ = ∀ {V} -> PTerm V σ 37 | 38 | 39 | 40 | I : Term (⋆ ⇒ ⋆) 41 | I = ↓ id 42 | 43 | K : Term (⋆ ⇒ ⋆ ⇒ ⋆) 44 | K = ↓ const 45 | 46 | S : Term ((⋆ ⇒ ⋆ ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆) 47 | S = ↓ _ˢ_ 48 | 49 | B : Term ((⋆ ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆) 50 | B = ↓ _∘′_ 51 | 52 | C : Term ((⋆ ⇒ ⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆ ⇒ ⋆) 53 | C = ↓ flip 54 | 55 | W : Term ((⋆ ⇒ ⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆) 56 | W = ↓ λ f x -> f x x 57 | 58 | P : Term ((⋆ ⇒ ⋆ ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆ ⇒ ⋆) 59 | P = ↓ _on_ 60 | 61 | O : Term (((⋆ ⇒ ⋆) ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆) 62 | O = ↓ λ g f -> f (g f) 63 | -------------------------------------------------------------------------------- /normal-forms.agda: -------------------------------------------------------------------------------- 1 | -- This is related to http://stackoverflow.com/questions/26615082/how-does-one-prove-a-type-of-the-form-a-b-in-agda 2 | 3 | open import Function 4 | open import Relation.Binary.PropositionalEquality 5 | 6 | data Int : Set where 7 | Z : Int 8 | S : Int -> Int 9 | P : Int -> Int 10 | 11 | normalize : Int -> Int 12 | normalize Z = Z 13 | normalize (S n) with normalize n 14 | ... | P m = m 15 | ... | m = S m 16 | normalize (P n) with normalize n 17 | ... | S m = m 18 | ... | m = P m 19 | 20 | data NormalForm : Int -> Set where 21 | NZ : NormalForm Z 22 | NSZ : NormalForm (S Z) 23 | NPZ : NormalForm (P Z) 24 | NSS : ∀ {n} -> NormalForm (S n) -> NormalForm (S (S n)) 25 | NPP : ∀ {n} -> NormalForm (P n) -> NormalForm (P (P n)) 26 | 27 | normalForm : ∀ n -> NormalForm (normalize n) 28 | normalForm Z = NZ 29 | normalForm (S n) with normalize n | normalForm n 30 | ... | Z | nf = NSZ 31 | ... | S _ | nf = NSS nf 32 | ... | P ._ | NPZ = NZ 33 | ... | P ._ | NPP nf = nf 34 | normalForm (P n) with normalize n | normalForm n 35 | ... | Z | nf = NPZ 36 | ... | S ._ | NSZ = NZ 37 | ... | S ._ | NSS nf = nf 38 | ... | P _ | nf = NPP nf 39 | 40 | idempotent' : ∀ {n} -> NormalForm n -> normalize n ≡ n 41 | idempotent' NZ = refl 42 | idempotent' NSZ = refl 43 | idempotent' NPZ = refl 44 | idempotent' (NSS p) rewrite idempotent' p = refl 45 | idempotent' (NPP p) rewrite idempotent' p = refl 46 | 47 | idempotent : ∀ n -> normalize (normalize n) ≡ normalize n 48 | idempotent = idempotent' ∘ normalForm -------------------------------------------------------------------------------- /Dumb/HMTS/Tests.agda: -------------------------------------------------------------------------------- 1 | module HMTS.Tests where 2 | 3 | open import Data.Unit 4 | 5 | open import HMTS.Main 6 | 7 | -- You can omit type signatures. 8 | 9 | I : Pure 10 | I = pure (1 # λ x → x) 11 | 12 | Iᵀ : Term (a ⇒ a) 13 | Iᵀ = term I 14 | 15 | Iᵀ' : Term (a ⇒ a) 16 | Iᵀ' = term (I · I) 17 | 18 | ω : Pure 19 | ω = pure (1 # λ x → x · x) 20 | 21 | Ωᵀ : ⊤ 22 | Ωᵀ = term (ω · ω) 23 | 24 | applicator : Term ((a ⇒ b) ⇒ a ⇒ b) 25 | applicator = term (2 # λ a b → a · b) 26 | 27 | applicator' : Term ((b ⇒ a) ⇒ b ⇒ a) 28 | applicator' = term (2 # λ a b → a · b) 29 | 30 | applicator-speсialized : Term ((a ⇒ a) ⇒ a ⇒ a) 31 | applicator-speсialized = term (2 # λ a b → a · b) 32 | 33 | applicator-generic : ∀ {a b} -> Term ((a ⇒ b) ⇒ a ⇒ b) 34 | applicator-generic = term (2 # λ a b → a · b) 35 | 36 | applicator-generic-specialized : ∀ {a} -> Term ((a ⇒ a) ⇒ a ⇒ a) 37 | applicator-generic-specialized = applicator-generic 38 | 39 | cardinal : Term ((a ⇒ b ⇒ c) ⇒ b ⇒ a ⇒ c) 40 | cardinal = term (3 # λ a b c -> a · c · b) 41 | 42 | owl : Term (((a ⇒ b) ⇒ a) ⇒ (a ⇒ b) ⇒ b) 43 | owl = term (2 # λ a b → b · (a · b)) 44 | 45 | quacky : Term (a ⇒ (a ⇒ b) ⇒ (b ⇒ c) ⇒ c) 46 | quacky = term (3 # λ a b c → c · (b · a)) 47 | 48 | psi : Term ((b ⇒ b ⇒ c) ⇒ (a ⇒ b) ⇒ a ⇒ a ⇒ c) 49 | psi = term (4 # λ a b c d → a · (b · c) · (b · d)) 50 | 51 | phoenix : Term ((b ⇒ c ⇒ d) ⇒ (a ⇒ b) ⇒ (a ⇒ c) ⇒ a ⇒ d) 52 | phoenix = term (4 # λ a b c d → a · (b · d) · (c · d)) 53 | 54 | eaglebald : Term ((e ⇒ f ⇒ g) ⇒ (a ⇒ b ⇒ e) ⇒ a ⇒ b ⇒ (c ⇒ d ⇒ f) ⇒ c ⇒ d ⇒ g) 55 | eaglebald = term (7 # λ a b c d e f g → a · (b · c · d) · (e · f · g)) 56 | -------------------------------------------------------------------------------- /Dumb/HMTS/Terms.agda: -------------------------------------------------------------------------------- 1 | module HMTS.Terms where 2 | 3 | open import Function 4 | open import Relation.Binary.PropositionalEquality 5 | open import Data.Maybe 6 | open import Data.List 7 | open import Data.Vec as Vec hiding (_>>=_; _⊛_; _∈_; module _∈_) 8 | 9 | open import HMTS.Prelude 10 | open import HMTS.Types 11 | open import HMTS.Annotated 12 | 13 | infix 1 _⊢_ 14 | 15 | _▻_ : ∀ {α} {A : Set α} -> List A -> A -> List A 16 | _▻_ = flip _∷_ 17 | 18 | data _⊢_ (Γ : List Type) : Type -> Set where 19 | var : ∀ {σ} -> σ ∈ Γ -> Γ ⊢ σ 20 | ƛ_ : ∀ {σ τ} -> Γ ▻ σ ⊢ τ -> Γ ⊢ σ ⇒ τ 21 | _∙_ : ∀ {σ τ} -> Γ ⊢ σ ⇒ τ -> Γ ⊢ σ -> Γ ⊢ τ 22 | 23 | Term : Type -> Set 24 | Term σ = [] ⊢ σ 25 | 26 | cod : Type -> Type 27 | cod (σ ⇒ τ) = τ 28 | cod σ = σ 29 | 30 | typeOfInᵃ : ∀ {n} -> Con n -> Annotated n -> Type 31 | typeOfInᵃ Γ (varᵃ i) = Vec.lookup i Γ 32 | typeOfInᵃ Γ (ƛᵃ σ b) = σ ⇒ typeOfInᵃ (σ ∷ Γ) b 33 | typeOfInᵃ Γ (f ·ᵃ x) = cod (typeOfInᵃ Γ f) 34 | 35 | coerce : ∀ {Γ σ τ} -> Γ ⊢ σ -> Maybe (Γ ⊢ τ) 36 | coerce {Γ} {σ} {τ} e = (λ p -> subst (_⊢_ Γ) p e) <$> (σ ≟ᵀ τ) 37 | 38 | typifyInᵃ : ∀ {n} -> (Γ : Vec Type n) -> (e : Annotated n) -> Maybe (toList Γ ⊢ typeOfInᵃ Γ e) 39 | typifyInᵃ Γ (varᵃ i) = just (var (lookup-in i Γ)) 40 | typifyInᵃ Γ (ƛᵃ σ bᵃ) = ƛ_ <$> typifyInᵃ (σ ∷ Γ) bᵃ 41 | typifyInᵃ Γ (fᵃ ·ᵃ xᵃ) with typeOfInᵃ Γ fᵃ | typifyInᵃ Γ fᵃ | typifyInᵃ Γ xᵃ 42 | ... | σ ⇒ τ | f | x = _∙_ <$> f ⊛ (x >>= coerce) 43 | ... | _ | _ | _ = nothing 44 | 45 | typeOfᵃ : Annotated⁽⁾ -> Type 46 | typeOfᵃ = typeOfInᵃ [] 47 | 48 | typifyᵃ : ∀ e -> Maybe (Term (typeOfᵃ e)) 49 | typifyᵃ = typifyInᵃ [] 50 | -------------------------------------------------------------------------------- /Dumb/HMTS/Bind.agda: -------------------------------------------------------------------------------- 1 | module HMTS.Bind where 2 | 3 | -- This is a generalization of Conor McBride's cool trick: 4 | -- https://personal.cis.strath.ac.uk/conor.mcbride/fooling/Jigger.agda 5 | 6 | open import Function 7 | open import Data.Nat 8 | open import Data.Fin hiding (_+_; #_) 9 | 10 | open import HMTS.Syntax 11 | 12 | shift : ∀ {m} n -> Fin (suc (n + m)) 13 | shift 0 = fromℕ _ 14 | shift (suc n) = inject₁ (shift n) 15 | 16 | Bound : ℕ -> Set 17 | Bound n = ∀ {m} -> Syntax (suc (n + m)) 18 | 19 | Bindᶜ : (ℕ -> ℕ) -> ℕ -> Set 20 | Bindᶜ k 0 = Syntax (k 0) 21 | Bindᶜ k (suc n) = Bound (k 0) -> Bindᶜ (k ∘ suc) n 22 | 23 | bindᶜ : ∀ k n -> Bindᶜ k n -> Syntax (k n) 24 | bindᶜ k 0 b = b 25 | bindᶜ k (suc n) b = bindᶜ (k ∘ suc) n (b (varˢ (shift (k 0)))) 26 | 27 | ƛⁿ : ∀ {m} n -> Syntax (n + m) -> Syntax m 28 | ƛⁿ 0 e = e 29 | ƛⁿ (suc n) e = ƛⁿ n (ƛˢ e) 30 | 31 | _#_ : ∀ {n} m -> Bindᶜ (flip _+_ n) m -> Syntax n 32 | _#_ {n} m b = ƛⁿ m (bindᶜ (flip _+_ n) m b) 33 | 34 | example : Syntax 0 35 | example = 3 # λ h f x → (1 # λ t → t · h) · (f · x) 36 | 37 | -- I tried to use instance arguments, but Agda infers wrong types. 38 | 39 | -- bind¹ : ∀ {n} -> (Bound n -> Syntax (suc n)) -> Syntax n 40 | -- bind¹ {n} b = ƛˢ (b (varˢ (shift n))) 41 | 42 | -- record Bind (B : Set) n : Set where 43 | -- field bind : B -> Syntax n 44 | -- open Bind {{...}} 45 | 46 | -- instance 47 | -- stop : ∀ {n} -> Bind (Syntax n) n 48 | -- stop = record { bind = id } 49 | 50 | -- keep : ∀ {n} {R : Set} {{_ : Bind R (suc n)}} -> Bind (Bound n -> R) n 51 | -- keep = record { bind = λ r -> bind¹ (bind ∘ r) } 52 | -------------------------------------------------------------------------------- /MonoEff/Prelude.agda: -------------------------------------------------------------------------------- 1 | module Prelude where 2 | 3 | open import Level renaming (zero to lzero; suc to lsuc) public 4 | open import Function public 5 | open import Relation.Binary.PropositionalEquality hiding ([_]) public 6 | open import Data.Nat.Base hiding (_⊔_) public 7 | open import Data.Fin using (Fin; zero; suc) public 8 | open import Data.Sum renaming (map to smap) public 9 | open import Data.Product renaming (map to pmap) hiding (,_) public 10 | open import Data.Vec renaming (map to vmap) hiding (_∈_; _>>=_; zip) public 11 | 12 | infix 4 ,_ 13 | 14 | pattern ,_ y = _ , y 15 | 16 | data ⊥ {α} : Set α where 17 | record ⊤ {α} : Set α where 18 | constructor tt 19 | 20 | first : ∀ {α β γ} {A : Set α} {B : Set β} {C : A -> Set γ} 21 | -> (∀ x -> C x) -> (p : A × B) -> C (proj₁ p) × B 22 | first f (x , y) = f x , y 23 | 24 | second : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : A -> Set γ} 25 | -> (∀ {x} -> B x -> C x) -> Σ A B -> Σ A C 26 | second g (x , y) = x , g y 27 | 28 | third : ∀ {α β γ δ} {A : Set α} {B : A -> Set β} 29 | {C : ∀ {x} -> B x -> Set γ} {D : ∀ {x} -> B x -> Set δ} 30 | -> (∀ {x} {y : B x} -> C y -> D y) -> (∃ λ x -> Σ (B x) C) -> ∃ λ x -> Σ (B x) D 31 | third h (x , y , z) = x , y , h z 32 | 33 | instance 34 | inst-refl : ∀ {α} {A : Set α} {x : A} -> x ≡ x 35 | inst-refl = refl 36 | 37 | inst-comma : ∀ {α β} {A : Set α} {B : A -> Set β} {{x : A}} {{y : B x}} -> Σ A B 38 | inst-comma {{x}} {{y}} = x , y 39 | 40 | inst-inj₁ : ∀ {α β} {A : Set α} {B : Set β} {{x : A}} -> A ⊎ B 41 | inst-inj₁ {{x}} = inj₁ x 42 | 43 | inst-inj₂ : ∀ {α β} {A : Set α} {B : Set β} {{y : B}} -> A ⊎ B 44 | inst-inj₂ {{y}} = inj₂ y 45 | -------------------------------------------------------------------------------- /Dumb/HMTS/AlgorithmM.agda: -------------------------------------------------------------------------------- 1 | module HMTS.AlgorithmM where 2 | 3 | open import Function 4 | open import Relation.Nullary 5 | open import Data.Nat as Nat 6 | open import Data.Maybe 7 | open import Data.Product 8 | open import Data.List 9 | open import Data.Vec as Vec hiding (_>>=_) 10 | 11 | open import HMTS.Prelude 12 | open import HMTS.Syntax 13 | open import HMTS.Types 14 | open import HMTS.Substitutions 15 | 16 | {-# TERMINATING #-} 17 | U : Type -> Type -> Maybe Subst 18 | U (Var i) (Var j) = just (case i ≟ j of λ 19 | { (yes _) -> [] 20 | ; (no _) -> (i , Var j) ∷ [] 21 | }) 22 | U (Var i) τ = subst i τ 23 | U σ (Var j) = subst j σ 24 | U (σ ⇒ τ) (σ' ⇒ τ') = 25 | U σ σ' >>= λ Ψ -> 26 | U (apply Ψ τ) (apply Ψ τ') >>= λ Φ -> 27 | just (Ψ ∘ˢ Φ) 28 | 29 | -- It probably would be nicer to use a coinductive list of fresh names. 30 | -- Wrapped in the State monad or something. 31 | -- Try to typify terms in M instead of afterwards. 32 | M : ∀ {n} -> ℕ -> Con n -> Syntax n -> Type -> Maybe (ℕ × Subst) 33 | M new Γ (varˢ i) σ = 34 | _,_ new <$> U σ (Vec.lookup i Γ) 35 | M new Γ (ƛˢ b) σ = 36 | U σ (Var new ⇒ Var (next new)) >>= λ Ψ -> 37 | M (next (next new)) (Vec.map (apply Ψ) (Var new ∷ Γ)) b (apply Ψ (Var (next new))) >>= λ{ (new' , Φ) -> 38 | just (new' , Ψ ∘ˢ Φ) 39 | } 40 | M new Γ (f · x) σ = 41 | M (next new) Γ f (Var new ⇒ σ) >>= λ{ (new' , Ψ) -> 42 | M new' (Vec.map (apply Ψ) Γ) x (apply Ψ (Var new)) >>= λ{ (new'' , Φ) -> 43 | just (new'' , Ψ ∘ˢ Φ) 44 | }} 45 | 46 | infer : Syntax⁽⁾ -> Maybe Subst 47 | infer e = proj₂ <$> M 1 [] e (Var 0) 48 | -------------------------------------------------------------------------------- /Lists/ChurchVector.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | Nat = ∀ (P : Set) -> (P -> P) -> P -> P 4 | 5 | zero : Nat 6 | zero = λ P f z -> z 7 | 8 | suc : Nat -> Nat 9 | suc = λ n P f z -> f (n P f z) 10 | 11 | plus : Nat -> Nat -> Nat 12 | plus = λ n m P f z -> n P f (m P f z) 13 | 14 | Vec = λ (A : Set) n -> 15 | (P : Nat -> Set) -> (∀ n -> A -> P n -> P (suc n)) -> P zero -> P n 16 | 17 | nil : ∀ A -> Vec A zero 18 | nil = λ A P f z -> z 19 | 20 | cons : ∀ A n -> A -> Vec A n -> Vec A (suc n) 21 | cons = λ A n x xs P f z -> f n x (xs P f z) 22 | 23 | concat : ∀ A n m -> Vec A n -> Vec A m -> Vec A (plus n m) 24 | concat = λ A n m xs ys P f z -> xs (λ n -> P (plus n m)) (λ n -> f (plus n m)) (ys P f z) 25 | 26 | Eq = λ (A : Set) (x y : A) -> 27 | (P : A -> A -> Set) -> (∀ x -> P x x) -> P x y 28 | 29 | refl : ∀ A x -> Eq A x x 30 | refl = λ A x P p -> p x 31 | 32 | Leibniz = λ (A : Set) (x y : A) -> 33 | (P : A -> Set) -> P x -> P y 34 | 35 | subst : ∀ A -> (x y : A) -> Eq A x y -> Leibniz A x y 36 | subst = λ A x y q P -> q (λ x y -> P x -> P y) (λ _ p -> p) 37 | 38 | tsbus : ∀ A -> (x y : A) -> Leibniz A x y -> Eq A x y 39 | tsbus = λ A x y f P r -> f (P x) (r x) 40 | 41 | one = suc zero 42 | two = suc one 43 | three = suc two 44 | 45 | [1] : Vec Nat one 46 | [1] = cons _ _ one (nil _) 47 | 48 | [2,3] : Vec Nat two 49 | [2,3] = cons _ _ two (cons _ _ three (nil _)) 50 | 51 | [1,2,3] : Vec Nat three 52 | [1,2,3] = cons _ _ (suc zero) [2,3] 53 | 54 | test1 : Eq _ (concat _ _ _ [1] [2,3]) [1,2,3] 55 | test1 = refl _ _ 56 | 57 | test2 : Eq _ (plus one two) three 58 | test2 = refl _ _ 59 | 60 | test3 : ∀ (A : Set) n m -> Eq Nat n m -> Vec A n -> Vec A m 61 | test3 = λ A n m q -> subst Nat n m q (Vec A) 62 | -------------------------------------------------------------------------------- /PolyMonadUnify.agda: -------------------------------------------------------------------------------- 1 | open import Level 2 | open import Function 3 | open import Relation.Binary.PropositionalEquality 4 | 5 | record Monad (M : ∀ {α} -> Set α -> Set α) α β : Set (suc (α ⊔ β)) where 6 | infixl 1 _>>=_ 7 | 8 | field 9 | ret : {q : α ≡ β} {A : Set α} -> A -> M A 10 | _>>=_ : {A : Set α} {B : Set β} -> M A -> (A -> M B) -> M B 11 | 12 | module Monadic {M : ∀ {α} -> Set α -> Set α} {α} {A : Set α} (mMonad : Monad M α α) where 13 | private open module Dummy = Monad mMonad 14 | 15 | return : A -> M A 16 | return = ret {q = refl} 17 | 18 | join : M (M A) -> M A 19 | join = _>>= id 20 | open Monadic {{...}} public 21 | open Monad {{...}} using (_>>=_) public 22 | 23 | private 24 | module Test where 25 | open import Data.List.Base 26 | 27 | instance 28 | ListMonad : ∀ {α β} -> Monad List α β 29 | ListMonad = record 30 | { ret = _∷ [] 31 | ; _>>=_ = bind 32 | } where 33 | bind : ∀ {α β} {A : Set α} {B : Set β} -> List A -> (A -> List B) -> List B 34 | bind [] f = [] 35 | bind (x ∷ xs) f = f x ++ bind xs f 36 | 37 | -- It should be Applicative, I know. 38 | mapM : ∀ {α β} {A : Set α} {B : Set β} 39 | {M : ∀ {α} -> Set α -> Set α} {{mMonad : ∀ {α β} -> Monad M α β}} 40 | -> (A -> M B) -> List A -> M (List B) 41 | mapM f [] = return [] 42 | mapM f (x ∷ xs) = f x >>= λ y -> mapM f xs >>= λ ys -> return (y ∷ ys) 43 | 44 | test₁ : Set -> List Set 45 | test₁ = return 46 | 47 | test₂ : List Set -> (Set -> List Level) -> (Level -> List Set₂) -> List Set₂ 48 | test₂ xs f g = xs >>= f >>= g 49 | 50 | test₃ : List Set 51 | test₃ = join $ mapM (const (Level ∷ List Level ∷ [])) (Set ∷ []) 52 | -------------------------------------------------------------------------------- /Desc/ParamDesc.agda: -------------------------------------------------------------------------------- 1 | module _ where 2 | 3 | open import Function 4 | open import Relation.Binary.PropositionalEquality 5 | open import Data.Unit.Base 6 | open import Data.Nat.Base using (ℕ; zero; suc) 7 | open import Data.Sum 8 | open import Data.Product 9 | 10 | module Param (P : Set) where 11 | infixr 5 _⊕_ 12 | infixr 6 _⊛_ 13 | 14 | data Desc (I : Set) : Set₁ where 15 | var : (P -> I) -> Desc I 16 | π : (A : P -> Set) -> ((∀ p -> A p) -> Desc I) -> Desc I 17 | _⊕_ _⊛_ : Desc I -> Desc I -> Desc I 18 | 19 | module _ where 20 | open Param ⊤ 21 | 22 | ⟦_⟧ : ∀ {I} -> Desc I -> (I -> Set) -> Set 23 | ⟦ var i ⟧ B = B (i tt) 24 | ⟦ π A D ⟧ B = ∀ x -> ⟦ D x ⟧ B 25 | ⟦ D ⊕ E ⟧ B = ⟦ D ⟧ B ⊎ ⟦ E ⟧ B 26 | ⟦ D ⊛ E ⟧ B = ⟦ D ⟧ B × ⟦ E ⟧ B 27 | 28 | Extend : ∀ {I} -> Desc I -> (I -> Set) -> I -> Set 29 | Extend (var i) B j = i tt ≡ j 30 | Extend (π A D) B j = ∃ λ x -> Extend (D x) B j 31 | Extend (D ⊕ E) B j = Extend D B j ⊎ Extend E B j 32 | Extend (D ⊛ E) B j = ⟦ D ⟧ B × Extend E B j 33 | 34 | data μ {I} (D : Desc I) j : Set where 35 | node : Extend D (μ D) j -> μ D j 36 | 37 | Desc : Set -> Set₁ 38 | Desc I = ∀ {P} -> Param.Desc P I 39 | 40 | open Param hiding (Desc) public 41 | 42 | 43 | 44 | vec : Set -> Desc ℕ 45 | vec A = var (const 0) 46 | ⊕ π (const ℕ) λ n -> π (const A) λ _ -> var n ⊛ var (suc ∘ n) 47 | 48 | Vec : Set -> ℕ -> Set 49 | Vec A = μ (vec A) 50 | 51 | pattern [] = node (inj₁ refl) 52 | pattern _∷_ {n} x xs = node (inj₂ (n , x , xs , refl)) 53 | 54 | elimVec : ∀ {n A} 55 | -> (P : ∀ {n} -> Vec A n -> Set) 56 | -> (∀ {n} x {xs : Vec A n} -> P xs -> P (x ∷ xs)) 57 | -> P [] 58 | -> (xs : Vec A n) 59 | -> P xs 60 | elimVec P f z [] = z 61 | elimVec P f z (x ∷ xs) = f x (elimVec P f z xs) 62 | -------------------------------------------------------------------------------- /Lists/ChurchScott.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | 3 | import Data.Maybe 4 | 5 | newtype Church a = Church { runChurch :: forall r. (a -> r -> r) -> r -> r } 6 | newtype Scott a = Scott { runScott :: forall r. (a -> Scott a -> r) -> r -> r } 7 | 8 | ---------- 9 | 10 | cnil :: Church a 11 | cnil = Church $ \f z -> z 12 | 13 | ccons :: a -> Church a -> Church a 14 | ccons x xs = Church $ \f z -> f x (cfoldr f z xs) 15 | 16 | cfoldr :: (a -> r -> r) -> r -> Church a -> r 17 | cfoldr f z xs = runChurch xs f z 18 | 19 | czipWith :: (a -> b -> c) -> Church a -> Church b -> Church c 20 | czipWith f xs ys = fromScott $ szipWith f (fromChurch xs) (fromChurch ys) 21 | 22 | ---------- 23 | 24 | snil :: Scott a 25 | snil = Scott $ \f z -> z 26 | 27 | scons :: a -> Scott a -> Scott a 28 | scons x xs = Scott $ \f z -> f x xs 29 | 30 | sfoldr :: (a -> r -> r) -> r -> Scott a -> r 31 | sfoldr f z xs = runScott xs (\x -> f x . sfoldr f z) z 32 | 33 | ---------- 34 | 35 | split :: Scott a -> Maybe (a, Scott a) 36 | split xs = runScott xs ((Just .) . (,)) Nothing 37 | 38 | szipWith :: (a -> b -> c) -> Scott a -> Scott b -> Scott c 39 | szipWith f xs ys = fromMaybe snil $ do 40 | (x, xs') <- split xs 41 | (y, ys') <- split ys 42 | return $ f x y `scons` szipWith f xs' ys' 43 | 44 | --------- 45 | 46 | fromChurch :: Church a -> Scott a 47 | fromChurch = cfoldr scons snil 48 | 49 | fromScott :: Scott a -> Church a 50 | fromScott = sfoldr ccons cnil 51 | 52 | --------- 53 | 54 | cfromList :: [a] -> Church a 55 | cfromList = foldr ccons cnil 56 | 57 | ctoList :: Church a -> [a] 58 | ctoList = cfoldr (:) [] 59 | 60 | sfromList :: [a] -> Scott a 61 | sfromList = foldr scons snil 62 | 63 | stoList :: Scott a -> [a] 64 | stoList = sfoldr (:) [] 65 | 66 | main = print $ length $ ctoList $ czipWith (,) (cfromList [1..10^6]) (cfromList [1..10^6]) 67 | -------------------------------------------------------------------------------- /Eff/Union1.agda: -------------------------------------------------------------------------------- 1 | module Eff.Union1 where 2 | 3 | open import Eff.Prelude 4 | open import Eff.Map 5 | 6 | -- Sets¹ : ∀ {n} -> (βs : Level ^ n) -> Set _ 7 | -- Sets¹ = Map (λ β -> ∀ {α} -> Set α -> Set β) 8 | 9 | Sets1 : ∀ {n α} -> Set α -> (βs : Level ^ n) -> Set _ 10 | Sets1 A = Map (λ β -> A -> Set β) 11 | 12 | Sets¹ : ∀ {n} -> (α : Level) -> (βs : Level ^ n) -> Set _ 13 | Sets¹ α = Sets1 (Set α) 14 | 15 | Union1 : ∀ {n α} {A : Set α} {βs : Level ^ n} -> Sets1 A βs -> A -> Set _ 16 | Union1 Bs x = foldrᵐ Setₛ (λ B R -> B x ⊎ R) ⊥ Bs 17 | 18 | inj-replaceᵐ : ∀ n {α β β₀} {βs : Level ^ n} {A : Set α} 19 | {B : A -> Set β} {B₀ : A -> Set β₀} {Bs : Sets1 A βs} {x} 20 | -> (p : B ∈ Bs) -> B₀ x -> Union1 (replaceᵐ (∈→Fin n p) B₀ Bs) x 21 | inj-replaceᵐ 0 () y 22 | inj-replaceᵐ (suc n) (inj₁ r) y = inj₁ y 23 | inj-replaceᵐ (suc n) (inj₂ p) y = inj₂ (inj-replaceᵐ n p y) 24 | 25 | -- Make it ((p : B ∈ Bs) -> Union1 Bs x -> B x ⊎ Union1 (deleteᵐ (∈→Fin n p) Bs) x) instead? 26 | popUnion1₀ : ∀ n {α β β₀} {βs : Level ^ n} {A : Set α} 27 | {B : A -> Set β} {B₀ : A -> Set β₀} {Bs : Sets1 A βs} {x} 28 | -> (p : B ∈ Bs) -> Union1 Bs x -> B x ⊎ Union1 (replaceᵐ (∈→Fin n p) B₀ Bs) x 29 | popUnion1₀ 0 () u 30 | popUnion1₀ (suc n) (inj₁ r) (inj₁ y) = inj₁ (hSubst (hsym r) y) 31 | popUnion1₀ (suc n) (inj₁ r) (inj₂ u) = inj₂ (inj₂ u) 32 | popUnion1₀ (suc n) (inj₂ p) (inj₁ y) = inj₂ (inj₁ y) 33 | popUnion1₀ (suc n) (inj₂ p) (inj₂ u) = smap id inj₂ (popUnion1₀ n p u) 34 | 35 | popUnion1 : ∀ n {α β β₀} {βs : Level ^ n} {A : Set α} 36 | {B : A -> Set β} {B₀ : A -> Set β₀} {Bs : Sets1 A βs} {x} 37 | -> (p : B ∈ Bs) -> Union1 (B₀ , Bs) x -> B x ⊎ Union1 (replaceᵐ (∈→Fin n p) B₀ Bs) x 38 | popUnion1 n p (inj₁ y) = inj₂ (inj-replaceᵐ n p y) 39 | popUnion1 n p (inj₂ u) = popUnion1₀ n p u 40 | -------------------------------------------------------------------------------- /Fin-neq-Nat.agda: -------------------------------------------------------------------------------- 1 | -- Stealing the idea from András Kovács: 2 | -- https://github.com/AndrasKovacs/misc-stuff/blob/master/agda/Fin-neq-Nat.agda 3 | 4 | open import Relation.Binary.PropositionalEquality 5 | open import Relation.Nullary 6 | open import Data.Empty 7 | open import Data.Nat.Base 8 | open import Data.Nat.Properties 9 | open import Data.Fin hiding (_≤_; _<_) 10 | open import Data.Product renaming (map to pmap) 11 | open import Data.List.Base renaming (map to lmap) 12 | 13 | infix 4 _∈_ _∉_ 14 | 15 | data _∈_ {α} {A : Set α} (x : A) : List A -> Set where 16 | here : ∀ {xs} -> x ∈ x ∷ xs 17 | there : ∀ {y xs} -> x ∈ xs -> x ∈ y ∷ xs 18 | 19 | _∉_ : ∀ {α} {A : Set α} -> A -> List A -> Set 20 | x ∉ xs = x ∈ xs -> ⊥ 21 | 22 | Finite : ∀ {α} -> Set α -> Set α 23 | Finite A = ∃ λ xs -> (x : A) -> x ∈ xs 24 | 25 | ∈-map : ∀ {α β} {A : Set α} {B : Set β} {f : A -> B} {x xs} -> x ∈ xs -> f x ∈ lmap f xs 26 | ∈-map here = here 27 | ∈-map (there p) = there (∈-map p) 28 | 29 | finiteFin : ∀ n -> Finite (Fin n) 30 | finiteFin 0 = [] , λ() 31 | finiteFin (suc n) with finiteFin n 32 | ... | xs , k = zero ∷ lmap suc xs , λ{ zero -> here ; (suc i) -> there (∈-map (k i)) } 33 | 34 | maximum : List ℕ -> ℕ 35 | maximum = foldr _⊔_ 0 36 | 37 | ⊔-≤ : ∀ {m p} n -> n ⊔ m ≤ p -> n ≤ p × m ≤ p 38 | ⊔-≤ 0 q = z≤n , q 39 | ⊔-≤ {0} (suc n) q = q , z≤n 40 | ⊔-≤ {suc m} (suc n) (s≤s q) = pmap s≤s s≤s (⊔-≤ n q) 41 | 42 | <-max-∉ : ∀ {m} {ns : List ℕ} -> maximum ns < m -> m ∉ ns 43 | <-max-∉ {ns = n ∷ ns} p here = 1+n≰n (proj₁ (⊔-≤ {m = suc (maximum ns)} (suc n) p)) 44 | <-max-∉ {ns = n ∷ ns} p (there q) = <-max-∉ (proj₂ (⊔-≤ (suc n) p)) q 45 | 46 | notFiniteℕ : ¬ Finite ℕ 47 | notFiniteℕ (ns , k) = <-max-∉ (n≤1+n _) (k _) 48 | 49 | Fin≢ℕ : ∀ n -> Fin n ≢ ℕ 50 | Fin≢ℕ n p = notFiniteℕ (subst Finite p (finiteFin n)) 51 | -------------------------------------------------------------------------------- /Lists/PList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | 3 | import Data.Maybe 4 | import Data.List 5 | 6 | newtype PList a = PList { runPList :: forall r. (PList a -> a -> r -> r) -> r -> r } 7 | 8 | pnil :: PList a 9 | pnil = PList $ \_ z -> z 10 | 11 | pcons :: a -> PList a -> PList a 12 | pcons x xs = PList $ \f z -> f xs x (runPList xs f z) 13 | 14 | psplit :: PList a -> Maybe (a, PList a) 15 | psplit xs = runPList xs (\t h _ -> Just (h, t)) Nothing 16 | 17 | pfoldr :: (a -> r -> r) -> r -> PList a -> r 18 | pfoldr f z xs = runPList xs (\_ -> f) z 19 | 20 | pfuse :: PList a -> PList a 21 | pfuse = pfoldr pcons pnil 22 | 23 | pappend :: PList a -> PList a -> PList a 24 | pappend xs ys = PList $ \f -> runPList xs (\xs' -> f (pappend xs' ys)) . runPList ys f 25 | 26 | pmap :: (a -> b) -> PList a -> PList b 27 | pmap h xs = PList $ \f -> runPList xs (\xs' -> f (pmap h xs') . h) 28 | 29 | pzipWith :: (a -> b -> c) -> PList a -> PList b -> PList c 30 | pzipWith f xs ys = go (pfuse xs) (pfuse ys) where 31 | go xs ys = fromMaybe pnil $ do 32 | (x, xs') <- psplit xs 33 | (y, ys') <- psplit ys 34 | return $ f x y `pcons` go xs' ys' 35 | 36 | pzip :: PList a -> PList b -> PList (a, b) 37 | pzip = pzipWith (,) 38 | 39 | pfromList :: [a] -> PList a 40 | pfromList = foldr pcons pnil 41 | 42 | ptoList :: PList a -> [a] 43 | ptoList = pfoldr (:) [] 44 | 45 | main = do 46 | print $ ptoList $ pzip (pfromList [1..10]) (pfromList [1..10]) 47 | -- [(1,1),(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),(8,8),(9,9),(10,10)] 48 | print $ ptoList $ pzip (pfromList [1..10]) (pfromList [1..9 ]) 49 | -- [(1,1),(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),(8,8),(9,9)] 50 | print $ ptoList $ pzip (pfromList [1..9 ]) (pfromList [1..10]) 51 | -- [(1,1),(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),(8,8),(9,9)] 52 | print $ length . ptoList $ foldl' pappend pnil . map (pfromList . (:[])) $ [1..1000000] 53 | -- 1000000 -------------------------------------------------------------------------------- /adder.hs: -------------------------------------------------------------------------------- 1 | -- related to http://stackoverflow.com/questions/29487773/how-to-build-a-typed-variadic-function-from-a-container 2 | 3 | {-# LANGUAGE GADTs, KindSignatures, DataKinds, PolyKinds, TypeFamilies, TypeOperators, UndecidableInstances #-} 4 | 5 | type family If b x y where 6 | If True x y = x 7 | If False x y = y 8 | 9 | data Booly :: Bool -> * where 10 | Truly :: Booly True 11 | Falsy :: Booly False 12 | 13 | data Nat = Z | S Nat 14 | 15 | data Natty :: Nat -> * where 16 | Zy :: Natty Z 17 | Sy :: Natty n -> Natty (S n) 18 | 19 | data Listy (b :: a -> *) :: [a] -> * where 20 | Nilly :: Listy b '[] 21 | Consy :: b x -> Listy b xs -> Listy b (x ': xs) 22 | 23 | type Natties = Listy Natty 24 | 25 | type family NatEq n m :: Bool where 26 | NatEq Z Z = True 27 | NatEq Z (S m) = False 28 | NatEq (S n) Z = False 29 | NatEq (S n) (S m) = NatEq n m 30 | 31 | type family Adder (ns :: [Nat]) :: * where 32 | Adder '[] = Int 33 | Adder (n ': ns) = If (NatEq n (S (S (S (S (S Z)))))) Int (Int -> Adder ns) 34 | 35 | nattyEq :: Natty n -> Natty m -> Booly (NatEq n m) 36 | nattyEq Zy Zy = Truly 37 | nattyEq Zy (Sy m) = Falsy 38 | nattyEq (Sy n) Zy = Falsy 39 | nattyEq (Sy n) (Sy m) = nattyEq n m 40 | 41 | adder :: Natties ns -> Adder ns 42 | adder = go 0 where 43 | go :: Int -> Natties ns -> Adder ns 44 | go i Nilly = 0 45 | go i (Consy n ns) = case nattyEq n (Sy (Sy (Sy (Sy (Sy Zy))))) of 46 | Truly -> i + 100 47 | Falsy -> \a -> go (i + a) ns 48 | 49 | list = Consy Zy $ Consy (Sy Zy) $ Consy (Sy (Sy (Sy (Sy (Sy Zy))))) $ Consy Zy $ Nilly 50 | 51 | main = do 52 | print $ adder (Consy Zy $ Consy (Sy Zy) $ Nilly) 3 9 -- 0 53 | print $ adder list 6 8 -- 114 54 | print $ adder (Consy (Sy (Sy Zy)) list) 1 2 3 -- 106 55 | -------------------------------------------------------------------------------- /IndIndEx.agda: -------------------------------------------------------------------------------- 1 | open import Level 2 | open import Function 3 | open import Relation.Binary.PropositionalEquality 4 | open import Data.Empty 5 | 6 | infix 4 _∉_ 7 | 8 | mutual 9 | data UList {α} (A : Set α) : Set α where 10 | [] : UList A 11 | cons : ∀ x xs -> x ∉ xs -> UList A 12 | 13 | data _∉_ {α} {A : Set α} (x : A) : UList A -> Set α where 14 | stop : x ∉ [] 15 | keep : ∀ {y xs} -> x ≢ y -> (p : y ∉ xs) -> x ∉ xs -> x ∉ cons y xs p 16 | 17 | data Tag {α} (A : Set α) : Set (suc α) where 18 | ulist : Tag A 19 | inn : {R : Set α} -> A -> R -> Tag A 20 | 21 | -- It's positive. Agda just doesn't track polarity of indices. 22 | -- "self-polymorphic recursion" 23 | {-# NO_POSITIVITY_CHECK #-} 24 | data UListInn {α} (A : Set α) : Tag A -> Set α where 25 | [] : UListInn A ulist 26 | cons : ∀ x (xs : UListInn A ulist) -> UListInn A (inn x xs) -> UListInn A ulist 27 | stop : ∀ {x} -> UListInn A (inn x (UListInn A ulist ∋ [])) 28 | keep : ∀ {x y} {xs : UListInn A ulist} 29 | -> x ≢ y 30 | -> (p : UListInn A (inn y xs)) 31 | -> UListInn A (inn x xs) 32 | -> UListInn A (inn x (UListInn.cons y xs p)) 33 | 34 | mutual 35 | coeUList : ∀ {α} {A : Set α} -> UList A -> UListInn A ulist 36 | coeUList [] = [] 37 | coeUList (cons x xs p) = cons x (coeUList xs) (coeInn p) 38 | 39 | coeInn : ∀ {α} {A : Set α} {x : A} {xs} -> x ∉ xs -> UListInn A (inn x (coeUList xs)) 40 | coeInn stop = stop 41 | coeInn (keep c p q) = keep c (coeInn p) (coeInn q) 42 | 43 | mutual 44 | uncoeUList : ∀ {α} {A : Set α} -> UListInn A ulist -> UList A 45 | uncoeUList [] = [] 46 | uncoeUList (cons x xs p) = cons x (uncoeUList xs) (uncoeInn p) 47 | 48 | uncoeInn : ∀ {α} {A : Set α} {x : A} {xs} -> UListInn A (inn x xs) -> x ∉ uncoeUList xs 49 | uncoeInn stop = stop 50 | uncoeInn (keep c p q) = keep c (uncoeInn p) (uncoeInn q) 51 | -------------------------------------------------------------------------------- /Indexed.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | open import Function 4 | open import Relation.Binary.PropositionalEquality 5 | open import Data.Empty 6 | 7 | Indexed : Set -> Set 8 | Indexed I = (I -> Set) -> I -> Set 9 | 10 | data IWer {I} (Ψ : Indexed I) : I -> Set where 11 | call : ∀ {S i} -> Ψ S i -> (∀ {i′} -> S i′ -> IWer Ψ i′) -> IWer Ψ i 12 | 13 | fmap : ∀ {I i} {Ψ Φ : Indexed I} -> (∀ {S i} -> Ψ S i -> Φ S i) -> IWer Ψ i -> IWer Φ i 14 | fmap f (call a k) = call (f a) (λ x -> fmap f (k x)) 15 | 16 | 17 | 18 | open import Data.Nat.Base 19 | open import Data.List.Base hiding ([]; _∷_; foldr) 20 | 21 | data VecF (A : Set) : Indexed ℕ where 22 | Nil : VecF A (const ⊥) 0 23 | Cons : ∀ {n} -> A -> VecF A (n ≡_) (suc n) 24 | 25 | Vec : Set -> ℕ -> Set 26 | Vec = IWer ∘ VecF 27 | 28 | [] : ∀ {A} -> Vec A 0 29 | [] = call Nil (λ()) 30 | 31 | infixr 5 _∷_ 32 | _∷_ : ∀ {n A} -> A -> Vec A n -> Vec A (suc n) 33 | x ∷ xs = call (Cons x) (λ q -> subst (Vec _) q xs) 34 | 35 | -- Nope. 36 | -- elimVec : ∀ {n A} 37 | -- -> (P : ∀ {n} -> Vec A n -> Set) 38 | -- -> (∀ {n} {xs : Vec A n} x -> P xs -> P (x ∷ xs)) 39 | -- -> P [] 40 | -- -> (xs : Vec A n) 41 | -- -> P xs 42 | -- elimVec P f z (call Nil k) = {!z!} 43 | -- elimVec P f z (call (Cons x) k) = {!f x (elimVec P f z (k refl))!} 44 | 45 | onVec : ∀ {A B S i} -> (A -> B) -> VecF A S i -> VecF B S i 46 | onVec f Nil = Nil 47 | onVec f (Cons x) = Cons (f x) 48 | 49 | foldr : ∀ {A n} 50 | -> (B : ℕ -> Set) 51 | -> (∀ {n} -> A -> B n -> B (suc n)) 52 | -> B 0 53 | -> Vec A n 54 | -> B n 55 | foldr B f z (call Nil k) = z 56 | foldr B f z (call (Cons x) k) = f x (foldr B f z (k refl)) 57 | 58 | toList : ∀ {A n} -> Vec A n -> List A 59 | toList = foldr _ List._∷_ List.[] 60 | 61 | test : toList (fmap (onVec suc) (1 ∷ 2 ∷ 3 ∷ [])) ≡ toList (2 ∷ 3 ∷ 4 ∷ []) 62 | test = refl 63 | -------------------------------------------------------------------------------- /MonoEff/Effect/IState.agda: -------------------------------------------------------------------------------- 1 | module Effect.IState where 2 | 3 | open import Prelude 4 | open import Core 5 | 6 | data State {α} (A : Set α) : Effectful α α (lsuc α) where 7 | Get : State A A (const A) 8 | Put : ∀ {B} -> B -> State A ⊤ (const B) 9 | 10 | get : ∀ {n α} {Ψs : Effects α α (lsuc α) n} {Rs : Resources α n} 11 | {A : Set α} {{p : State , A ∈ Ψs , Rs}} 12 | -> Eff Ψs A Rs _ 13 | get = invoke Get 14 | 15 | zap : ∀ {n α} {Ψs : Effects α α (lsuc α) n} {Rs : Resources α n} 16 | (A {B} : Set α) {{p : State , A ∈ Ψs , Rs}} 17 | -> B -> Eff Ψs ⊤ Rs _ 18 | zap A {{p}} = invoke {{p}} ∘ Put 19 | 20 | put : ∀ {n α} {Ψs : Effects α α (lsuc α) n} {Rs : Resources α n} 21 | {A : Set α} {{p : State , A ∈ Ψs , Rs}} 22 | -> A -> Eff Ψs ⊤ Rs _ 23 | put = zap _ 24 | 25 | execState : ∀ {n α β} {Ψs : Effects α α (lsuc α) n} {B : Set β} 26 | {Rs : Resources α (suc n)} {Rs′ : B -> Resources α (suc n)} 27 | -> head Rs 28 | -> Eff (State ∷ Ψs) B Rs Rs′ 29 | -> Eff Ψs (Σ B (head ∘ Rs′)) (tail Rs) (tail ∘ Rs′ ∘ proj₁) 30 | execState s (return y) = return (y , s) 31 | execState {Rs = _ ∷ _} s (call zero Get f) = execState s (f s) 32 | execState {Rs = _ ∷ _} _ (call zero (Put s) f) = execState s (f tt) 33 | execState {Rs = _ ∷ _} s (call (suc i) a f) = call i a λ x -> execState s (f x) 34 | 35 | open import Data.Bool.Base 36 | 37 | eff₁ : Eff [ State ] ℕ [ ℕ ] (λ n -> [ Vec Bool n ]) 38 | eff₁ = get >>= λ n -> zap ℕ (replicate true) >> return n 39 | 40 | eff₂ : Eff (State ∷ State ∷ []) ℕ (ℕ ∷ ⊤ ∷ []) (λ _ -> ℕ ∷ ⊤ ∷ []) 41 | eff₂ = get >>= λ n -> put n >> return (suc n) 42 | 43 | -- 3 , true ∷ true ∷ true ∷ [] 44 | test₁ : ∃ (Vec Bool) 45 | test₁ = runEff $ execState 3 eff₁ 46 | 47 | -- 4 , 3 48 | test₂ : ℕ × ℕ 49 | test₂ = proj₁ $ runEff $ execState tt $ execState 3 eff₂ 50 | -------------------------------------------------------------------------------- /Eff/Core.agda: -------------------------------------------------------------------------------- 1 | module Eff.Core where 2 | 3 | open import Eff.Prelude 4 | open import Eff.Freer 5 | open import Eff.Map 6 | open import Eff.Union1 7 | 8 | -- Tagging to make implicits inferrable. 9 | -- We could define a wrapper over `Freer', 10 | -- but that would introduce too much wrapping-unwrapping boilerplate. 11 | Eff : ∀ {n α γ} {ψs : Level ^ n} -> Sets¹ α ψs -> Set γ -> Set _ 12 | Eff Fs = Freer (Tag₂ Union1 Fs) 13 | 14 | pattern tcall a f = call (tag a) f 15 | 16 | inj : ∀ n {α ψ} {ψs : Level ^ n} {A : Set α} {F : Set α -> Set ψ} {Fs : Sets¹ α ψs} 17 | -> F A -> F ∈ Fs -> Union1 Fs A 18 | inj 0 a () 19 | inj (suc n) a (inj₁ r) = inj₁ (hSubst r a) 20 | inj (suc n) a (inj₂ p) = inj₂ (inj n a p) 21 | 22 | invoke : ∀ {n α ψ} {ψs : Level ^ n} {A : Set α} {F : Set α -> Set ψ} 23 | {Fs : Sets¹ α ψs} {{p : F ∈ Fs}} 24 | -> F A -> Eff Fs A 25 | invoke {n} {{p}} a = perform (tag (inj n a p)) 26 | 27 | execEff : ∀ {n α β ψ φ} {ψs : Level ^ n} {F : Set α -> Set ψ} 28 | {Fs : Sets¹ α ψs} {B : Set β} 29 | -> (G : Set β -> Set φ) 30 | -> (B -> G B) 31 | -> (∀ {A} -> F A -> A × (G B -> G B)) 32 | -> Eff (F , Fs) B 33 | -> Eff Fs (G B) 34 | execEff G ret out (return y) = return (ret y) 35 | execEff G ret out (tcall (inj₁ a) f) = let x , g = out a in g <$> execEff G ret out (f x) 36 | execEff G ret out (tcall (inj₂ a) f) = tcall a λ x -> execEff G ret out (f x) 37 | 38 | runEff : ∀ {α β} {B : Set β} -> Eff {α = α} tt B -> B 39 | runEff (return y) = y 40 | runEff (tcall () _) 41 | 42 | popEff : ∀ {n α β ψ ψ₀} {ψs : Level ^ n} {B : Set β} 43 | {F : Set α -> Set ψ} {F₀ : Set α -> Set ψ₀} 44 | {Fs : Sets¹ α ψs} {{p : F ∈ Fs}} 45 | -> Eff (F₀ , Fs) B -> Eff {ψs = ψ , _} (F , replaceᵐ (∈→Fin n p) F₀ Fs) B 46 | popEff (return y) = return y 47 | popEff {n} {{p}} (tcall a f) = tcall (popUnion1 n p a) λ x -> popEff (f x) 48 | -------------------------------------------------------------------------------- /SizedMonoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, KindSignatures, GADTs, DataKinds, PolyKinds, TypeFamilies, TemplateHaskell, BangPatterns #-} 2 | 3 | import Data.Monoid 4 | import Data.Array 5 | import Data.Singletons 6 | import Data.Singletons.TH 7 | 8 | $(singletons [d| 9 | data Nat = Z | S Nat 10 | |]) 11 | 12 | toInt :: Nat -> Int 13 | toInt = go 0 where 14 | go !a Z = a 15 | go a (S n) = go (1 + a) n 16 | 17 | newtype Vec (n :: Nat) a = Vec [a] 18 | deriving (Eq, Ord, Show) 19 | 20 | instance Ix a => Ix (Vec n a) where 21 | range (Vec ns, Vec ms) = map Vec . sequence $ zipWith (curry range) ns ms 22 | index (Vec ns, Vec ms) (Vec ps) = foldr (\(i, r) a -> i + r * a) 0 $ 23 | zipWith3 (\n m p -> (index (n, m) p, rangeSize (n, m))) ns ms ps 24 | inRange (Vec ns, Vec ms) (Vec ps) = and $ zipWith3 (curry inRange) ns ms ps 25 | 26 | newtype Sized m (ns :: [Nat]) a = Sized { getArray :: Array (Vec m Int) a } 27 | 28 | vecBounds :: forall m (ns :: [Nat]). SingI m => Sing ns -> (Vec m Int, Vec m Int) 29 | vecBounds singNs = (Vec $ replicate m 0, Vec ns') where 30 | m = toInt $ fromSing (sing :: Sing m) 31 | ns' = map (pred . toInt) $ fromSing singNs 32 | 33 | listSized :: forall m (ns :: [Nat]) a. (SingI m, SingI ns) => [a] -> Sized m ns a 34 | listSized = Sized . listArray (vecBounds (sing :: Sing ns)) 35 | 36 | instance (SingI m, SingI ns, Monoid a) => Monoid (Sized m ns a) where 37 | mempty = listSized $ repeat mempty 38 | Sized as `mappend` Sized bs = listSized $ zipWith mappend (elems as) (elems bs) 39 | 40 | type M = S (S (S Z)) 41 | type Ns = [S (S Z), S Z, S (S (S Z))] 42 | 43 | arr1 :: Sized M Ns (Sum Int) 44 | arr1 = listSized $ map Sum [5,3,6,7,1,4] 45 | 46 | arr2 :: Sized M Ns (Sum Int) 47 | arr2 = listSized $ map Sum [8,2,9,7,3,6] 48 | 49 | main = mapM_ (print . getArray) $ [arr1, arr2, arr1 `mappend` arr2 `mappend` mempty] 50 | -------------------------------------------------------------------------------- /Eff/Tests.agda: -------------------------------------------------------------------------------- 1 | module Eff.Tests where 2 | 3 | open import Eff.Prelude 4 | open import Eff.Freer 5 | open import Eff.Map 6 | open import Eff.Union1 7 | open import Eff.Core 8 | 9 | data Reader {α} (A : Set α) : ∀ {β} -> Set β -> Set where 10 | get : Reader A A 11 | 12 | data Writer {α} (A : Set α) : ∀ {β} -> Set β -> Set α where 13 | put : A -> Writer A {α} ⊤ 14 | 15 | runReader : ∀ {α β} {A : Set α} {B : Set β} -> A -> Reader A B -> B 16 | runReader x get = x 17 | 18 | runWriter : ∀ {α β} {A : Set α} {B : Set β} -> Writer A B -> B × A 19 | runWriter (put x) = _ , x 20 | 21 | ask : ∀ {n α} {ψs : Level ^ n} {A : Set α} {Fs : Sets¹ α ψs} 22 | {{In : Reader A ∈ Fs}} -> Eff Fs A 23 | ask = invoke get 24 | 25 | tell : ∀ {n α} {ψs : Level ^ n} {A : Set α} {Fs : Sets¹ α ψs} 26 | {{In : Writer A ∈ Fs}} -> A -> Eff Fs ⊤ 27 | tell = invoke ∘ put 28 | 29 | execReader : ∀ {n α β} {ψs : Level ^ n} {A : Set α} {Fs : Sets¹ α ψs} {B : Set β} 30 | -> A -> Eff (Reader A , Fs) B -> Eff Fs B 31 | execReader x = execEff id id (λ r -> runReader x r , id) 32 | 33 | execWriter : ∀ {n α β} {ψs : Level ^ n} {A : Set α} {Fs : Sets¹ α ψs} {B : Set β} 34 | -> Eff (Writer A , Fs) B -> Eff Fs (List A × B) 35 | execWriter = execEff (List _ ×_) (_,_ []) (second (first ∘ _∷_) ∘ runWriter) 36 | 37 | 38 | 39 | eff₁ : Eff (Writer ℕ , Reader ℕ , tt) ℕ 40 | eff₁ = ask >>= λ n -> tell n >> tell (n + 2) >> return n 41 | 42 | eff₂ : Eff (Writer Set , Reader ℕ , tt) ℕ 43 | eff₂ = ask 44 | 45 | eff₃ : Eff (Writer Set , Reader ℕ , tt) ℕ 46 | eff₃ = tell (Fin 1) >> return 1 47 | 48 | eff₄ : Eff (Writer Set , Reader (Lift {ℓ = lsuc lzero} ℕ) , tt) ℕ 49 | eff₄ = tell (Fin 1) >> ask >>= λ n -> tell (Fin (lower n)) >> return (lower n) 50 | 51 | -- 3 ∷ 5 ∷ [] , 3 52 | test₁ : List ℕ × ℕ 53 | test₁ = runEff $ execReader 3 $ execWriter eff₁ 54 | 55 | -- 3 ∷ 5 ∷ [] , 3 56 | test₂ : List ℕ × ℕ 57 | test₂ = runEff $ execWriter $ execReader 3 $ popEff eff₁ 58 | -------------------------------------------------------------------------------- /DefCheck.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Relation.Binary.PropositionalEquality 3 | open import Data.Maybe.Base hiding (nothing; just; map) 4 | open Maybe 5 | open import Data.List.Base 6 | open import Reflection 7 | 8 | infixl 2 _>>=_ 9 | infix 5 _≟ᵈ_ 10 | 11 | pattern explRelArg x = arg (arg-info visible relevant) x 12 | 13 | vis : {A : Set} -> (A -> List (Arg Term) -> Term) -> A -> List Term -> Term 14 | vis f x = f x ∘ map explRelArg 15 | 16 | vis₀ : {A : Set} -> (A -> List (Arg Term) -> Term) -> A -> Term 17 | vis₀ k x = vis k x [] 18 | 19 | vis₁ : {A : Set} -> (A -> List (Arg Term) -> Term) -> A -> Term -> Term 20 | vis₁ k f x₁ = vis k f (x₁ ∷ []) 21 | 22 | vis₂ : {A : Set} -> (A -> List (Arg Term) -> Term) -> A -> Term -> Term -> Term 23 | vis₂ k f x₁ x₂ = vis k f (x₁ ∷ x₂ ∷ []) 24 | 25 | _>>=_ : ∀ {α β} {A : Set α} {B : Set β} -> TC A -> (A -> TC B) -> TC B 26 | _>>=_ = bindTC 27 | 28 | _<$>_ : ∀ {α β} {A : Set α} {B : Set β} -> (A -> B) -> TC A -> TC B 29 | f <$> a = a >>= returnTC ∘ f 30 | 31 | ‵refl : Term 32 | ‵refl = vis₀ con (quote refl) 33 | 34 | ‵nothing : Term 35 | ‵nothing = vis₀ con (quote nothing) 36 | 37 | ‵just : Term -> Term 38 | ‵just = vis₁ con (quote just) 39 | 40 | _‵≡_ : Term -> Term -> Term 41 | _‵≡_ = vis₂ def (quote _≡_) 42 | 43 | ‵Maybe : Term -> Term 44 | ‵Maybe = vis₁ def (quote Maybe) 45 | 46 | macro 47 | _≟ᵈ_ : ∀ {α} {A : Set α} -> A -> A -> Term -> TC _ 48 | _≟ᵈ_ x y ?r = 49 | quoteTC x >>= λ qx -> 50 | quoteTC y >>= λ qy -> 51 | checkType ?r (‵Maybe (qx ‵≡ qy)) >>= λ ?r′ -> 52 | catchTC (unify ?r′ (‵just ‵refl)) (unify ?r′ ‵nothing) 53 | 54 | open import Data.Nat.Base 55 | 56 | test₁ : (2 ∷ 3 ∷ []) ≟ᵈ (2 ∷ 3 ∷ []) ≡ just refl 57 | test₁ = refl 58 | 59 | test₂ : (2 ∷ 3 ∷ []) ≟ᵈ (3 ∷ 2 ∷ []) ≡ nothing 60 | test₂ = refl 61 | 62 | test₃ : ∀ {α} {A : Set α} {x y z : A} -> (x ∷ y ∷ z ∷ []) ≟ᵈ (x ∷ y ∷ z ∷ []) ≡ just refl 63 | test₃ = refl 64 | 65 | test₄ : ∀ {α} {A : Set α} {x y : A} -> x ≟ᵈ y ≡ nothing 66 | test₄ = refl 67 | -------------------------------------------------------------------------------- /division.agda: -------------------------------------------------------------------------------- 1 | -- related to http://stackoverflow.com/questions/28581814/how-to-define-division-operator-in-agda/ 2 | 3 | open import Function 4 | open import Relation.Nullary 5 | open import Relation.Nullary.Decidable hiding (map) 6 | open import Relation.Binary 7 | open import Relation.Binary.PropositionalEquality 8 | open import Data.Nat 9 | open import Data.Product hiding (map) 10 | open import Data.List.Base 11 | open import Induction.WellFounded 12 | open import Induction.Nat 13 | open import Data.Nat.Properties 14 | 15 | calls : ∀ {a b ℓ} {A : Set a} {_<_ : Rel A ℓ} {guarded : A -> Set b} 16 | -> (f : A -> A) 17 | -> Well-founded _<_ 18 | -> (∀ {x} -> guarded x -> f x < x) 19 | -> (∀ x -> Dec (guarded x)) 20 | -> A 21 | -> List A 22 | calls {A = A} {_<_} f wf smaller dec-guarded x = go (wf x) where 23 | go : ∀ {x} -> Acc _<_ x -> List A 24 | go {x} (acc r) with dec-guarded x 25 | ... | no _ = [] 26 | ... | yes g = x ∷ go (r (f x) (smaller g)) 27 | 28 | record Is {α} {A : Set α} (x : A) : Set α where 29 | ¡ = x 30 | open Is 31 | 32 | ! : ∀ {α} {A : Set α} -> (x : A) -> Is x 33 | ! _ = _ 34 | 35 | 36 | 37 | _-⁺_ : ∀ {m} -> ℕ -> Is (suc m) -> ℕ 38 | n -⁺ im = n ∸ ¡ im 39 | 40 | lem : ∀ {n m} {im : Is (suc m)} -> m < n -> n -⁺ im <′ n 41 | lem {suc n} {m} (s≤s _) = s≤′s (≤⇒≤′ (n∸m≤n m n)) 42 | 43 | iter-sub : ∀ {m} -> ℕ -> Is (suc m) -> List ℕ 44 | iter-sub n im = calls (λ n -> n -⁺ im) <-well-founded lem (_≤?_ (¡ im)) n 45 | 46 | _div⁺_ : ∀ {m} -> ℕ -> Is (suc m) -> ℕ 47 | n div⁺ im = length (iter-sub n im) 48 | 49 | _div_ : ℕ -> (m : ℕ) {_ : False (m ≟ 0)} -> ℕ 50 | n div 0 = λ{()} 51 | n div (suc m) = n div⁺ (! (suc m)) 52 | 53 | test-1 : iter-sub 10 (! 3) ≡ 10 ∷ 7 ∷ 4 ∷ [] 54 | test-1 = refl 55 | 56 | test-2 : iter-sub 16 (! 4) ≡ 16 ∷ 12 ∷ 8 ∷ 4 ∷ [] 57 | test-2 = refl 58 | 59 | test-3 : map (λ n -> n div 3) 60 | (0 ∷ 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ []) 61 | ≡ (0 ∷ 0 ∷ 0 ∷ 1 ∷ 1 ∷ 1 ∷ 2 ∷ 2 ∷ 2 ∷ 3 ∷ []) 62 | test-3 = refl 63 | -------------------------------------------------------------------------------- /Fin-injective.agda: -------------------------------------------------------------------------------- 1 | -- This is inspired by https://github.com/luqui/experiments/blob/master/Fin-inj.agda 2 | -- No longer type checks. 3 | 4 | open import Function 5 | open import Relation.Nullary 6 | open import Relation.Binary.PropositionalEquality 7 | open import Relation.Binary.HeterogeneousEquality using (refl ; _≅_ ; _≇_ ) 8 | open import Data.Empty 9 | open import Data.Nat 10 | open import Data.Fin as F hiding (_+_; _≟_) 11 | open import Data.Nat.Properties 12 | 13 | unsubst : ∀ {α γ} {A : Set α} {C : A -> Set γ} {i j : A} (p : i ≡ j) {x : C i} {y : C j} 14 | -> subst C p x ≡ y -> x ≅ y 15 | unsubst refl refl = refl 16 | 17 | suc-inv : ∀ {n m} {i : Fin n} {j : Fin m} -> F.suc i ≅ F.suc j -> i ≅ j 18 | suc-inv refl = refl 19 | 20 | fromℕ-+-neq : ∀ {n} m (i : Fin n) -> fromℕ (n + m) ≇ i 21 | fromℕ-+-neq {0} m () q 22 | fromℕ-+-neq {suc n} m zero () 23 | fromℕ-+-neq {suc n} m (suc i) q = fromℕ-+-neq m i (suc-inv q) 24 | 25 | Fin-suc-+-neq : ∀ n m -> Fin (suc n + m) ≢ Fin n 26 | Fin-suc-+-neq n m q with subst id q (fromℕ (n + m)) | inspect (subst id q) (fromℕ (n + m)) 27 | ... | i | [ r ] = fromℕ-+-neq m i (unsubst q r) 28 | 29 | decrease-Fin : ∀ {n m} p -> Fin (suc p + n) ≡ Fin (suc p + m) -> Fin (p + n) ≡ Fin (p + m) 30 | decrease-Fin {0} {0} p q = refl 31 | decrease-Fin {suc n} {0} p q rewrite +-right-identity p | +-suc p n = 32 | ⊥-elim (Fin-suc-+-neq (suc p) n q) 33 | decrease-Fin {0} {suc m} p q rewrite +-right-identity p | +-suc p m = 34 | ⊥-elim (Fin-suc-+-neq (suc p) m (sym q)) 35 | decrease-Fin {suc n} {suc m} p q rewrite +-suc p n | +-suc p m = decrease-Fin (suc p) q 36 | 37 | Fin-neq : ∀ {n m} -> n ≢ m -> Fin n ≢ Fin m 38 | Fin-neq {0} {0} ¬q = λ _ -> ¬q refl 39 | Fin-neq {suc n} {0} ¬q = Fin-suc-+-neq 0 n 40 | Fin-neq {0} {suc m} ¬q = Fin-suc-+-neq 0 m ∘ sym 41 | Fin-neq {suc n} {suc m} ¬q = Fin-neq (¬q ∘ cong suc) ∘ decrease-Fin 0 42 | 43 | Fin-injective : ∀ {n m} -> Fin n ≡ Fin m -> n ≡ m 44 | Fin-injective {n} {m} q with n ≟ m 45 | ... | yes r = r 46 | ... | no r = ⊥-elim (Fin-neq r q) 47 | -------------------------------------------------------------------------------- /Categories/Examples.agda: -------------------------------------------------------------------------------- 1 | module Categories.Examples where 2 | 3 | import Function as F 4 | open import Relation.Binary.PropositionalEquality as P using (_≡_) 5 | open import Data.List.Base 6 | open import Data.List.Properties 7 | 8 | open import Categories.Setoid 9 | open import Categories.Category 10 | open import Categories.Functor 11 | 12 | open Setoid-Instances _ 13 | 14 | ∘′-resp-≡ : ∀ {α} {A B C : Set α} {g₁ g₂ : B -> C} {f₁ f₂ : A -> B} 15 | -> (∀ y -> g₁ y ≡ g₂ y) -> (∀ x -> f₁ x ≡ f₂ x) -> ∀ x -> g₁ (f₁ x) ≡ g₂ (f₂ x) 16 | ∘′-resp-≡ q p x rewrite p x = q _ 17 | 18 | instance 19 | Agda : ∀ {α} -> IsCategory (λ (A B : Set α) -> A -> B) 20 | Agda = record 21 | { id = F.id 22 | ; _∘_ = F._∘′_ 23 | ; idˡ = λ x -> P.refl 24 | ; idʳ = λ x -> P.refl 25 | ; assoc = λ f x -> P.refl 26 | ; ∘-resp-≈ = ∘′-resp-≡ 27 | } 28 | 29 | →-IsEndofunctor : ∀ {α} {R : Set α} -> IsEndofunctor (λ (A B : Set α) -> A -> B) (λ Q -> R -> Q) 30 | →-IsEndofunctor {α} {C} = record 31 | { F₁ = F._∘′_ 32 | ; F-id = λ x -> P.refl 33 | ; F-∘ = λ x -> P.refl 34 | ; F-resp-≈ = λ p f -> ext (λ x -> p (f x)) 35 | } where postulate ext : P.Extensionality _ _ 36 | 37 | List-IsEndofunctor : ∀ {α} -> IsEndofunctor (λ (A B : Set α) -> A -> B) List 38 | List-IsEndofunctor = record 39 | { F₁ = map 40 | ; F-id = map-id 41 | ; F-∘ = map-compose 42 | ; F-resp-≈ = map-cong 43 | } 44 | 45 | module Test where 46 | open IsFunctor {{...}} 47 | 48 | -- open IsFunctor {{...}} renaming (F₁ to _<$>_) 49 | 50 | _<$>_ : ∀ {α β} {Obj : Set α} {_⇒_ : Obj -> Obj -> Set β} {A B : Obj} {F₀ : Obj -> Obj} 51 | {{setoid : ∀ {A B} -> Setoid (A ⇒ B)}} {{C : IsCategory _⇒_ {{setoid}}}} 52 | {{isEndofunctor : IsEndofunctor _⇒_ F₀ {{C}}}} 53 | -> A ⇒ B -> F₀ A ⇒ F₀ B 54 | _<$>_ = F₁ 55 | 56 | open import Data.Nat 57 | 58 | test-→ : (List ℕ -> ℕ) -> (ℕ -> List ℕ) -> ℕ -> ℕ 59 | test-→ = _<$>_ 60 | 61 | test-List : List ℕ 62 | test-List = ℕ.suc <$> (1 ∷ 2 ∷ 3 ∷ []) 63 | -------------------------------------------------------------------------------- /Dumb/HMTS/Prelude.agda: -------------------------------------------------------------------------------- 1 | module HMTS.Prelude where 2 | 3 | open import Level 4 | open import Function 5 | open import Relation.Nullary 6 | open import Relation.Nullary.Decidable 7 | open import Relation.Binary.PropositionalEquality 8 | open import Data.Bool 9 | open import Data.Nat as Nat 10 | open import Data.Fin 11 | open import Data.Unit 12 | open import Data.Maybe as Maybe 13 | open import Data.Product 14 | open import Data.List as List 15 | open import Data.Vec as Vec hiding (lookup; _∈_; module _∈_) 16 | open import Category.Monad 17 | open RawMonad {{...}} public hiding (pure) 18 | 19 | infix 4 _∈_ 20 | 21 | -- I imported this from `Data.List.Any' first, 22 | -- but it's less cumbersome to just redefine. 23 | data _∈_ {α} {A : Set α} (x : A) : List A -> Set α where 24 | vz : ∀ {xs} -> x ∈ x ∷ xs 25 | vs_ : ∀ {y} {xs} -> x ∈ xs -> x ∈ y ∷ xs 26 | 27 | instance 28 | Maybe-monad : ∀ {ℓ} -> RawMonad {ℓ} Maybe 29 | Maybe-monad = Maybe.monad 30 | 31 | _==_ : ℕ -> ℕ -> Bool 32 | n == m = ⌊ n Nat.≟ m ⌋ 33 | 34 | _∈?_ : ℕ -> List ℕ -> Bool 35 | n ∈? ns = List.any (_==_ n) ns 36 | 37 | lookup : ∀ {α} {A : Set α} -> ℕ -> List (ℕ × A) -> Maybe A 38 | lookup n [] = nothing 39 | lookup n ((m , x) ∷ xs) = if n == m then just x else lookup n xs 40 | 41 | delete : ℕ -> List ℕ -> List ℕ 42 | delete n [] = [] 43 | delete n (m ∷ ms) = if n == m then ms else m ∷ delete n ms 44 | 45 | union : List ℕ -> List ℕ -> List ℕ 46 | union ns ms = ns List.++ List.foldr delete ms ns 47 | 48 | lookup-in : ∀ {α n} {A : Set α} i -> (xs : Vec A n) -> Vec.lookup i xs ∈ toList xs 49 | lookup-in zero (x ∷ xs) = vz 50 | lookup-in (suc i) (x ∷ xs) = vs (lookup-in i xs) 51 | 52 | _>>=ᵀ_ : ∀ {α} {A : Set α} {b : A -> Level} 53 | -> (mx : Maybe A) -> (B : ∀ x -> Set (b x)) -> Set (maybe b Level.zero mx) 54 | nothing >>=ᵀ B = ⊤ 55 | just x >>=ᵀ B = B x 56 | 57 | _>>=⊤_ : ∀ {α} {A : Set α} {b : A -> Level} {B : ∀ x -> Set (b x)} 58 | -> (mx : Maybe A) -> (∀ x -> B x) -> mx >>=ᵀ B 59 | nothing >>=⊤ f = _ 60 | just x >>=⊤ f = f x 61 | 62 | next : ℕ -> ℕ 63 | next = Nat.suc 64 | -------------------------------------------------------------------------------- /VanillaTypedJigger.agda: -------------------------------------------------------------------------------- 1 | infixr 5 _⇒_ 2 | infixl 6 _▻_ _▻▻_ 3 | infix 3 _⊢_ _∈_ 4 | infixr 5 vs_ 5 | infixr 4 ƛ_ 6 | infixl 6 _·_ 7 | 8 | data Type : Set where 9 | ⋆ : Type 10 | _⇒_ : Type -> Type -> Type 11 | 12 | -- Contexts are snoc-lists 13 | 14 | data Con : Set where 15 | ε : Con 16 | _▻_ : (Γ : Con) (τ : Type) -> Con 17 | 18 | data _∈_ σ : Con -> Set where 19 | vz : ∀ {Γ} -> σ ∈ Γ ▻ σ 20 | vs_ : ∀ {Γ τ} -> σ ∈ Γ -> σ ∈ Γ ▻ τ 21 | 22 | data _⊢_ Γ : Type -> Set where 23 | var : ∀ {σ} -> σ ∈ Γ -> Γ ⊢ σ 24 | ƛ_ : ∀ {σ τ} -> Γ ▻ σ ⊢ τ -> Γ ⊢ σ ⇒ τ 25 | _·_ : ∀ {σ τ} -> Γ ⊢ σ ⇒ τ -> Γ ⊢ σ -> Γ ⊢ τ 26 | 27 | Term : Type -> Set 28 | Term σ = ε ⊢ σ 29 | 30 | -- A cons that does not match on the context. 31 | -- This is the main trick to make inference work. 32 | 33 | cons : Type -> Con -> Con 34 | cons σ Γ = init∘cons σ Γ ▻ last∘cons σ Γ 35 | where 36 | last∘cons : Type -> Con -> Type 37 | last∘cons σ ε = σ 38 | last∘cons σ (Γ ▻ τ) = τ 39 | 40 | init∘cons : Type -> Con -> Con 41 | init∘cons σ ε = ε 42 | init∘cons σ (Γ ▻ τ) = cons σ Γ 43 | 44 | _▻▻_ : Con -> Con -> Con 45 | ε ▻▻ Δ = Δ 46 | Γ ▻ σ ▻▻ Δ = Γ ▻▻ cons σ Δ 47 | -- Inference would be better with `(Γ ▻▻ init∘cons σ Δ) ▻ last∘cons σ Δ`, 48 | -- but then `init∘cons` must use something else than `cons`, 49 | -- and I can't figure out what it must use. 50 | 51 | coe : ∀ {α Δ σ} (A : Con -> Set α) Γ -> A (Γ ▻▻ Δ ▻ σ) -> A (Γ ▻▻ (Δ ▻ σ)) 52 | coe A ε x = x 53 | coe A (Γ ▻ τ) x = coe A Γ x 54 | 55 | fit : ∀ {Δ σ} Γ -> σ ∈ Γ ▻▻ cons σ Δ 56 | fit {ε} Γ = coe (_ ∈_) Γ vz 57 | fit {Δ ▻ τ} Γ = coe (_ ∈_) Γ (vs (fit Γ)) 58 | 59 | lam : ∀ {Γ σ τ} -> ((∀ {Δ} -> Γ ▻ σ ▻▻ Δ ⊢ σ) -> Γ ▻ σ ⊢ τ) -> Γ ⊢ σ ⇒ τ 60 | lam {Γ} k = ƛ k (var (fit Γ)) 61 | 62 | I : Term (⋆ ⇒ ⋆) 63 | I = lam λ x -> x 64 | 65 | K : Term (⋆ ⇒ ⋆ ⇒ ⋆) 66 | K = lam λ x -> lam λ y -> y 67 | 68 | A : Term ((⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆) 69 | A = lam λ f -> lam λ x -> f · x 70 | 71 | O : Term (((⋆ ⇒ ⋆) ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆) 72 | O = lam λ g -> lam λ f -> f · (g · f) 73 | 74 | O-η : Term (((⋆ ⇒ ⋆) ⇒ ⋆) ⇒ (⋆ ⇒ ⋆) ⇒ ⋆) 75 | O-η = lam λ g -> lam λ f -> f · (g · lam λ x -> f · x) 76 | -------------------------------------------------------------------------------- /TABA.agda: -------------------------------------------------------------------------------- 1 | -- Related to 2 | 3 | -- "There and Back Again", Olivier Danvy, Mayer 4 | -- Goldberg http://www.brics.dk/RS/05/3/BRICS-RS-05-3.pdf 5 | 6 | -- and 7 | 8 | -- ""There and Back Again" and What Happened After", Kenneth Foner 9 | -- https://github.com/kwf/TABA-AWHA 10 | 11 | open import Function 12 | open import Relation.Binary.PropositionalEquality 13 | open import Data.Nat.Base 14 | open import Data.Product 15 | open import Data.Vec 16 | 17 | data Diff n : ℕ -> ℕ -> Set where 18 | base : Diff n 0 n 19 | step : ∀ {m p} -> Diff n m (suc p) -> Diff n (suc m) p 20 | 21 | gsame : ∀ {α} (A : ℕ -> ℕ -> ℕ -> Set α) 22 | -> (∀ {n m p} -> A n m (suc p) -> A n (suc m) p) 23 | -> (∀ {n} -> A n 0 n) 24 | -> (n : ℕ) 25 | -> A n n 0 26 | gsame A s b 0 = b 27 | gsame A s b (suc n) = s (gsame (λ n m p -> A (suc n) m (suc p)) s b n) 28 | 29 | same : ∀ {n} -> Diff n n 0 30 | same = gsame Diff step base _ 31 | 32 | convolve : ∀ {α β n} {A : Set α} {B : Set β} -> Vec A n -> Vec B n -> Vec (A × B) n 33 | convolve {n = n} {A} {B} xs ys = proj₁ (walk same xs) where 34 | walk : ∀ {m p} -> Diff n m p -> Vec A m -> Vec (A × B) m × Vec B p 35 | walk base [] = [] , ys 36 | walk (step d) (x ∷ xs) with walk d xs 37 | ... | ps , y ∷ ys' = ((x , y) ∷ ps) , ys' 38 | 39 | open import Data.Fin 40 | 41 | same₁ : ∀ {n} -> Diff (suc n) n 1 42 | same₁ = gsame (λ n m p -> Diff (suc n) m (suc p)) step base _ 43 | 44 | lookupʳ₁ : ∀ {α n} {A : Set α} -> Fin (suc n) -> Vec A (suc n) -> A 45 | lookupʳ₁ {n = n} {A} i = proj₂ ∘ go same₁ where 46 | go : ∀ {m p} -> Diff (suc n) m (suc p) -> Vec A (suc m) -> Fin (suc p) × A 47 | go base (x ∷ []) = i , x 48 | go (step d) (x ∷ xs) with go d xs 49 | ... | zero , y = zero , y 50 | ... | suc j , y = j , x 51 | 52 | lookupʳ : ∀ {n α} {A : Set α} -> Fin n -> Vec A n -> A 53 | lookupʳ {0} () 54 | lookupʳ {suc _} = lookupʳ₁ 55 | 56 | lookupʳ-test₀ : lookupʳ zero (0 ∷ 1 ∷ 2 ∷ []) ≡ 2 57 | lookupʳ-test₀ = refl 58 | 59 | lookupʳ-test₁ : lookupʳ (suc zero) (0 ∷ 1 ∷ 2 ∷ []) ≡ 1 60 | lookupʳ-test₁ = refl 61 | 62 | lookupʳ-test₂ : lookupʳ (suc (suc zero)) (0 ∷ 1 ∷ 2 ∷ []) ≡ 0 63 | lookupʳ-test₂ = refl 64 | -------------------------------------------------------------------------------- /Eff/Prelude.agda: -------------------------------------------------------------------------------- 1 | module Eff.Prelude where 2 | 3 | open import Level renaming (zero to lzero; suc to lsuc) public 4 | open import Function public 5 | open import Data.Nat.Base hiding (_⊔_; fold) public 6 | open import Data.Fin using (Fin; zero; suc) public 7 | open import Data.Sum renaming (map to smap) public 8 | open import Data.Product renaming (map to pmap) public 9 | open import Data.List.Base renaming (map to lmap) hiding (foldr; zip) public 10 | 11 | infix 4 _≅_ 12 | 13 | data ⊥ {α} : Set α where 14 | record ⊤ {α} : Set α where 15 | constructor tt 16 | 17 | data _≅_ {α} {A : Set α} (x : A) : ∀ {β} {B : Set β} -> B -> Set where 18 | hrefl : x ≅ x 19 | 20 | hsym : ∀ {α β} {A : Set α} {B : Set β} {x : A} {y : B} -> x ≅ y -> y ≅ x 21 | hsym hrefl = hrefl 22 | 23 | instance 24 | refl-instance : ∀ {α} {A : Set α} {x : A} -> x ≅ x 25 | refl-instance = hrefl 26 | 27 | inj₁-instance : ∀ {α β} {A : Set α} {B : Set β} {{x : A}} -> A ⊎ B 28 | inj₁-instance {{x}} = inj₁ x 29 | 30 | inj₂-instance : ∀ {α β} {A : Set α} {B : Set β} {{x : B}} -> A ⊎ B 31 | inj₂-instance {{y}} = inj₂ y 32 | 33 | -- left, right 34 | 35 | first : ∀ {α β γ} {A : Set α} {B : Set β} {C : A -> Set γ} 36 | -> (∀ x -> C x) -> (p : A × B) -> C (proj₁ p) × B 37 | first f (x , y) = f x , y 38 | 39 | second : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : A -> Set γ} 40 | -> (∀ {x} -> B x -> C x) -> Σ A B -> Σ A C 41 | second g (x , y) = x , g y 42 | 43 | record Tag {α β} {A : Set α} (B : A -> Set β) (x : A) : Set β where 44 | constructor tag 45 | field detag : B x 46 | tagOf = x 47 | open Tag public 48 | 49 | Tag₂ : ∀ {α β γ} {A : Set α} {B : A -> Set β} -> (∀ x -> B x -> Set γ) -> ∀ x -> B x -> Set γ 50 | Tag₂ C x y = Tag (uncurry C) (x , y) 51 | 52 | tagWith : ∀ {α β} {A : Set α} {B : (x : A) -> Set β} -> (x : A) -> B x -> Tag B x 53 | tagWith _ = tag 54 | 55 | hsubst : ∀ {α β} {A : Set α} {x y} -> (B : A -> Set β) -> x ≅ y -> B x -> B y 56 | hsubst B hrefl = id 57 | 58 | module _ where 59 | open import Relation.Binary.PropositionalEquality.TrustMe 60 | 61 | hSubst : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : A -> Set γ} {x} -> B ≅ C -> B x -> C x 62 | hSubst {β = β} {γ} rewrite trustMe {x = β} {γ} = hsubst (_$ _) 63 | -------------------------------------------------------------------------------- /Desc/Prop.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Relation.Binary.PropositionalEquality 3 | open import Data.Sum 4 | open import Data.Product 5 | 6 | infixr 5 _⊕_ 7 | 8 | data Desc (I : Set) : Set₁ where 9 | ret : I -> Desc I 10 | π : (A : Set) -> (A -> Desc I) -> Desc I 11 | _⊕_ : Desc I -> Desc I -> Desc I 12 | ind : I -> Desc I -> Desc I 13 | 14 | ⟦_⟧ : ∀ {I} -> Desc I -> (I -> Set) -> I -> Set 15 | ⟦ ret i ⟧ B j = i ≡ j 16 | ⟦ π A D ⟧ B j = ∃ λ x -> ⟦ D x ⟧ B j 17 | ⟦ D ⊕ E ⟧ B j = ⟦ D ⟧ B j ⊎ ⟦ E ⟧ B j 18 | ⟦ ind i D ⟧ B j = B i × ⟦ D ⟧ B j 19 | 20 | data μ {I} (D : Desc I) j : Set where 21 | node : ⟦ D ⟧ (μ D) j -> μ D j 22 | 23 | Elim : ∀ {I B} -> (∀ {i} -> B i -> Set) -> (D : Desc I) -> (∀ {j} -> ⟦ D ⟧ B j -> B j) -> Set 24 | Elim C (ret i) k = C (k refl) 25 | Elim C (π A D) k = ∀ x -> Elim C (D x) (k ∘ _,_ x) 26 | Elim C (D ⊕ E) k = Elim C D (k ∘ inj₁) × Elim C E (k ∘ inj₂) 27 | Elim C (ind i D) k = ∀ {y} -> C y -> Elim C D (k ∘ _,_ y) 28 | 29 | module _ {I} {D₀ : Desc I} (P : ∀ {j} -> μ D₀ j -> Set) (f₀ : Elim P D₀ node) where 30 | mutual 31 | elimSem : ∀ {j} 32 | -> (D : Desc I) {k : ∀ {j} -> ⟦ D ⟧ (μ D₀) j -> μ D₀ j} 33 | -> Elim P D k 34 | -> (e : ⟦ D ⟧ (μ D₀) j) 35 | -> P (k e) 36 | elimSem (ret i) z refl = z 37 | elimSem (π A D) f (x , e) = elimSem (D x) (f x) e 38 | elimSem (D ⊕ E) (f , g) (inj₁ x) = elimSem D f x 39 | elimSem (D ⊕ E) (f , g) (inj₂ y) = elimSem E g y 40 | elimSem (ind i D) f (d , e) = elimSem D (f (elim d)) e 41 | 42 | elim : ∀ {j} -> (d : μ D₀ j) -> P d 43 | elim (node e) = elimSem D₀ f₀ e 44 | 45 | 46 | 47 | open import Data.Unit.Base 48 | open import Data.Nat.Base 49 | 50 | vec : Set -> Desc ℕ 51 | vec A = ret 0 52 | ⊕ π ℕ λ n -> π A λ _ -> ind n $ ret (suc n) 53 | 54 | Vec : Set -> ℕ -> Set 55 | Vec A = μ (vec A) 56 | 57 | pattern [] = node (inj₁ refl) 58 | pattern _∷_ {n} x xs = node (inj₂ (n , x , xs , refl)) 59 | 60 | elimVec : ∀ {n A} 61 | -> (P : ∀ {n} -> Vec A n -> Set) 62 | -> (∀ {n} x {xs : Vec A n} -> P xs -> P (x ∷ xs)) 63 | -> P [] 64 | -> (xs : Vec A n) 65 | -> P xs 66 | elimVec P f z = elim P (z , λ _ -> f) 67 | -------------------------------------------------------------------------------- /Yoneda.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | open import Function 4 | open import Relation.Binary.PropositionalEquality 5 | 6 | open ≡-Reasoning 7 | 8 | record _≃_ (A B : Set) : Set where 9 | field 10 | f : A -> B 11 | f⁻¹ : B -> A 12 | .isoˡ : f⁻¹ ∘ f ≗ id 13 | .isoʳ : f ∘ f⁻¹ ≗ id 14 | 15 | record Functor (F : Set -> Set) : Set where 16 | field 17 | fmap : ∀ {A B} -> (A -> B) -> F A -> F B 18 | .fmap-id : ∀ {A} -> fmap {A} id ≗ id 19 | .fmap-∘ : ∀ {A B C} {g : B -> C} {f : A -> B} -> fmap (g ∘ f) ≗ fmap g ∘ fmap f 20 | 21 | module Parametricity where 22 | module _ {F : Set -> Set} (Ψ : Functor F) where 23 | open Functor Ψ 24 | 25 | postulate 26 | isoˡ : ∀ {A} 27 | -> (η : ∀ {B} -> (A -> B) -> F B) 28 | -> (λ {B} (f : A -> B) -> fmap f (η id)) ≡ η 29 | 30 | Yoneda : ∀ {F : Set -> Set} {A} 31 | -> Functor F -> (∀ {B} -> (A -> B) -> F B) ≃ F A 32 | Yoneda {A = A} Ψ = record 33 | { f = _$ id 34 | ; f⁻¹ = λ x f -> fmap f x 35 | ; isoˡ = isoˡ Ψ 36 | ; isoʳ = fmap-id 37 | } where open Functor Ψ 38 | 39 | -- natural trasformations 40 | record _∸>_ {F₁ F₂} (Ψ₁ : Functor F₁) (Ψ₂ : Functor F₂) : Set where 41 | constructor Nat 42 | 43 | open Functor 44 | 45 | field 46 | η : ∀ A -> F₁ A -> F₂ A 47 | .naturality : ∀ {A B} {f : A -> B} -> η B ∘ fmap Ψ₁ f ≗ fmap Ψ₂ f ∘ η A 48 | 49 | module _ where 50 | open _∸>_ 51 | 52 | η-rule : ∀ {F₁ F₂} {Ψ₁ : Functor F₁} {Ψ₂ : Functor F₂} {N₁ N₂ : Ψ₁ ∸> Ψ₂} 53 | -> η N₁ ≡ η N₂ -> N₁ ≡ N₂ 54 | η-rule refl = refl 55 | 56 | -- covariant hom-functor 57 | ~> : ∀ A -> Functor (λ B -> A -> B) 58 | ~> A = record 59 | { fmap = λ g f -> g ∘ f 60 | ; fmap-id = λ x -> refl 61 | ; fmap-∘ = λ x -> refl 62 | } 63 | 64 | postulate 65 | ext : ∀ {α β} -> Extensionality α β 66 | 67 | Yoneda : ∀ {F : Set -> Set} {A} -> (Ψ : Functor F) -> ((~>) A ∸> Ψ) ≃ F A 68 | Yoneda {A = A} Ψ = record 69 | { f = λ N -> η N A id 70 | ; f⁻¹ = λ ⌜x⌝ -> record 71 | { η = λ B f -> fmap f ⌜x⌝ 72 | ; naturality = λ f -> fmap-∘ ⌜x⌝ 73 | } 74 | ; isoˡ = λ N -> η-rule $ ext λ B -> ext λ f -> sym (naturality N id) 75 | ; isoʳ = fmap-id 76 | } where open _∸>_; open Functor Ψ 77 | -------------------------------------------------------------------------------- /Diff.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Level renaming (zero to lzero; suc to lsuc) 3 | open import Relation.Binary.PropositionalEquality 4 | open import Data.Nat.Base 5 | open import Data.Fin using (Fin; zero; suc; fromℕ) 6 | 7 | infixr 9 _∘ᵈ_ 8 | 9 | record Diff (k : ℕ -> ℕ) : Set where 10 | field βk : ∀ {n} -> k (suc n) ≡ suc (k n) 11 | 12 | module Kit {n α} (A : ℕ -> Set α) where 13 | ink : A (suc (k n)) -> A (k (suc n)) 14 | ink = subst A (sym βk) 15 | 16 | outk : A (k (suc n)) -> A (suc (k n)) 17 | outk = subst A βk 18 | 19 | unink : ∀ {β} {B : Set β} -> (f : ∀ {n} -> (x : A n) -> B) -> f ∘ ink ≗ f 20 | unink f x rewrite βk {n} = refl 21 | 22 | unoutk : ∀ {β} {B : Set β} -> (f : ∀ {n} -> (x : A n) -> B) -> f ∘ outk ≗ f 23 | unoutk f x rewrite βk {n} = refl 24 | 25 | ink-outk : ink ∘ outk ≗ id 26 | ink-outk x rewrite βk {n} = refl 27 | 28 | outk-ink : outk ∘ ink ≗ id 29 | outk-ink x rewrite βk {n} = refl 30 | 31 | module DiffKit {k} (d : Diff k) where 32 | open Diff d public 33 | open Kit public 34 | 35 | module DiffKitOver {α k} (A : ℕ -> Set α) (d : Diff k) where 36 | open Diff d public 37 | private open module Dummy {n} = Kit {n} A public 38 | 39 | dzero : Diff id 40 | dzero = record { βk = refl } 41 | 42 | module _ {k} (d : Diff k) where 43 | open Diff d 44 | 45 | dsucˡ : Diff (suc ∘ k) 46 | dsucˡ = record { βk = cong suc βk } 47 | 48 | dsucʳ : Diff (k ∘ suc) 49 | dsucʳ = record { βk = βk } 50 | 51 | dnum : ∀ n -> Diff (n +_) 52 | dnum 0 = dzero 53 | dnum (suc n) = dsucˡ (dnum n) 54 | 55 | done : Diff suc 56 | done = dnum 1 57 | 58 | _∘ᵈ_ : ∀ {k₂ k₁} -> Diff k₂ -> Diff k₁ -> Diff (k₂ ∘ k₁) 59 | _∘ᵈ_ {k₂} d₂ d₁ = let open Diff in record { βk = trans (cong k₂ (βk d₁)) (βk d₂) } 60 | 61 | module _ {k} (d : Diff k) where 62 | open DiffKitOver Fin d 63 | 64 | injectd : ∀ {n} -> Fin n -> Fin (k n) 65 | injectd zero = ink zero 66 | injectd (suc i) = ink (suc (injectd i)) 67 | 68 | inject+′ : ∀ {n} m -> Fin n -> Fin (m + n) 69 | inject+′ m = injectd (dnum m) 70 | 71 | revertd : ∀ {k n} -> Diff k -> Fin n -> Fin (k n) 72 | revertd d zero = injectd d (fromℕ _) 73 | revertd d (suc i) = revertd (dsucʳ d) i 74 | 75 | revert : ∀ {n} -> Fin n -> Fin n 76 | revert = revertd dzero 77 | -------------------------------------------------------------------------------- /HomoFree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, DataKinds, TypeFamilies, TemplateHaskell, TypeOperators #-} 2 | 3 | import Data.Functor 4 | import Data.Singletons.TH 5 | import Data.Singletons.Prelude 6 | 7 | $(singletons [d| data Nat = Z | S Nat |]) 8 | 9 | data HomoFree n f a where 10 | Pure :: a -> HomoFree Z f a 11 | Free :: f (HomoFree n f a) -> HomoFree (S n) f a 12 | 13 | mapFree :: Functor f => (a -> b) -> HomoFree n f a -> HomoFree n f b 14 | mapFree f (Pure x) = Pure $ f x 15 | mapFree f (Free fx) = Free $ mapFree f <$> fx 16 | 17 | type family IterN n f a where 18 | IterN Z f a = a 19 | IterN (S n) f a = f (IterN n f a) 20 | 21 | toFree :: (Functor f, SingI n) => IterN n f a -> HomoFree n f a 22 | toFree = go sing where 23 | go :: Functor f => Sing n -> IterN n f a -> HomoFree n f a 24 | go SZ x = Pure x 25 | go (SS n) fx = Free $ go n <$> fx 26 | 27 | fromFree :: Functor f => HomoFree n f a -> IterN n f a 28 | fromFree (Pure x) = x 29 | fromFree (Free fx) = fromFree <$> fx 30 | 31 | lowerFree :: (Functor f, SingI n) => HomoFree (S n) f a -> HomoFree n f (f a) 32 | lowerFree = go sing where 33 | go :: Functor f => Sing n -> HomoFree (S n) f a -> HomoFree n f (f a) 34 | go SZ (Free fx) = Pure $ fromFree <$> fx 35 | go (SS n) (Free fx) = Free $ go n <$> fx 36 | 37 | type family n :+ m :: Nat where 38 | Z :+ m = m 39 | (S n) :+ m = S (n :+ m) 40 | 41 | nmapFree :: Functor f 42 | => Sing n 43 | -> (HomoFree m f a -> HomoFree p f b) 44 | -> HomoFree (n :+ m) f a 45 | -> HomoFree (n :+ p) f b 46 | nmapFree SZ f h = f h 47 | nmapFree (SS n) f (Free fx) = Free $ nmapFree n f <$> fx 48 | 49 | sumFree :: SingI n => HomoFree (S n) [] Int -> HomoFree n [] Int 50 | sumFree = mapFree sum . lowerFree 51 | 52 | xs = [[[1, 2, 3], [4, 5, 6]], [[7, 8, 9]]] 53 | 54 | main = do 55 | print $ fromFree . mapFree (+ 1) $ (toFree xs :: HomoFree (S (S (S Z))) [] Int ) -- [[[2,3,4],[5,6,7]],[[8,9,10]]] 56 | print $ fromFree . mapFree sum $ (toFree xs :: HomoFree (S (S Z )) [] [Int]) -- [[6,15],[24]] 57 | print $ fromFree . sumFree $ (toFree xs :: HomoFree (S (S (S Z))) [] Int ) -- [[6,15],[24]] 58 | print $ fromFree . nmapFree (SS (SS SZ)) sumFree $ (toFree xs :: HomoFree (S (S (S Z))) [] Int ) -- [[6,15],[24]] -------------------------------------------------------------------------------- /Kitchen/FreerKitchen.agda: -------------------------------------------------------------------------------- 1 | open import Level renaming (zero to lzero; suc to lsuc) 2 | open import Function 3 | open import Relation.Nullary.Decidable 4 | open import Data.Empty 5 | open import Data.Unit.Base 6 | open import Data.Bool.Base hiding (_≟_) 7 | open import Data.Nat.Base hiding (_⊔_) 8 | open import Data.Product 9 | open import Data.List.Base 10 | 11 | infixl 1 _>>=_ _>>_ 12 | 13 | data IFreer {ι α β γ} {I : Set ι} (F : Set β -> I -> I -> Set γ) 14 | (A : Set α) : I -> I -> Set (ι ⊔ α ⊔ lsuc β ⊔ γ) where 15 | pure : ∀ {i} -> A -> IFreer F A i i 16 | free : ∀ {i j k B} -> F B i j -> (B -> IFreer F A j k) -> IFreer F A i k 17 | 18 | _>>=_ : ∀ {ι α β γ δ} {I : Set ι} {F : Set γ -> I -> I -> Set δ} {A : Set α} {B : Set β} {i j k} 19 | -> IFreer F A i j -> (A -> IFreer F B j k) -> IFreer F B i k 20 | pure x >>= f = f x 21 | free a g >>= f = free a λ y -> g y >>= f 22 | 23 | _>>_ : ∀ {ι α β γ δ} {I : Set ι} {F : Set γ -> I -> I -> Set δ} {A : Set α} {B : Set β} {i j k} 24 | -> IFreer F A i j -> IFreer F B j k -> IFreer F B i k 25 | a >> b = a >>= λ _ -> b 26 | 27 | liftF : ∀ {ι α γ} {I : Set ι} {F : Set α -> I -> I -> Set γ} {A : Set α} {i j} 28 | -> F A i j -> IFreer F A i j 29 | liftF x = free x pure 30 | 31 | 32 | 33 | record Sing {α} {A : Set α} (x : A) : Set where 34 | 35 | _==_ : ℕ -> ℕ -> Bool 36 | n == m = ⌊ n ≟ m ⌋ 37 | 38 | _∈?_ : ℕ -> List ℕ -> Set 39 | n ∈? ns = foldr (λ m r -> if n == m then ⊤ else r) ⊥ ns 40 | 41 | remove : ∀ n ns -> n ∈? ns -> List ℕ 42 | remove n [] () 43 | remove n (m ∷ ns) p with n == m 44 | ... | true = ns 45 | ... | false = m ∷ remove n ns p 46 | 47 | fresh : List ℕ -> ℕ 48 | fresh [] = 0 49 | fresh (n ∷ ns) = suc n 50 | 51 | data KitchenF : Set -> List ℕ -> List ℕ -> Set where 52 | bakeF : ∀ {is} -> KitchenF (Sing (fresh is)) is (fresh is ∷ is) 53 | eatF : ∀ {is i} -> (p : i ∈? is) -> Sing i -> KitchenF ⊤ is (remove i is p) 54 | 55 | Kitchen : ∀ {α} -> Set α -> List ℕ -> List ℕ -> Set _ 56 | Kitchen = IFreer KitchenF 57 | 58 | bake : ∀ {is} -> Kitchen (Sing (fresh is)) is (fresh is ∷ is) 59 | bake = liftF bakeF 60 | 61 | eat : ∀ {is i} {p : i ∈? is} -> Sing i -> Kitchen ⊤ is (remove i is p) 62 | eat {p = p} c = liftF (eatF p c) 63 | 64 | ok : Kitchen ⊤ [] [ _ ] 65 | ok = bake >>= λ brownie -> 66 | bake >>= λ muffin -> 67 | bake >>= λ cupcake -> 68 | eat muffin >> 69 | eat brownie >> 70 | pure _ 71 | -------------------------------------------------------------------------------- /UncurryN.agda: -------------------------------------------------------------------------------- 1 | -- Based on 2 | -- http://stackoverflow.com/questions/29179508/arity-generic-programming-in-agda 3 | -- http://effectfully.blogspot.com/2016/04/generic-universe-polymorphic.html 4 | -- http://effectfully.blogspot.com/2016/06/deriving-eliminators-of-described-data.html 5 | 6 | open import Level renaming (zero to lzero; suc to lsuc) 7 | open import Function 8 | open import Data.Nat.Base hiding (_⊔_) 9 | open import Data.Product 10 | 11 | infixl 6 _^_ 12 | 13 | record Nil {α} : Set α where 14 | constructor [] 15 | 16 | _^_ : ∀ {α} -> Set α -> ℕ -> Set α 17 | A ^ 0 = Nil 18 | A ^ suc n = A × A ^ n 19 | 20 | foldr : ∀ {n α β} {A : Set α} 21 | -> (B : ℕ -> Set β) -> (∀ {n} -> A -> B n -> B (suc n)) -> B 0 -> A ^ n -> B n 22 | foldr {0} B f z [] = z 23 | foldr {suc n} B f z (x , xs) = f x (foldr B f z xs) 24 | 25 | _⊔ⁿ_ : ∀ {n} -> Level ^ n -> Level -> Level 26 | _⊔ⁿ_ = flip $ foldr _ _⊔_ 27 | 28 | max₀ : ∀ {n} -> Level ^ n -> Level 29 | max₀ = _⊔ⁿ lzero 30 | 31 | Tele : ∀ {n} -> (αs : Level ^ n) -> Set (foldr _ (_⊔_ ∘ lsuc) lzero αs) 32 | Tele {0} [] = Nil 33 | Tele {suc n} (α , αs) = Σ (Set α) λ A -> A -> Tele αs 34 | 35 | TList : ∀ {n} {αs : Level ^ n} -> Tele αs -> Set (max₀ αs) 36 | TList {0} [] = Nil 37 | TList {1} (A , _) = A 38 | TList {suc n} (A , R) = Σ A λ x -> TList (R x) 39 | 40 | Hyp : ∀ {n β} {αs : Level ^ n} -> (As : Tele αs) -> (TList As -> Set β) -> Set (αs ⊔ⁿ β) 41 | Hyp {0} [] B = B [] 42 | Hyp {1} (A , _) B = (x : A) -> B x 43 | Hyp {suc (suc n)} (A , R) B = (x : A) -> Hyp (R x) (B ∘ _,_ x) 44 | 45 | uncurryⁿ : ∀ n {β} {αs : Level ^ n} {As : Tele αs} {B : TList As -> Set β} 46 | -> Hyp As B -> ∀ xs -> B xs 47 | uncurryⁿ 0 y [] = y 48 | uncurryⁿ 1 f x = f x 49 | uncurryⁿ (suc (suc n)) f (x , xs) = uncurryⁿ (suc n) (f x) xs 50 | 51 | private 52 | uncurry₀ : ∀ {a b} {A : Set a} {B : A → Set b} → ((x : A) → B x) → (x : A) → B x 53 | uncurry₀ = uncurryⁿ 1 54 | 55 | uncurry₂ : ∀ {a b c} {A : Set a} {B : A → Set b} {C : Σ A B → Set c} → 56 | ((x : A) → (y : B x) → C (x , y)) → 57 | ((p : Σ A B) → C p) 58 | uncurry₂ = uncurryⁿ 2 59 | 60 | uncurry₃ : ∀ {a b c d} {A : Set a} {B : A → Set b} {C : ∀ x → B x → Set c} {D : ∃₂ C → Set d} → 61 | ((x : A) → (y : B x) → (z : C x y) → D (x , y , z)) → 62 | ((p : ∃₂ C) → D p) 63 | uncurry₃ = uncurryⁿ 3 64 | -------------------------------------------------------------------------------- /Rose/NonGADT.agda: -------------------------------------------------------------------------------- 1 | open import Level renaming (zero to lzero; suc to lsuc) 2 | open import Data.List.Base 3 | open import Data.Product 4 | 5 | infixr 5 _∷₁_ 6 | 7 | data List₁ {α β} {A : Set α} (B : A -> Set β) : List A -> Set β where 8 | []₁ : List₁ B [] 9 | _∷₁_ : ∀ {x xs} -> B x -> List₁ B xs -> List₁ B (x ∷ xs) 10 | 11 | data Somewhere {α β} {A : Set α} (B : A -> Set β) : List A -> Set β where 12 | here : ∀ {x xs} -> B x -> Somewhere B (x ∷ xs) 13 | there : ∀ {x xs} -> Somewhere B xs -> Somewhere B (x ∷ xs) 14 | 15 | Over : ∀ {ι} -> Set ι -> ∀ α -> Set (ι ⊔ lsuc α) 16 | Over I α = I -> List (Σ (Set α) λ A -> A -> List I) 17 | 18 | record Rose {ι α} {I : Set ι} (F : Over I α) i : Set (ι ⊔ α) where 19 | inductive 20 | constructor rose 21 | field childs : Somewhere (uncurry λ A f -> Σ A λ x -> List₁ (Rose F) (f x)) (F i) 22 | 23 | 24 | 25 | open import Function 26 | open import Relation.Binary.PropositionalEquality 27 | open import Data.Unit.Base 28 | open import Data.Nat.Base 29 | open import Data.Product 30 | 31 | module Nat where 32 | Nat : Set 33 | Nat = Rose (λ _ -> (⊤ , λ _ -> []) ∷ (⊤ , λ _ -> tt ∷ []) ∷ []) tt 34 | 35 | z : Nat 36 | z = rose (here (tt , []₁)) 37 | 38 | s : Nat -> Nat 39 | s n = rose (there (here (tt , (n ∷₁ []₁)))) 40 | 41 | elimNat : ∀ {π} -> (P : Nat -> Set π) -> (∀ {n} -> P n -> P (s n)) -> P z -> ∀ n -> P n 42 | elimNat P f x (rose (here (tt , []₁))) = x 43 | elimNat P f x (rose (there (here (tt , n ∷₁ []₁)))) = f (elimNat P f x n) 44 | elimNat P f x (rose (there (there ()))) 45 | 46 | module Vec where 47 | open Nat 48 | 49 | Vec : ∀ {α} -> Set α -> Nat -> Set α 50 | Vec A = Rose λ n -> (Lift (n ≡ z) , λ _ -> []) 51 | ∷ ((∃ λ m -> n ≡ s m × A) , λ p -> proj₁ p ∷ []) 52 | ∷ [] 53 | 54 | nil : ∀ {α} {A : Set α} -> Vec A z 55 | nil = rose (here (lift refl , []₁)) 56 | 57 | cons : ∀ {n α} {A : Set α} -> A -> Vec A n -> Vec A (s n) 58 | cons x xs = rose (there (here ((, refl , x) , xs ∷₁ []₁))) 59 | 60 | elimVec : ∀ {α π} {A : Set α} {n} 61 | -> (P : ∀ {n} -> Vec A n -> Set π) 62 | -> (∀ {n} {xs : Vec A n} x -> P xs -> P (cons x xs)) 63 | -> P nil 64 | -> (xs : Vec A n) 65 | -> P xs 66 | elimVec P f z (rose (here (lift refl , []₁))) = z 67 | elimVec P f z (rose (there (here ((_ , (refl , x)) , xs ∷₁ []₁)))) = f x (elimVec P f z xs) 68 | elimVec P f z (rose (there (there ()))) 69 | -------------------------------------------------------------------------------- /liftA.agda: -------------------------------------------------------------------------------- 1 | open import Level 2 | open import Function 3 | 4 | infixl 0 _·_ 5 | infixl 9 _% 6 | 7 | _·_ = _$_ 8 | _% = _∘_ 9 | 10 | record Functor {α} (F : Set α -> Set α) : Set (suc α) where 11 | infixl 4 _<$>_ 12 | 13 | field 14 | _<$>_ : ∀ {A B} -> (A -> B) -> F A -> F B 15 | open Functor {{...}} 16 | 17 | record Applicative {α} (F : Set α -> Set α) : Set (suc α) where 18 | infixl 4 _<*>_ 19 | 20 | field 21 | pure : ∀ {A} -> A -> F A 22 | _<*>_ : ∀ {A B} -> F (A -> B) -> F A -> F B 23 | 24 | instance 25 | Applicative<:Functor : Functor F 26 | Applicative<:Functor = record { _<$>_ = _<*>_ ∘ pure } 27 | open Applicative {{...}} 28 | 29 | record Monad {α} (M : Set α -> Set α) : Set (suc α) where 30 | infixl 1 _>>=_ 31 | 32 | field 33 | return : ∀ {A} -> A -> M A 34 | _>>=_ : ∀ {A B} -> M A -> (A -> M B) -> M B 35 | 36 | instance 37 | Monad<:Applicative : Applicative M 38 | Monad<:Applicative = record { pure = return ; _<*>_ = λ mf mx -> mf >>= λ f -> mx >>= return ∘ f } 39 | open Monad {{...}} 40 | 41 | -------------------- 42 | 43 | record _~>_ {α β} (A : Set α) (B : Set β) : Set (α ⊔ β) where 44 | constructor rec 45 | field apply : A -> B 46 | 47 | instance 48 | Id : ∀ {α} {A : Set α} -> A ~> A 49 | Id = rec id 50 | 51 | Ap : ∀ {α γ} {A B : Set α} {C : Set γ} {F : Set α -> Set α} 52 | -> {{_ : F B ~> C}} {{_ : Applicative F}} -> F (A -> B) ~> (F A -> C) 53 | Ap {{rec r}} = rec (r % ∘ _<*>_) 54 | 55 | liftA : ∀ {α γ} {A B : Set α} {C : Set γ} {F : Set α -> Set α} 56 | -> {{_ : F B ~> C}} {{_ : Applicative F}} -> (A -> B) -> F A -> C 57 | liftA {{rec r}} = _~>_.apply (rec (r % ∘ _<$>_)) 58 | 59 | ------------------- 60 | 61 | open import Data.Maybe 62 | open import Data.List 63 | 64 | instance 65 | Maybe-Monad : ∀ {α} -> Monad (Maybe {α}) 66 | Maybe-Monad = record { return = just ; _>>=_ = λ x f -> maybe f nothing x } 67 | 68 | List-Monad : ∀ {α} -> Monad (List {α}) 69 | List-Monad = record { return = [_] ; _>>=_ = flip concatMap } 70 | 71 | open import Data.Nat 72 | open import Data.Product 73 | 74 | test-1 : List ℕ -> List ℕ 75 | test-1 = liftA ℕ.suc 76 | 77 | test-2 : List ℕ -> List ℕ -> List ℕ 78 | test-2 = liftA _+_ 79 | 80 | test-3 : List ℕ -> List (ℕ -> ℕ) 81 | test-3 = liftA _+_ 82 | 83 | test-4 : List (ℕ × ℕ) 84 | test-4 = liftA _,_ · (1 ∷ 2 ∷ 3 ∷ []) · (4 ∷ 5 ∷ []) 85 | 86 | -- Note that _·_ is just an infixl synonym for _$_ 87 | yellow : List (ℕ × ℕ) 88 | yellow = liftA _,_ (1 ∷ 2 ∷ 3 ∷ []) (4 ∷ 5 ∷ []) 89 | -------------------------------------------------------------------------------- /pigeonhole.agda: -------------------------------------------------------------------------------- 1 | -- Based on https://github.com/gallais/potpourri/blob/master/agda/poc/PigeonHole.agda 2 | 3 | open import Function 4 | open import Data.Nat 5 | open import Data.Sum 6 | open import Data.List hiding (map) 7 | 8 | infix 3 _∈_ _⊆_ 9 | 10 | data _∈_ {α} {A : Set α} (x : A) : List A -> Set where 11 | here : ∀ {xs} -> x ∈ x ∷ xs 12 | there : ∀ {xs y} -> x ∈ xs -> x ∈ y ∷ xs 13 | 14 | data repeats {α} {A : Set α} : List A -> Set where 15 | this : ∀ {x xs} -> x ∈ xs -> repeats (x ∷ xs) 16 | other : ∀ {x xs} -> repeats xs -> repeats (x ∷ xs) 17 | 18 | _⊆_ : ∀ {α} {A : Set α} -> List A -> List A -> Set α 19 | xs ⊆ ys = ∀ {z} -> z ∈ xs -> z ∈ ys 20 | 21 | swap : ∀ {α} {A : Set α} {x y} {xs : List A} -> x ∷ y ∷ xs ⊆ y ∷ x ∷ xs 22 | swap here = there here 23 | swap (there here) = here 24 | swap (there (there r)) = there (there r) 25 | 26 | cut : ∀ {α} {A : Set α} {x} {xs ys : List A} -> x ∷ xs ⊆ x ∷ ys -> x ∈ xs ⊎ xs ⊆ ys 27 | cut {xs = []} p = inj₂ λ() 28 | cut {xs = x ∷ xs} p with p (there here) 29 | ... | here = inj₁ here 30 | ... | there x∈ys = map there aux $ cut (p ∘ swap ∘ there) where 31 | aux : _ -> x ∷ xs ⊆ _ 32 | aux p' here = x∈ys 33 | aux p' (there z∈xs) = p' z∈xs 34 | 35 | reduce : ∀ {α} {A : Set α} {x : A} {xs} -> x ∈ xs -> List A 36 | reduce {xs = x ∷ xs} here = xs 37 | reduce {xs = x ∷ xs} (there x∈xs) = x ∷ reduce x∈xs 38 | 39 | bubble : ∀ {α} {A : Set α} {x} {xs ys : List A} 40 | -> x ∷ xs ⊆ ys -> (x∈ys : x ∈ ys) -> x ∷ xs ⊆ x ∷ reduce x∈ys 41 | bubble p here z∈x∷xs = p z∈x∷xs 42 | bubble {x = x} p (there x∈ys) z∈x∷xs with p z∈x∷xs 43 | ... | here = there here 44 | ... | there z∈ys = swap $ there $ bubble aux x∈ys $ there z∈ys where 45 | aux : x ∷ _ ⊆ _ 46 | aux here = x∈ys 47 | aux (there z∈xs) = z∈xs 48 | 49 | reduce-length : ∀ {α} {A : Set α} {x} {xs : List A} 50 | -> (x∈xs : x ∈ xs) 51 | -> (ys : List A) 52 | -> length xs ≤ length ys 53 | -> length (reduce x∈xs) < length ys 54 | reduce-length here ys le = le 55 | reduce-length (there x∈xs) [] () 56 | reduce-length (there x∈xs) (_ ∷ ys) (s≤s le) = s≤s (reduce-length x∈xs ys le) 57 | 58 | pigeonhole : ∀ {α} {A : Set α} 59 | -> (xs ys : List A) -> xs ⊆ ys -> length xs > length ys -> repeats xs 60 | pigeonhole [] ys p () 61 | pigeonhole (x ∷ xs) ys p (s≤s gt) with cut (bubble p (p here)) 62 | ... | inj₁ x∈xs = this x∈xs 63 | ... | inj₂ p' = other (pigeonhole xs (reduce (p here)) p' 64 | (reduce-length (p here) xs gt)) 65 | -------------------------------------------------------------------------------- /Dependent types and runtime data.hs: -------------------------------------------------------------------------------- 1 | -- This is related to http://stackoverflow.com/questions/27029564/how-do-i-build-a-list-with-a-dependently-typed-length/ 2 | 3 | {-# LANGUAGE GADTs, KindSignatures, DataKinds, PolyKinds, RankNTypes, TypeOperators #-} 4 | 5 | import Data.Either 6 | import Data.Functor 7 | import Control.Monad 8 | 9 | data Nat = Z | S Nat 10 | 11 | data Natty :: Nat -> * where 12 | Zy :: Natty Z 13 | Sy :: Natty n -> Natty (S n) 14 | 15 | data Finny :: Nat -> Nat -> * where 16 | FZ :: Finny (S n) Z 17 | FS :: Finny n m -> Finny (S n) (S m) 18 | 19 | type Finny0 n = Finny (S n) 20 | 21 | data Vec :: * -> Nat -> * where 22 | VNil :: Vec a Z 23 | VCons :: a -> Vec a n -> Vec a (S n) 24 | 25 | fromIntNatty :: Int -> (forall n. Natty n -> b) -> b 26 | fromIntNatty 0 f = f Zy 27 | fromIntNatty n f = fromIntNatty (n - 1) (f . Sy) 28 | 29 | fromNattyFinny0 :: Natty n -> (forall m. Finny0 n m -> b) -> b 30 | fromNattyFinny0 Zy f = f FZ 31 | fromNattyFinny0 (Sy n) f = fromNattyFinny0 n (f . FS) 32 | 33 | fromIntNattyFinny0 :: Int -> (forall n m. Natty n -> Finny0 n m -> b) -> b 34 | fromIntNattyFinny0 n f = fromIntNatty n $ \n'' -> fromNattyFinny0 n'' (f n'') 35 | 36 | vfromList :: [a] -> (forall n. Vec a n -> b) -> b 37 | vfromList [] f = f VNil 38 | vfromList (x:xs) f = vfromList xs (f . VCons x) 39 | 40 | vhead :: Vec a (S n) -> a 41 | vhead (VCons x xs) = x 42 | 43 | vtoList :: Vec a n -> [a] 44 | vtoList VNil = [] 45 | vtoList (VCons x xs) = x : vtoList xs 46 | 47 | vlength :: Vec a n -> Natty n 48 | vlength VNil = Zy 49 | vlength (VCons x xs) = Sy (vlength xs) 50 | 51 | vlookup :: Finny n m -> Vec a n -> a 52 | vlookup FZ (VCons x xs) = x 53 | vlookup (FS i) (VCons x xs) = vlookup i xs 54 | 55 | vtake :: Finny0 n m -> Vec a n -> Vec a m 56 | vtake FZ _ = VNil 57 | vtake (FS i) (VCons x xs) = VCons x (vtake i xs) 58 | 59 | data (:<=) :: Nat -> Nat -> * where 60 | Z_le_Z :: Z :<= m 61 | S_le_S :: n :<= m -> S n :<= S m 62 | 63 | type n :< m = S n :<= m 64 | 65 | (<=?) :: Natty n -> Natty m -> Either (m :< n) (n :<= m) 66 | Zy <=? m = Right Z_le_Z 67 | Sy n <=? Zy = Left (S_le_S Z_le_Z) 68 | Sy n <=? Sy m = either (Left . S_le_S) (Right . S_le_S) $ n <=? m 69 | 70 | inject0Le :: Finny0 n p -> n :<= m -> Finny0 m p 71 | inject0Le FZ _ = FZ 72 | inject0Le (FS i) (S_le_S le) = FS (inject0Le i le) 73 | 74 | main = do 75 | xs <- readLn :: IO [Int] 76 | ns <- readLn 77 | forM_ ns $ \n -> putStrLn $ 78 | fromIntNattyFinny0 n $ \n' i' -> 79 | vfromList xs $ \xs' -> 80 | case n' <=? vlength xs' of 81 | Left _ -> "What should I do with this input?" 82 | Right le -> show $ vtoList $ vtake (inject0Le i' le) xs' -------------------------------------------------------------------------------- /IsNat.agda: -------------------------------------------------------------------------------- 1 | -- `IsNat` is the same thing as `IsNatAt`, 2 | -- but without any universe polymorphism related problems. 3 | 4 | open import Level as L using (_⊔_) 5 | open import Function 6 | open import Data.Unit.Base 7 | open import Data.Nat.Base hiding (_⊔_) 8 | open import Data.List.Base 9 | 10 | elimℕ : ∀ {π} 11 | -> (P : ℕ -> Set π) 12 | -> (∀ {n} -> P n -> P (suc n)) 13 | -> P 0 14 | -> ∀ n 15 | -> P n 16 | elimℕ P f z 0 = z 17 | elimℕ P f z (suc n) = f (elimℕ P f z n) 18 | 19 | elimList : ∀ {α π} {A : Set α} 20 | -> (P : List A -> Set π) 21 | -> (∀ {xs} x -> P xs -> P (x ∷ xs)) 22 | -> P [] 23 | -> ∀ xs 24 | -> P xs 25 | elimList P f z [] = z 26 | elimList P f z (x ∷ xs) = f x (elimList P f z xs) 27 | 28 | record HasNat {α} (A : Set α) : Set α where 29 | field 30 | gzero : A 31 | gsuc : A -> A 32 | 33 | data SingNat : A -> Set α where 34 | szero : SingNat gzero 35 | ssuc : ∀ {n} -> SingNat n -> SingNat (gsuc n) 36 | 37 | elimSingNat : ∀ {n π} 38 | -> (P : A -> Set π) 39 | -> (∀ {n} -> P n -> P (gsuc n)) 40 | -> P gzero 41 | -> SingNat n 42 | -> P n 43 | elimSingNat P f z szero = z 44 | elimSingNat P f z (ssuc sn) = f (elimSingNat P f z sn) 45 | open HasNat {{...}} 46 | 47 | record IsNat {α} (A : Set α) {{hasNat : HasNat A}} : Set α where 48 | field 49 | singNat : (n : A) -> SingNat n 50 | 51 | elimNat : ∀ {π} (P : A -> Set π) 52 | -> (∀ {n} -> P n -> P (gsuc n)) 53 | -> P gzero 54 | -> ∀ n 55 | -> P n 56 | elimNat P f z = elimSingNat P f z ∘ singNat 57 | open IsNat {{...}} 58 | 59 | instance 60 | hasNatℕ : HasNat ℕ 61 | hasNatℕ = record { gzero = 0 ; gsuc = suc } 62 | 63 | isNatℕ : IsNat ℕ 64 | isNatℕ = record { singNat = elimℕ SingNat ssuc szero } 65 | 66 | hasNatList⊤ : HasNat (List ⊤) 67 | hasNatList⊤ = record { gzero = [] ; gsuc = _ ∷_ } 68 | 69 | isNatList⊤ : IsNat (List ⊤) 70 | isNatList⊤ = record { singNat = elimList SingNat (const ssuc) szero } 71 | 72 | record IsNatAt {α} π (A : Set α) {{hasNat : HasNat A}} : Set (α ⊔ L.suc π) where 73 | field 74 | elimNat′ : (P : A -> Set π) 75 | -> (∀ {n} -> P n -> P (gsuc n)) 76 | -> P gzero 77 | -> ∀ n 78 | -> P n 79 | 80 | isNatIsNatAt : ∀ {α π} {A : Set α} {{hasNat : HasNat A}} {{isNat : IsNat A}} -> IsNatAt π A 81 | isNatIsNatAt = record { elimNat′ = elimNat } 82 | 83 | isNatAtIsNat : ∀ {α} {A : Set α} {{hasNat : HasNat A}} 84 | -> (isNat : ∀ {π} -> IsNatAt π A) -> IsNat A 85 | isNatAtIsNat isNat = record { singNat = elimNat′ SingNat ssuc szero } 86 | where open IsNatAt isNat 87 | -------------------------------------------------------------------------------- /Normalization/Dependent.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting #-} 2 | 3 | open import Function 4 | open import Relation.Binary.PropositionalEquality 5 | 6 | {-# BUILTIN REWRITE _≡_ #-} 7 | 8 | infixl 6 _·_ 9 | infixr 5 _⇒_ 10 | 11 | mutual 12 | data Type : Set₁ where 13 | emb : Set -> Type 14 | π : ∀ A -> (⟦ A ⟧ᵗ -> Type) -> Type 15 | 16 | ⟦_⟧ᵗ : Type -> Set 17 | ⟦ emb A ⟧ᵗ = A 18 | ⟦ π A B ⟧ᵗ = ∀ x -> ⟦ B x ⟧ᵗ 19 | 20 | mutual 21 | data Term : Type -> Set₁ where 22 | var : ∀ {A} -> ⟦ A ⟧ᵗ -> Term A 23 | _·_ : ∀ {A B} -> Term (π A B) -> (e : Term A) -> Term (B ⟦ e ⟧) 24 | lam : ∀ {A B} -> (∀ x -> Term (B x)) -> Term (π A B) 25 | 26 | ⟦_⟧ : ∀ {A} -> Term A -> ⟦ A ⟧ᵗ 27 | ⟦ var v ⟧ = v 28 | ⟦ f · x ⟧ = ⟦ f ⟧ ⟦ x ⟧ 29 | ⟦ lam k ⟧ = λ x -> ⟦ k x ⟧ 30 | 31 | mutual 32 | data Ne : Type -> Set₁ where 33 | varⁿᵉ : ∀ {A} -> A -> Ne (emb A) 34 | _·ⁿᵉ_ : ∀ {A B} -> Ne (π A B) -> (e : NF A) -> Ne (B ⟦ e ⟧ⁿᶠ) 35 | 36 | data NF : Type -> Set₁ where 37 | neⁿᶠ : ∀ {A} -> Ne A -> NF A 38 | lamⁿᶠ : ∀ {A B} -> (∀ x -> NF (B x)) -> NF (π A B) 39 | 40 | ⟦_⟧ⁿᵉ : ∀ {A} -> Ne A -> ⟦ A ⟧ᵗ 41 | ⟦_⟧ⁿᵉ = ⟦_⟧ ∘ embⁿᵉ 42 | 43 | ⟦_⟧ⁿᶠ : ∀ {A} -> NF A -> ⟦ A ⟧ᵗ 44 | ⟦_⟧ⁿᶠ = ⟦_⟧ ∘ embⁿᶠ 45 | 46 | embⁿᵉ : ∀ {A} -> Ne A -> Term A 47 | embⁿᵉ (varⁿᵉ v) = var v 48 | embⁿᵉ (f ·ⁿᵉ x) = embⁿᵉ f · embⁿᶠ x 49 | 50 | embⁿᶠ : ∀ {A} -> NF A -> Term A 51 | embⁿᶠ (neⁿᶠ n) = embⁿᵉ n 52 | embⁿᶠ (lamⁿᶠ k) = lam λ x -> embⁿᶠ (k x) 53 | 54 | module _ where 55 | ⟦_⟧ᵛ : Type -> Set₁ 56 | reify : ∀ {A} -> ⟦ A ⟧ᵛ -> NF A 57 | unreflect : ∀ {A} -> ⟦ A ⟧ᵛ -> ⟦ A ⟧ᵗ 58 | reflect : ∀ {A} -> ⟦ A ⟧ᵗ -> ⟦ A ⟧ᵛ 59 | 60 | unreflect = ⟦_⟧ⁿᶠ ∘ reify 61 | 62 | postulate 63 | unreflect-reflect : ∀ {A} (x : ⟦ A ⟧ᵗ) -> ⟦ embⁿᶠ (reify (reflect {A} x)) ⟧ ≡ x 64 | {-# REWRITE unreflect-reflect #-} 65 | 66 | ⟦ emb A ⟧ᵛ = Ne (emb A) 67 | ⟦ π A B ⟧ᵛ = ∀ x -> ⟦ B (unreflect {A} x) ⟧ᵛ 68 | 69 | reify {emb A} n = neⁿᶠ n 70 | reify {π A B} f = lamⁿᶠ λ x -> reify (f (reflect x)) 71 | 72 | reflect {emb A} x = varⁿᵉ x 73 | reflect {π A B} f = λ x -> reflect (f (unreflect x)) 74 | 75 | read : ∀ {A} -> ⟦ A ⟧ᵗ -> Term A 76 | read = embⁿᶠ ∘ reify ∘ reflect 77 | 78 | norm : ∀ {A} -> Term A -> Term A 79 | norm = read ∘ ⟦_⟧ 80 | 81 | _⇒_ : Type -> Type -> Type 82 | A ⇒ B = π A λ _ -> B 83 | 84 | I : ∀ {A} -> Term (A ⇒ A) 85 | I = read id 86 | 87 | K : ∀ {A B} -> Term (A ⇒ B ⇒ A) 88 | K = read const 89 | 90 | S : ∀ {A} {B : ⟦ A ⟧ᵗ -> Type} {C : ∀ {x} -> ⟦ B x ⟧ᵗ -> Type} 91 | -> Term ((π A λ x -> π (B x) λ y -> C y) ⇒ π (π A λ x -> B x) λ f -> π A λ x -> C (f x)) 92 | S = read _ˢ_ 93 | 94 | testS : ∀ {A B} {C : ∀ {x} -> ⟦ B x ⟧ᵗ -> Type} -> norm S ≡ S {A} {B} {C} 95 | testS = refl 96 | 97 | testSKI : ∀ {A} -> norm (S · K · I) ≡ I {A} 98 | testSKI = refl 99 | -------------------------------------------------------------------------------- /Normalization/NbE_BSN.agda: -------------------------------------------------------------------------------- 1 | -- Write some tests. 2 | 3 | {-# OPTIONS --no-positivity-check #-} 4 | 5 | open import Function 6 | open import Data.Nat 7 | open import Data.List 8 | 9 | lookup : ∀ {α} {A : Set α} -> ℕ -> List A -> A 10 | lookup 0 (x ∷ xs) = x 11 | lookup (suc n) (x ∷ xs) = lookup n xs 12 | lookup _ _ = ⊥ where postulate ⊥ : _ 13 | 14 | data Type : Set where 15 | ⋆ : Type 16 | _⇒_ : Type -> Type -> Type 17 | 18 | data Term : Set where 19 | var : ℕ -> Term 20 | ƛ : Term -> Term 21 | _·_ : Term -> Term -> Term 22 | 23 | data Neᴾ A : Set where 24 | varⁿ : ℕ -> Neᴾ A 25 | _·ⁿ_ : Neᴾ A -> A -> Neᴾ A 26 | 27 | mutual 28 | data Nf : Set where 29 | ne : Ne -> Nf 30 | ƛⁿ : Nf -> Nf 31 | 32 | Ne = Neᴾ Nf 33 | 34 | mutual 35 | embⁿᵉ : Ne -> Term 36 | embⁿᵉ (varⁿ i) = var i 37 | embⁿᵉ (f ·ⁿ x) = embⁿᵉ f · embⁿᶠ x 38 | 39 | embⁿᶠ : Nf -> Term 40 | embⁿᶠ (ne x) = embⁿᵉ x 41 | embⁿᶠ (ƛⁿ b) = ƛ (embⁿᶠ b) 42 | 43 | data Valᴾ A : Set where 44 | v : A -> Valᴾ A 45 | ƛᵛ : (Valᴾ A -> Valᴾ A) -> Valᴾ A 46 | 47 | Con : Set -> Set 48 | Con A = List (Valᴾ A) 49 | 50 | _$ᵛ_ : ∀ {A} -> Valᴾ A -> Valᴾ A -> Valᴾ A 51 | ƛᵛ f $ᵛ x = f x 52 | v x $ᵛ y = ⊥ where postulate ⊥ : _ 53 | 54 | ⟦_⟧ : ∀ {A} -> Term -> Con A -> Valᴾ A 55 | ⟦ var i ⟧ ρ = lookup i ρ 56 | ⟦ ƛ b ⟧ ρ = ƛᵛ λ x -> ⟦ b ⟧ (x ∷ ρ) 57 | ⟦ f · x ⟧ ρ = ⟦ f ⟧ ρ $ᵛ ⟦ x ⟧ ρ 58 | 59 | normᴾ : ∀ {A} -> (Valᴾ A -> Nf) -> Term -> Term 60 | normᴾ h x = embⁿᶠ (h (⟦ x ⟧ [])) 61 | 62 | module NbE where 63 | Ñf : Set 64 | Ñf = ℕ -> Nf 65 | 66 | Ñe : Set 67 | Ñe = ℕ -> Ne 68 | 69 | Val : Set 70 | Val = Valᴾ Ñf 71 | 72 | mutual 73 | reify : Type -> Val -> Ñf 74 | reify ⋆ (v x) = x 75 | reify (σ ⇒ τ) (ƛᵛ f) = λ i -> ƛⁿ (reify τ (f (reflect σ (λ j -> varⁿ (j ∸ i ∸ 1)))) (suc i)) 76 | reify _ _ = ⊥ where postulate ⊥ : _ 77 | 78 | reflect : Type -> Ñe -> Val 79 | reflect ⋆ x = v (ne ∘ x) 80 | reflect (σ ⇒ τ) f = ƛᵛ λ x -> reflect τ (λ i -> f i ·ⁿ reify σ x i) 81 | 82 | norm : Type -> Term -> Term 83 | norm σ = normᴾ (λ v -> reify σ v 0) 84 | 85 | module BSN where 86 | record Fix (A : Set -> Set) : Set where 87 | constructor F 88 | field x : A (Fix A) 89 | 90 | Val : Set 91 | Val = Fix (Valᴾ ∘ Neᴾ) 92 | 93 | Neᵛ : Set 94 | Neᵛ = Neᴾ Val 95 | 96 | mutual 97 | quoteᵛ : ℕ -> Val -> Nf 98 | quoteᵛ i (F (v x)) = ne (quoteⁿ i x) 99 | quoteᵛ i (F (ƛᵛ f)) = ƛⁿ (quoteᵛ (suc i) (F (f (v (varⁿ i))))) 100 | 101 | quoteⁿ : ℕ -> Neᵛ -> Ne 102 | quoteⁿ i (varⁿ j) = varⁿ (i ∸ j ∸ 1) 103 | quoteⁿ i (f ·ⁿ x) = quoteⁿ i f ·ⁿ quoteᵛ i x 104 | 105 | norm : Term -> Term 106 | norm = normᴾ (quoteᵛ 0 ∘ F) 107 | -------------------------------------------------------------------------------- /Desc/IRDesc.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type #-} 2 | 3 | open import Function 4 | open import Relation.Binary.PropositionalEquality 5 | open import Data.Unit.Base 6 | open import Data.Product 7 | 8 | _∸>_ : ∀ {I} -> (I -> Set) -> (I -> Set) -> Set 9 | A ∸> B = ∀ {i} -> A i -> B i 10 | 11 | data Desc I (R : I -> Set) : Set 12 | 13 | Arg : Set -> Set 14 | Arg I = Desc I (const ⊤) 15 | 16 | ⟦_⟧ : ∀ {I} -> Arg I -> (I -> Set) -> Set 17 | 18 | data Desc I R where 19 | ret : ∀ i -> R i -> Desc I R 20 | π : ∀ A -> (A -> Desc I R) -> Desc I R 21 | σ : ∀ D -> (⟦ D ⟧ R -> Desc I R) -> Desc I R 22 | 23 | pattern ind i = ret i tt 24 | 25 | ⟦ ind i ⟧ B = B i 26 | ⟦ π A D ⟧ B = ∀ x -> ⟦ D x ⟧ B 27 | ⟦ σ D E ⟧ B = ∃ λ x -> ⟦ E x ⟧ B 28 | 29 | imap : ∀ {I B C} -> (B ∸> C) -> (D : Arg I) -> ⟦ D ⟧ B -> ⟦ D ⟧ C 30 | imap g (ret i r) y = g y 31 | imap g (π A D) f = λ x -> imap g (D x) (f x) 32 | imap g (σ D E) (r , y) = r , imap g (E r) y 33 | 34 | Extend : ∀ {I R} -> Desc I R -> (B : I -> Set) -> (B ∸> R) -> I -> Set 35 | Extend (ret i r) B g j = i ≡ j 36 | Extend (π A D) B g j = ∃ λ x -> Extend (D x) B g j 37 | Extend (σ D E) B g j = ∃ λ x -> Extend (E (imap g D x)) B g j 38 | 39 | {-# TERMINATING #-} 40 | mutual 41 | data μ {I R} (D : Desc I R) j : Set where 42 | node : Extend D (μ D) eval j -> μ D j 43 | 44 | eval : ∀ {I R} {D : Desc I R} -> μ D ∸> R 45 | eval {D = D} (node e) = evalExtend D e 46 | 47 | evalExtend : ∀ {I R} ({D} E : Desc I R) -> Extend E (μ D) eval ∸> R 48 | evalExtend (ret i r) refl = r 49 | evalExtend (π A D) (x , e) = evalExtend (D x) e 50 | evalExtend (σ D E) (r , e) = evalExtend (E (imap eval D r)) e 51 | 52 | 53 | 54 | data Descᵗ : Set where 55 | retᵗ πᵗ ⊛ᵗ : Descᵗ 56 | 57 | Desc′ : ∀ I -> (I -> Set) -> Set 58 | Desc′ I = μ $ π Descᵗ λ 59 | { retᵗ -> π (I -> Set) λ R -> 60 | π I λ i -> 61 | π (R i) λ _ -> 62 | ret R (_$ i) 63 | ; πᵗ -> π (I -> Set) λ R -> 64 | π Set λ A -> 65 | σ (π A λ _ -> ind R) λ D -> 66 | ret R (λ B -> ∀ x -> D x B) 67 | ; ⊛ᵗ -> π (I -> Set) λ R -> 68 | σ (ind (const ⊤)) λ D -> 69 | σ (π (D R) λ _ -> ind R) λ E -> 70 | ret R (λ B -> Σ (D R) (λ r -> E r B)) 71 | } 72 | 73 | mutual 74 | toDesc′ : ∀ {I R} -> Desc I R -> Desc′ I R 75 | toDesc′ (ret i r) = node (retᵗ , _ , i , r , refl) 76 | toDesc′ (π A D) = node (πᵗ , _ , A , (λ x -> toDesc′ (D x)) , refl) 77 | toDesc′ (σ D E) = node (⊛ᵗ , _ , toDesc′ D , (λ r -> toDesc′ (E (coe D r))) , refl) 78 | 79 | coe : ∀ {I R} -> (D : Arg I) -> eval (toDesc′ D) R -> ⟦ D ⟧ R 80 | coe (ret i _) r = r 81 | coe (π A D) f = λ x -> coe (D x) (f x) 82 | coe (σ D E) (t , r) = coe D t , coe (E (coe D t)) r 83 | -------------------------------------------------------------------------------- /PolyMonad.agda: -------------------------------------------------------------------------------- 1 | open import Level 2 | open import Function 3 | open import Relation.Binary.PropositionalEquality 4 | 5 | record ⊤ α : Set α where 6 | constructor tt 7 | 8 | _<ℓ_ : Level -> Level -> Set 9 | α <ℓ β = suc α ⊔ β ≡ β 10 | 11 | Coerce′ : ∀ {α β} -> α ≡ β -> Set α -> Set β 12 | Coerce′ refl = id 13 | 14 | coerce′ : ∀ {α β} {A : Set α} -> (q : α ≡ β) -> A -> Coerce′ q A 15 | coerce′ refl = id 16 | 17 | record Monad (M : ∀ {α} -> Set α -> Set α) ω : Set ω where 18 | field 19 | ret : ∀ {α} (q : α <ℓ ω) -> Coerce′ q $ ∀ {_ : ⊤ ω} {A : Set α} -> A -> M A 20 | bind : ∀ {α β} (q : α <ℓ ω) (r : β <ℓ ω) 21 | -> Coerce′ (cong₂ _⊔_ q r) $ 22 | ∀ {_ : ⊤ ω} {A : Set α} {B : Set β} -> M A -> (A -> M B) -> M B 23 | 24 | module Monadic {M : ∀ {α} -> Set α -> Set α} (mMonad : ∀ {ω} -> Monad M ω) where 25 | infixl 1 _>>=_ 26 | 27 | private open module Dummy {ω} = Monad (mMonad {ω}) 28 | 29 | return : ∀ {α} {A : Set α} -> A -> M A 30 | return {α} x = ret {suc α} refl x 31 | 32 | _>>=_ : ∀ {α β} {A : Set α} {B : Set β} -> M A -> (A -> M B) -> M B 33 | _>>=_ {α} {β} a f = bind {suc (α ⊔ β)} refl refl a f 34 | 35 | join : ∀ {α} {A : Set α} -> M (M A) -> M A 36 | join = _>>= id 37 | open Monadic {{...}} public 38 | 39 | module MakeMonad (M : ∀ {α} -> Set α -> Set α) where 40 | makeRet : ∀ {α ω} 41 | -> ({A : Set α} -> A -> M A) 42 | -> (q : α <ℓ ω) 43 | -> Coerce′ q $ ∀ {_ : ⊤ ω} {A : Set α} -> A -> M A 44 | makeRet ret q = coerce′ q λ {_ _} -> ret 45 | 46 | makeBind : ∀ {α β ω} 47 | -> ({A : Set α} {B : Set β} -> M A -> (A -> M B) -> M B) 48 | -> (q : α <ℓ ω) (r : β <ℓ ω) 49 | -> Coerce′ (cong₂ _⊔_ q r) $ 50 | ∀ {_ : ⊤ ω} {A : Set α} {B : Set β} -> M A -> (A -> M B) -> M B 51 | makeBind bind q r = coerce′ (cong₂ _⊔_ q r) λ {_ _ _} -> bind 52 | 53 | private 54 | module Test where 55 | open import Data.List.Base 56 | 57 | instance 58 | ListMonad : ∀ {ω} -> Monad List ω 59 | ListMonad = record 60 | { ret = makeRet (_∷ []) 61 | ; bind = makeBind bind 62 | } where 63 | open MakeMonad List 64 | 65 | bind : ∀ {α β} {A : Set α} {B : Set β} -> List A -> (A -> List B) -> List B 66 | bind [] f = [] 67 | bind (x ∷ xs) f = f x ++ bind xs f 68 | 69 | -- It should be Applicative, I know. 70 | mapM : ∀ {α β} {A : Set α} {B : Set β} 71 | {M : ∀ {α} -> Set α -> Set α} {{mMonad : ∀ {ω} -> Monad M ω}} 72 | -> (A -> M B) -> List A -> M (List B) 73 | mapM f [] = return [] 74 | mapM f (x ∷ xs) = f x >>= λ y -> mapM f xs >>= λ ys -> return (y ∷ ys) 75 | 76 | test₁ : Set -> List Set 77 | test₁ = return 78 | 79 | test₂ : List Set -> (Set -> List Level) -> (Level -> List Set₂) -> List Set₂ 80 | test₂ xs f g = xs >>= f >>= g 81 | 82 | test₃ : List Set 83 | test₃ = join $ mapM (const (Level ∷ ⊤ _ ∷ [])) (Set ∷ []) 84 | -------------------------------------------------------------------------------- /IFreerIFree.agda: -------------------------------------------------------------------------------- 1 | open import Level 2 | open import Function 3 | open import Data.Unit.Base 4 | open import Data.Product 5 | 6 | infixl 1 _>>=ᵣ_ _>>ᵣ_ 7 | 8 | data IFreer {ι α β γ} {I : Set ι} (F : Set β -> I -> I -> Set γ) 9 | (A : Set α) : I -> I -> Set (ι ⊔ α ⊔ suc β ⊔ γ) where 10 | pureᵣ : ∀ {i} -> A -> IFreer F A i i 11 | freeᵣ : ∀ {i j k B} -> F B i j -> (B -> IFreer F A j k) -> IFreer F A i k 12 | 13 | _>>=ᵣ_ : ∀ {ι α β γ δ} {I : Set ι} {F : Set γ -> I -> I -> Set δ} {A : Set α} {B : Set β} {i j k} 14 | -> IFreer F A i j -> (A -> IFreer F B j k) -> IFreer F B i k 15 | pureᵣ x >>=ᵣ f = f x 16 | freeᵣ a g >>=ᵣ f = freeᵣ a λ y -> g y >>=ᵣ f 17 | 18 | _>>ᵣ_ : ∀ {ι α β γ δ} {I : Set ι} {F : Set γ -> I -> I -> Set δ} {A : Set α} {B : Set β} {i j k} 19 | -> IFreer F A i j -> IFreer F B j k -> IFreer F B i k 20 | a >>ᵣ b = a >>=ᵣ λ _ -> b 21 | 22 | liftFᵣ : ∀ {ι α β γ} {I : Set ι} {F : Set β -> I -> I -> Set γ} {A : Set α} {B : Set β} {i j} 23 | -> F B i j -> (B -> A) -> IFreer F A i j 24 | liftFᵣ x g = freeᵣ x (pureᵣ ∘ g) 25 | 26 | 27 | 28 | infixr 0 _◃_ 29 | infixl 1 _>>=_ _>>_ 30 | 31 | record IContainer {ι} (I : Set ι) σ π : Set (ι ⊔ suc (σ ⊔ π)) where 32 | constructor _◃_ 33 | field 34 | Shape : I -> Set σ 35 | Position : ∀ i -> Shape i -> Set π 36 | 37 | ⟦_⟧ᵢ : ∀ {α} -> Set α -> I -> Set (σ ⊔ π ⊔ α) 38 | ⟦_⟧ᵢ A i = ∃ λ sh -> Position i sh -> A 39 | open IContainer 40 | 41 | data IFree {ι σ π α} {I : Set ι} (C : IContainer (I × I) σ π) 42 | (A : Set α) : I -> I -> Set (ι ⊔ σ ⊔ π ⊔ α) where 43 | pure : ∀ {i} -> A -> IFree C A i i 44 | free : ∀ {i j k} sh -> (Position C (i , j) sh -> IFree C A j k) -> IFree C A i k 45 | 46 | _>>=_ : ∀ {ι σ π α β} {I : Set ι} {C : IContainer (I × I) σ π} {A : Set α} {B : Set β} {i j k} 47 | -> IFree C A i j -> (A -> IFree C B j k) -> IFree C B i k 48 | pure x >>= f = f x 49 | free sh r >>= f = free sh λ p -> r p >>= f 50 | 51 | _>>_ : ∀ {ι σ π α β} {I : Set ι} {C : IContainer (I × I) σ π} {A : Set α} {B : Set β} {i j k} 52 | -> IFree C A i j -> IFree C B j k -> IFree C B i k 53 | a >> b = a >>= λ _ -> b 54 | 55 | liftF : ∀ {ι σ π α} {I : Set ι} {C : IContainer (I × I) σ π} {A : Set α} {i j} 56 | -> ⟦ C ⟧ᵢ A (i , j) -> IFree C A i j 57 | liftF (sh , el) = free sh (pure ∘ el) 58 | 59 | 60 | 61 | toIFree : ∀ {ι α β γ} {I : Set ι} {F : Set β -> I -> I -> Set γ} {A : Set α} {i j} 62 | -> IFreer F A i j -> IFree (∃ ∘ flip (uncurry ∘ F) ◃ λ _ -> proj₁) A i j 63 | toIFree (pureᵣ x) = pure x 64 | toIFree (freeᵣ a g) = free (, a) (λ y -> toIFree (g y)) 65 | 66 | toIFreer : ∀ {ι σ π α} {I : Set ι} {C : IContainer (I × I) σ π} {A : Set α} {i j} 67 | -> IFree C A i j -> IFreer (const (curry (Shape C))) A i j 68 | toIFreer (pure x) = pureᵣ x 69 | toIFreer (free sh r) = freeᵣ sh (λ p -> toIFreer (r p)) 70 | 71 | toIFreer′ : ∀ {ι σ π α} {I : Set ι} {C : IContainer (I × I) σ π} {A : Set α} {i j} 72 | -> IFree C A i j -> IFreer (curry ∘ ⟦ C ⟧ᵢ) A i j 73 | toIFreer′ (pure x) = pureᵣ x 74 | toIFreer′ (free sh r) = freeᵣ (sh , id) (λ p -> toIFreer′ (r p)) 75 | -------------------------------------------------------------------------------- /Kitchen/FreeKitchen.agda: -------------------------------------------------------------------------------- 1 | open import Level renaming (zero to lzero; suc to lsuc) 2 | open import Function 3 | open import Relation.Nullary.Decidable 4 | open import Data.Empty 5 | open import Data.Unit.Base 6 | open import Data.Bool.Base hiding (_≟_) 7 | open import Data.Nat.Base hiding (_⊔_) 8 | open import Data.Product 9 | open import Data.List.Base 10 | 11 | infixr 0 _◃_ 12 | infixl 1 _>>=_ _>>_ 13 | 14 | record IContainer {ι} (I : Set ι) σ π : Set (ι ⊔ lsuc (σ ⊔ π)) where 15 | constructor _◃_ 16 | field 17 | Shape : I -> Set σ 18 | Position : ∀ i -> Shape i -> Set π 19 | 20 | ⟦_⟧ᵢ : ∀ {α} -> Set α -> I -> Set (σ ⊔ π ⊔ α) 21 | ⟦_⟧ᵢ A i = ∃ λ sh -> Position i sh -> A 22 | open IContainer 23 | 24 | data IFree {ι σ π α} {I : Set ι} (C : IContainer (I × I) σ π) 25 | (A : Set α) : I -> I -> Set (ι ⊔ σ ⊔ π ⊔ α) where 26 | pure : ∀ {i} -> A -> IFree C A i i 27 | free : ∀ {i j k} sh -> (Position C (i , j) sh -> IFree C A j k) -> IFree C A i k 28 | 29 | _>>=_ : ∀ {ι σ π α β} {I : Set ι} {C : IContainer (I × I) σ π} {A : Set α} {B : Set β} {i j k} 30 | -> IFree C A i j -> (A -> IFree C B j k) -> IFree C B i k 31 | pure x >>= f = f x 32 | free sh r >>= f = free sh λ p -> r p >>= f 33 | 34 | _>>_ : ∀ {ι σ π α β} {I : Set ι} {C : IContainer (I × I) σ π} {A : Set α} {B : Set β} {i j k} 35 | -> IFree C A i j -> IFree C B j k -> IFree C B i k 36 | a >> b = a >>= λ _ -> b 37 | 38 | liftF : ∀ {ι σ π α} {I : Set ι} {C : IContainer (I × I) σ π} {A : Set α} {i j} 39 | -> ⟦ C ⟧ᵢ A (i , j) -> IFree C A i j 40 | liftF (sh , el) = free sh (pure ∘ el) 41 | 42 | 43 | 44 | record Sing {α} {A : Set α} (x : A) : Set where 45 | 46 | _==_ : ℕ -> ℕ -> Bool 47 | n == m = ⌊ n ≟ m ⌋ 48 | 49 | _∈?_ : ℕ -> List ℕ -> Set 50 | n ∈? ns = foldr (λ m r -> if n == m then ⊤ else r) ⊥ ns 51 | 52 | remove : ∀ n ns -> n ∈? ns -> List ℕ 53 | remove n [] () 54 | remove n (m ∷ ns) p with n == m 55 | ... | true = ns 56 | ... | false = m ∷ remove n ns p 57 | 58 | fresh : List ℕ -> ℕ 59 | fresh [] = 0 60 | fresh (n ∷ ns) = suc n 61 | 62 | data Kitchen-Shape (is : List ℕ) : List ℕ -> Set where 63 | bakeˢ : Kitchen-Shape is (fresh is ∷ is) 64 | eatˢ : ∀ {i} -> (p : i ∈? is) -> Sing i -> Kitchen-Shape is (remove i is p) 65 | 66 | Kitchen-Position : ∀ {is os} -> Kitchen-Shape is os -> Set 67 | Kitchen-Position {is} bakeˢ = Sing (fresh is) 68 | Kitchen-Position (eatˢ p c) = ⊤ 69 | 70 | Kitchen-Container : IContainer (List ℕ × List ℕ) lzero lzero 71 | Kitchen-Container = record 72 | { Shape = uncurry Kitchen-Shape 73 | ; Position = λ _ -> Kitchen-Position 74 | } 75 | 76 | Kitchen : ∀ {α} -> Set α -> List ℕ -> List ℕ -> Set α 77 | Kitchen = IFree Kitchen-Container 78 | 79 | bake : ∀ {is} -> Kitchen (Sing (fresh is)) is (fresh is ∷ is) 80 | bake = liftF (bakeˢ , id) 81 | 82 | eat : ∀ {is i} {p : i ∈? is} -> Sing i -> Kitchen ⊤ is (remove i is p) 83 | eat {p = p} c = liftF (eatˢ p c , _) 84 | 85 | ok : Kitchen ⊤ [] [ _ ] 86 | ok = bake >>= λ brownie -> 87 | bake >>= λ muffin -> 88 | bake >>= λ cupcake -> 89 | eat brownie >> 90 | eat muffin >> 91 | pure _ 92 | -------------------------------------------------------------------------------- /Categories/Category.agda: -------------------------------------------------------------------------------- 1 | module Categories.Category where 2 | 3 | open import Level public 4 | open import Function using (flip) public 5 | 6 | open import Categories.Setoid public 7 | 8 | open Setoid {{...}} public 9 | open EqReasoning {{...}} public 10 | 11 | record IsCategory 12 | {α β} {Obj : Set α} (_⇒_ : Obj -> Obj -> Set β) 13 | {{setoid : ∀ {A B} -> Setoid (A ⇒ B)}} : Set (α ⊔ β) where 14 | infixr 9 _∘_ 15 | 16 | field 17 | id : ∀ {A} -> A ⇒ A 18 | _∘_ : ∀ {A B C} -> B ⇒ C -> A ⇒ B -> A ⇒ C 19 | 20 | idˡ : ∀ {A B} {f : A ⇒ B} -> id ∘ f ≈ f 21 | idʳ : ∀ {A B} {f : A ⇒ B} -> f ∘ id ≈ f 22 | assoc : ∀ {A B C D} (h : C ⇒ D) {g : B ⇒ C} {f : A ⇒ B} 23 | -> (h ∘ g) ∘ f ≈ h ∘ (g ∘ f) 24 | ∘-resp-≈ : ∀ {A B C} {g₁ g₂ : B ⇒ C} {f₁ f₂ : A ⇒ B} 25 | -> g₁ ≈ g₂ -> f₁ ≈ f₂ -> g₁ ∘ f₁ ≈ g₂ ∘ f₂ 26 | 27 | open IsEquivalenceOn₂ _⇒_ 28 | 29 | isCategoryᵒᵖ : IsCategory (flip _⇒_) 30 | isCategoryᵒᵖ = record 31 | { id = id 32 | ; _∘_ = flip _∘_ 33 | ; idˡ = idʳ 34 | ; idʳ = idˡ 35 | ; assoc = λ _ -> sym (assoc _) 36 | ; ∘-resp-≈ = flip ∘-resp-≈ 37 | } 38 | 39 | module Heterogeneous 40 | {α β} {Obj : Set α} {_⇒_ : Obj -> Obj -> Set β} 41 | {{setoid : ∀ {A B} -> Setoid (A ⇒ B)}} (C : IsCategory _⇒_) where 42 | open IsCategory C; open IsEquivalenceOn₂ _⇒_ 43 | 44 | infix 4 _≋_ 45 | 46 | data _≋_ {A B} (f : A ⇒ B) : ∀ {A' B'} -> A' ⇒ B' -> Set β where 47 | het : ∀ {g} -> f ≈ g -> f ≋ g 48 | 49 | hrefl : ∀ {A B} {f : A ⇒ B} 50 | -> f ≋ f 51 | hrefl = het refl 52 | 53 | hsym : ∀ {A A' B B'} {f : A ⇒ B} {g : A' ⇒ B'} 54 | -> f ≋ g -> g ≋ f 55 | hsym (het p) = het (sym p) 56 | 57 | htrans : ∀ {A A' A'' B B' B''} {f : A ⇒ B} {g : A' ⇒ B'} {h : A'' ⇒ B''} 58 | -> f ≋ g -> g ≋ h -> f ≋ h 59 | htrans (het p) (het q) = het (trans p q) 60 | 61 | ∘-resp-≋ : ∀ {A A' B B' C C'} {g₁ : B ⇒ C} {g₂ : B' ⇒ C'} {f₁ : A ⇒ B} {f₂ : A' ⇒ B'} 62 | -> g₁ ≋ g₂ -> f₁ ≋ f₂ -> g₁ ∘ f₁ ≋ g₂ ∘ f₂ 63 | ∘-resp-≋ (het p) (het q) = het (∘-resp-≈ p q) 64 | 65 | record Category α β : Set (suc (α ⊔ β)) where 66 | infix 4 _⇒_ 67 | 68 | field 69 | {Obj} : Set α 70 | {_⇒_} : Obj -> Obj -> Set β 71 | {{setoid}} : ∀ {A B} -> Setoid (A ⇒ B) 72 | isCategory : IsCategory _⇒_ 73 | 74 | instance 75 | Category->Setoid : ∀ {A B} -> Setoid (A ⇒ B) 76 | Category->Setoid = setoid 77 | 78 | Category->IsCategory : IsCategory _⇒_ 79 | Category->IsCategory = isCategory 80 | 81 | categoryᵒᵖ : Category α β 82 | categoryᵒᵖ = record { isCategory = isCategoryᵒᵖ } where open IsCategory isCategory 83 | 84 | module IsEquivalenceFrom {α β} (C : Category α β) where 85 | open Category C; open IsEquivalenceOn₂ _⇒_ public 86 | 87 | module HeterogeneousFrom {α β} (C : Category α β) where 88 | open Category C; open Heterogeneous isCategory public 89 | 90 | arr-syntax = Category._⇒_ 91 | syntax arr-syntax C A B = A [ C ]⇒ B 92 | 93 | eq-syntax : ∀ {α β} -> (C : Category α β) -> ∀ {A B} -> (f g : A [ C ]⇒ B) -> Set β 94 | eq-syntax C f g = f ≈ g where open Category C 95 | syntax eq-syntax C f g = f [ C ]≈ g 96 | -------------------------------------------------------------------------------- /Omega.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Relation.Binary.PropositionalEquality 3 | open import Data.Empty 4 | open import Data.Bool.Base 5 | open import Data.Nat.Base 6 | open import Data.Nat.Properties.Simple 7 | open import Data.Product 8 | 9 | record Apply {α β} {A : Set α} (B : A -> Set β) x : Set β where 10 | constructor wrap 11 | field unwrap : B x 12 | open Apply 13 | 14 | record Universe : Set₁ where 15 | constructor Ψ 16 | field 17 | {Univ} : Set 18 | ⟦_/_⟧ : Univ -> Set 19 | open Universe 20 | 21 | mutual 22 | data Typeᵤ U : Set where 23 | π σ : ∀ a -> (⟦ U / a ⟧ᵤ -> Typeᵤ U) -> Typeᵤ U 24 | prev : Typeᵤ U 25 | emb : Univ U -> Typeᵤ U 26 | natᵤ : Typeᵤ U 27 | 28 | ⟦_/_⟧ᵤ : ∀ U -> Typeᵤ U -> Set 29 | ⟦ U / π a b ⟧ᵤ = ∀ x -> ⟦ U / b x ⟧ᵤ 30 | ⟦ U / σ a b ⟧ᵤ = ∃ λ x -> ⟦ U / b x ⟧ᵤ 31 | ⟦ U / prev ⟧ᵤ = Univ U 32 | ⟦ U / emb c ⟧ᵤ = ⟦ U / c ⟧ 33 | ⟦ U / natᵤ ⟧ᵤ = ℕ 34 | 35 | {-# TERMINATING #-} -- We only need this for good inference. Everything can be rewritten without 36 | -- the pragma at the cost of providing more explicit arguments to functions. 37 | mutual 38 | Type : ℕ -> Set 39 | Type = Apply (Typeᵤ ∘ univ) 40 | 41 | ⟦_⟧ : ∀ {n} -> Type n -> Set 42 | ⟦_⟧ = ⟦ _ /_⟧ᵤ ∘ unwrap 43 | 44 | univ : ℕ -> Universe 45 | univ 0 = record { Univ = ⊥ ; ⟦_/_⟧ = ⊥-elim } 46 | univ (suc n) = record { Univ = Type n ; ⟦_/_⟧ = ⟦_⟧ } 47 | 48 | infixr 5 _‵π‵_ _⇒_ 49 | 50 | _‵π‵_ : ∀ {n} -> (a : Type n) -> (⟦ a ⟧ -> Type n) -> Type n 51 | a ‵π‵ b = wrap (π (unwrap a) (unwrap ∘ b)) 52 | 53 | _⇒_ : ∀ {n} -> Type n -> Type n -> Type n 54 | a ⇒ b = a ‵π‵ const b 55 | 56 | Type⁺ : ℕ -> Set 57 | Type⁺ n = ∀ {m} -> Type (n + m) 58 | 59 | lift₀ : Type 0 -> Type⁺ 0 60 | lift₀ a {0} = a 61 | lift₀ a {suc m} = wrap (emb (lift₀ a)) 62 | 63 | lift : ∀ {n} -> Type n -> Type⁺ n 64 | lift {n} a {m} = subst Type (+-comm m n) (go m a) where 65 | go : ∀ {n} m -> Type n -> Type (m + n) 66 | go 0 a = a 67 | go (suc m) a = wrap (emb (go m a)) 68 | 69 | nat : Type⁺ 0 70 | nat = lift₀ (wrap natᵤ) 71 | 72 | type : ∀ n -> Type⁺ (suc n) 73 | type n = lift {suc n} (wrap prev) 74 | 75 | mutual 76 | data Ω : Set where 77 | π σ : ∀ a -> (⟦ a ⟧ₒ -> Ω) -> Ω 78 | emb : ∀ {n} -> Type n -> Ω 79 | 80 | ⟦_⟧ₒ : Ω -> Set 81 | ⟦ π a b ⟧ₒ = ∀ x -> ⟦ b x ⟧ₒ 82 | ⟦ σ a b ⟧ₒ = ∃ λ x -> ⟦ b x ⟧ₒ 83 | ⟦ emb a ⟧ₒ = ⟦ a ⟧ 84 | 85 | natₒ : Ω 86 | natₒ = emb (nat {0}) 87 | 88 | typeₒ : ℕ -> Ω 89 | typeₒ n = emb {suc n} (wrap prev) 90 | 91 | ω : Ω 92 | ω = π natₒ typeₒ 93 | 94 | test₀ : Type 0 95 | test₀ = nat ⇒ nat 96 | 97 | test₁ : ⟦ Type 3 ∋ type 1 ⟧ ≡ Type 1 98 | test₁ = refl 99 | 100 | test₂ : ⟦ Type 3 ∋ type 2 ⟧ ≡ Type 2 101 | test₂ = refl 102 | 103 | test₃ : Type 4 104 | test₃ = nat ⇒ (type 3 ⇒ type 1) ⇒ type 2 105 | 106 | test₄ : Type 3 107 | test₄ = type 1 ‵π‵ λ a -> lift a ⇒ type 2 ‵π‵ λ b -> nat ⇒ lift b 108 | 109 | test₅ : ⟦ test₄ ⟧ ≡ ((a : Type 1) -> ⟦ a ⟧ -> (b : Type 2) -> ℕ -> ⟦ b ⟧) 110 | test₅ = refl 111 | 112 | test₆ : ∀ {n} -> ⟦ typeₒ n ⟧ₒ ≡ Type n 113 | test₆ = refl 114 | 115 | test₇ : ⟦ ω ⟧ₒ ≡ ∀ n -> Type n 116 | test₇ = refl 117 | -------------------------------------------------------------------------------- /Categories/Setoid.agda: -------------------------------------------------------------------------------- 1 | module Categories.Setoid where 2 | 3 | open import Level 4 | open import Relation.Binary.PropositionalEquality as P using (_≡_) public 5 | open import Data.Product 6 | 7 | record IsEquivalence {α} {A : Set α} (_≈_ : A -> A -> Set α) : Set α where 8 | field 9 | refl : ∀ {x} -> x ≈ x 10 | sym : ∀ {x y} -> x ≈ y -> y ≈ x 11 | trans : ∀ {x y z} -> x ≈ y -> y ≈ z -> x ≈ z 12 | 13 | module IsEquivalenceOn {α} (A : Set α) where 14 | private module Dummy = IsEquivalence {A = A} 15 | open Dummy {{...}} public 16 | 17 | -- Arity-generic `IsEquivalenceOn'? 18 | module IsEquivalenceOn₂ {α β} {A : Set α} (_⊕_ : A -> A -> Set β) where 19 | private module Dummy {x y} = IsEquivalence {A = x ⊕ y} 20 | open Dummy {{...}} public 21 | 22 | record Setoid {α} (A : Set α) : Set (suc α) where 23 | infix 4 _≈_ 24 | 25 | field 26 | _≈_ : A -> A -> Set α 27 | isEquivalence : IsEquivalence _≈_ 28 | 29 | instance 30 | Setoid->IsEquivalence : IsEquivalence _≈_ 31 | Setoid->IsEquivalence = isEquivalence 32 | 33 | record Setoid-Instances : Set where 34 | open IsEquivalence {{...}} 35 | 36 | postulate 37 | instance 38 | Σ-Setoid : ∀ {α β} {A : Set α} {B : A -> Set β} 39 | {{setoid₁ : Setoid A}} {setoid₂ : ∀ {x} -> Setoid (B x)} 40 | -> Setoid (Σ A B) 41 | instance 42 | -- That's where the idea "_≈_ can't lie in a universe higher than a universe where A lies" fails. 43 | -- →-Setoid : ∀ {α} {A B : Set α} -> Setoid (A -> B) 44 | -- →-Setoid {A = A} {B = B} = record 45 | -- { _≈_ = λ f g -> {{setoid : Setoid B}} -> ∀ x -> f x ≈ g x 46 | -- ; isEquivalence = record 47 | -- { refl = λ x -> refl 48 | -- ; sym = λ p x -> sym (p x) 49 | -- ; trans = λ p q x -> trans (p x) (q x) 50 | -- } 51 | -- } where open IsEquivalenceOn B 52 | 53 | →-Setoid : ∀ {α} {A B : Set α} {{setoid : Setoid B}} -> Setoid (A -> B) 54 | →-Setoid {α} {A} {B} {{setoid}} = record 55 | { _≈_ = λ f g -> ∀ x -> f x ≈ g x 56 | ; isEquivalence = record 57 | { refl = λ x -> refl 58 | ; sym = λ p x -> sym (p x) 59 | ; trans = λ p q x -> trans (p x) (q x) 60 | } 61 | } where open Setoid setoid 62 | 63 | ≡-Setoid : ∀ {α} {A : Set α} -> Setoid A 64 | ≡-Setoid = record 65 | { _≈_ = _≡_ 66 | ; isEquivalence = record 67 | { refl = P.refl 68 | ; sym = P.sym 69 | ; trans = P.trans 70 | } 71 | } 72 | 73 | module EqReasoning {α} {A : Set α} (setoid : Setoid A) where 74 | open Setoid setoid; open IsEquivalence isEquivalence 75 | 76 | infix 4 _IsRelatedTo_ 77 | infix 1 begin_ 78 | infixr 2 _→⟨_⟩_ _←⟨_⟩_ 79 | infix 3 _∎ 80 | 81 | record _IsRelatedTo_ (x y : A) : Set α where 82 | constructor relTo 83 | field eq : x ≈ y 84 | 85 | begin_ : ∀ {x y} -> x IsRelatedTo y -> x ≈ y 86 | begin (relTo p) = p 87 | 88 | _→⟨_⟩_ : ∀ {y z} x -> x ≈ y -> y IsRelatedTo z -> x IsRelatedTo z 89 | x →⟨ p ⟩ (relTo q) = relTo (trans p q) 90 | 91 | _←⟨_⟩_ : ∀ {y z} x -> y ≈ x -> y IsRelatedTo z -> x IsRelatedTo z 92 | _←⟨_⟩_ {y} x p (relTo q) = relTo (trans (sym p) q) 93 | 94 | _∎ : ∀ x -> x IsRelatedTo x 95 | x ∎ = relTo refl 96 | -------------------------------------------------------------------------------- /maybe-elim.agda: -------------------------------------------------------------------------------- 1 | -- related to http://stackoverflow.com/questions/31105947/eliminating-a-maybe-at-the-type-level/ 2 | 3 | open import Level 4 | open import Function 5 | open import Relation.Binary.PropositionalEquality 6 | open import Data.Unit.Base 7 | open import Data.Bool 8 | open import Data.Maybe.Base hiding (Is-just) renaming (is-just to isJust) 9 | 10 | Is-just : ∀ {α} {A : Set α} -> Maybe A -> Set 11 | Is-just = T ∘ isJust 12 | 13 | infixl 1 _>>=ᵗ_ 14 | infixl 4 _<$>ᵗ_ 15 | 16 | data _>>=ᵗ_ {α β} {A : Set α} : (mx : Maybe A) -> (Is-just mx -> Set β) -> Set (α ⊔ β) where 17 | nothingᵗ : ∀ {B} -> nothing >>=ᵗ B 18 | justᵗ : ∀ {B x} -> B _ -> just x >>=ᵗ B 19 | 20 | From-justᵗ : ∀ {α β} {A : Set α} {mx : Maybe A} {B : Is-just mx -> Set β} 21 | -> mx >>=ᵗ B -> Set β 22 | From-justᵗ nothingᵗ = Lift ⊤ 23 | From-justᵗ (justᵗ {B} y) = B _ 24 | 25 | from-justᵗ : ∀ {α β} {A : Set α} {mx : Maybe A} {B : Is-just mx -> Set β} 26 | -> (yᵗ : mx >>=ᵗ B) -> From-justᵗ yᵗ 27 | from-justᵗ nothingᵗ = _ 28 | from-justᵗ (justᵗ y) = y 29 | 30 | runᵗ : ∀ {α β} {A : Set α} {mx : Maybe A} {B : Is-just mx -> Set β} 31 | -> mx >>=ᵗ B -> (imx : Is-just mx) -> B imx 32 | runᵗ {mx = nothing} _ () 33 | runᵗ {mx = just x} (justᵗ y) _ = y 34 | 35 | _<$>ᵗ_ : ∀ {α β γ} {A : Set α} {mx : Maybe A} {B : Is-just mx -> Set β} {C : ∀ {x} -> B x -> Set γ} 36 | -> (∀ {x} -> (y : B x) -> C y) -> (yᵗ : mx >>=ᵗ B) -> mx >>=ᵗ C ∘ runᵗ yᵗ 37 | g <$>ᵗ nothingᵗ = nothingᵗ 38 | g <$>ᵗ justᵗ y = justᵗ (g y) 39 | 40 | ! : ∀ {α β} {A : Set α} {B : ∀ {mx} -> Is-just mx -> Set β} {mx : Maybe A} 41 | -> (∀ x {_ : mx ≡ just x} -> B {just x} _) -> (imx : Is-just mx) -> B imx 42 | ! {mx = nothing} f () 43 | ! {mx = just x } f _ = f x {refl} 44 | 45 | ¡ : ∀ {α β} {A : Set α} {B : A -> Set β} {mx : Maybe A} 46 | -> (∀ x {_ : mx ≡ just x} -> B x) -> mx >>=ᵗ ! λ x -> B x 47 | ¡ {mx = nothing} f = nothingᵗ 48 | ¡ {mx = just x} f = justᵗ (f x {refl}) 49 | 50 | open import Data.Nat.Base hiding (pred) 51 | open import Data.Vec hiding (tail) 52 | 53 | pred : ℕ -> Maybe ℕ 54 | pred 0 = nothing 55 | pred (suc n) = just n 56 | 57 | tailᵗ : ∀ {α n} {A : Set α} -> Vec A n -> pred n >>=ᵗ ! λ pn -> Vec A pn 58 | tailᵗ [] = nothingᵗ 59 | tailᵗ (x ∷ xs) = justᵗ xs 60 | 61 | tail : ∀ {α n} {A : Set α} -> (xs : Vec A n) -> From-justᵗ (tailᵗ xs) 62 | tail = from-justᵗ ∘ tailᵗ 63 | 64 | pred-replicate : ∀ {n} -> pred n >>=ᵗ ! λ pn -> Vec ℕ pn 65 | pred-replicate = ¡ λ pn -> replicate {n = pn} 0 66 | 67 | test-nil : tail (Vec ℕ 0 ∋ []) ≡ lift tt 68 | test-nil = refl 69 | 70 | test-cons : tail (1 ∷ 2 ∷ 3 ∷ []) ≡ 2 ∷ 3 ∷ [] 71 | test-cons = refl 72 | 73 | test : from-justᵗ ((0 ∷_) <$>ᵗ ((0 ∷_) <$>ᵗ tailᵗ (1 ∷ 2 ∷ 3 ∷ []))) ≡ 0 ∷ 0 ∷ 2 ∷ 3 ∷ [] 74 | test = refl 75 | 76 | is-just : ∀ {α} {A : Set α} {mx} {x : A} -> mx ≡ just x -> Is-just mx 77 | is-just refl = _ 78 | 79 | !' : ∀ {α β} {A : Set α} {mx : Maybe A} {B : Is-just mx -> Set β} 80 | -> (∀ x {p : mx ≡ just x} -> B (is-just p)) -> (imx : Is-just mx) -> B imx 81 | !' {mx = nothing} f () 82 | !' {mx = just x } f _ = f x {refl} 83 | 84 | ¡' : ∀ {α β} {A : Set α} {mx : Maybe A} {B : Is-just mx -> Set β} 85 | -> (∀ x {p : mx ≡ just x} -> B (is-just p)) -> mx >>=ᵗ B 86 | ¡' {mx = nothing} f = nothingᵗ 87 | ¡' {mx = just x} f = justᵗ (f x {refl}) 88 | -------------------------------------------------------------------------------- /NaryDec/Nary.agda: -------------------------------------------------------------------------------- 1 | module NaryDec.Nary where 2 | 3 | open import Level renaming (zero to lzero; suc to lsuc) 4 | open import Function 5 | open import Relation.Nullary 6 | open import Data.Unit.Base 7 | open import Data.Nat.Base hiding (_⊔_) 8 | open import Data.Product hiding (map) 9 | open import Data.Vec 10 | 11 | infixl 6 _^_ 12 | infixr 5 _,ʳ_ _,,_ _×ʳ_ _××_ 13 | infixr 0 _->ⁿ_ 14 | 15 | _^_ : ∀ {α} -> Set α -> ℕ -> Set α 16 | A ^ 0 = Lift ⊤ 17 | A ^ suc n = A × A ^ n 18 | 19 | to-^ : ∀ {n α} {A : Set α} -> Vec A n -> A ^ n 20 | to-^ = foldr (_^_ _) _,_ _ 21 | 22 | from-^ : ∀ {n α} {A : Set α} -> A ^ n -> Vec A n 23 | from-^ {0} _ = [] 24 | from-^ {suc _} (x , xs) = x ∷ from-^ xs 25 | 26 | on-^ : ∀ {α β n} {A : Set α} {B : Vec A n -> Set β} 27 | -> (∀ xs -> B xs) -> ∀ xs -> B (from-^ xs) 28 | on-^ f = f ∘ from-^ 29 | 30 | mono-^ : ∀ {α n m} {A : Set α} -> (Vec A n -> Vec A m) -> A ^ n -> A ^ m 31 | mono-^ f = to-^ ∘ on-^ f 32 | 33 | _,ʳ_ : ∀ {n α} {A : Set α} -> A ^ n -> A -> A ^ suc n 34 | _,ʳ_ {0} _ y = y , _ 35 | _,ʳ_ {suc _} (x , xs) y = x , xs ,ʳ y 36 | 37 | _,,_ : ∀ {n m α} {A : Set α} -> A ^ n -> A ^ m -> A ^ (n + m) 38 | _,,_ {0} _ ys = ys 39 | _,,_ {suc _} (x , xs) ys = x , xs ,, ys 40 | 41 | _⊔ⁿ_ : ∀ {n} -> Level ^ n -> Level -> Level 42 | _⊔ⁿ_ = on-^ $ flip $ foldr _ _⊔_ 43 | 44 | Sets : ∀ {n} -> (αs : Level ^ n) -> Set (mono-^ (map lsuc) αs ⊔ⁿ lzero) 45 | Sets {0} _ = ⊤ 46 | Sets {suc _} (α , αs) = Σ (Set α) λ A -> A -> Sets αs 47 | 48 | _×ʳ_ : ∀ {n β} {αs : Level ^ n} -> Sets αs -> Set β -> Sets (αs ,ʳ β) 49 | _×ʳ_ {0} _ B = B , _ 50 | _×ʳ_ {suc _} (A , F) B = A , λ x -> F x ×ʳ B 51 | 52 | _->ⁿ_ : ∀ {n} {αs : Level ^ n} {β} -> Sets αs -> Set β -> Set (αs ⊔ⁿ β) 53 | _->ⁿ_ {0} _ B = B 54 | _->ⁿ_ {suc _} (_ , F) B = ∀ x -> F x ->ⁿ B 55 | 56 | _××_ : ∀ {n m} {αs : Level ^ n} {βs : Level ^ m} -> Sets αs -> Sets βs -> Sets (αs ,, βs) 57 | _××_ {0} _ Bs = Bs 58 | _××_ {suc _} (A , F) Bs = A , λ x -> F x ×× Bs 59 | 60 | uncurryⁿ : ∀ n {β γ} {αs : Level ^ n} {As : Sets αs} {B : Set β} {C : Set γ} 61 | -> (As ->ⁿ (B -> C)) -> As ×ʳ B ->ⁿ C 62 | uncurryⁿ 0 f = f 63 | uncurryⁿ (suc n) f = uncurryⁿ n ∘ f 64 | 65 | uncurryⁿ² : ∀ n {m γ} {αs : Level ^ n} {βs : Level ^ m} 66 | {As : Sets αs} {Bs : Sets βs} {C : Set γ} 67 | -> (As ->ⁿ Bs ->ⁿ C) -> As ×× Bs ->ⁿ C 68 | uncurryⁿ² 0 f = f 69 | uncurryⁿ² (suc n) f = uncurryⁿ² n ∘ f 70 | 71 | ---------------------------------------- 72 | 73 | applyⁿ : ∀ n {β γ} {αs : Level ^ n} {As : Sets αs} {B : Set β} {C : B -> Set γ} 74 | -> (As ->ⁿ ((y : B) -> C y)) -> (y : B) -> As ->ⁿ C y 75 | applyⁿ 0 g y = g y 76 | applyⁿ (suc n) f y = λ x -> applyⁿ n (f x) y 77 | 78 | compⁿ : ∀ n {β γ} {αs : Level ^ n} {As : Sets αs} {B : Set β} {C : Set γ} 79 | -> (B -> C) -> (As ->ⁿ B) -> As ->ⁿ C 80 | compⁿ 0 g y = g y 81 | compⁿ (suc n) g f = compⁿ n g ∘ f 82 | 83 | compⁿ² : ∀ m n {β γ} {αs : Level ^ n} {βs : Level ^ m} 84 | {As : Sets αs} {Bs : Sets βs} {B : Set β} {C : Set γ} 85 | -> (Bs ->ⁿ (B -> C)) -> (As ->ⁿ B) -> Bs ×× As ->ⁿ C 86 | compⁿ² m n g f = uncurryⁿ² m $ compⁿ m (λ g' -> compⁿ n g' f) g 87 | 88 | ∃ⁿ : ∀ n {αs : Level ^ n} {β} {As : Sets αs} -> (As ->ⁿ Set β) -> Set (αs ⊔ⁿ β) 89 | ∃ⁿ 0 B = B 90 | ∃ⁿ (suc n) F = ∃ (∃ⁿ n ∘ F) 91 | -------------------------------------------------------------------------------- /Normalization/DecNfSpines.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Relation.Nullary 3 | open import Relation.Nullary.Decidable 4 | 5 | infixl 6 _▻_ 6 | infixr 6 _⇒_ 7 | infix 4 _⊢_ _∈_ 8 | infixl 7 _·_ 9 | infixl 5 _▷_ 10 | 11 | data Type : Set where 12 | ι : Type 13 | _⇒_ : Type -> Type -> Type 14 | 15 | data Con : Set where 16 | ε : Con 17 | _▻_ : Con -> Type -> Con 18 | 19 | data _∈_ σ : Con -> Set where 20 | vz : ∀ {Γ} -> σ ∈ Γ ▻ σ 21 | vs_ : ∀ {Γ τ} -> σ ∈ Γ -> σ ∈ Γ ▻ τ 22 | 23 | data _⊢_ Γ : Type -> Set where 24 | var : ∀ {σ} -> σ ∈ Γ -> Γ ⊢ σ 25 | ƛ : ∀ {σ τ} -> Γ ▻ σ ⊢ τ -> Γ ⊢ σ ⇒ τ 26 | _·_ : ∀ {σ τ} -> Γ ⊢ σ ⇒ τ -> Γ ⊢ σ -> Γ ⊢ τ 27 | unit : Γ ⊢ ι 28 | 29 | mutual 30 | data Nf {Γ} : ∀ {σ} -> Γ ⊢ σ -> Set where 31 | appⁿᶠ : ∀ {σ τ} {t : Γ ⊢ τ} -> (v : σ ∈ Γ) -> Spine v t -> Nf t 32 | ƛⁿᶠ : ∀ {σ τ} {b : Γ ▻ σ ⊢ τ} -> Nf b -> Nf (ƛ b) 33 | unitⁿᶠ : Nf unit 34 | 35 | data Spine {Γ σ} (v : σ ∈ Γ) : ∀ {τ} -> Γ ⊢ τ -> Set where 36 | ø : Spine v (var v) 37 | _▷_ : ∀ {τ ν} {t : Γ ⊢ τ ⇒ ν} {s : Γ ⊢ τ} -> Spine v t -> Nf s -> Spine v (t · s) 38 | 39 | pattern _·ˢᵖ_ f x = appⁿᶠ _ (f ▷ x) 40 | 41 | unƛⁿᶠ : ∀ {Γ σ τ} {b : Γ ▻ σ ⊢ τ} 42 | -> Nf (ƛ b) -> Nf b 43 | unƛⁿᶠ (appⁿᶠ v ()) 44 | unƛⁿᶠ (ƛⁿᶠ b) = b 45 | 46 | unfunⁿᶠ : ∀ {Γ σ τ} {f : Γ ⊢ σ ⇒ τ} {x} 47 | -> Nf (f · x) -> Nf f 48 | unfunⁿᶠ (f ·ˢᵖ x) = appⁿᶠ _ f 49 | 50 | unargⁿᶠ : ∀ {Γ σ τ} {f : Γ ⊢ σ ⇒ τ} {x} 51 | -> Nf (f · x) -> Nf x 52 | unargⁿᶠ (f ·ˢᵖ x) = x 53 | 54 | noβⁿᶠ : ∀ {Γ σ τ} {b : Γ ▻ σ ⊢ τ} {x} 55 | -> ¬ Nf (ƛ b · x) 56 | noβⁿᶠ (() ·ˢᵖ x) 57 | 58 | decNf : ∀ {Γ σ} -> (t : Γ ⊢ σ) -> Dec (Nf t) 59 | decNf (var v) = yes (appⁿᶠ v ø) 60 | decNf (ƛ b) = map′ ƛⁿᶠ unƛⁿᶠ (decNf b) 61 | decNf (f · x) with decNf f 62 | ... | yes (appⁿᶠ v sp) = map′ (sp ·ˢᵖ_) unargⁿᶠ (decNf x) 63 | ... | yes (ƛⁿᶠ b′) = no noβⁿᶠ 64 | ... | no c = no (c ∘ unfunⁿᶠ) 65 | decNf unit = yes unitⁿᶠ 66 | 67 | module Translation where 68 | infix 4 _⊢ⁿᶠ_ _⊢ⁿᵉ_ _⊢ˢᵖ_∶_ 69 | infixl 5 _▷_ 70 | 71 | mutual 72 | data _⊢ⁿᶠ_ (Γ : Con) : Type → Set where 73 | neⁿᶠ : ∀ {P} → Γ ⊢ⁿᵉ P → Γ ⊢ⁿᶠ P 74 | lamⁿᶠ : ∀ {A B} → Γ ▻ A ⊢ⁿᶠ B → Γ ⊢ⁿᶠ A ⇒ B 75 | unitⁿᶠ : Γ ⊢ⁿᶠ ι 76 | 77 | data _⊢ⁿᵉ_ (Γ : Con) : Type → Set where 78 | spⁿᵉ : ∀ {A C} → A ∈ Γ → Γ ⊢ˢᵖ A ∶ C → Γ ⊢ⁿᵉ C 79 | 80 | data _⊢ˢᵖ_∶_ (Γ : Con) : Type → Type → Set where 81 | ø : ∀ {C} → Γ ⊢ˢᵖ C ∶ C 82 | _▷_ : ∀ {A B C} → Γ ⊢ˢᵖ B ∶ C → Γ ⊢ⁿᶠ A → Γ ⊢ˢᵖ A ⇒ B ∶ C 83 | 84 | mutual 85 | coeⁿᶠ : ∀ {Γ σ} {t : Γ ⊢ σ} -> Nf t -> Γ ⊢ⁿᶠ σ 86 | coeⁿᶠ (appⁿᶠ v sp) = neⁿᶠ (spⁿᵉ v (coeˢᵖ ø sp)) 87 | coeⁿᶠ (ƛⁿᶠ b) = lamⁿᶠ (coeⁿᶠ b) 88 | coeⁿᶠ unitⁿᶠ = unitⁿᶠ 89 | 90 | coeˢᵖ : ∀ {Γ σ τ ν} {v : σ ∈ Γ} {t : Γ ⊢ τ} -> Γ ⊢ˢᵖ τ ∶ ν -> Spine v t -> Γ ⊢ˢᵖ σ ∶ ν 91 | coeˢᵖ a ø = a 92 | coeˢᵖ a (sp ▷ t) = coeˢᵖ (a ▷ coeⁿᶠ t) sp 93 | 94 | mine : ∀ {Γ σ τ ν δ} {t : Γ ⊢ σ} {s : Γ ⊢ τ} {u : Γ ⊢ ν} 95 | -> (v : σ ⇒ τ ⇒ ν ⇒ δ ∈ Γ) -> Nf t -> Nf s -> Nf u -> Nf (var v · t · s · u) 96 | mine v t s u = appⁿᶠ v (ø ▷ t ▷ s ▷ u) 97 | 98 | yours : ∀ {Γ σ τ ν δ} 99 | -> (v : σ ⇒ τ ⇒ ν ⇒ δ ∈ Γ) -> Γ ⊢ⁿᶠ σ -> Γ ⊢ⁿᶠ τ -> Γ ⊢ⁿᶠ ν -> Γ ⊢ⁿᶠ δ 100 | yours v t s u = neⁿᶠ (spⁿᵉ v (ø ▷ u ▷ s ▷ t)) 101 | -------------------------------------------------------------------------------- /Extensionality'.agda: -------------------------------------------------------------------------------- 1 | open import Level as Le 2 | open import Function 3 | open import Relation.Binary.PropositionalEquality 4 | open import Data.Unit 5 | open import Data.Product hiding (map) 6 | open import Data.Nat as N hiding (_⊔_) 7 | open import Data.Vec 8 | 9 | N-ary-level-Vec' : ∀ {n} -> Vec Level n -> Level -> Level 10 | N-ary-level-Vec' = flip $ foldr _ Le._⊔_ 11 | 12 | UVec' : ∀ {n} (αs : Vec Level n) γ -> Set (N-ary-level-Vec' (map Le.suc αs) (Le.suc γ)) 13 | UVec' [] γ = Set γ 14 | UVec' (α ∷ αs) γ = Σ (Set α) (λ X -> X -> UVec' αs γ) 15 | 16 | N-ary-UVec : ∀ {n} {αs : Vec Level n} {γ} -> UVec' αs γ -> Set (N-ary-level-Vec' αs γ) 17 | N-ary-UVec {αs = []} Z = Z 18 | N-ary-UVec {αs = α ∷ αs} (X , F) = (x : X) -> N-ary-UVec (F x) 19 | 20 | _^_ : ∀ {α} -> Set α -> ℕ -> Set α 21 | A ^ 0 = Lift ⊤ 22 | A ^ suc n = A × A ^ n 23 | 24 | from-^ : ∀ {n α} {A : Set α} -> A ^ n -> Vec A n 25 | from-^ {0} _ = [] 26 | from-^ {suc n} (x , xs) = x ∷ from-^ xs 27 | 28 | UVec : ∀ {n} 29 | -> (αs : Level ^ n) 30 | -> (γ : Level) 31 | -> Set (N-ary-level-Vec' (map Le.suc (from-^ αs)) (Le.suc γ)) 32 | UVec αs = UVec' (from-^ αs) 33 | 34 | N-ary-level-Vec : ∀ {n} -> Level ^ n -> Level -> Level 35 | N-ary-level-Vec αs = N-ary-level-Vec' (from-^ αs) 36 | 37 | 38 | _[]⇒_≡ₑ_ : ∀ {n γ} (αs : Vec Level n) {Xs : UVec' αs γ} 39 | -> N-ary-UVec Xs -> N-ary-UVec Xs -> Set (N-ary-level-Vec' αs γ) 40 | [] []⇒ x ≡ₑ y = x ≡ y 41 | (α ∷ αs) []⇒ f ≡ₑ g = ∀ x -> αs []⇒ f x ≡ₑ g x 42 | 43 | data _⇒_≡ₑ_ n {γ} {αs : Level ^ n} {Xs : UVec αs γ} (f : N-ary-UVec Xs) : 44 | N-ary-UVec Xs -> Set (N-ary-level-Vec αs γ) where 45 | reflₑ : ∀ {g} -> from-^ αs []⇒ f ≡ₑ g -> n ⇒ f ≡ₑ g 46 | 47 | 48 | 49 | _[]~ₑ_ : ∀ {n γ} {αs : Vec Level n} {Xs : UVec' αs γ} {f g h : N-ary-UVec Xs} 50 | -> αs []⇒ f ≡ₑ g -> αs []⇒ g ≡ₑ h -> αs []⇒ f ≡ₑ h 51 | _[]~ₑ_ {αs = []} refl refl = refl 52 | _[]~ₑ_ {αs = α ∷ αs} p q = λ x -> p x []~ₑ q x 53 | 54 | _~ₑ_ : ∀ {n γ} {αs : Level ^ n} {Xs : UVec αs γ} {f g h : N-ary-UVec Xs} 55 | -> n ⇒ f ≡ₑ g -> n ⇒ g ≡ₑ h -> n ⇒ f ≡ₑ h 56 | reflₑ p ~ₑ reflₑ q = reflₑ (p []~ₑ q) 57 | 58 | module _ where 59 | private 60 | postulate 61 | Extensionality' : ∀ {n γ} {αs : Level ^ n} {Xs : UVec αs γ} {f g : N-ary-UVec Xs} 62 | -> n ⇒ f ≡ₑ g -> f ≡ g 63 | 64 | []E->E' : ∀ {n γ} {αs : Vec Level n} {Xs : UVec' αs γ} {f g : N-ary-UVec Xs} 65 | -> (∀ {α β} {A : Set α} {B : A -> Set β} {f g : (x : A) -> B x} 66 | -> (∀ x -> f x ≡ g x) -> f ≡ g) 67 | -> αs []⇒ f ≡ₑ g -> f ≡ g 68 | []E->E' {αs = []} E refl = refl 69 | []E->E' {αs = α ∷ αs} E p = E λ x -> []E->E' E (p x) 70 | 71 | E->E' : (∀ {α β} {A : Set α} {B : A -> Set β} {f g : (x : A) -> B x} 72 | -> (∀ x -> f x ≡ g x) -> f ≡ g) 73 | -> (∀ {n γ} {αs : Level ^ n} {Xs : UVec αs γ} {f g : N-ary-UVec Xs} 74 | -> n ⇒ f ≡ₑ g -> f ≡ g) 75 | E->E' E (reflₑ p) = []E->E' E p 76 | 77 | E'->E : (∀ {n γ} {αs : Level ^ n} {Xs : UVec αs γ} {f g : N-ary-UVec Xs} 78 | -> n ⇒ f ≡ₑ g -> f ≡ g) 79 | -> (∀ {α β} {A : Set α} {B : A -> Set β} {f g : (x : A) -> B x} 80 | -> (∀ x -> f x ≡ g x) -> f ≡ g) 81 | E'->E E' p = E' (reflₑ p) 82 | 83 | 84 | 85 | +0 : (n : ℕ) -> n ≡ n + 0 86 | +0 0 = refl 87 | +0 (suc n) = cong N.suc (+0 n) 88 | 89 | example : 1 ⇒ (λ n -> 0 + n) ≡ₑ (λ n -> n + 0) 90 | example = reflₑ +0 91 | -------------------------------------------------------------------------------- /Desc/Elim.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Relation.Binary.PropositionalEquality 3 | open import Data.Sum 4 | open import Data.Product 5 | 6 | infixr 5 _⊕_ 7 | infixr 6 _⊛_ 8 | 9 | data Desc (I : Set) : Set₁ where 10 | var : I -> Desc I 11 | π : (A : Set) -> (A -> Desc I) -> Desc I 12 | _⊕_ _⊛_ : Desc I -> Desc I -> Desc I 13 | 14 | ⟦_⟧ : ∀ {I} -> Desc I -> (I -> Set) -> Set 15 | ⟦ var i ⟧ B = B i 16 | ⟦ π A D ⟧ B = ∀ x -> ⟦ D x ⟧ B 17 | ⟦ D ⊕ E ⟧ B = ⟦ D ⟧ B ⊎ ⟦ E ⟧ B 18 | ⟦ D ⊛ E ⟧ B = ⟦ D ⟧ B × ⟦ E ⟧ B 19 | 20 | Extend : ∀ {I} -> Desc I -> (I -> Set) -> I -> Set 21 | Extend (var i) B j = i ≡ j 22 | Extend (π A D) B j = ∃ λ x -> Extend (D x) B j 23 | Extend (D ⊕ E) B j = Extend D B j ⊎ Extend E B j 24 | Extend (D ⊛ E) B j = ⟦ D ⟧ B × Extend E B j 25 | 26 | data μ {I} (D : Desc I) j : Set where 27 | node : Extend D (μ D) j -> μ D j 28 | 29 | Hyp : ∀ {I B} -> (∀ {i} -> B i -> Set) -> (D : Desc I) -> ⟦ D ⟧ B -> Set 30 | Hyp C (var i) y = C y 31 | Hyp C (π A D) f = ∀ x -> Hyp C (D x) (f x) 32 | Hyp C (D ⊕ E) s = [ Hyp C D , Hyp C E ]′ s 33 | Hyp C (D ⊛ E) (x , y) = Hyp C D x × Hyp C E y 34 | 35 | Elim : ∀ {I B} -> (∀ {i} -> B i -> Set) -> (D : Desc I) -> (∀ {j} -> Extend D B j -> B j) -> Set 36 | Elim C (var i) k = C (k refl) 37 | Elim C (π A D) k = ∀ x -> Elim C (D x) (k ∘ _,_ x) 38 | Elim C (D ⊕ E) k = Elim C D (k ∘ inj₁) × Elim C E (k ∘ inj₂) 39 | Elim C (D ⊛ E) k = ∀ {x} -> Hyp C D x -> Elim C E (k ∘ _,_ x) 40 | 41 | module _ {I} {D₀ : Desc I} (P : ∀ {j} -> μ D₀ j -> Set) (f₀ : Elim P D₀ node) where 42 | mutual 43 | elimExtend : ∀ {j} 44 | -> (D : Desc I) {k : ∀ {j} -> Extend D (μ D₀) j -> μ D₀ j} 45 | -> Elim P D k 46 | -> (e : Extend D (μ D₀) j) 47 | -> P (k e) 48 | elimExtend (var i) z refl = z 49 | elimExtend (π A D) f (x , e) = elimExtend (D x) (f x) e 50 | elimExtend (D ⊕ E) (f , g) (inj₁ x) = elimExtend D f x 51 | elimExtend (D ⊕ E) (f , g) (inj₂ y) = elimExtend E g y 52 | elimExtend (D ⊛ E) f (d , e) = elimExtend E (f (hyp D d)) e 53 | 54 | hyp : ∀ D -> (d : ⟦ D ⟧ (μ D₀)) -> Hyp P D d 55 | hyp (var i) d = elim d 56 | hyp (π A D) f = λ x -> hyp (D x) (f x) 57 | hyp (D ⊕ E) (inj₁ x) = hyp D x 58 | hyp (D ⊕ E) (inj₂ y) = hyp E y 59 | hyp (D ⊛ E) (x , y) = hyp D x , hyp E y 60 | 61 | elim : ∀ {j} -> (d : μ D₀ j) -> P d 62 | elim (node e) = elimExtend D₀ f₀ e 63 | 64 | 65 | 66 | open import Data.Unit.Base 67 | open import Data.Nat.Base 68 | 69 | 70 | 71 | vec : Set -> Desc ℕ 72 | vec A = var 0 73 | ⊕ π ℕ λ n -> π A λ _ -> var n ⊛ var (suc n) 74 | 75 | Vec : Set -> ℕ -> Set 76 | Vec A = μ (vec A) 77 | 78 | pattern [] = node (inj₁ refl) 79 | pattern _∷_ {n} x xs = node (inj₂ (n , x , xs , refl)) 80 | 81 | elimVec : ∀ {n A} 82 | -> (P : ∀ {n} -> Vec A n -> Set) 83 | -> (∀ {n} x {xs : Vec A n} -> P xs -> P (x ∷ xs)) 84 | -> P [] 85 | -> (xs : Vec A n) 86 | -> P xs 87 | elimVec P f z = elim P (z , λ _ -> f) 88 | 89 | 90 | 91 | W : (A : Set) -> (A -> Set) -> Set 92 | W A B = μ (π A λ x -> (π (B x) λ _ -> var tt) ⊛ var tt) tt 93 | 94 | pattern sup x g = node (x , g , refl) 95 | 96 | elimW : ∀ {A B} 97 | -> (P : W A B -> Set) 98 | -> (∀ {x} {g : B x -> W A B} -> (∀ y -> P (g y)) -> P (sup x g)) 99 | -> ∀ w 100 | -> P w 101 | elimW P h = elim P (λ _ -> h) 102 | -------------------------------------------------------------------------------- /Normalization/SpinePHOAS.agda: -------------------------------------------------------------------------------- 1 | -- The non-strictly-positive part is taken from 2 | -- http://code.haskell.org/~dolio/agda-share/PHOASNorm.agda 3 | 4 | -- This is for the non-strictly-positive part. 5 | {-# OPTIONS --no-termination-check #-} 6 | 7 | open import Function 8 | 9 | infixr 6 _⇒_ 10 | 11 | data Type : Set where 12 | ⋆ : Type 13 | _⇒_ : Type -> Type -> Type 14 | 15 | module _ (A : Type -> Set) where 16 | mutual 17 | data Term : Type -> Set where 18 | unit : Term ⋆ 19 | lam : ∀ {σ τ} -> (A σ -> Term τ) -> Term (σ ⇒ τ) 20 | app : ∀ {σ} -> A σ -> Spine σ -> Term ⋆ 21 | 22 | data Spine : Type -> Set where 23 | ø : Spine ⋆ 24 | _◁_ : ∀ {σ τ} -> Term σ -> Spine τ -> Spine (σ ⇒ τ) 25 | 26 | mapSpine : ∀ {A B σ} -> (∀ {σ} -> Term A σ -> Term B σ) -> Spine A σ -> Spine B σ 27 | mapSpine f ø = ø 28 | mapSpine f (x ◁ xs) = f x ◁ mapSpine f xs 29 | 30 | module NonStrictilyPositive where 31 | {-# NO_POSITIVITY_CHECK #-} 32 | data Knot (A : Type -> Set) σ : Set where 33 | var : A σ -> Knot A σ 34 | tie : Term (Knot A) σ -> Knot A σ 35 | 36 | apply : ∀ {A σ} -> Term (Knot A) σ -> Spine (Knot A) σ -> Term (Knot A) ⋆ 37 | apply t ø = t 38 | apply (lam k) (x ◁ xs) = apply (k (tie x)) xs 39 | 40 | norm : ∀ {A σ} -> Term (Knot A) σ -> Term (Knot A) σ 41 | norm unit = unit 42 | norm (lam k) = lam λ x -> norm (k x) 43 | norm (app (var f) xs) = app (var f) (mapSpine norm xs) 44 | norm (app (tie f) xs) = apply (norm f) (mapSpine norm xs) 45 | 46 | flatten : ∀ {A σ} -> Term (Knot A) σ -> Term A σ 47 | flatten unit = unit 48 | flatten (lam k) = lam λ x -> flatten (k (var x)) 49 | flatten (app (var f) xs) = app f (mapSpine flatten xs) 50 | flatten (app (tie f) xs) = flatten (apply f xs) 51 | 52 | normalize : ∀ {A σ} -> Term (Knot A) σ -> Term A σ 53 | normalize = flatten ∘ norm 54 | 55 | module StrictlyPositive where 56 | ⟦_/_⟧ : (Type -> Set) -> Type -> Set 57 | ⟦ A / ⋆ ⟧ = Term A ⋆ 58 | ⟦ A / σ ⇒ τ ⟧ = ⟦ A / σ ⟧ -> ⟦ A / τ ⟧ 59 | 60 | mutual 61 | eval : ∀ {A σ} -> Term ⟦ A /_⟧ σ -> ⟦ A / σ ⟧ 62 | eval unit = unit 63 | eval (lam k) = λ x -> eval (k x) 64 | eval (app f xs) = apply f xs 65 | 66 | apply : ∀ {A σ} -> ⟦ A / σ ⟧ -> Spine ⟦ A /_⟧ σ -> Term A ⋆ 67 | apply t ø = t 68 | apply k (x ◁ xs) = apply (k (eval x)) xs 69 | 70 | mutual 71 | η* : ∀ {τ A} σ -> (Spine A σ -> Spine A τ) -> A τ -> ⟦ A / σ ⟧ 72 | η* ⋆ k v = app v (k ø) 73 | η* (σ ⇒ τ) k v = λ x -> η* τ (k ∘ (readback x ◁_)) v 74 | 75 | η : ∀ {A} σ -> A σ -> ⟦ A / σ ⟧ 76 | η σ = η* σ id 77 | 78 | readback : ∀ {σ A} -> ⟦ A / σ ⟧ -> Term A σ 79 | readback {⋆} t = t 80 | readback {σ ⇒ τ} k = lam (readback ∘ k ∘ η σ) 81 | 82 | join : ∀ {A σ} -> Term ⟦ A /_⟧ σ -> Term A σ 83 | join = readback ∘ eval 84 | 85 | Term⁺ : Type -> Set₁ 86 | Term⁺ σ = ∀ {A} -> Term A σ 87 | 88 | app⁺ : ∀ {A σ} -> Term⁺ σ -> Spine ⟦ A /_⟧ σ -> Term ⟦ A /_⟧ ⋆ 89 | app⁺ f = app (eval f) 90 | 91 | A : ∀ {A} -> Term A ((⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆) 92 | A = lam λ f -> lam λ x -> app f (app x ø ◁ ø) 93 | 94 | I : ∀ {A} -> Term A (⋆ ⇒ ⋆) 95 | I = lam λ x -> app x ø 96 | 97 | open import Relation.Binary.PropositionalEquality 98 | 99 | I-unit : ∀ {A} -> Term ⟦ Term A /_⟧ ⋆ 100 | I-unit = app⁺ I (unit ◁ ø) 101 | 102 | test : ∀ {A} -> join (I-unit {A}) ≡ unit 103 | test = refl 104 | -------------------------------------------------------------------------------- /PEG-lemma/one.agda: -------------------------------------------------------------------------------- 1 | -- related to http://stackoverflow.com/questions/29260874/problems-on-data-type-indices-that-uses-list-concatenation 2 | 3 | open import Data.List 4 | open import Data.Fin hiding (_+_) 5 | open import Data.Nat renaming (ℕ to Nat) 6 | open import Data.Product as P 7 | open import Data.Vec using (Vec ; lookup) 8 | open import Data.Empty 9 | open import Relation.Nullary 10 | open import Relation.Binary.PropositionalEquality renaming (_≡_ to _==_ ; sym to symm) 11 | open import Data.Maybe 12 | open import Function 13 | 14 | postulate A : Set 15 | 16 | data Foo : Nat -> Set where 17 | emp : forall {n} -> Foo n 18 | sym : forall {n} -> A -> Foo n 19 | var : forall {n} -> Fin (suc n) -> Foo n 20 | _o_ : forall {n} -> Foo n -> Foo n -> Foo n 21 | 22 | Con : Nat -> Set 23 | Con n = Vec (Foo n) (suc n) 24 | 25 | infix 1 _::_=>_ 26 | 27 | data _::_=>_ {n} (G : Con n) : Foo n × List A -> Nat × Maybe (List A) -> Set where 28 | empty : ∀ {x} -> G :: emp , x => 1 , just [] 29 | sym-success : ∀ {a x} -> G :: sym a , (a ∷ x) => 1 , just (a ∷ []) 30 | sym-failure : ∀ {a b x} -> ¬ (a == b) -> G :: sym a , b ∷ x => 1 , nothing 31 | var : ∀ {x m o} {v : Fin (suc n)} 32 | -> G :: lookup v G , x => m , o -> G :: var v , x => suc m , o 33 | o-success : ∀ {e e' x x' y n n'} 34 | -> G :: e , x ++ x' ++ y => n , just x 35 | -> G :: e' , x' ++ y => n' , just x' 36 | -> G :: e o e' , x ++ x' ++ y => suc (n + n') , just (x ++ x') 37 | o-fail1 : ∀ {e e' x x' y n} 38 | -> G :: e , x ++ x' ++ y => n , nothing 39 | -> G :: e o e' , x ++ x' ++ y => suc n , nothing 40 | o-fail2 : ∀ {e e' x x' y n n'} 41 | -> G :: e , x ++ x' ++ y => n , just x 42 | -> G :: e' , x' ++ y => n' , nothing 43 | -> G :: e o e' , x ++ x' ++ y => suc (n + n') , nothing 44 | 45 | postulate 46 | cut : ∀ {α} {A : Set α} -> ∀ xs {ys zs : List A} -> xs ++ ys == xs ++ zs -> ys == zs 47 | 48 | mutual 49 | aux : ∀ {n} {G : Con n} {e e' z x x' y n n' m' p'} 50 | -> z == x ++ x' ++ y 51 | -> G :: e , z => n , just x 52 | -> G :: e' , x' ++ y => n' , just x' 53 | -> G :: e o e' , z => m' , p' 54 | -> suc (n + n') == m' × just (x ++ x') == p' 55 | aux {x = x} {x'} {n = n} {n'} r pr1 pr2 (o-success {x = x''} pr3 pr4) with x | n | lemma pr1 pr3 56 | ... | ._ | ._ | refl , refl rewrite cut x'' r with x' | n' | lemma pr2 pr4 57 | ... | ._ | ._ | refl , refl = refl , refl 58 | aux r pr1 pr2 (o-fail1 pr3) = case proj₂ (lemma pr1 pr3) of λ() 59 | aux {x = x} r pr1 pr2 (o-fail2 {x = x''} pr3 pr4) with x | lemma pr1 pr3 60 | ... | ._ | _ , refl rewrite cut x'' r = case proj₂ (lemma pr2 pr4) of λ() 61 | 62 | lemma : ∀ {n m m'} {G : Con n} {f x p p'} 63 | -> G :: f , x => m , p -> G :: f , x => m' , p' -> m == m' × p == p' 64 | lemma empty empty = refl , refl 65 | lemma sym-success sym-success = refl , refl 66 | lemma sym-success (sym-failure p) = ⊥-elim (p refl) 67 | lemma (sym-failure p) sym-success = ⊥-elim (p refl) 68 | lemma (sym-failure _) (sym-failure _) = refl , refl 69 | lemma (var pr1) (var pr2) = P.map (cong suc) id (lemma pr1 pr2) 70 | lemma (o-success pr1 pr2) pr3 = aux refl pr1 pr2 pr3 71 | lemma (o-fail1 pr1) pr2 = {!!} 72 | lemma (o-fail2 pr1 pr2) pr3 = {!!} 73 | -------------------------------------------------------------------------------- /Desc/IRPropDesc.agda: -------------------------------------------------------------------------------- 1 | open import Level renaming (zero to lzero; suc to lsuc) 2 | open import Relation.Binary.PropositionalEquality 3 | open import Data.Bool.Base 4 | open import Data.Nat.Base using (ℕ) 5 | open import Data.Product 6 | 7 | _∸>_ : ∀ {ι α β} {I : Set ι} -> (I -> Set α) -> (I -> Set β) -> Set (ι ⊔ α ⊔ β) 8 | A ∸> B = ∀ {i} -> A i -> B i 9 | 10 | mutual 11 | data Univ : Set where 12 | bool nat : Univ 13 | π : ∀ A -> (⟦ A ⟧ -> Univ) -> Univ 14 | 15 | ⟦_⟧ : Univ -> Set 16 | ⟦ bool ⟧ = Bool 17 | ⟦ nat ⟧ = ℕ 18 | ⟦ π A B ⟧ = ∀ x -> ⟦ B x ⟧ 19 | 20 | data Tel : Set where 21 | end : Tel 22 | sig : (A : Univ) -> (⟦ A ⟧ -> Tel) -> Tel 23 | 24 | _->ₜ_ : ∀ {β} -> Tel -> Set β -> Set β 25 | end ->ₜ B = B 26 | sig A K ->ₜ B = ∀ x -> K x ->ₜ B 27 | 28 | Πₜ : ∀ {β γ} {B : Set β} T -> (B -> Set γ) -> (T ->ₜ B) -> Set γ 29 | Πₜ end C y = C y 30 | Πₜ (sig A K) C f = ∀ x -> Πₜ (K x) C (f x) 31 | 32 | fmapΠₜ : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : A -> Set γ} 33 | -> ∀ T {k : T ->ₜ A} -> (B ∸> C) -> Πₜ T B k -> Πₜ T C k 34 | fmapΠₜ end g y = g y 35 | fmapΠₜ (sig A K) g f = λ x -> fmapΠₜ (K x) g (f x) 36 | 37 | data Desc (I : Set) (R : I -> Set) : Set where 38 | ret : ∀ j -> R j -> Desc I R 39 | pi : ∀ A -> (⟦ A ⟧ -> Desc I R) -> Desc I R 40 | rpi : ∀ T -> (k : T ->ₜ I) -> (Πₜ T R k -> Desc I R) -> Desc I R 41 | 42 | Extend : ∀ {I R} -> Desc I R -> (P : I -> Set) -> (P ∸> R) -> I -> Set 43 | Extend (ret i r) P g j = i ≡ j 44 | Extend (pi A B) P g j = ∃ λ x -> Extend (B x) P g j 45 | Extend (rpi T k B) P g j = ∃ λ (y : Πₜ T P k) -> Extend (B (fmapΠₜ T g y)) P g j 46 | 47 | Coercible : {I : Set} -> (I -> Set) -> Set 48 | Coercible R = ∀ {i j} -> i ≡ j -> R i -> R j 49 | 50 | module CoeData {I R} (coe : Coercible R) where 51 | {-# TERMINATING #-} -- I refuse to manually inline `fmapΠₜ'. 52 | mutual 53 | record Data (D : Desc I R) i : Set where 54 | inductive 55 | constructor node 56 | field tree : Extend D (Data D) eval i 57 | 58 | eval : {D : Desc I R} -> Data D ∸> R 59 | eval {D} (node t) = evalExtend D t 60 | 61 | evalExtend : ({E} D : Desc I R) -> Extend D (Data E) eval ∸> R 62 | evalExtend (ret i r) q = coe q r 63 | evalExtend (pi A B) (x , t) = evalExtend (B x) t 64 | evalExtend (rpi T k B) (y , t) = evalExtend (B (fmapΠₜ T eval y)) t 65 | 66 | coerceExtend : ∀ {i j} 67 | -> ({E} D : Desc I R) 68 | -> i ≡ j 69 | -> Extend D (Data E) eval i 70 | -> Extend D (Data E) eval j 71 | coerceExtend (ret i r) q₁ q₂ = trans q₂ q₁ 72 | coerceExtend (pi A B) q₁ (x , t) = x , coerceExtend (B x) q₁ t 73 | coerceExtend (rpi T k B) q₁ (y , t) = y , coerceExtend (B (fmapΠₜ T eval y)) q₁ t 74 | 75 | coerce : ∀ {D : Desc I R} {i j} -> i ≡ j -> Data D i -> Data D j 76 | coerce {D} q (node t) = node (coerceExtend D q t) 77 | 78 | 79 | 80 | open import Function 81 | open import Data.Unit.Base 82 | 83 | open CoeData {⊤} {λ _ -> Univ} (λ _ A -> A) 84 | 85 | U : Set 86 | U = Data (pi bool λ 87 | { true -> ret tt nat 88 | ; false -> rpi end tt λ A -> rpi (sig A λ _ -> end) (λ _ -> tt) λ B -> ret tt (π A B) 89 | }) tt 90 | 91 | pattern unat = node (true , refl) 92 | pattern uπ A B = node (false , A , B , refl) 93 | 94 | {-# TERMINATING #-} 95 | elimU : ∀ {π} 96 | -> (P : U -> Set π) 97 | -> (∀ {A B} -> P A -> (∀ x -> P (B x)) -> P (uπ A B)) 98 | -> P unat 99 | -> ∀ A 100 | -> P A 101 | elimU P h z unat = z 102 | elimU P h z (uπ A B) = h (elimU P h z A) (elimU P h z ∘ B) 103 | -------------------------------------------------------------------------------- /PEG-lemma/two.agda: -------------------------------------------------------------------------------- 1 | open import Data.List 2 | open import Data.Fin hiding (_+_) 3 | open import Data.Nat renaming (ℕ to Nat) 4 | open import Data.Product as P 5 | open import Data.Vec using (Vec ; lookup) 6 | open import Data.Empty 7 | open import Relation.Nullary 8 | open import Relation.Binary.PropositionalEquality renaming (_≡_ to _==_ ; sym to symm) hiding (inspect) 9 | open import Data.Maybe as Maybe 10 | open import Function 11 | 12 | postulate A : Set 13 | 14 | data Foo : Nat -> Set where 15 | emp : forall {n} -> Foo n 16 | sym : forall {n} -> A -> Foo n 17 | var : forall {n} -> Fin (suc n) -> Foo n 18 | _o_ : forall {n} -> Foo n -> Foo n -> Foo n 19 | 20 | Con : Nat -> Set 21 | Con n = Vec (Foo n) (suc n) 22 | 23 | infix 1 _::_=>_ 24 | 25 | data _::_=>_ {n} (G : Con n) : Foo n × List A -> Maybe (List A) -> Set where 26 | empty : ∀ {x} -> G :: emp , x => just [] 27 | sym-success : ∀ {a x} -> G :: sym a , (a ∷ x) => just (a ∷ []) 28 | sym-failure : ∀ {a b x} -> ¬ (a == b) -> G :: sym a , b ∷ x => nothing 29 | var : ∀ {x o} {v : Fin (suc n)} -> G :: lookup v G , x => o -> G :: var v , x => o 30 | o-success : ∀ {e e' x x' y} 31 | -> G :: e , x ++ x' ++ y => just x 32 | -> G :: e' , x' ++ y => just x' 33 | -> G :: e o e' , x ++ x' ++ y => just (x ++ x') 34 | o-fail1 : ∀ {e e' z} 35 | -> G :: e , z => nothing 36 | -> G :: e o e' , z => nothing 37 | o-fail2 : ∀ {e e' x z} 38 | -> G :: e , x ++ z => just x 39 | -> G :: e' , z => nothing 40 | -> G :: e o e' , x ++ z => nothing 41 | 42 | postulate 43 | cut : ∀ {α} {A : Set α} -> ∀ xs {ys zs : List A} -> xs ++ ys == xs ++ zs -> ys == zs 44 | 45 | open Deprecated-inspect 46 | 47 | un-just : ∀ {α} {A : Set α} {x y : A} -> _==_ {A = Maybe A} (just x) (just y) -> x == y 48 | un-just refl = refl 49 | 50 | lemma : ∀ {n} {G : Con n} {f x p p'} -> G :: f , x => p -> G :: f , x => p' -> p == p' 51 | lemma empty empty = refl 52 | lemma sym-success sym-success = refl 53 | lemma sym-success (sym-failure p) = ⊥-elim (p refl) 54 | lemma (sym-failure p) sym-success = ⊥-elim (p refl) 55 | lemma (sym-failure _) (sym-failure _) = refl 56 | lemma (var pr1) (var pr2) = lemma pr1 pr2 57 | lemma (o-success {x = x} {x'} {y} pr1 pr2) pr3 with inspect (x ++ x' ++ y) 58 | ... | z with-≡ r rewrite r with z | pr3 59 | ... | ._ | o-success {x = x''} pr1' pr2' 60 | rewrite un-just (lemma pr1 pr1') | cut x'' r 61 | | un-just (lemma pr2 pr2') = refl 62 | ... | ._ | o-fail1 pr1' = case lemma pr1 pr1' of λ() 63 | ... | ._ | o-fail2 {x = x''} pr1' pr2' 64 | rewrite un-just (lemma pr1 pr1') | cut x'' r = case lemma pr2 pr2' of λ() 65 | lemma (o-fail1 pr1) (o-success pr1' pr2') = case lemma pr1 pr1' of λ() 66 | lemma (o-fail1 pr1) (o-fail1 pr1') = refl 67 | lemma (o-fail1 pr1) (o-fail2 pr1' pr2') = refl 68 | lemma (o-fail2 {x = x} {y} pr1 pr2) pr3 with inspect (x ++ y) 69 | ... | z with-≡ r rewrite r with z | pr3 70 | ... | ._ | o-success {x = x''} pr1' pr2' 71 | rewrite un-just (lemma pr1 pr1') | cut x'' r = case lemma pr2 pr2' of λ() 72 | ... | ._ | o-fail1 pr1' = refl 73 | ... | ._ | o-fail2 pr1' pr2' = refl 74 | -------------------------------------------------------------------------------- /Eff/Map.agda: -------------------------------------------------------------------------------- 1 | module Eff.Map where 2 | 3 | open import Eff.Prelude 4 | 5 | infixl 6 _^_ 6 | infix 3 _∈_ 7 | 8 | _^_ : ∀ {α} -> Set α -> ℕ -> Set α 9 | A ^ 0 = ⊤ 10 | A ^ suc n = A × A ^ n 11 | 12 | foldr : ∀ {n α β} {A : Set α} 13 | -> (B : ℕ -> Set β) -> (∀ {n} -> A -> B n -> B (suc n)) -> B 0 -> A ^ n -> B n 14 | foldr {0} B f z _ = z 15 | foldr {suc n} B f z (x , xs) = f x (foldr B f z xs) 16 | 17 | head : ∀ {n α} {A : Set α} -> A ^ suc n -> A 18 | head (x , xs) = x 19 | 20 | map : ∀ {n α β} {A : Set α} {B : Set β} -> (A -> B) -> A ^ n -> B ^ n 21 | map f = foldr (_ ^_) (_,_ ∘ f) _ 22 | 23 | lookup : ∀ {n α} {A : Set α} -> Fin n -> A ^ n -> A 24 | lookup zero (x , xs) = x 25 | lookup (suc i) (x , xs) = lookup i xs 26 | 27 | replace : ∀ {n α} {A : Set α} -> Fin n -> A -> A ^ n -> A ^ n 28 | replace zero x (y , xs) = x , xs 29 | replace (suc i) x (y , xs) = y , replace i x xs 30 | 31 | _⊔ⁿ_ : ∀ {n} -> Level ^ n -> Level -> Level 32 | _⊔ⁿ_ = flip $ foldr _ _⊔_ 33 | 34 | max : ∀ {n} -> Level ^ n -> Level 35 | max = _⊔ⁿ lzero 36 | 37 | Setsʰ : ∀ α -> ℕ -> Set (lsuc α) 38 | Setsʰ α n = Set α ^ n 39 | 40 | Unionʰ : ∀ {n α} -> Setsʰ α n -> Set α 41 | Unionʰ = foldr _ _⊎_ ⊥ 42 | 43 | Setₛ : ∀ {n} -> (αs : Level ^ n) -> Set _ 44 | Setₛ αs = Set (max αs) 45 | 46 | Setₖₛ : ∀ {n α} {A : Set α} -> (k : A -> Level) -> (xs : A ^ n) -> Set _ 47 | Setₖₛ k xs = Setₛ (map k xs) 48 | 49 | Map : ∀ {n α} {A : Set α} {k : A -> Level} 50 | -> (∀ x -> Set (k x)) -> (xs : A ^ n) -> Setₖₛ k xs 51 | Map {0} B _ = ⊤ 52 | Map {suc n} B (x , xs) = B x × Map B xs 53 | 54 | foldrᵐ : ∀ {n α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} 55 | {kₛ : ∀ {n} -> A ^ n -> Level} {xs : A ^ n} 56 | -> (C : ∀ {n} -> (xs : A ^ n) -> Set (kₛ xs)) 57 | -> (∀ {n x} {xs : A ^ n} -> B x -> C xs -> C (x , xs)) 58 | -> C {0} _ 59 | -> Map B xs 60 | -> C xs 61 | foldrᵐ {0} B f z _ = z 62 | foldrᵐ {suc n} B f z (y , ys) = f y (foldrᵐ B f z ys) 63 | 64 | homo : ∀ {n α β} {A : Set α} {B : Set β} {xs : A ^ n} -> Map (λ _ -> B) xs -> B ^ n 65 | homo {B = B} = foldrᵐ (λ {n} _ -> B ^ n) _,_ _ 66 | 67 | headᵐ : ∀ {n α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} {xs : A ^ suc n} 68 | -> Map B xs -> B (head xs) 69 | headᵐ (y , ys) = y 70 | 71 | mapᵐ : ∀ {n α} {A : Set α} {k₀ : A -> Level} {k₁ : A -> Level} 72 | {B : ∀ x -> Set (k₀ x)} {C : ∀ x -> Set (k₁ x)} {xs : A ^ n} 73 | -> (∀ {x} -> B x -> C x) -> Map B xs -> Map C xs 74 | mapᵐ {C = C} f = foldrᵐ (Map C) (_,_ ∘ f) tt 75 | 76 | lookupᵐ : ∀ {n α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} {xs : A ^ n} 77 | -> (i : Fin n) -> Map B xs -> B (lookup i xs) 78 | lookupᵐ zero (y , ys) = y 79 | lookupᵐ (suc i) (y , ys) = lookupᵐ i ys 80 | 81 | replaceᵐ : ∀ {n α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} {xs : A ^ n} {x} 82 | -> (i : Fin n) -> B x -> Map B xs -> Map B (replace i x xs) 83 | replaceᵐ zero y (z , ys) = y , ys 84 | replaceᵐ (suc i) y (z , ys) = z , replaceᵐ i y ys 85 | 86 | _∈_ : ∀ {n α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} {xs : A ^ n} {x} 87 | -> B x -> Map B xs -> Set 88 | y ∈ ys = Unionʰ (homo (mapᵐ (y ≅_) ys)) 89 | 90 | ∈→Fin : ∀ n {α} {A : Set α} {k : A -> Level} {B : ∀ x -> Set (k x)} 91 | {xs : A ^ n} {ys : Map B xs} {x} {y : B x} 92 | -> y ∈ ys -> Fin n 93 | ∈→Fin 0 () 94 | ∈→Fin (suc n) (inj₁ r) = zero 95 | ∈→Fin (suc n) (inj₂ p) = suc (∈→Fin n p) 96 | 97 | Sets : ∀ {n} -> (αs : Level ^ n) -> Set _ 98 | Sets = Map (λ α -> Set α) 99 | 100 | Union : ∀ {n} {αs : Level ^ n} -> Sets αs -> Set _ 101 | Union = foldrᵐ Setₛ _⊎_ ⊥ 102 | -------------------------------------------------------------------------------- /Normalization/DecNf.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Relation.Nullary 3 | open import Relation.Nullary.Decidable 4 | open import Data.Nat.Base 5 | open import Data.Fin 6 | open import Data.Sum renaming (map to smap) 7 | 8 | fromInj₁ : ∀ {α β} {A : Set α} {B : Set β} -> (A -> B) -> A ⊎ B -> B 9 | fromInj₁ f = [ f , id ]′ 10 | 11 | fromInj₂ : ∀ {α β} {A : Set α} {B : Set β} -> (B -> A) -> A ⊎ B -> A 12 | fromInj₂ g = [ id , g ]′ 13 | 14 | infixl 6 _▻_ 15 | infixr 6 _⇒_ 16 | infix 4 _⊢_ 17 | infixl 7 _·_ 18 | 19 | data Type : Set where 20 | ι : Type 21 | _⇒_ : Type -> Type -> Type 22 | 23 | Con : ℕ -> Set 24 | Con n = Fin n -> Type 25 | 26 | _▻_ : ∀ {n} -> Con n -> Type -> Con (suc n) 27 | (Γ ▻ σ) zero = σ 28 | (Γ ▻ σ) (suc i) = Γ i 29 | 30 | data _⊢_ {n} (Γ : Con n) : Type -> Set where 31 | var : ∀ i -> Γ ⊢ Γ i 32 | ƛ : ∀ {σ τ} -> Γ ▻ σ ⊢ τ -> Γ ⊢ σ ⇒ τ 33 | _·_ : ∀ {σ τ} -> Γ ⊢ σ ⇒ τ -> Γ ⊢ σ -> Γ ⊢ τ 34 | unit : Γ ⊢ ι 35 | 36 | mutual 37 | data Ne {n} {Γ : Con n} : ∀ {σ} -> Γ ⊢ σ -> Set where 38 | varⁿᵉ : ∀ {i} -> Ne {Γ = Γ} (var i) 39 | _·ⁿᵉ_ : ∀ {σ τ} {f : Γ ⊢ σ ⇒ τ} {x} -> Ne f -> Nf x -> Ne (f · x) 40 | 41 | data Nf {n} {Γ : Con n} : ∀ {σ} -> Γ ⊢ σ -> Set where 42 | neⁿᶠ : ∀ {σ} {t : Γ ⊢ σ} -> Ne t -> Nf t 43 | ƛⁿᶠ : ∀ {σ τ} {b : Γ ▻ σ ⊢ τ} -> Nf b -> Nf (ƛ b) 44 | unitⁿᶠ : Nf {Γ = Γ} unit 45 | 46 | Shaped : ∀ {n σ} {Γ : Con n} -> Γ ⊢ σ -> Set 47 | Shaped t = Ne t ⊎ Nf t 48 | 49 | nfˢ : ∀ {n σ} {Γ : Con n} {t : Γ ⊢ σ} 50 | -> Shaped t -> Nf t 51 | nfˢ = fromInj₁ neⁿᶠ 52 | 53 | appˢ : ∀ {n σ τ} {Γ : Con n} {f : Γ ⊢ σ ⇒ τ} {x} 54 | -> Ne f -> Shaped x -> Shaped (f · x) 55 | appˢ f = inj₁ ∘ _·ⁿᵉ_ f ∘ nfˢ 56 | 57 | ƛˢ : ∀ {n σ τ} {Γ : Con n} {b : Γ ▻ σ ⊢ τ} 58 | -> Shaped b -> Shaped (ƛ b) 59 | ƛˢ = inj₂ ∘ ƛⁿᶠ ∘ nfˢ 60 | 61 | unappⁿᶠ : ∀ {n σ τ} {Γ : Con n} {f : Γ ⊢ σ ⇒ τ} {x} 62 | -> Nf (f · x) -> Ne (f · x) 63 | unappⁿᶠ (neⁿᶠ t) = t 64 | 65 | unfunⁿᵉ : ∀ {n σ τ} {Γ : Con n} {f : Γ ⊢ σ ⇒ τ} {x} 66 | -> Ne (f · x) -> Ne f 67 | unfunⁿᵉ (f ·ⁿᵉ x) = f 68 | 69 | unargⁿᵉ : ∀ {n σ τ} {Γ : Con n} {f : Γ ⊢ σ ⇒ τ} {x} 70 | -> Ne (f · x) -> Nf x 71 | unargⁿᵉ (f ·ⁿᵉ x) = x 72 | 73 | unƛⁿᶠ : ∀ {n σ τ} {Γ : Con n} {b : Γ ▻ σ ⊢ τ} 74 | -> Nf (ƛ b) -> Nf b 75 | unƛⁿᶠ (neⁿᶠ ()) 76 | unƛⁿᶠ (ƛⁿᶠ b) = b 77 | 78 | noβⁿᵉ : ∀ {n σ τ} {Γ : Con n} {b : Γ ▻ σ ⊢ τ} {x} 79 | -> ¬ Ne (ƛ b · x) 80 | noβⁿᵉ (() ·ⁿᵉ _) 81 | 82 | unappˢ : ∀ {n σ τ} {Γ : Con n} {f : Γ ⊢ σ ⇒ τ} {x} 83 | -> Shaped (f · x) -> Ne (f · x) 84 | unappˢ = fromInj₂ unappⁿᶠ 85 | 86 | unfunˢ : ∀ {n σ τ} {Γ : Con n} {f : Γ ⊢ σ ⇒ τ} {x} 87 | -> Shaped (f · x) -> Shaped f 88 | unfunˢ = inj₁ ∘ unfunⁿᵉ ∘ unappˢ 89 | 90 | unargˢ : ∀ {n σ τ} {Γ : Con n} {f : Γ ⊢ σ ⇒ τ} {x} 91 | -> Shaped (f · x) -> Shaped x 92 | unargˢ = inj₂ ∘ unargⁿᵉ ∘ unappˢ 93 | 94 | unƛˢ : ∀ {n σ τ} {Γ : Con n} {b : Γ ▻ σ ⊢ τ} 95 | -> Shaped (ƛ b) -> Shaped b 96 | unƛˢ = smap (λ()) unƛⁿᶠ 97 | 98 | noβˢ : ∀ {n σ τ} {Γ : Con n} {b : Γ ▻ σ ⊢ τ} {x} 99 | -> ¬ Shaped (ƛ b · x) 100 | noβˢ = noβⁿᵉ ∘ unappˢ 101 | 102 | decShaped : ∀ {n σ} {Γ : Con n} -> (t : Γ ⊢ σ) -> Dec (Shaped t) 103 | decShaped (var i) = yes (inj₁ varⁿᵉ) 104 | decShaped (ƛ b) = map′ ƛˢ unƛˢ (decShaped b) 105 | decShaped (f · x) with decShaped f | λ f′ -> map′ (appˢ f′) unargˢ (decShaped x) 106 | ... | yes (inj₁ f′) | rec = rec f′ 107 | ... | yes (inj₂ (neⁿᶠ f′)) | rec = rec f′ 108 | ... | yes (inj₂ (ƛⁿᶠ b′)) | rec = no noβˢ 109 | ... | no c | rec = no (c ∘ unfunˢ) 110 | decShaped unit = yes (inj₂ unitⁿᶠ) 111 | 112 | decNf : ∀ {n σ} {Γ : Con n} -> (t : Γ ⊢ σ) -> Dec (Nf t) 113 | decNf = map′ nfˢ inj₂ ∘ decShaped 114 | -------------------------------------------------------------------------------- /Incremental2.agda: -------------------------------------------------------------------------------- 1 | open import Function hiding (_∋_) 2 | open import Relation.Nullary.Decidable 3 | open import Relation.Binary.PropositionalEquality 4 | open import Relation.Binary hiding (_⇒_) 5 | open import Data.Unit.Base 6 | open import Data.Bool.Base 7 | open import Data.Nat.Base 8 | open import Data.Fin renaming (zero to fzero; suc to fsuc) using (Fin) 9 | open import Data.Maybe 10 | open import Data.Product 11 | open import Category.Monad 12 | open module Silly {α} = RawMonad (monad {α}) hiding (pure; _>>_) 13 | 14 | infixr 6 _⇒_ 15 | infixl 5 _▻_ _▻▻_ 16 | infix 4 _∈_ _⊢_ 17 | infix 3 vs_ 18 | infixr 3 ƛ_ 19 | infixl 6 _·_ 20 | infix 5 _≟ᵗ_ 21 | infix 2 _∋_ 22 | 23 | module _ A where 24 | data Syntax n : Set where 25 | pure : A -> Syntax n 26 | var : Fin n -> Syntax n 27 | ƛ_ : Syntax (suc n) -> Syntax n 28 | _·_ : Syntax n -> Syntax n -> Syntax n 29 | 30 | data Type : Set where 31 | ⋆ : Type 32 | _⇒_ : Type -> Type -> Type 33 | 34 | data Con : ℕ -> Set where 35 | ε : Con 0 36 | _▻_ : ∀ {n} -> Con n -> Type -> Con (suc n) 37 | 38 | data _∈_ σ : ∀ {n} -> Con n -> Set where 39 | vz : ∀ {n} {Γ : Con n} -> σ ∈ Γ ▻ σ 40 | vs_ : ∀ {n τ} {Γ : Con n} -> σ ∈ Γ -> σ ∈ Γ ▻ τ 41 | 42 | data _⊢_ {n} (Γ : Con n) : Type -> Set where 43 | var : ∀ {σ} -> σ ∈ Γ -> Γ ⊢ σ 44 | ƛ_ : ∀ {σ τ} -> Γ ▻ σ ⊢ τ -> Γ ⊢ σ ⇒ τ 45 | _·_ : ∀ {σ τ} -> Γ ⊢ σ ⇒ τ -> Γ ⊢ σ -> Γ ⊢ τ 46 | 47 | Syntax⁽⁾ : Set -> Set 48 | Syntax⁽⁾ A = Syntax A 0 49 | 50 | Term⁽⁾ : Type -> Set 51 | Term⁽⁾ σ = ε ⊢ σ 52 | 53 | Term⁺ : Type -> Set 54 | Term⁺ σ = ∀ {n} {Γ : Con n} -> Γ ⊢ σ 55 | 56 | Code : ℕ -> Set 57 | Code = Syntax (∃ Term⁺) 58 | 59 | Def : Set 60 | Def = Code 0 61 | 62 | _▻▻_ : ∀ {n m} -> Con m -> Con n -> Con (n + m) 63 | Δ ▻▻ ε = Δ 64 | Δ ▻▻ (Γ ▻ σ) = (Δ ▻▻ Γ) ▻ σ 65 | 66 | wkᵛ : ∀ {n m σ} {Γ : Con n} {Δ : Con m} -> σ ∈ Γ -> σ ∈ Δ ▻▻ Γ 67 | wkᵛ vz = vz 68 | wkᵛ (vs v) = vs (wkᵛ v) 69 | 70 | wk : ∀ {n m σ} {Γ : Con n} {Δ : Con m} -> Γ ⊢ σ -> Δ ▻▻ Γ ⊢ σ 71 | wk (var v) = var (wkᵛ v) 72 | wk (ƛ b ) = ƛ (wk b) 73 | wk (f · x) = wk f · wk x 74 | 75 | lift : ∀ {σ} -> Term⁽⁾ σ -> Term⁺ σ 76 | lift t = wk t 77 | 78 | ⇒-inj : ∀ {σ₁ σ₂ τ₁ τ₂} -> σ₁ ⇒ τ₁ ≡ σ₂ ⇒ τ₂ -> σ₁ ≡ σ₂ × τ₁ ≡ τ₂ 79 | ⇒-inj refl = refl , refl 80 | 81 | _≟ᵗ_ : (σ τ : Type) -> Maybe (σ ≡ τ) 82 | ⋆ ≟ᵗ ⋆ = just refl 83 | σ₁ ⇒ τ₁ ≟ᵗ σ₂ ⇒ τ₂ = cong₂ _⇒_ <$> σ₁ ≟ᵗ σ₂ ⊛ τ₁ ≟ᵗ τ₂ 84 | _ ≟ᵗ _ = nothing 85 | 86 | coerce : ∀ {n σ τ} {Γ : Con n} -> Γ ⊢ σ -> Maybe (Γ ⊢ τ) 87 | coerce {σ = σ} {τ} t = (λ p -> subst (_ ⊢_) p t) <$> σ ≟ᵗ τ 88 | 89 | lookupᶜ : ∀ {n} -> Fin n -> Con n -> Type 90 | lookupᶜ fzero (Γ ▻ σ) = σ 91 | lookupᶜ (fsuc v) (Γ ▻ σ) = lookupᶜ v Γ 92 | 93 | lookup-∈ : ∀ {n Γ} -> (v : Fin n) -> lookupᶜ v Γ ∈ Γ 94 | lookup-∈ {Γ = Γ ▻ σ} fzero = vz 95 | lookup-∈ {Γ = Γ ▻ σ} (fsuc v) = vs (lookup-∈ v) 96 | 97 | mutual 98 | infer : ∀ {n} {Γ : Con n} -> Code n -> Maybe (∃ (Γ ⊢_)) 99 | infer (pure (σ , t)) = just (σ , t) 100 | infer (var v ) = just (, var (lookup-∈ v)) 101 | infer (ƛ b ) = nothing 102 | infer (f · x ) = infer f >>= λ 103 | { (σ ⇒ τ , fₜ) -> (λ xₜ -> , fₜ · xₜ) <$> check x σ 104 | ; _ -> nothing 105 | } 106 | 107 | check : ∀ {n} {Γ : Con n} -> Code n -> (σ : Type) -> Maybe (Γ ⊢ σ) 108 | check (ƛ t) (σ ⇒ τ) = ƛ_ <$> check t τ 109 | check t σ = infer t >>= coerce ∘ proj₂ 110 | 111 | typecheck : Def -> Type -> Maybe Def 112 | typecheck t σ = pure ∘ ,_ ∘ lift <$> check t σ 113 | 114 | _∋_ : ∀ σ t -> _ 115 | σ ∋ t = from-just $ typecheck t σ 116 | 117 | I : Def 118 | I = ⋆ ⇒ ⋆ ∋ ƛ var fzero 119 | 120 | A : Def 121 | A = (⋆ ⇒ ⋆) ⇒ ⋆ ⇒ ⋆ ∋ ƛ ƛ var (fsuc fzero) · var fzero 122 | 123 | test : T ∘ is-just $ typecheck (A · I) (⋆ ⇒ ⋆) 124 | test = tt 125 | -------------------------------------------------------------------------------- /Normalization/Readback.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Data.Empty 3 | open import Data.Sum 4 | 5 | infixl 5 _▻_ 6 | infixr 6 _⇒_ 7 | infix 4 _⊆_ _∈_ _⊢_ _⊢ⁿᵉ_ _⊢ⁿᶠ_ _⊨_ _⊨*_ 8 | infix 4 vs_ 9 | infixr 3 ƛ_ ƛⁿᶠ_ 10 | infixl 6 _·_ _·ⁿᵉ_ 11 | 12 | data Type : Set where 13 | ⋆ : Type 14 | _⇒_ : Type -> Type -> Type 15 | 16 | data Con : Set where 17 | ε : Con 18 | _▻_ : Con -> Type -> Con 19 | 20 | data _⊆_ : Con -> Con -> Set where 21 | stop : ∀ {Γ} -> Γ ⊆ Γ 22 | skip : ∀ {Γ Δ τ} -> Γ ⊆ Δ -> Γ ⊆ Δ ▻ τ 23 | keep : ∀ {Γ Δ σ} -> Γ ⊆ Δ -> Γ ▻ σ ⊆ Δ ▻ σ 24 | 25 | data _∈_ σ : Con -> Set where 26 | vz : ∀ {Γ} -> σ ∈ Γ ▻ σ 27 | vs_ : ∀ {Γ τ} -> σ ∈ Γ -> σ ∈ Γ ▻ τ 28 | 29 | data _⊢_ Γ : Type -> Set where 30 | var : ∀ {σ} -> σ ∈ Γ -> Γ ⊢ σ 31 | ƛ_ : ∀ {σ τ} -> Γ ▻ σ ⊢ τ -> Γ ⊢ σ ⇒ τ 32 | _·_ : ∀ {σ τ} -> Γ ⊢ σ ⇒ τ -> Γ ⊢ σ -> Γ ⊢ τ 33 | 34 | mutual 35 | data _⊢ⁿᵉ_ Γ : Type -> Set where 36 | varⁿᵉ : ∀ {σ} -> σ ∈ Γ -> Γ ⊢ⁿᵉ σ 37 | _·ⁿᵉ_ : ∀ {σ τ} -> Γ ⊢ⁿᵉ σ ⇒ τ -> Γ ⊢ⁿᶠ σ -> Γ ⊢ⁿᵉ τ 38 | 39 | data _⊢ⁿᶠ_ Γ : Type -> Set where 40 | neⁿᶠ : ∀ {σ} -> Γ ⊢ⁿᵉ σ -> Γ ⊢ⁿᶠ σ 41 | ƛⁿᶠ_ : ∀ {σ τ} -> Γ ▻ σ ⊢ⁿᶠ τ -> Γ ⊢ⁿᶠ σ ⇒ τ 42 | 43 | top : ∀ {Γ σ} -> Γ ⊆ Γ ▻ σ 44 | top = skip stop 45 | 46 | _∘ˢ_ : ∀ {Γ Δ Θ} -> Δ ⊆ Θ -> Γ ⊆ Δ -> Γ ⊆ Θ 47 | stop ∘ˢ ψ = ψ 48 | skip φ ∘ˢ ψ = skip (φ ∘ˢ ψ) 49 | keep φ ∘ˢ stop = keep φ 50 | keep φ ∘ˢ skip ψ = skip (φ ∘ˢ ψ) 51 | keep φ ∘ˢ keep ψ = keep (φ ∘ˢ ψ) 52 | 53 | renᵛ : ∀ {Γ Δ σ} -> Γ ⊆ Δ -> σ ∈ Γ -> σ ∈ Δ 54 | renᵛ stop v = v 55 | renᵛ (skip ψ) v = vs (renᵛ ψ v) 56 | renᵛ (keep ψ) vz = vz 57 | renᵛ (keep ψ) (vs v) = vs (renᵛ ψ v) 58 | 59 | mutual 60 | embⁿᵉ : ∀ {Γ σ} -> Γ ⊢ⁿᵉ σ -> Γ ⊢ σ 61 | embⁿᵉ (varⁿᵉ v) = var v 62 | embⁿᵉ (f ·ⁿᵉ x) = embⁿᵉ f · embⁿᶠ x 63 | 64 | embⁿᶠ : ∀ {Γ σ} -> Γ ⊢ⁿᶠ σ -> Γ ⊢ σ 65 | embⁿᶠ (neⁿᶠ n) = embⁿᵉ n 66 | embⁿᶠ (ƛⁿᶠ b) = ƛ (embⁿᶠ b) 67 | 68 | mutual 69 | renⁿᵉ : ∀ {Γ Δ σ} -> Γ ⊆ Δ -> Γ ⊢ⁿᵉ σ -> Δ ⊢ⁿᵉ σ 70 | renⁿᵉ ψ (varⁿᵉ v) = varⁿᵉ (renᵛ ψ v) 71 | renⁿᵉ ψ (f ·ⁿᵉ x) = renⁿᵉ ψ f ·ⁿᵉ renⁿᶠ ψ x 72 | 73 | renⁿᶠ : ∀ {Γ Δ σ} -> Γ ⊆ Δ -> Γ ⊢ⁿᶠ σ -> Δ ⊢ⁿᶠ σ 74 | renⁿᶠ ψ (neⁿᶠ n) = neⁿᶠ (renⁿᵉ ψ n) 75 | renⁿᶠ ψ (ƛⁿᶠ b) = ƛⁿᶠ (renⁿᶠ (keep ψ) b) 76 | 77 | mutual 78 | _⊨_ : Con -> Type -> Set 79 | Γ ⊨ σ = Γ ⊢ⁿᵉ σ ⊎ Kripke Γ σ 80 | 81 | Kripke : Con -> Type -> Set 82 | Kripke Γ ⋆ = ⊥ 83 | Kripke Γ (σ ⇒ τ) = ∀ {Δ} -> Γ ⊆ Δ -> Δ ⊨ σ -> Δ ⊨ τ 84 | 85 | varˢ : ∀ {Γ σ} -> σ ∈ Γ -> Γ ⊨ σ 86 | varˢ = inj₁ ∘ varⁿᵉ 87 | 88 | renˢ : ∀ {σ Γ Δ} -> Γ ⊆ Δ -> Γ ⊨ σ -> Δ ⊨ σ 89 | renˢ ψ (inj₁ t) = inj₁ (renⁿᵉ ψ t) 90 | renˢ {⋆} ψ (inj₂ ()) 91 | renˢ {σ ⇒ τ} ψ (inj₂ k) = inj₂ (λ φ -> k (φ ∘ˢ ψ)) 92 | 93 | readback : ∀ {σ Γ} -> Γ ⊨ σ -> Γ ⊢ⁿᶠ σ 94 | readback (inj₁ t) = neⁿᶠ t 95 | readback {⋆} (inj₂ ()) 96 | readback {σ ⇒ τ} (inj₂ k) = ƛⁿᶠ (readback (k top (varˢ vz))) 97 | 98 | _∙_ : ∀ {Γ σ τ} -> Γ ⊨ σ ⇒ τ -> Γ ⊨ σ -> Γ ⊨ τ 99 | inj₁ f ∙ x = inj₁ (f ·ⁿᵉ readback x) 100 | inj₂ k ∙ x = k stop x 101 | 102 | data _⊨*_ Δ : Con -> Set where 103 | Ø : Δ ⊨* ε 104 | _▷_ : ∀ {Γ σ} -> Δ ⊨* Γ -> Δ ⊨ σ -> Δ ⊨* Γ ▻ σ 105 | 106 | lookupᵉ : ∀ {Γ Δ σ} -> σ ∈ Γ -> Δ ⊨* Γ -> Δ ⊨ σ 107 | lookupᵉ vz (ρ ▷ x) = x 108 | lookupᵉ (vs v) (ρ ▷ x) = lookupᵉ v ρ 109 | 110 | idᵉ : ∀ {Γ} -> Γ ⊨* Γ 111 | idᵉ {ε} = Ø 112 | idᵉ {Γ ▻ σ} = renᵉ top idᵉ ▷ varˢ vz 113 | 114 | renᵉ : ∀ {Γ Δ Θ} -> Δ ⊆ Θ -> Δ ⊨* Γ -> Θ ⊨* Γ 115 | renᵉ ψ Ø = Ø 116 | renᵉ ψ (ρ ▷ x) = renᵉ ψ ρ ▷ renˢ ψ x 117 | 118 | ⟦_⟧ : ∀ {Γ Δ τ} -> Γ ⊢ τ -> Δ ⊨* Γ -> Δ ⊨ τ 119 | ⟦ var v ⟧ ρ = lookupᵉ v ρ 120 | ⟦ ƛ b ⟧ ρ = inj₂ (λ ψ x -> ⟦ b ⟧ (renᵉ ψ ρ ▷ x)) 121 | ⟦ f · x ⟧ ρ = ⟦ f ⟧ ρ ∙ ⟦ x ⟧ ρ 122 | 123 | eval : ∀ {Γ σ} -> Γ ⊢ σ -> Γ ⊨ σ 124 | eval t = ⟦ t ⟧ idᵉ 125 | 126 | norm : ∀ {Γ σ} -> Γ ⊢ σ -> Γ ⊢ σ 127 | norm = embⁿᶠ ∘ readback ∘ eval 128 | -------------------------------------------------------------------------------- /Modal/NoTermSem.agda: -------------------------------------------------------------------------------- 1 | open import Function 2 | open import Relation.Binary.PropositionalEquality 3 | open import Data.Product 4 | open import Data.Nat.Base as Nat hiding (fold) 5 | 6 | infixl 5 _▻_ 7 | infixr 6 _⇒_ 8 | infix 4 _∈_ _⊢_ 9 | infix 4 vs_ 10 | infixr 3 ƛ_ 11 | infixl 6 _·_ 12 | 13 | data Type : Set where 14 | _⇒_ : Type -> Type -> Type 15 | □ : Type -> Type 16 | nat : Type 17 | 18 | data Con : Set where 19 | ε : Con 20 | _▻_ : Con -> Type -> Con 21 | 22 | data _∈_ σ : Con -> Set where 23 | vz : ∀ {Γ} -> σ ∈ Γ ▻ σ 24 | vs_ : ∀ {Γ τ} -> σ ∈ Γ -> σ ∈ Γ ▻ τ 25 | 26 | mutual 27 | data _⊢_ Γ : Type -> Set where 28 | var : ∀ {σ} -> σ ∈ Γ -> Γ ⊢ σ 29 | ƛ_ : ∀ {σ τ} -> Γ ▻ σ ⊢ τ -> Γ ⊢ σ ⇒ τ 30 | _·_ : ∀ {σ τ} -> Γ ⊢ σ ⇒ τ -> Γ ⊢ σ -> Γ ⊢ τ 31 | up : ∀ {σ} -> Term σ -> Γ ⊢ □ σ 32 | down : ∀ {σ} -> Γ ⊢ □ σ -> Γ ⊢ σ 33 | _∙_ : ∀ {σ τ} -> Γ ⊢ □ (σ ⇒ τ) -> Γ ⊢ □ σ -> Γ ⊢ □ τ 34 | elim : ∀ {σ τ} -> Γ ⊢ τ ⇒ τ ⇒ τ -> Γ ⊢ nat ⇒ τ -> Γ ⊢ τ -> Γ ⊢ □ σ -> Γ ⊢ τ 35 | z : Γ ⊢ nat 36 | s : Γ ⊢ nat -> Γ ⊢ nat 37 | fold : ∀ {τ} -> Γ ⊢ τ ⇒ τ -> Γ ⊢ τ -> Γ ⊢ nat -> Γ ⊢ τ 38 | 39 | Term : Type -> Set 40 | Term σ = ε ⊢ σ 41 | 42 | ∈→ℕ : ∀ {Γ σ} -> σ ∈ Γ -> ℕ 43 | ∈→ℕ vz = 0 44 | ∈→ℕ (vs v) = suc (∈→ℕ v) 45 | 46 | module _ {A : Set} (g : A -> A -> A) (f : ℕ -> A) (x : A) where 47 | infixr 5 _⊕_ 48 | _⊕_ = g 49 | 50 | foldTerm : ∀ {Γ σ} -> Γ ⊢ σ -> A 51 | foldTerm (var v) = f (∈→ℕ v) 52 | foldTerm (ƛ b) = foldTerm b 53 | foldTerm (f · x) = foldTerm f ⊕ foldTerm x 54 | foldTerm (up t) = foldTerm t 55 | foldTerm (down t) = foldTerm t 56 | foldTerm (f ∙ x) = foldTerm f ⊕ foldTerm x 57 | foldTerm (elim g f x t) = foldTerm g ⊕ foldTerm f ⊕ foldTerm x ⊕ foldTerm t 58 | foldTerm z = x 59 | foldTerm (s n) = foldTerm n 60 | foldTerm (fold f x n) = foldTerm f ⊕ foldTerm x ⊕ foldTerm n 61 | 62 | ⟦_⟧ᵗ : Type -> Set 63 | ⟦ σ ⇒ τ ⟧ᵗ = ⟦ σ ⟧ᵗ -> ⟦ τ ⟧ᵗ 64 | ⟦ □ σ ⟧ᵗ = ⟦ σ ⟧ᵗ 65 | ⟦ nat ⟧ᵗ = ℕ 66 | 67 | data Env : Con -> Set where 68 | ø : Env ε 69 | _▷_ : ∀ {Γ σ} -> Env Γ -> ⟦ σ ⟧ᵗ -> Env (Γ ▻ σ) 70 | 71 | lookup : ∀ {Γ σ} -> σ ∈ Γ -> Env Γ -> ⟦ σ ⟧ᵗ 72 | lookup vz (ρ ▷ x) = x 73 | lookup (vs v) (ρ ▷ x) = lookup v ρ 74 | 75 | mutual 76 | ⟦_⟧ : ∀ {Γ σ} -> Γ ⊢ σ -> Env Γ -> ⟦ σ ⟧ᵗ 77 | ⟦ var v ⟧ ρ = lookup v ρ 78 | ⟦ ƛ b ⟧ ρ = λ x -> ⟦ b ⟧ (ρ ▷ x) 79 | ⟦ f · x ⟧ ρ = ⟦ f ⟧ ρ (⟦ x ⟧ ρ) 80 | ⟦ up t ⟧ ρ = eval t 81 | ⟦ down t ⟧ ρ = ⟦ t ⟧ ρ 82 | ⟦ f ∙ x ⟧ ρ = ⟦ f ⟧ ρ (⟦ x ⟧ ρ) 83 | ⟦ elim g f x t ⟧ ρ = foldTerm (⟦ g ⟧ ρ) (⟦ f ⟧ ρ) (⟦ x ⟧ ρ) t 84 | ⟦ z ⟧ ρ = 0 85 | ⟦ s n ⟧ ρ = suc (⟦ n ⟧ ρ) 86 | ⟦ fold f x n ⟧ ρ = Nat.fold (⟦ x ⟧ ρ) (⟦ f ⟧ ρ) (⟦ n ⟧ ρ) 87 | 88 | eval : ∀ {σ} -> Term σ -> ⟦ σ ⟧ᵗ 89 | eval t = ⟦ t ⟧ ø 90 | 91 | Term⁺ : Type -> Set 92 | Term⁺ σ = ∀ {Γ} -> Γ ⊢ σ 93 | 94 | open import Relation.Binary.PropositionalEquality 95 | 96 | I : ∀ {σ} -> Term⁺ (σ ⇒ σ) 97 | I = ƛ var vz 98 | 99 | A : ∀ {σ τ} -> Term⁺ ((σ ⇒ τ) ⇒ σ ⇒ τ) 100 | A = ƛ ƛ var (vs vz) · var vz 101 | 102 | plus : Term⁺ (nat ⇒ nat ⇒ nat) 103 | plus = ƛ ƛ fold (ƛ s (var vz)) (var vz) (var (vs vz)) 104 | 105 | countVars : ∀ {σ} -> Term σ -> Term nat 106 | countVars = elim plus (ƛ s z) z ∘ up 107 | 108 | runCountVars : ∀ {σ} -> Term σ -> ℕ 109 | runCountVars = eval ∘ countVars 110 | 111 | testI : ∀ {σ} -> runCountVars (I {σ}) ≡ 1 112 | testI = refl 113 | 114 | testA : ∀ {σ τ} -> runCountVars (A {σ} {τ}) ≡ 2 115 | testA = refl 116 | 117 | testPlus : runCountVars plus ≡ 3 118 | testPlus = refl 119 | 120 | testCountVars : ∀ {σ t} -> runCountVars (countVars {σ} t) ≡ 3 + runCountVars t 121 | testCountVars = refl 122 | -------------------------------------------------------------------------------- /Categories/Monoid.agda: -------------------------------------------------------------------------------- 1 | module Categories.Monoid where 2 | 3 | import Function as F 4 | open import Data.Unit 5 | 6 | open import Categories.Category 7 | open import Categories.Functor 8 | 9 | record Monoid {α} (A : Set α) {{setoid : Setoid A}} : Set α where 10 | infix 5 _∙_ 11 | 12 | field 13 | ε : A 14 | _∙_ : A -> A -> A 15 | 16 | idˡ : ∀ {x} -> ε ∙ x ≈ x 17 | idʳ : ∀ {x} -> x ∙ ε ≈ x 18 | assoc : ∀ {x y z} -> (x ∙ y) ∙ z ≈ x ∙ (y ∙ z) 19 | ∙-resp-≈ : ∀ {x₁ x₂ y₁ y₂} -> x₁ ≈ x₂ -> y₁ ≈ y₂ -> x₁ ∙ y₁ ≈ x₂ ∙ y₂ 20 | 21 | record MonoidHom {α β} {A : Set α} {B : Set β} {{setoid₁ : Setoid A}} {{setoid₂ : Setoid B}} 22 | (M₁ : Monoid A) (M₂ : Monoid B) : Set (α ⊔ β) where 23 | open Monoid {{...}} 24 | 25 | field 26 | f₁ : A -> B 27 | 28 | f-ε : f₁ ε ≈ ε 29 | f-∙ : ∀ {x y} -> f₁ (x ∙ y) ≈ f₁ x ∙ f₁ y 30 | f-resp-≈ : ∀ {x y} -> x ≈ y -> f₁ x ≈ f₁ y 31 | 32 | idʰ : ∀ {α} {A : Set α} {{setoid : Setoid A}} {M : Monoid A} -> MonoidHom M M 33 | idʰ {A = A} = record 34 | { f₁ = F.id 35 | ; f-ε = refl 36 | ; f-∙ = refl 37 | ; f-resp-≈ = F.id 38 | } where open IsEquivalenceOn A 39 | 40 | -- Can we derive this from the fact, that monoid homomorphisms are functors? Should we? 41 | _∘ʰ_ : ∀ {α β γ} {A : Set α} {B : Set β} {C : Set γ} 42 | {{setoid₁ : Setoid A}} {{setoid₂ : Setoid B}} {{setoid₃ : Setoid C}} 43 | {M₁ : Monoid A} {M₂ : Monoid B} {M₃ : Monoid C} 44 | -> MonoidHom M₂ M₃ -> MonoidHom M₁ M₂ -> MonoidHom M₁ M₃ 45 | _∘ʰ_ {C = C} H₁ H₂ = record 46 | { f₁ = f₁ H₁ F.∘ f₁ H₂ 47 | ; f-ε = 48 | begin 49 | f₁ H₁ (f₁ H₂ ε) →⟨ f-resp-≈ H₁ (f-ε H₂) ⟩ 50 | f₁ H₁ ε →⟨ f-ε H₁ ⟩ 51 | ε 52 | ∎ 53 | ; f-∙ = λ {x y} -> 54 | begin 55 | f₁ H₁ (f₁ H₂ (x ∙ y)) →⟨ f-resp-≈ H₁ (f-∙ H₂) ⟩ 56 | f₁ H₁ (f₁ H₂ x ∙ f₁ H₂ y) →⟨ f-∙ H₁ ⟩ 57 | f₁ H₁ (f₁ H₂ x) ∙ f₁ H₁ (f₁ H₂ y) 58 | ∎ 59 | ; f-resp-≈ = f-resp-≈ H₁ F.∘ f-resp-≈ H₂ 60 | } where open MonoidHom; open Monoid {{...}}; open IsEquivalenceOn C 61 | 62 | instance 63 | MonoidHom-Setoid : ∀ {α β} {A : Set α} {B : Set β} {{setoid₁ : Setoid A}} {{setoid₂ : Setoid B}} 64 | {{M₁ : Monoid A}} {{M₂ : Monoid B}} 65 | -> Setoid (MonoidHom M₁ M₂) 66 | MonoidHom-Setoid {B = B} = record 67 | { _≈_ = λ H₁ H₂ -> ∀ {x} -> f₁ H₁ x ≈ f₁ H₂ x 68 | ; isEquivalence = record 69 | { refl = refl 70 | ; sym = λ p -> sym p 71 | ; trans = λ p q -> trans p q 72 | } 73 | } where open MonoidHom; open IsEquivalenceOn B 74 | 75 | Mon : ∀ {α} {A : Set α} {{setoid : Setoid A}} -> IsCategory {Obj = Monoid A} MonoidHom 76 | Mon {A = A} = record 77 | { id = idʰ 78 | ; _∘_ = _∘ʰ_ 79 | ; idˡ = refl 80 | ; idʳ = refl 81 | ; assoc = refl 82 | ; ∘-resp-≈ = λ {M₁ M₂ M₃ H₁ H₂ H₃ H₄} q p -> trans q (f-resp-≈ H₂ p) 83 | } where open MonoidHom; open IsEquivalenceOn A 84 | 85 | Monoid-IsCategory : ∀ {α} {A : Set α} {{setoid : Setoid A}} {{M : Monoid A}} 86 | -> IsCategory {Obj = ⊤} (λ _ _ -> A) 87 | Monoid-IsCategory {{M = M}} = record 88 | { id = ε 89 | ; _∘_ = _∙_ 90 | ; idˡ = idˡ 91 | ; idʳ = idʳ 92 | ; assoc = assoc 93 | ; ∘-resp-≈ = ∙-resp-≈ 94 | } where open Monoid M 95 | 96 | MonoidHom-IsFunctor : ∀ 97 | {α β} {A : Set α} {B : Set β} {{setoid₁ : Setoid A}} {{setoid₂ : Setoid B}} 98 | {M₁ : Monoid A} {M₂ : Monoid B} {{H : MonoidHom M₁ M₂}} 99 | -> IsFunctor (λ _ _ -> A) (λ _ _ -> B) F.id 100 | MonoidHom-IsFunctor {{H = H}} = record 101 | { F₁ = f₁ 102 | ; F-id = f-ε 103 | ; F-∘ = f-∙ 104 | ; F-resp-≈ = f-resp-≈ 105 | } where open MonoidHom H 106 | -------------------------------------------------------------------------------- /lib.agda: -------------------------------------------------------------------------------- 1 | open import Level 2 | open import Function hiding (const) 3 | open import Relation.Binary.PropositionalEquality as P 4 | open import Relation.Binary.HeterogeneousEquality as H hiding (subst₂) 5 | open import Data.Product 6 | 7 | const : ∀ {α β} {A : Set α} {B : A -> Set β} -> (x : A) -> B x -> A 8 | const x = λ _ -> x 9 | 10 | -- Is it in the standard library? I cannot find. 11 | _<->_ : ∀ {α β} -> Set α -> Set β -> Set (α ⊔ β) 12 | A <-> B = (A -> B) × (B -> A) 13 | 14 | subst-removable-cool : ∀ {ι α β} {I : Set ι} {i j : I} 15 | -> (A : I -> Set α) {B : ∀ {k} -> A k -> Set β} {x : A i} 16 | -> (f : ∀ {k} -> (x : A k) -> B x) 17 | -> (i≅j : i ≅ j) {y : B (H.subst A i≅j x)} 18 | -> f (H.subst A i≅j x) ≅ y 19 | -> f x ≅ y 20 | subst-removable-cool A f refl r = r 21 | 22 | unsubst : ∀ {ι α} {I : Set ι} {A : I -> Set α} {i j : I} (i≡j : i ≡ j) {x : A i} {y : A j} 23 | -> P.subst A i≡j x ≡ y -> x ≅ y 24 | unsubst refl refl = refl 25 | 26 | subst-removable-cong : ∀ {ι α β} {I : Set ι} {B : Set β} {i j : I} 27 | -> (A : I -> Set α) 28 | -> (i≡j : i ≡ j) 29 | -> (x : A i) 30 | -> (f : ∀ {k} -> A k -> B) 31 | -> f (P.subst A i≡j x) ≡ f x 32 | subst-removable-cong A refl x f = refl 33 | 34 | subst-removable-id : ∀ {ι α} {I : Set ι} {b : I -> Level} {i j : I} 35 | -> (A : I -> Set α) 36 | -> (i≡j : i ≡ j) 37 | -> (x : A i) 38 | -> (F : ∀ {k} -> A k -> Set (b k)) 39 | -> F (P.subst A i≡j x) <-> F x 40 | subst-removable-id A refl x F = id , id 41 | 42 | subst₂ : ∀ {α β γ} {A : Set α} {B : A -> Set β} {x y} {v w} 43 | -> (C : ∀ x -> B x -> Set γ) -> x ≅ y -> v ≅ w -> C x v -> C y w 44 | subst₂ C refl refl = id 45 | 46 | isubst : ∀ {ι α β} {I : Set ι} {i j : I} 47 | (A : I -> Set α) {x : A i} {y : A j} 48 | -> (B : ∀ {k} -> A k -> Set β) -> i ≅ j -> x ≅ y -> B x -> B y 49 | isubst A C refl refl = id 50 | 51 | icong : ∀ {ι α β} {I : Set ι} {i j : I} 52 | (A : I -> Set α) {B : ∀ {k} -> A k -> Set β} {x : A i} {y : A j} 53 | -> (f : ∀ {k} -> (x : A k) -> B x) -> i ≅ j -> x ≅ y -> f x ≅ f y 54 | icong A f refl refl = refl 55 | 56 | icong² : ∀ {ι₁ ι₂ α β} {I₁ : Set ι₁} {I₂ : I₁ -> Set ι₂} 57 | (A : ∀ i₁ -> I₂ i₁ -> Set α) {B : ∀ {i₁ i₂} -> A i₁ i₂ -> Set β} 58 | {i₁ i₂ j₁ j₂} {x : A i₁ i₂} {y : A j₁ j₂} 59 | -> (f : ∀ {i₁ i₂} -> (x : A i₁ i₂) -> B x) 60 | -> i₁ ≅ j₁ -> i₂ ≅ j₂ -> x ≅ y -> f x ≅ f y 61 | icong² A f refl refl refl = refl 62 | 63 | icong³ : ∀ {ι₁ ι₂ ι₃ α β} {I₁ : Set ι₁} {I₂ : I₁ -> Set ι₂} 64 | {I₃ : ∀ {i₁} -> I₂ i₁ -> Set ι₃} 65 | (A : ∀ i₁ -> (i₂ : I₂ i₁) -> I₃ i₂ -> Set α) 66 | {B : ∀ {i₁ i₂ i₃} -> A i₁ i₂ i₃ -> Set β} 67 | {i₁ i₂ i₃ j₁ j₂ j₃} {x : A i₁ i₂ i₃} {y : A j₁ j₂ j₃} 68 | -> (f : ∀ {i₁ i₂ i₃} -> (x : A i₁ i₂ i₃) -> B x) 69 | -> i₁ ≅ j₁ -> i₂ ≅ j₂ -> i₃ ≅ j₃ -> x ≅ y -> f x ≅ f y 70 | icong³ A f refl refl refl refl = refl 71 | 72 | icong₂ : ∀ {ι α β γ} {I : Set ι} 73 | (A : I -> Set α) {B : ∀ {k} -> A k -> Set β} 74 | {C : ∀ {k} -> (x : A k) -> B x -> Set γ} 75 | {i j} {x : A i} {y : A j} {v w} 76 | -> (f : ∀ {k} -> (x : A k) -> (y : B x) -> C x y) 77 | -> i ≅ j -> x ≅ y -> v ≅ w -> f x v ≅ f y w 78 | icong₂ A f refl refl refl = refl 79 | 80 | icong²₂ : ∀ {ι₁ ι₂ α β γ} {I₁ : Set ι₁} {I₂ : I₁ -> Set ι₂} 81 | (A : ∀ i₁ -> I₂ i₁ -> Set α) {B : ∀ {i₁ i₂} -> A i₁ i₂ -> Set β} 82 | {C : ∀ {i₁ i₂} {x : A i₁ i₂} -> B x -> Set γ} 83 | {i₁ i₂ j₁ j₂} {x : A i₁ i₂} {y : A j₁ j₂} {v w} 84 | -> (f : ∀ {i₁ i₂} -> (x : A i₁ i₂) -> (y : B x) -> C y) 85 | -> i₁ ≅ j₁ -> i₂ ≅ j₂ -> x ≅ y -> v ≅ w -> f x v ≅ f y w 86 | icong²₂ A f refl refl refl refl = refl 87 | -------------------------------------------------------------------------------- /Lists/elimChurchList.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --type-in-type --rewriting #-} 2 | 3 | open import Function 4 | open import Relation.Binary.PropositionalEquality 5 | open import Data.Product hiding (map) 6 | 7 | infixr 5 _∷′_ _∷_ 8 | 9 | List′ : Set -> Set 10 | List′ A = ∀ {B} -> (A -> B -> B) -> B -> B 11 | 12 | []′ : ∀ {A} -> List′ A 13 | []′ = λ f z -> z 14 | 15 | _∷′_ : ∀ {A} -> A -> List′ A -> List′ A 16 | x ∷′ xs = λ f z -> f x (xs f z) 17 | 18 | Univ : ∀ {A} -> List′ A -> Set 19 | Univ {A} xs = ∀ {B} 20 | -> (h′ : List′ A -> B) 21 | -> (f : A -> B -> B) 22 | -> (z : B) 23 | -> (∀ x (xs : List′ A) -> h′ (x ∷′ xs) ≡ f x (h′ xs)) 24 | -> h′ []′ ≡ z 25 | -> h′ xs ≡ xs f z 26 | 27 | List : Set -> Set 28 | List A = Σ (List′ A) Univ 29 | 30 | init : ∀ {A} 31 | -> (p : List A) 32 | -> (h′ : List′ A -> List′ A) 33 | -> (∀ x (xs : List′ A) -> (λ {B} -> h′ (x ∷′ xs) {B}) ≡ x ∷′ h′ xs) 34 | -> (λ {B} -> h′ []′ {B}) ≡ []′ 35 | -> (λ {B} -> h′ (proj₁ p) {B}) ≡ proj₁ p 36 | init (xs , u) h′ q r = trans (u h′ _∷′_ []′ q r) (sym (u id _∷′_ []′ (λ _ _ -> refl) refl)) 37 | 38 | [] : ∀ {A} -> List A 39 | [] = []′ , λ h′ f z q r -> r 40 | 41 | _∷_ : ∀ {A} -> A -> List A -> List A 42 | x ∷ (xs , u) = x ∷′ xs , λ h′ f z q r -> trans (q x xs) (cong (f x) (u h′ f z q r)) 43 | 44 | elimList′ : ∀ {A} 45 | -> (P : List′ A -> Set) 46 | -> (∀ {xs : List′ A} x -> P xs -> P (x ∷′ xs)) 47 | -> P []′ 48 | -> (xs : List A) 49 | -> P (proj₁ xs) 50 | elimList′ {A} P f z p@(xs , u) = subst P coh (proj₂ (xs cons nil)) where 51 | cons : A -> ∃ P -> ∃ P 52 | cons x (xs , r) = x ∷′ xs , f x r 53 | 54 | nil : ∃ P 55 | nil = []′ , z 56 | 57 | coh = init p (λ xs -> proj₁ (xs cons nil)) (λ _ _ -> refl) refl 58 | 59 | pointwise : ∀ {A : Set} {B : A -> Set} {x₁ x₂ y₁ y₂} 60 | -> (q : x₁ ≡ x₂) -> subst B q y₁ ≡ y₂ -> (x₁ , y₁) ≡ (x₂ , y₂) 61 | pointwise refl refl = refl 62 | 63 | elimList : ∀ {A} 64 | -> (P : List A -> Set) 65 | -> (∀ {xs : List A} x -> P xs -> P (x ∷ xs)) 66 | -> P [] 67 | -> (xs : List A) 68 | -> P xs 69 | elimList {A} P f z p@(xs , u) = subst P coh (proj₂ (xs cons nil)) where 70 | cons : A -> ∃ P -> ∃ P 71 | cons x (xs , r) = x ∷ xs , f x r 72 | 73 | nil : ∃ P 74 | nil = [] , z 75 | 76 | open import Relation.Binary.PropositionalEquality.TrustMe 77 | 78 | coh = pointwise (init p (λ xs -> proj₁ (proj₁ (xs cons nil))) (λ _ _ -> refl) refl) trustMe 79 | 80 | map : ∀ {A B} -> (A -> B) -> List A -> List B 81 | map f = elimList _ (_∷_ ∘ f) [] 82 | 83 | subst-compute : ∀ {I A} {i j : I} {x : A} -> (p : i ≡ j) -> subst (const A) p x ≡ x 84 | subst-compute refl = refl 85 | 86 | {-# BUILTIN REWRITE _≡_ #-} 87 | {-# REWRITE subst-compute #-} 88 | 89 | map-map : ∀ {A B C} {f : A -> B} {g : B -> C} -> map g ∘ map f ≗ map (g ∘ f) 90 | map-map {f = f} {g} = elimList (λ xs -> map g (map f xs) ≡ map (g ∘ f) xs) 91 | (λ x -> cong (g (f x) ∷_)) 92 | refl 93 | 94 | open import Data.Nat.Base 95 | open import Data.Vec renaming ([] to []ᵥ; _∷_ to _∷ᵥ_) hiding (toList) 96 | 97 | length : ∀ {A} -> List A -> ℕ 98 | length = elimList _ (const suc) 0 99 | 100 | toVec : ∀ {A} -> (xs : List A) -> Vec A (length xs) 101 | toVec = elimList (Vec _ ∘ length) _∷ᵥ_ []ᵥ 102 | 103 | toList : ∀ {A n} -> Vec A n -> List A 104 | toList = foldr _ _∷_ [] 105 | 106 | -- We need a more complicated computational rule for `subst` to prove this lemma. 107 | toList-toVec : ∀ {A} -> toList ∘ toVec {A} ≗ id 108 | toList-toVec = elimList (λ xs -> toList (toVec xs) ≡ xs) (λ x r -> {!!}) refl 109 | 110 | -- Is this enough for all cases? I doubt. 111 | subst-compute₂ : ∀ {I B} {i j : I} 112 | -> (A : I -> Set) 113 | -> (p : i ≡ j) 114 | -> (x : A i) 115 | -> (f : ∀ {k} -> A k -> B) 116 | -> f (subst A p x) ≡ f x 117 | subst-compute₂ A refl x f = refl 118 | -------------------------------------------------------------------------------- /Nary/Comps.agda: -------------------------------------------------------------------------------- 1 | module Nary.Comps where 2 | 3 | open import Level 4 | open import Data.Nat.Base 5 | open import Data.Product 6 | 7 | open import Nary.Power 8 | 9 | module comp1 where 10 | open import Data.Vec.N-ary 11 | 12 | comp : ∀ n {α β γ} {X : Set α} {Y : Set β} {Z : Set γ} 13 | -> (Y -> Z) -> N-ary n X Y -> N-ary n X Z 14 | comp 0 g y = g y 15 | comp (suc n) g f = λ x -> comp n g (f x) 16 | 17 | module comp2 where 18 | open import Data.Vec.N-ary 19 | 20 | Comp : ∀ n {α β γ} {X : Set α} {Y : Set β} 21 | -> (Y -> Set γ) -> N-ary n X Y -> Set (N-ary-level α γ n) 22 | Comp 0 Z y = Z y 23 | Comp (suc n) Z f = ∀ x -> Comp n Z (f x) 24 | 25 | comp : ∀ n {α β γ} {X : Set α} {Y : Set β} {Z : Y -> Set γ} 26 | -> ((y : Y) -> Z y) -> (f : N-ary n X Y) -> Comp n Z f 27 | comp 0 g y = g y 28 | comp (suc n) g f = λ x -> comp n g (f x) 29 | 30 | module comp3 where 31 | open import Nary.Naive 32 | 33 | comp : ∀ n {Xs : Set ^ n} {Y Z : Set} 34 | -> (Y -> Z) -> (Xs ->ⁿ Y) -> Xs ->ⁿ Z 35 | comp 0 g y = g y 36 | comp (suc n) g f = λ x -> comp n g (f x) 37 | 38 | module comp4 where 39 | open import Nary.Naive 40 | 41 | Comp : ∀ n {Xs : Set ^ n} {Y : Set} 42 | -> (Y -> Set) -> (Xs ->ⁿ Y) -> Set 43 | Comp 0 Z y = Z y 44 | Comp (suc n) Z f = ∀ x -> Comp n Z (f x) 45 | 46 | comp : ∀ n {Xs : Set ^ n} {Y : Set} {Z : Y -> Set} 47 | -> ((y : Y) -> Z y) -> (f : Xs ->ⁿ Y) -> Comp n Z f 48 | comp 0 g y = g y 49 | comp (suc n) g f = λ x -> comp n g (f x) 50 | 51 | module comp5 where 52 | open import Nary.Simple 53 | 54 | comp : ∀ n {β γ} {αs : Level ^ n} {Xs : Sets αs} {Y : Set β} {Z : Set γ} 55 | -> (Y -> Z) -> (Xs ->ⁿ Y) -> Xs ->ⁿ Z 56 | comp 0 g y = g y 57 | comp (suc n) g f = λ x -> comp n g (f x) 58 | 59 | module comp6 where 60 | open import Nary.Simple 61 | 62 | Comp : ∀ n {αs : Level ^ n} {β γ} {Xs : Sets αs} {Y : Set β} 63 | -> (Y -> Set γ) -> (Xs ->ⁿ Y) -> Set (αs ⊔ⁿ γ) 64 | Comp 0 Z y = Z y 65 | Comp (suc n) Z f = ∀ x -> Comp n Z (f x) 66 | 67 | comp : ∀ n {β γ} {αs : Level ^ n} {Xs : Sets αs} {Y : Set β} {Z : Y -> Set γ} 68 | -> ((y : Y) -> Z y) -> (f : Xs ->ⁿ Y) -> Comp n Z f 69 | comp 0 g y = g y 70 | comp (suc n) g f = λ x -> comp n g (f x) 71 | 72 | module comp7 where 73 | open import Nary.Dependent 74 | 75 | comp : ∀ n {α β γ} {αs : Level ^ n} {Xs : Sets αs α} {Y : Set β} {Z : Set γ} 76 | -> (Y -> Z) -> (Xs ->ⁿ Y) -> Xs ->ⁿ Z 77 | comp 0 g f = λ x -> g (f x) 78 | comp (suc n) g f = λ x -> comp n g (f x) 79 | 80 | module comp8 where 81 | open import Nary.Dependent 82 | 83 | Comp : ∀ n {αs : Level ^ n} {β γ} {Xs : Sets αs β} 84 | -> (Xs ⋯>ⁿ Set γ) -> Fold Xs -> Set (αs ⊔ⁿ γ) 85 | Comp 0 Z y = Z y 86 | Comp (suc n) Z f = ∀ x -> Comp n Z (f x) 87 | 88 | comp : ∀ n {β γ} {αs : Level ^ n} {Xs : Sets αs β} {Z : Xs ⋯>ⁿ Set γ} 89 | -> Πⁿ Xs Z -> (f : Fold Xs) -> Comp n Z f 90 | comp 0 g y = g y 91 | comp (suc n) g f = λ x -> comp n g (f x) 92 | 93 | module tests where 94 | open import Data.Bool 95 | open import Data.Vec 96 | open import Relation.Binary.PropositionalEquality 97 | 98 | length : ∀ {α} {A : Set α} {n} -> Vec A n -> ℕ 99 | length {n = n} _ = n 100 | 101 | explicit-replicate : (A : Set) -> (n : ℕ) -> A -> Vec A n 102 | explicit-replicate _ _ x = replicate x 103 | 104 | foo : (A : Set) -> ℕ -> A -> ℕ 105 | foo = comp 3 length explicit-replicate 106 | 107 | test : foo Bool 5 true ≡ 5 108 | test = refl 109 | 110 | foo' : ∀ {α} {A : Set α} -> ℕ -> A -> ℕ 111 | foo' = comp 2 length (λ n -> replicate {n = n}) 112 | 113 | test' : foo' 5 true ≡ 5 114 | test' = refl 115 | 116 | explicit-replicate' : ∀ α -> (A : Set α) -> (n : ℕ) -> A -> Vec A n 117 | explicit-replicate' _ _ _ x = replicate x 118 | 119 | -- ... because this would result in an invalid use of Setω ... 120 | -- error : ∀ α -> (A : Set α) -> ℕ -> A -> ℕ 121 | -- error = comp 4 length explicit-replicate' 122 | -------------------------------------------------------------------------------- /System-F/Subst.agda: -------------------------------------------------------------------------------- 1 | module System-F.Subst where 2 | 3 | open import System-F.Prelude 4 | open import System-F.Kits 5 | open import System-F.Core 6 | 7 | -- This is awful. 8 | module _ where 9 | open TypeThing 10 | open TypeEnvironment 11 | 12 | ren-lookup-top : ∀ {Θ Ξ σ τ} {α : Θ ⊢ᵗ σ} Γ (ι : Θ ⊆ Ξ) (v : τ ∈ Θ ▻ σ ▻▻ Γ) 13 | -> renᵗ (keeps Γ ι) (lookupᵉ v (keepsᵉ Γ (topᵉ α))) 14 | ≡ lookupᵉ (renᵛ (keeps Γ (keep ι)) v) (keepsᵉ Γ (topᵉ (renᵗ ι α))) 15 | ren-lookup-top ε ι vz = refl 16 | ren-lookup-top ε ι (vs v) = trans (cong (renᵗ ι) (lookupᵉ-idᵉ v)) 17 | (sym (lookupᵉ-idᵉ (renᵛ ι v))) 18 | ren-lookup-top (Γ ▻ σ) ι vz = refl 19 | ren-lookup-top (Γ ▻ σ) ι (vs v) = 20 | trans (cong (renᵗ (keep (keeps Γ ι))) (lookupᵉ-renᵉ v top _)) 21 | (trans (renᵗ-∘ˢ (keep (keeps Γ ι)) top _) 22 | (trans (trans (trans (trans (cong (λ ι -> renᵗ (skip ι) _) 23 | (∘ˢ-idˢ (keeps Γ ι))) 24 | (cong (λ ι -> renᵗ (skip ι) _) 25 | (sym (idˢ-∘ˢ (keeps Γ ι))))) 26 | (sym (renᵗ-∘ˢ top (keeps Γ ι) _))) 27 | (cong shiftᵗ (ren-lookup-top Γ ι v))) 28 | (sym (lookupᵉ-renᵉ (renᵛ (keeps Γ (keep ι)) v) top _)))) 29 | 30 | -- Would this be any better? 31 | -- subᵗ (renᵉ ι idᵉ ▻ α) β ≡ subᵗ (idᵉ ▻ α) (renᵗ (keep ι) β) 32 | -- subᵗ (keepᵉ (renᵉ ι idᵉ ▻ α)) γ ≡ subᵗ (keepᵉ (idᵉ ▻ α)) (renᵗ (keep (keep ι)) γ) 33 | 34 | -- renᵗ ι (subᵗ (topᵉ α) β) ≡ subᵗ (topᵉ (renᵗ ι α)) (renᵗ (keep ι) β) 35 | -- renᵗ (keep ι) (subᵗ (keepᵉ (topᵉ α)) γ) ≡ subᵗ (keepᵉ (topᵉ (renᵗ ι α))) (renᵗ (keep (keep ι) γ)) 36 | ren-sub-top : ∀ {Θ Ξ σ τ} {α : Θ ⊢ᵗ σ} Γ (ι : Θ ⊆ Ξ) (β : Θ ▻ σ ▻▻ Γ ⊢ᵗ τ) 37 | -> renᵗ (keeps Γ ι) (subᵗ (keepsᵉ Γ (topᵉ α)) β) 38 | ≡ subᵗ (keepsᵉ Γ (topᵉ (renᵗ ι α))) (renᵗ (keeps Γ (keep ι)) β) 39 | ren-sub-top Γ ι (Var v) = ren-lookup-top Γ ι v 40 | ren-sub-top Γ ι (f ·ᵗ β) = cong₂ _·ᵗ_ (ren-sub-top Γ ι f) (ren-sub-top Γ ι β) 41 | ren-sub-top Γ ι (β ⇒ γ) = cong₂ _⇒_ (ren-sub-top Γ ι β) (ren-sub-top Γ ι γ) 42 | ren-sub-top Γ ι (π σ γ) = cong (π σ) (ren-sub-top (Γ ▻ σ) ι γ) 43 | ren-sub-top Γ ι list = refl 44 | 45 | ren-top-sub : ∀ {Θ Ξ σ} {α : Θ ⊢ᵗ σ} (ι : Θ ⊆ Ξ) (β : Type (Θ ▻ σ)) 46 | -> renᵗ ι (β [ α ]ᵗ) ≡ renᵗ (keep ι) β [ renᵗ ι α ]ᵗ 47 | ren-top-sub = ren-sub-top ε 48 | 49 | rename : ∀ {Θ Ξ α} {Γ : Conᵗ Θ} -> (ι : Θ ⊆ Ξ) -> Γ ⊢ α -> renᶜ ι Γ ⊢ renᵗ ι α 50 | rename ι (var v) = var (renameᵛ ι v) 51 | rename {Γ = Γ} ι (Λ b) = 52 | Λ (coerceCon (trans (renᶜ-∘ˢ (keep ι) top Γ) 53 | (trans (cong (λ ι -> renᶜ (skip ι) Γ) 54 | (trans (∘ˢ-idˢ ι) (sym (idˢ-∘ˢ ι)))) 55 | (sym (renᶜ-∘ˢ top ι Γ)))) 56 | (rename (keep ι) b)) 57 | rename ι (_[_] {β = β} f α) rewrite ren-top-sub {α = α} ι β 58 | = rename ι f [ renᵗ ι α ] 59 | rename ι (ƛ b) = ƛ (rename ι b) 60 | rename ι (f · x) = rename ι f · rename ι x 61 | rename ι [] = [] 62 | rename ι (x :: xs) = rename ι x :: rename ι xs 63 | rename ι (foldr f z xs) = foldr (rename ι f) (rename ι z) (rename ι xs) 64 | 65 | TermNestedEnvs : NestedEnvironments TermEnv TypeEnv 66 | TermNestedEnvs = record 67 | { renⁿᶠ = rename 68 | } 69 | 70 | open TermEnvironment 71 | open NestedEnvironments TermNestedEnvs 72 | 73 | sub : ∀ {Θ Γ Δ} {σ : Type Θ} -> Δ ⊢ᵉ Γ -> Γ ⊢ σ -> Δ ⊢ σ 74 | sub ρ (var v) = lookupᵉ v ρ 75 | sub ρ (Λ b) = Λ (sub (shiftᵉ-⊆ ρ) b) 76 | sub ρ (f [ α ]) = sub ρ f [ α ] 77 | sub ρ (ƛ b) = ƛ (sub (keepᵉ ρ) b) 78 | sub ρ (f · x) = sub ρ f · sub ρ x 79 | sub ρ [] = [] 80 | sub ρ (x :: xs) = sub ρ x :: sub ρ xs 81 | sub ρ (foldr f z xs) = foldr (sub ρ f) (sub ρ z) (sub ρ xs) 82 | -------------------------------------------------------------------------------- /Categories/Morphism.agda: -------------------------------------------------------------------------------- 1 | module Categories.Morphism where 2 | 3 | open import Level 4 | open import Function as F using (const; case_of_) 5 | open import Relation.Binary.PropositionalEquality as P 6 | open import Data.Unit 7 | open import Data.Product 8 | 9 | open import Categories.Setoid 10 | open import Categories.Category 11 | 12 | module _ {α β} {A : Set α} {B : Set β} (f : A -> B) 13 | {{setoid₁ : Setoid A}} {{setoid₂ : Setoid B}} where 14 | 15 | record Injective : Set (α ⊔ β) where 16 | field inj : ∀ {x y} -> f x ≈ f y -> x ≈ y 17 | 18 | record Surjective : Set (α ⊔ β) where 19 | field surj : ∀ y -> ∃ λ x -> f x ≈ y 20 | 21 | Bijective = Injective × Surjective 22 | 23 | module _ {α β} {A : Set α} {B : Set β} {f : A -> B} 24 | {{setoid₁ : Setoid A}} {{setoid₂ : Setoid B}} where 25 | instance 26 | Bijective->Injective : {{bijective : Bijective f}} -> Injective f 27 | Bijective->Injective {{injective , surjective}} = injective 28 | 29 | Bijective->Surjective : {{bijective : Bijective f}} -> Surjective f 30 | Bijective->Surjective {{injective , surjective}} = surjective 31 | 32 | module _ {α β} {Obj : Set α} {_⇒_ : Obj -> Obj -> Set β} 33 | {{setoid : ∀ {A B} -> Setoid (A ⇒ B)}} {{C : IsCategory _⇒_}} where 34 | open IsCategory C 35 | 36 | module _ {A B : Obj} (f : A ⇒ B) where 37 | record Mono : Set (α ⊔ β) where 38 | field mono : ∀ {C} {g h : C ⇒ A} -> f ∘ g ≈ f ∘ h -> g ≈ h 39 | 40 | record Epi : Set (α ⊔ β) where 41 | field epi : ∀ {C} {g h : B ⇒ C} -> g ∘ f ≈ h ∘ f -> g ≈ h 42 | 43 | record Iso : Set (α ⊔ β) where 44 | field 45 | f⁻¹ : B ⇒ A 46 | isoˡ : f ∘ f⁻¹ ≈ id 47 | isoʳ : f⁻¹ ∘ f ≈ id 48 | 49 | record _≅_ A B : Set (α ⊔ β) where 50 | field 51 | {f} : A ⇒ B 52 | iso : Iso f 53 | 54 | record InAgda : Set where 55 | open Setoid-Instances _ 56 | 57 | ∘′-resp-≡ : ∀ {α} {A B C : Set α} {g₁ g₂ : B -> C} {f₁ f₂ : A -> B} 58 | -> (∀ y -> g₁ y ≡ g₂ y) -> (∀ x -> f₁ x ≡ f₂ x) -> ∀ x -> g₁ (f₁ x) ≡ g₂ (f₂ x) 59 | ∘′-resp-≡ q p x rewrite p x = q _ 60 | 61 | instance 62 | Agda : ∀ {α} -> IsCategory (λ (A B : Set α) -> A -> B) 63 | Agda = record 64 | { id = F.id 65 | ; _∘_ = F._∘′_ 66 | ; idˡ = λ x -> P.refl 67 | ; idʳ = λ x -> P.refl 68 | ; assoc = λ f x -> P.refl 69 | ; ∘-resp-≈ = ∘′-resp-≡ 70 | } 71 | 72 | open Injective {{...}}; open Surjective {{...}} 73 | open Mono {{...}}; open Epi {{...}}; open Iso {{...}} 74 | 75 | infix 9 _⁻¹_ 76 | _⁻¹_ = f⁻¹ 77 | 78 | module _ {α} {A B : Set α} {f : A -> B} where 79 | Iso->Mono&Epi : {{_ : Iso f}} -> Mono f × Epi f 80 | Iso->Mono&Epi = record 81 | { mono = λ {C g h} p x -> 82 | begin 83 | g x ←⟨ isoʳ f (g x) ⟩ 84 | f ⁻¹ f (g x) →⟨ cong (f⁻¹ f) (p x) ⟩ -- `cong (λ x -> f⁻¹ f x)` gives an error. 85 | f ⁻¹ f (h x) →⟨ isoʳ f (h x) ⟩ 86 | h x 87 | ∎ 88 | } , record 89 | { epi = λ {C g h} p y -> 90 | begin 91 | g y ←⟨ cong g (isoˡ f y) ⟩ 92 | g (f (f ⁻¹ y)) →⟨ p (f ⁻¹ y) ⟩ 93 | h (f (f ⁻¹ y)) →⟨ cong h (isoˡ f y) ⟩ 94 | h y 95 | ∎ 96 | } 97 | 98 | Mono->Injective : {{_ : Mono f}} -> Injective f 99 | Mono->Injective = record { inj = λ p -> mono f (const p) (lift tt) } 100 | 101 | Injective->Mono : {{_ : Injective f}} -> Mono f 102 | Injective->Mono = record { mono = λ p x -> inj f (p x) } 103 | 104 | -- What is the most constructive way to say this? 105 | -- Epi->Surjective : {{_ : Epi f}} -> Surjective f 106 | 107 | Surjective->Epi : {{_ : Surjective f}} -> Epi f 108 | Surjective->Epi = record { epi = λ p y -> uncurry (λ x q -> subst _ q (p x)) (surj f y) } 109 | 110 | Bijective->Iso : {{_ : Bijective f}} -> Iso f 111 | Bijective->Iso = record 112 | { f⁻¹ = λ y -> proj₁ (surj f y) 113 | ; isoˡ = λ y -> proj₂ (surj f y) 114 | ; isoʳ = λ x -> inj f (proj₂ (surj f (f x))) 115 | } 116 | --------------------------------------------------------------------------------