├── higher-rank-syntax.agda-lib
└── src
    ├── Alternatives.agda
    ├── FixPointRel.agda
    ├── Rank.agda
    ├── Renaming.agda
    ├── SizeInduction.agda
    ├── Substitution.agda
    └── Syntax.agda


/higher-rank-syntax.agda-lib:
--------------------------------------------------------------------------------
1 | name: higher-rank-syntax -- formalization of higher-rank syntax
2 | depend: agda-categories
3 | include: src
4 | 


--------------------------------------------------------------------------------
/src/Alternatives.agda:
--------------------------------------------------------------------------------
  1 | -- Old attempts at convincing Agda that substituition terminates.
  2 | 
  3 | open import Agda.Primitive
  4 | open import Relation.Unary hiding (_∈_)
  5 | open import Relation.Binary
  6 | open import Relation.Binary.PropositionalEquality
  7 | open import Data.Product using (_,_; _×_)
  8 | open import Function using (_∘_)
  9 | open import Data.List hiding ([_]; tabulate; map)
 10 | 
 11 | open ≡-Reasoning
 12 | 
 13 | import Syntax
 14 | import Renaming
 15 | 
 16 | 
 17 | module Alternatives (Class : Set) where
 18 | 
 19 |   open Syntax Class
 20 |   open Renaming Class
 21 | 
 22 |   -- Lifting of renamings to substitutions, and of variables to expressions
 23 | 
 24 |   lift : ∀ {γ δ} → (γ →ʳ δ) → (γ →ˢ δ)
 25 | 
 26 |   η : ∀ {γ a} (x : a ∈ γ) → Arg γ a
 27 | 
 28 |   lift 𝟘 = 𝟘
 29 |   lift [ x ] = [ η x ]
 30 |   lift (ρ₁ ⊕ ρ₂) = lift ρ₁ ⊕ lift ρ₂
 31 | 
 32 |   η x = var-left x ` lift (tabulate var-right)
 33 | 
 34 |   -- Ideally we would like the following to be the definition of lift,
 35 |   -- but Agda termination gets in the way
 36 | 
 37 |   lift-map-η : ∀ {γ δ} (ρ : γ →ʳ δ) → lift ρ ≡ map η ρ
 38 |   lift-map-η 𝟘 = refl
 39 |   lift-map-η [ x ] = refl
 40 |   lift-map-η (ρ₁ ⊕ ρ₂) = cong₂ _⊕_ (lift-map-η ρ₁) (lift-map-η ρ₂)
 41 | 
 42 |   lift-𝟙ʳ : ∀ {γ} → lift 𝟙ʳ ≡ tabulate (η {γ = γ})
 43 |   lift-𝟙ʳ = trans (lift-map-η 𝟙ʳ) map-tabulate
 44 | 
 45 |   -- Identity substitution
 46 | 
 47 |   𝟙ˢ : ∀ {γ} → γ →ˢ γ
 48 |   𝟙ˢ = lift 𝟙ʳ
 49 | 
 50 |   -- Substitution extension
 51 | 
 52 |   ⇑ˢ : ∀ {γ δ θ} → γ →ˢ δ → γ ⊕ θ →ˢ δ ⊕ θ
 53 |   ⇑ˢ {θ = θ} f =  map [ ⇑ʳ (tabulate var-left) ]ʳ_ f ⊕ lift (tabulate var-right)
 54 | 
 55 |   -- The interaction of lifting with various operations
 56 | 
 57 |   lift-∙ : ∀ {γ δ} (ρ : γ →ʳ δ) {a} (x : a ∈ γ) →
 58 |            lift ρ ∙ x ≡ η (ρ ∙ x)
 59 |   lift-∙ [ _ ] var-here = refl
 60 |   lift-∙ (ρ₁ ⊕ ρ₂) (var-left x) = lift-∙ ρ₁ x
 61 |   lift-∙ (ρ₁ ⊕ ρ₂) (var-right y) = lift-∙ ρ₂ y
 62 | 
 63 |   𝟙ˢ-∙ : ∀ {γ a} {x : a ∈ γ} → 𝟙ˢ ∙ x ≡ η x
 64 |   𝟙ˢ-∙ {x = x} = trans (lift-∙ 𝟙ʳ x) (cong η 𝟙ʳ-≡)
 65 | 
 66 |   lift-tabulate : ∀ {γ δ} (f : ∀ {α} → α ∈ γ → α ∈ δ) {a} (x : a ∈ γ) →
 67 |                   lift (tabulate f) ∙ x ≡ η (f x)
 68 |   lift-tabulate f var-here = refl
 69 |   lift-tabulate f (var-left x) = lift-tabulate (λ z → f (var-left z)) x
 70 |   lift-tabulate f (var-right y) = lift-tabulate (λ z → f (var-right z)) y
 71 | 
 72 |   ∘ʳ-lift : ∀ {γ δ θ} (ρ : γ →ʳ δ) (τ : δ →ʳ θ) {a} (x : a ∈ γ) →
 73 |              lift (τ ∘ʳ ρ) ∙ x ≡  lift τ ∙ (ρ ∙ x)
 74 |   ∘ʳ-lift [ x ] τ var-here = sym (lift-∙ τ x)
 75 |   ∘ʳ-lift (ρ₁ ⊕ ρ₂) τ (var-left x) = ∘ʳ-lift ρ₁ τ x
 76 |   ∘ʳ-lift (ρ₁ ⊕ ρ₂) τ (var-right y) = ∘ʳ-lift ρ₂ τ y
 77 | 
 78 |   []ʳ-lift : ∀ {γ δ θ} (ρ : γ →ʳ δ) (τ : δ →ʳ θ) {a} (x : a ∈ γ) → [ ⇑ʳ τ ]ʳ (lift ρ ∙ x) ≡  lift (τ ∘ʳ ρ) ∙ x
 79 |   []ʳ-η : ∀ {γ δ} (ρ : γ →ʳ δ) {a} (x : a ∈ γ) → [ ⇑ʳ ρ ]ʳ η x ≡ η (ρ ∙ x)
 80 | 
 81 |   []ʳ-lift [ x ] τ var-here = []ʳ-η τ x
 82 |   []ʳ-lift (ρ₁ ⊕ ρ₂) τ (var-left x) = []ʳ-lift ρ₁ τ x
 83 |   []ʳ-lift (ρ₁ ⊕ ρ₂) τ (var-right x) = []ʳ-lift ρ₂ τ x
 84 | 
 85 |   ⇑ʳ-∘ʳ-tabulate-var-right : ∀ {γ δ θ} (ρ : γ →ʳ δ) →
 86 |                              (⇑ʳ {θ = θ} ρ ∘ʳ tabulate var-right) ≡ tabulate var-right
 87 |   ⇑ʳ-∘ʳ-tabulate-var-right {θ = θ} ρ = shape-≡ ξ
 88 |     where ξ : ∀ {a} (x : a ∈ θ) → (⇑ʳ ρ ∘ʳ tabulate var-right) ∙ x ≡ tabulate var-right ∙ x
 89 |           ξ x = trans
 90 |                   (trans
 91 |                       (∘ʳ-∙  {ρ = ⇑ʳ ρ} {τ = tabulate var-right} {x = x})
 92 |                       (trans (cong (⇑ʳ ρ ∙_) (tabulate-∙ var-right)) (tabulate-∙ var-right)))
 93 |                   (sym (tabulate-∙ var-right))
 94 | 
 95 |   [⇑ʳ]-lift-var-right : ∀ {γ δ θ} (ρ : γ →ʳ δ) {a} (x : a ∈ θ) →
 96 |                         [ ⇑ʳ (⇑ʳ ρ) ]ʳ lift (tabulate var-right) ∙ x  ≡ lift (tabulate var-right) ∙ x
 97 |   [⇑ʳ]-lift-var-right ρ x = trans ([]ʳ-lift (tabulate var-right) (⇑ʳ ρ) x) (cong (λ τ → lift τ ∙ x) (⇑ʳ-∘ʳ-tabulate-var-right ρ))
 98 | 
 99 |   ʳ∘ˢ-lift-var-right : ∀ {γ δ θ} (ρ : γ →ʳ δ) {a} (x : a ∈ θ) →
100 |                        ((⇑ʳ {θ = θ} ρ) ʳ∘ˢ lift (tabulate var-right)) ∙ x ≡ lift (tabulate var-right) ∙ x
101 |   ʳ∘ˢ-lift-var-right ρ x =
102 |     trans
103 |       (ʳ∘ˢ-∙ {ρ = ⇑ʳ ρ} {ts = lift (tabulate var-right)})
104 |       ([⇑ʳ]-lift-var-right ρ x)
105 | 
106 |   []ʳ-η ρ x = ≡-` (map-∙ {f = var-left} {ps = ρ}) (λ z → ʳ∘ˢ-lift-var-right ρ z)
107 | 
108 | 
109 |   ʳ∘ˢ-lift : ∀ {γ δ θ} (ρ : γ →ʳ δ) (τ : δ →ʳ θ) {a} (x : a ∈ γ) →
110 |              (τ ʳ∘ˢ lift ρ) ∙ x ≡ lift (τ ∘ʳ ρ) ∙ x
111 |   ʳ∘ˢ-lift [ x ] τ var-here = ≡-` ( map-∙ {f = var-left} {ps = τ}) λ z → ʳ∘ˢ-lift-var-right τ z
112 |   ʳ∘ˢ-lift (ρ₁ ⊕ ρ₂) τ (var-left x) = ʳ∘ˢ-lift ρ₁ τ x
113 |   ʳ∘ˢ-lift (ρ₁ ⊕ ρ₂) τ (var-right x) = ʳ∘ˢ-lift ρ₂ τ x
114 | 
115 |   lift-map : ∀ {γ δ θ} (f : ∀ {α} → α ∈ γ → α ∈ δ) (ρ : θ →ʳ γ) →
116 |              lift (map f ρ) ≡ map [ ⇑ʳ (tabulate f) ]ʳ_ (lift ρ)
117 |   lift-map f 𝟘 = refl
118 |   lift-map f [ x ] = cong [_] (trans (cong η (sym (tabulate-∙ f))) (sym ([]ʳ-η (tabulate f) x)))
119 |   lift-map f (ρ₁ ⊕ ρ₂) = cong₂ _⊕_ (lift-map f ρ₁) (lift-map f ρ₂)
120 | 
121 |   ⇑ˢ-lift : ∀ {γ δ θ} (ρ : γ →ʳ δ) → ⇑ˢ {θ = θ} (lift ρ) ≡ lift (⇑ʳ ρ)
122 |   ⇑ˢ-lift ρ = cong₂ _⊕_ (sym (lift-map var-left ρ)) refl
123 | 
124 |   shift : Shape → List Shape → Shape
125 |   shift γ [] = γ
126 |   shift γ (δ ∷ δs) = (shift γ δs) ⊕ δ
127 | 
128 |   ⟰ʳ : ∀ {γ δ Ξ} → (γ →ʳ δ) → (shift γ Ξ →ʳ shift δ Ξ)
129 |   ⟰ʳ {Ξ = []} ρ = ρ
130 |   ⟰ʳ {Ξ = _ ∷ _} ρ = ⇑ʳ (⟰ʳ ρ)
131 | 
132 |   ⟰ˢ : ∀ {γ δ Ξ} → (γ →ˢ δ) → (shift γ Ξ →ˢ shift δ Ξ)
133 |   ⟰ˢ {Ξ = []} f = f
134 |   ⟰ˢ {Ξ = _ ∷ _} f = ⇑ˢ (⟰ˢ f)
135 | 
136 |   data act-defined : ∀ {γ cl} → Expr γ cl → Set where
137 |     act-sub : ∀ {γ δ} {cl} (x : (δ , cl) ∈ γ) → (ts : δ →ˢ γ) →
138 |               (∀ {a} (z : a ∈ δ) → act-defined (ts ∙ z)) → act-defined (x ` ts)
139 |     -- act-∙ : ∀ {γ δ} {cl} (f : γ →ˢ δ) (x : (δ , cl) ∈ γ) → (ts : δ →ˢ γ) →
140 |     --           (act-defined (f ∙ x)
141 | 
142 | 
143 |   module SubstitutionWithFucus where
144 |     -- An attempt that explicitly deals with all the shifting and weakening
145 | 
146 |     infix 4 _⇒ˢ_
147 |     data _⇒ˢ_ : Shape → Shape → Set where
148 |       sbs : ∀ {γ δ} (f : γ →ˢ δ) → γ ⇒ˢ δ
149 |       𝟙⊕ : ∀ {δ θ} (f : θ ⇒ˢ δ) → δ ⊕ θ ⇒ˢ δ
150 |       rgh : ∀ {γ δ θ} (f : γ ⇒ˢ δ) → γ ⊕ θ ⇒ˢ δ ⊕ θ
151 |       𝟙, : ∀ {γ δ θ} (f : γ ⇒ˢ θ ⊕ δ) → θ ⊕ γ ⇒ˢ θ ⊕ δ
152 | 
153 |     infix 7 _∙∙_
154 |     _∙∙_ : ∀ {γ δ} (f : γ ⇒ˢ δ) {a} → a ∈ γ → Arg δ a
155 |     sbs f ∙∙ x = f ∙ x
156 |     𝟙⊕ f ∙∙ var-left x = η x
157 |     𝟙⊕ f ∙∙ var-right y = f ∙∙ y
158 |     rgh f ∙∙ var-left x = [ ⇑ʳ (tabulate var-left) ]ʳ (f ∙∙ x)
159 |     rgh f ∙∙ var-right y = η (var-right y)
160 |     𝟙, f ∙∙ var-left x = η (var-left x)
161 |     𝟙, f ∙∙ var-right y = f ∙∙ y
162 | 
163 |     {-# TERMINATING #-}
164 |     act : ∀ {γ δ cl} (f : γ ⇒ˢ δ) → Expr γ cl → Expr δ cl
165 |     act (sbs f) (x ` ts) =  act (𝟙⊕ (sbs (tabulate λ z → act (rgh (sbs f)) (ts ∙ z)))) (f ∙ x)
166 |     act (𝟙⊕ f) (var-left x ` ts) = x ` (tabulate λ z → act (rgh (𝟙⊕ f)) (ts ∙ z))
167 |     act (𝟙⊕ f) (var-right y ` ts) = act (𝟙⊕ (sbs (tabulate λ z → act (rgh (𝟙⊕ f)) (ts ∙ z)))) (f ∙∙ y)
168 |     act (rgh f) (var-left x ` ts) = act (𝟙, (sbs (tabulate (λ z → act (rgh (rgh f))  (ts ∙ z))))) (f ∙∙ x)
169 |     act (rgh f) (var-right y ` ts) = var-right y ` tabulate λ z → act (rgh (rgh f)) (ts ∙ z)
170 |     act (𝟙, f) (var-left x ` ts) = var-left x ` tabulate (λ z →  act (rgh (𝟙, f)) (ts ∙ z))
171 |     act (𝟙, f) (var-right x ` ts) = act (𝟙⊕ (sbs (tabulate (λ z → act (rgh (𝟙, f)) (ts ∙ z))))) (f ∙∙ x)
172 | 
173 | 
174 |   module IdealDefintion where
175 |     -- The naive definition, which Agda does not see as terminating
176 |     infix 6 [_]ˢ_
177 |     infix 6 _∘ˢ_
178 | 
179 |     {-# TERMINATING #-}
180 |     [_]ˢ_ : ∀ {γ δ cl} (f : γ →ˢ δ) → Expr γ cl → Expr δ cl
181 | 
182 |     {-# TERMINATING #-}
183 |     _∘ˢ_ : ∀ {γ δ θ} (g : δ →ˢ θ) (f : γ →ˢ δ) → γ →ˢ θ
184 | 
185 |     [ f ]ˢ x ` ts = [ 𝟙ˢ ⊕ (f ∘ˢ ts) ]ˢ (f ∙ x)
186 |     g ∘ˢ f = tabulate (λ x → [ ⇑ˢ g ]ˢ f ∙ x)
187 | 
188 |     [lift]ˢ : ∀ {γ δ cl} (ρ : γ →ʳ δ) (e : Expr γ cl) → [ lift ρ ]ˢ e ≡ [ ρ ]ʳ e
189 |     [lift]ˢ ρ (x ` ts) = trans (cong [ 𝟙ˢ ⊕ lift ρ ∘ˢ ts ]ˢ_ (lift-∙ ρ x)) {!!}
190 | 
191 |     [𝟙]ˢ : ∀ {γ cl} {e : Expr γ cl} → [ 𝟙ˢ ]ˢ e ≡ e
192 |     [𝟙]ˢ {e = x ` ts} = trans (cong [ 𝟙ˢ ⊕ (𝟙ˢ ∘ˢ ts) ]ˢ_ 𝟙ˢ-∙) {!!}
193 | 
194 | 
195 | 
196 | 
197 |   module BoveCappreta where
198 |     -- Instead we use the Bove-Cappreta method, whereby we define the support of [_]ˢ_ and _∘ˢ_, then we define the maps
199 |     -- as partial maps defined on the support, and finally show that the supports are the entire domains.
200 |     -- See doi:10.1017/S0960129505004822
201 | 
202 |     -- The action of a substitution defined at a given argument
203 |     data defined : ∀ {γ δ cl} (f : γ →ˢ δ) (e : Expr γ cl) → Set
204 | 
205 |     -- The action of substitution
206 |     act : ∀ {γ δ cl} (f : γ →ˢ δ) (e : Expr γ cl) → defined f e → Expr δ cl
207 | 
208 |     -- The action is defined when the recursive calls are defined
209 |     data defined where
210 |       df : ∀ {γ δ} {f : γ →ˢ δ} {γˣ clˣ} {x : (γˣ , clˣ) ∈ γ} {ts : γˣ →ˢ γ}
211 |               (D : ∀ {a} (z : a ∈ γˣ) → defined (⇑ˢ f) (ts ∙ z)) →
212 |               (E : defined (𝟙ˢ ⊕ tabulate (λ z → act (⇑ˢ f) (ts ∙ z) (D z))) (f ∙ x)) →
213 |               defined f (x ` ts)
214 | 
215 |     act f (x ` ts) (df D E) = act (𝟙ˢ ⊕ tabulate (λ z → act (⇑ˢ f) (ts ∙ z) (D z))) (f ∙ x) E
216 | 
217 |     -- we'll do this later
218 |     postulate total-D : ∀ {γ δ} {f : γ →ˢ δ} {γˣ clˣ} (x : (γˣ , clˣ) ∈ γ) (ts : γˣ →ˢ γ) →
219 |                         ∀ {a} (z : a ∈ γˣ) → defined (⇑ˢ f) (ts ∙ z)
220 | 
221 |     postulate total-E : ∀ {γ δ} {f : γ →ˢ δ} {γˣ clˣ} (x : (γˣ , clˣ) ∈ γ) (ts : γˣ →ˢ γ) →
222 |                         defined (𝟙ˢ ⊕ tabulate (λ {a} (z : a ∈ γˣ) → act (⇑ˢ f) (ts ∙ z)
223 |                                         (total-D x ts z))) (f ∙ x)
224 | 
225 |     total-act : ∀ {γ δ cl} (f : γ →ˢ δ) (e : Expr γ cl) → defined f e
226 |     total-act f (x ` ts) = df (total-D x ts) (total-E x ts)
227 | 
228 |     infix 6 [_]ˢ_
229 |     [_]ˢ_ : ∀ {γ δ cl} (f : γ →ˢ δ) → Expr γ cl → Expr δ cl
230 |     [ f ]ˢ e = act f e (total-act f e)
231 | 
232 |     [𝟙]ˢ : ∀ {γ cl} {e : Expr γ cl} → [ 𝟙ˢ ]ˢ e ≡ e
233 |     [𝟙]ˢ {e = x ` ts} = {!!}
234 | 
235 |     [lift]ˢ : ∀ {γ δ cl} (ρ : γ →ʳ δ) (e : Expr γ cl) → [ lift ρ ]ˢ e ≡ [ ρ ]ʳ e
236 |     [lift]ˢ ρ (x ` ts) = {! !}
237 | 
238 | 
239 |   module AsGraph where
240 |     -- action of substitution as a graph
241 |     infix 4 [_]ˢ_:=_
242 |     data [_]ˢ_:=_ : ∀ {γ δ cl} → (γ →ˢ δ) → Expr γ cl → Expr δ cl → Set where
243 |        sbs : ∀ {γ δ} {f : γ →ˢ δ} {γˣ clˣ} {x : (γˣ , clˣ) ∈ γ} {ts : γˣ →ˢ γ} (d : γˣ →ˢ δ) {e} →
244 |                   (∀ {a} (z : a ∈ γˣ) → [ ⇑ˢ f ]ˢ ts ∙ z := d ∙ z) →
245 |                   [ 𝟙ˢ ⊕ d ]ˢ f ∙ x := e →
246 |                   [ f ]ˢ (x ` ts) := e
247 | 
248 |     act-⊕-left : ∀ {γ δ θ} {f : γ →ˢ θ} {g : δ →ˢ θ} {γˣ clˣ} {x : (γˣ , clˣ) ∈ γ} {ts : γˣ →ˢ γ ⊕ δ} (d : γˣ →ˢ θ) e →
249 |                  (∀ {a} (z : a ∈ γˣ) → [ ⇑ˢ (f ⊕ g) ]ˢ ts ∙ z  := d ∙ z) →
250 |                  [ 𝟙ˢ ⊕ d ]ˢ (f ∙ x) := e →
251 |                  [ f ⊕ g ]ˢ var-left x ` ts := e
252 |     act-⊕-left d e r₁ r₂ = sbs d r₁ r₂
253 | 
254 |     act-⇑ˢ : ∀ {γ δ θ} {f : γ →ˢ δ} {γˣ clˣ} {ts : γˣ →ˢ γ} {x : (γˣ , clˣ) ∈ γ} {ts : γˣ →ˢ γ ⊕ θ} (d : γˣ →ˢ δ ⊕ θ) e →
255 |             (∀ {a} (z : a ∈ γˣ) → [ ⇑ˢ (⇑ˢ f) ]ˢ ts ∙ z := d ∙ z) →
256 |             [ 𝟙ˢ ⊕ d ]ˢ [ ⇑ʳ (tabulate var-left) ]ʳ f ∙ x  := e →
257 |             [ ⇑ˢ f ]ˢ var-left x ` ts := e
258 |     act-⇑ˢ {γ = γ} {θ = θ} {f = f} {x = x} d e r₁ r₂ =
259 |       sbs d r₁ (subst (λ u → [ 𝟙ˢ ⊕ d ]ˢ u := e) (sym (map-∙ {ps = f} {x = x})) r₂)
260 | 
261 |     act-η : ∀ {γ δ} (f : γ →ˢ δ) {a} (x : a ∈ γ) → [ ⇑ˢ f ]ˢ η x := f ∙ x
262 |     act-η f x = {!!}
263 | 
264 |     act-lift : ∀ {γ δ cl} (ρ : γ →ʳ δ) (e : Expr γ cl) →
265 |                [ lift ρ ]ˢ e := [ ρ ]ʳ e
266 |     act-lift ρ (x ` ts) = sbs (ρ ʳ∘ˢ ts) (λ z → {!!}) {!lift-∙!}
267 | 
268 |     infix 6 [_]ˢ_
269 |     [_]ˢ_ : ∀ {γ δ cl} (f : γ →ˢ δ) → Expr γ cl → Expr δ cl
270 |     [ f ]ˢ e = {!!}
271 | 
272 |     []ˢ-total : ∀ {γ δ cl} (f : γ →ˢ δ) (e : Expr γ cl) → [ f ]ˢ e := [ f ]ˢ e
273 |     []ˢ-total f e = {!!}
274 | 


--------------------------------------------------------------------------------
/src/FixPointRel.agda:
--------------------------------------------------------------------------------
 1 | open import Agda.Primitive
 2 | open import Relation.Unary
 3 | open import Relation.Binary
 4 | open import Relation.Binary.PropositionalEquality
 5 | open import Induction.WellFounded
 6 | 
 7 | -- This is the same as Induction.WellFounded.Fixpoint, but works for any
 8 | -- relation that is preserved by the recursor, instead of just ≡
 9 | 
10 | module FixPointRel
11 |   {a r e} {A : Set a}
12 |   {_<_ : Rel A r} (wf : WellFounded _<_) ℓ
13 |   (P : Pred A ℓ) (f : WfRec _<_ P ⊆′ P)
14 |   (_≈_ : ∀ {x : A} → Rel (P x) e)
15 |   (f-ext : (x : A) {IH IH′ : WfRec _<_ P x} → (∀ {y} y<x → IH y y<x ≈ IH′ y y<x) → f x IH ≈ f x IH′)
16 |   where
17 | 
18 |   some-wfRec-irrelevant : ∀ x → (q q′ : Acc _<_ x) → Some.wfRec P f x q ≈ Some.wfRec P f x q′
19 |   some-wfRec-irrelevant =
20 |     All.wfRec wf _
21 |       (λ x → (q q′ : Acc _<_ x) → Some.wfRec P f x q ≈ Some.wfRec P f x q′)
22 |       (λ { x IH (acc rs) (acc rs′) → f-ext x (λ y<x → IH _ y<x (rs _ y<x) (rs′ _ y<x)) })
23 | 
24 |   open All wf ℓ
25 |   wfRecBuilder-wfRec : ∀ {x y} y<x → wfRecBuilder P f x y y<x ≈ wfRec P f y
26 |   wfRecBuilder-wfRec {x} {y} y<x with wf x
27 |   ... | acc rs = some-wfRec-irrelevant y (rs y y<x) (wf y)
28 | 
29 |   unfold-wfRec : ∀ {x} → wfRec P f x ≈ f x (λ y _ → wfRec P f y)
30 |   unfold-wfRec {x} = f-ext x wfRecBuilder-wfRec
31 | 


--------------------------------------------------------------------------------
/src/Rank.agda:
--------------------------------------------------------------------------------
 1 | open import Agda.Primitive hiding (_⊔_)
 2 | open import Relation.Binary.PropositionalEquality
 3 | open import Relation.Unary hiding (_∈_)
 4 | open import Relation.Binary
 5 | open import Data.Nat
 6 | open import Data.Nat.Properties
 7 | open import Data.Product using (_×_; _,_)
 8 | open import Function using (_∘_)
 9 | 
10 | import Syntax
11 | 
12 | module Rank (Class : Set) where
13 | 
14 |   open Syntax Class
15 | 
16 |   rank : Shape → ℕ
17 |   rank 𝟘 = 0
18 |   rank [ γ , _ ] = suc (rank γ)
19 |   rank (γ ⊕ δ) = (rank γ) ⊔ (rank δ)
20 | 
21 |   rank-< : ∀ {γ δ cl} (x : (γ , cl) ∈ δ) → rank γ < rank δ
22 |   rank-< var-here = n<1+n _
23 |   rank-< (var-left x) = m<n⇒m<n⊔o _ (rank-< x)
24 |   rank-< (var-right y) = m<n⇒m<o⊔n _ (rank-< y)
25 | 


--------------------------------------------------------------------------------
/src/Renaming.agda:
--------------------------------------------------------------------------------
  1 | open import Agda.Primitive
  2 | open import Relation.Binary.PropositionalEquality
  3 | open import Data.Nat
  4 | open import Data.Product hiding (map)
  5 | open import Function using (_∘_)
  6 | 
  7 | import Categories.Category
  8 | import Syntax
  9 | 
 10 | 
 11 | module Renaming (Sort : Set) where
 12 | 
 13 |   open Syntax Sort
 14 | 
 15 |   -- identity renaming
 16 | 
 17 |   𝟙ʳ : ∀ {γ} → γ →ʳ γ
 18 |   𝟙ʳ = tabulate (λ x → x)
 19 | 
 20 |   -- 𝟙ʳ is the identity
 21 |   𝟙ʳ-≡ : ∀ {γ} {α} {x : α ∈ γ} → (𝟙ʳ ∙ x) ≡ x
 22 |   𝟙ʳ-≡ = tabulate-∙ (λ x → x)
 23 | 
 24 |   -- composition of renamings
 25 | 
 26 |   infixl 7 _∘ʳ_
 27 | 
 28 |   _∘ʳ_ : ∀ {γ} {δ} {θ} → (δ →ʳ θ) → (γ →ʳ δ) → (γ →ʳ θ)
 29 |   (ρ ∘ʳ τ) = tabulate (λ x → ρ ∙ (τ ∙ x))
 30 | 
 31 |   ∘ʳ-∙ : ∀ {γ δ θ} {ρ : δ →ʳ θ} {τ : γ →ʳ δ} {α} {x : α ∈ γ} → (ρ ∘ʳ τ) ∙ x ≡ ρ ∙ (τ ∙ x)
 32 |   ∘ʳ-∙ {ρ = ρ} {τ = τ} = tabulate-∙ (λ x → ρ ∙ (τ ∙ x))
 33 | 
 34 |   -- canonical renamings
 35 | 
 36 |   assoc-right : ∀ {γ δ θ} → (γ ⊕ δ) ⊕ θ →ʳ γ ⊕ (δ ⊕ θ)
 37 |   assoc-right = tabulate λ { (var-left (var-left x)) → var-left x ;
 38 |                              (var-left (var-right x)) → var-right (var-left x) ;
 39 |                              (var-right x) → var-right (var-right x)}
 40 | 
 41 |   assoc-left : ∀ {γ δ θ} → γ ⊕ (δ ⊕ θ) →ʳ (γ ⊕ δ) ⊕ θ
 42 |   assoc-left = tabulate λ { (var-left x) → var-left (var-left x) ;
 43 |                             (var-right (var-left x)) → var-left (var-right x) ;
 44 |                             (var-right (var-right x)) → var-right x}
 45 | 
 46 |   in-left : ∀ {γ δ} → γ →ʳ γ ⊕ δ
 47 |   in-left = tabulate var-left
 48 | 
 49 |   in-right : ∀ {γ δ} → δ →ʳ γ ⊕ δ
 50 |   in-right = tabulate var-right
 51 | 
 52 |   in-𝟘 : ∀ {γ} → 𝟘 →ʳ γ
 53 |   in-𝟘 = 𝟘
 54 | 
 55 |   -- renaming extension
 56 | 
 57 |   ⇑ʳ : ∀ {γ} {δ} {θ} → (γ →ʳ δ) → (γ ⊕ θ →ʳ δ ⊕ θ)
 58 |   ⇑ʳ ρ = map var-left ρ ⊕ in-right
 59 | 
 60 |   -- extension respects identity
 61 | 
 62 |   ⇑ʳ-resp-𝟙ʳ : ∀ {γ} {δ} → ⇑ʳ {θ = δ} (𝟙ʳ {γ = γ}) ≡ 𝟙ʳ
 63 |   ⇑ʳ-resp-𝟙ʳ = cong₂ _⊕_ map-tabulate refl
 64 | 
 65 |   -- extension commutes with composition
 66 | 
 67 |   ⇑ʳ-resp-∘ʳ : ∀ {γ δ η θ} {ρ : γ →ʳ δ} {τ : δ →ʳ η} → ⇑ʳ {θ = θ} (τ ∘ʳ ρ) ≡ ⇑ʳ τ ∘ʳ ⇑ʳ ρ
 68 |   ⇑ʳ-resp-∘ʳ {γ = γ} {θ = θ} {ρ = ρ} {τ = τ} =
 69 |     cong₂ _⊕_
 70 |      (trans map-tabulate (tabulate-ext ξ₁))
 71 |      (tabulate-ext ξ₂)
 72 |     where
 73 |       open ≡-Reasoning
 74 | 
 75 |       ξ₁ : ∀ {α : Arity} {x : α ∈ γ} → var-left (τ ∙ (ρ ∙ x)) ≡ ⇑ʳ τ ∙ (map var-left ρ ∙ x)
 76 |       ξ₁ {x = x} =
 77 |         begin
 78 |           var-left (τ ∙ (ρ ∙ x))
 79 |              ≡⟨ sym (map-∙ {ps = τ}) ⟩
 80 |           ⇑ʳ τ ∙ var-left (ρ ∙ x)
 81 |              ≡⟨ cong-∙ {f = ⇑ʳ τ} {y = map var-left ρ ∙ x} refl (sym (map-∙ {ps = ρ})) ⟩
 82 |           ⇑ʳ τ ∙ (map var-left ρ ∙ x)
 83 |           ∎
 84 | 
 85 |       ξ₂ : ∀ {α : Arity} {x : α ∈ θ} → var-right x ≡ ⇑ʳ τ ∙ (in-right ∙ x)
 86 |       ξ₂ {x = x} =
 87 |         begin
 88 |           var-right x
 89 |             ≡⟨ sym (tabulate-∙ var-right) ⟩
 90 |           ⇑ʳ τ ∙ var-right x
 91 |             ≡⟨  sym (cong (⇑ʳ τ ∙_) (tabulate-∙ var-right)) ⟩
 92 |           ⇑ʳ τ ∙ (in-right ∙ x)
 93 |           ∎
 94 | 
 95 |   -- composition of a substitution and a renaming
 96 |   infixr 7 _ˢ∘ʳ_
 97 |   _ˢ∘ʳ_ : ∀ {γ δ η} → (δ →ˢ η) → (γ →ʳ δ) → (γ →ˢ η)
 98 |   f ˢ∘ʳ 𝟘 = 𝟘
 99 |   f ˢ∘ʳ [ x ] = [ f ∙ x ]
100 |   f ˢ∘ʳ (ρ₁ ⊕ ρ₂) = (f ˢ∘ʳ ρ₁) ⊕ (f ˢ∘ʳ ρ₂)
101 | 
102 |   ˢ∘ʳ-∙ : ∀ {γ δ η} (f : δ →ˢ η) (ρ : γ →ʳ δ) {a} (x : a ∈ γ) →
103 |              (f ˢ∘ʳ ρ) ∙ x ≡ f ∙ (ρ ∙ x)
104 |   ˢ∘ʳ-∙ f [ y ] var-here = refl
105 |   ˢ∘ʳ-∙ f (ρ₁ ⊕ ρ₂) (var-left x) = ˢ∘ʳ-∙ f ρ₁ x
106 |   ˢ∘ʳ-∙ f (ρ₁ ⊕ ρ₂) (var-right y) = ˢ∘ʳ-∙ f ρ₂ y
107 | 
108 |   -- the action of a renaming on an expression
109 | 
110 |   infixr 6 [_]ʳ_
111 |   infixl 7 _ʳ∘ˢ_
112 | 
113 |   [_]ʳ_ : ∀ {γ δ cl} → γ →ʳ δ → Expr γ cl → Expr δ cl
114 |   _ʳ∘ˢ_ : ∀ {γ δ η} → δ →ʳ η → γ →ˢ δ → γ →ˢ η
115 | 
116 |   [ ρ ]ʳ (x ` ts) = ρ ∙ x ` (ρ ʳ∘ˢ ts)
117 | 
118 |   ρ ʳ∘ˢ 𝟘 = 𝟘
119 |   ρ ʳ∘ˢ [ t ] = [ [ ⇑ʳ ρ ]ʳ t ]
120 |   ρ ʳ∘ˢ (ts₁ ⊕ ts₂) = (ρ ʳ∘ˢ ts₁) ⊕ (ρ ʳ∘ˢ ts₂)
121 | 
122 |   ʳ∘ˢ-∙ : ∀ {γ δ η} {ρ : δ →ʳ η} {ts : γ →ˢ δ} {α} {x : α ∈ γ} →
123 |           (ρ ʳ∘ˢ ts) ∙ x ≡ [ ⇑ʳ ρ ]ʳ (ts ∙ x)
124 |   ʳ∘ˢ-∙ {ts = [ _ ]} {x = var-here} = refl
125 |   ʳ∘ˢ-∙ {ts = ts₁ ⊕ ts₂} {x = var-left x₁} = ʳ∘ˢ-∙ {ts = ts₁}
126 |   ʳ∘ˢ-∙ {ts = ts₁ ⊕ ts₂} {x = var-right x₂} = ʳ∘ˢ-∙ {ts = ts₂}
127 | 
128 |   𝟙ʳ-ʳ∘ˢ : ∀ {γ δ} → {ts : γ →ˢ δ} → 𝟙ʳ ʳ∘ˢ ts ≡ ts
129 |   [𝟙ʳ] : ∀ {γ cl} {t : Expr γ cl} → [ 𝟙ʳ ]ʳ t ≡ t
130 | 
131 |   𝟙ʳ-ʳ∘ˢ {ts = 𝟘} = refl
132 |   𝟙ʳ-ʳ∘ˢ {ts = [ x ]} = cong [_] (trans (cong₂ [_]ʳ_ (cong₂ _⊕_ map-tabulate refl) refl) [𝟙ʳ])
133 |   𝟙ʳ-ʳ∘ˢ {ts = ts ⊕ ts₁} = cong₂ _⊕_ 𝟙ʳ-ʳ∘ˢ 𝟙ʳ-ʳ∘ˢ
134 | 
135 |   [𝟙ʳ] {t = x ` ts} = ≡-` 𝟙ʳ-≡ λ z → cong-∙ {f = 𝟙ʳ ʳ∘ˢ ts} 𝟙ʳ-ʳ∘ˢ refl
136 | 
137 |   ʳ∘ˢ-map : ∀ {γ δ η} {ρ : δ →ʳ η} {ts : γ →ˢ δ} → ρ ʳ∘ˢ ts ≡ map [ ⇑ʳ ρ ]ʳ_ ts
138 |   ʳ∘ˢ-map {ts = 𝟘} = refl
139 |   ʳ∘ˢ-map {ts = [ x ]} = refl
140 |   ʳ∘ˢ-map {ts = ts₁ ⊕ ts₂} = cong₂ _⊕_ ʳ∘ˢ-map ʳ∘ˢ-map
141 | 
142 |   -- the action is functorial
143 | 
144 |   ∘ʳ-ʳ∘ˢ : ∀ {γ δ θ η} {ρ : γ →ʳ δ} {τ : δ →ʳ θ} {σ : η →ˢ γ}  → τ ∘ʳ ρ ʳ∘ˢ σ ≡ τ ʳ∘ˢ (ρ ʳ∘ˢ σ)
145 |   [∘ʳ] : ∀ {γ δ θ cl} {ρ : γ →ʳ δ} {τ : δ →ʳ θ} (t : Expr γ cl) → [ τ ∘ʳ ρ ]ʳ t ≡ [ τ ]ʳ [ ρ ]ʳ t
146 | 
147 |   ∘ʳ-ʳ∘ˢ {σ = 𝟘} = refl
148 |   ∘ʳ-ʳ∘ˢ {ρ = ρ} {τ = τ} {σ = [ t ]} = cong [_] (trans (cong (λ η → [ η ]ʳ t) (⇑ʳ-resp-∘ʳ {ρ = ρ} {τ = τ})) ([∘ʳ] t))
149 |   ∘ʳ-ʳ∘ˢ {σ = σ₁ ⊕ σ₂} = cong₂ _⊕_ ∘ʳ-ʳ∘ˢ ∘ʳ-ʳ∘ˢ
150 | 
151 |   [∘ʳ] {ρ = ρ} {τ = τ} (x ` ts) = ≡-` (tabulate-∙ (λ z → τ ∙ (ρ ∙ z))) λ z → cong (_∙ z) (∘ʳ-ʳ∘ˢ {σ = ts})
152 | 
153 |   -- the categorical structure of shapes and renamings
154 | 
155 |   ∘ʳ-assoc : {γ δ θ η : Shape} {f : γ →ʳ δ} {g : δ →ʳ θ} {h : θ →ʳ η} → h ∘ʳ g ∘ʳ f ≡ h ∘ʳ (g ∘ʳ f)
156 |   ∘ʳ-assoc {f = f} {g = g} {h = h} =
157 |     tabulate-ext (trans (tabulate-∙ (λ x → h ∙ (g ∙ x))) (cong (h ∙_) (sym (tabulate-∙ (λ x → g ∙ (f ∙ x))))))
158 | 
159 |   -- The category of shapes and renamings
160 | 
161 |   module _ where
162 |     open Categories.Category
163 | 
164 |     Renamings : Category lzero lzero lzero
165 |     Renamings =
166 |      record
167 |        { Obj = Shape
168 |        ; _⇒_ = _→ʳ_
169 |        ; _≈_ = _≡_
170 |        ; id = 𝟙ʳ
171 |        ; _∘_ = _∘ʳ_
172 |        ; assoc = λ {_} {_} {_} {_} {f} {g} {h} → ∘ʳ-assoc {f = f} {g = g} {h = h}
173 |        ; sym-assoc = λ {_} {_} {_} {_} {f} {g} {h} → sym (∘ʳ-assoc {f = f} {g = g} {h = h})
174 |        ; identityˡ = λ {γ} {_} {ρ} → shape-≡ (λ x → trans (∘ʳ-∙ {ρ = 𝟙ʳ} {τ = ρ}) 𝟙ʳ-≡)
175 |        ; identityʳ = λ {_} {_} {ρ} → shape-≡ (λ x → trans ((∘ʳ-∙ {ρ = ρ} {τ = 𝟙ʳ})) (cong (ρ ∙_) 𝟙ʳ-≡))
176 |        ; identity² = tabulate-ext (trans 𝟙ʳ-≡ 𝟙ʳ-≡)
177 |        ; equiv = record { refl = refl ; sym = sym ; trans = trans }
178 |        ; ∘-resp-≈ = λ ζ ξ → cong₂ _∘ʳ_ ζ ξ
179 |        }
180 | 


--------------------------------------------------------------------------------
/src/SizeInduction.agda:
--------------------------------------------------------------------------------
 1 | open import Agda.Primitive
 2 | open import Relation.Unary
 3 | open import Relation.Binary
 4 | open import Relation.Binary.PropositionalEquality
 5 | open import Induction.WellFounded
 6 | 
 7 | -- Recursive definitions in which recursive calls reduce well-founded size
 8 | 
 9 | module SizeInduction
10 |   {ℓs ℓr ℓa}
11 |   {S : Set ℓs} -- size
12 |   {_<_ : S → S → Set ℓr} (wf-< : WellFounded _<_) -- well-founded size order
13 |   {A : Set ℓa}
14 |   (size : A → S) {ℓp}
15 |   (P : A → Set ℓp)
16 |   (f : ∀ x → (∀ y → size y < size x → P y) → P x)
17 |   where
18 | 
19 |   open All wf-< (ℓs ⊔ ℓa ⊔ ℓp)
20 | 
21 |   -- We actually carry out well-founded induction on Q
22 |   Q : S → Set (ℓs ⊔ ℓa ⊔ ℓp)
23 |   Q = (λ s → ∀ x → size x ≡ s → P x)
24 | 
25 |   -- The recursive builder
26 |   q : ∀ (s : S) (r : ∀ t → t < s → Q t) (x : A) (ξ : size x ≡ s) → P x
27 |   q s r x ξ = f x (λ y p → r (size y) (subst (λ t → size y < t) ξ p) y refl)
28 | 
29 |   -- The recursive construction
30 |   sizeRec : ∀ x → P x
31 |   sizeRec x = wfRec Q q (size x) x refl
32 | 
33 |   -- The desired fixed-point equation with respect to any binary relation
34 |   module SizeFixPoint
35 |     {ℓe} (_≈_ : ∀ {x : A} → P x → P x → Set ℓe)
36 |     (f-ext : ∀ x {r₁ r₂ : ∀ y → size y < size x → P y} → (∀ {y} p₁ p₂ → r₁ y p₁ ≈ r₂ y p₂) → f x r₁ ≈ f x r₂)
37 |     where
38 | 
39 |     -- the derived relation, suitable for q
40 | 
41 |     _≈'_ : ∀ {s : S} (g₁ g₂ : ∀ (x : A) (ξ : size x ≡ s) → P x) → Set (ℓs ⊔ ℓa ⊔ ℓe)
42 |     g₁ ≈' g₂ = ∀ (x : A) (ξ : size x ≡ _) → g₁ x ξ ≈ g₂ x ξ
43 | 
44 |     -- the rest is adapted from WellFounded.FixPoint
45 | 
46 |     some-wfRec-irrelevant : ∀ s → (u₁ u₂ : Acc _<_ s) → Some.wfRec Q q s u₁ ≈' Some.wfRec Q q s u₂
47 |     some-wfRec-irrelevant =
48 |       All.wfRec wf-< _
49 |         (λ s → (u₁ u₂ : Acc _<_ s) → Some.wfRec Q q s u₁ ≈' Some.wfRec Q q s u₂)
50 |         (λ { s IH (acc us₁) (acc us₂) →
51 |            λ x ξ → f-ext x λ p₁ p₂ → IH _ (subst (λ t → _ < t) ξ p₁) (us₁ _ _) (us₂ _ _) _ refl})
52 | 
53 |     wfRecBuilder-wfRec : ∀ {x y} y<x → wfRecBuilder Q q x y y<x ≈' wfRec Q q y
54 |     wfRecBuilder-wfRec {x} {y} y<x with wf-< x
55 |     ... | acc rs = some-wfRec-irrelevant y (rs y y<x) (wf-< y)
56 | 
57 |     -- the fixed point equation
58 | 
59 |     unfold-sizeRec : ∀ x → sizeRec x ≈ f x λ y _ → sizeRec y
60 |     unfold-sizeRec x = f-ext x (λ p₁ p₂ → wfRecBuilder-wfRec p₁ _ refl)
61 | 


--------------------------------------------------------------------------------
/src/Substitution.agda:
--------------------------------------------------------------------------------
  1 | open import Agda.Primitive
  2 | open import Relation.Unary hiding (_∈_)
  3 | open import Relation.Binary
  4 | open import Relation.Binary.PropositionalEquality
  5 | open import Data.Product using (_,_; _×_)
  6 | open import Function using (_∘_)
  7 | open import Data.List hiding ([_]; tabulate; map)
  8 | 
  9 | open ≡-Reasoning
 10 | 
 11 | import Syntax
 12 | import Renaming
 13 | 
 14 | 
 15 | module Substitution (Class : Set) where
 16 | 
 17 |   open Syntax Class
 18 |   open Renaming Class
 19 | 
 20 |   -- Lifting of renamings to substitutions, and of variables to expressions
 21 | 
 22 |   lift : ∀ {γ δ} → (γ →ʳ δ) → (γ →ˢ δ)
 23 | 
 24 |   η : ∀ {γ a} (x : a ∈ γ) → Arg γ a
 25 | 
 26 |   lift 𝟘 = 𝟘
 27 |   lift [ x ] = [ η x ]
 28 |   lift (ρ₁ ⊕ ρ₂) = lift ρ₁ ⊕ lift ρ₂
 29 | 
 30 |   η x = var-left x ` lift (tabulate var-right)
 31 | 
 32 |   -- Ideally we would like the following to be the definition of lift,
 33 |   -- but Agda termination gets in the way
 34 | 
 35 |   lift-map-η : ∀ {γ δ} (ρ : γ →ʳ δ) → lift ρ ≡ map η ρ
 36 |   lift-map-η 𝟘 = refl
 37 |   lift-map-η [ x ] = refl
 38 |   lift-map-η (ρ₁ ⊕ ρ₂) = cong₂ _⊕_ (lift-map-η ρ₁) (lift-map-η ρ₂)
 39 | 
 40 |   lift-𝟙ʳ : ∀ {γ} → lift 𝟙ʳ ≡ tabulate (η {γ = γ})
 41 |   lift-𝟙ʳ = trans (lift-map-η 𝟙ʳ) map-tabulate
 42 | 
 43 |   -- Identity substitution
 44 | 
 45 |   𝟙ˢ : ∀ {γ} → γ →ˢ γ
 46 |   𝟙ˢ = lift 𝟙ʳ
 47 | 
 48 |   -- Substitution extension
 49 | 
 50 |   ⇑ˢ : ∀ {γ δ θ} → γ →ˢ δ → γ ⊕ θ →ˢ δ ⊕ θ
 51 |   ⇑ˢ {θ = θ} f =  map [ ⇑ʳ (tabulate var-left) ]ʳ_ f ⊕ lift (tabulate var-right)
 52 | 
 53 |   -- The interaction of lifting with various operations
 54 | 
 55 |   lift-∙ : ∀ {γ δ} (ρ : γ →ʳ δ) {a} (x : a ∈ γ) →
 56 |            lift ρ ∙ x ≡ η (ρ ∙ x)
 57 |   lift-∙ [ _ ] var-here = refl
 58 |   lift-∙ (ρ₁ ⊕ ρ₂) (var-left x) = lift-∙ ρ₁ x
 59 |   lift-∙ (ρ₁ ⊕ ρ₂) (var-right y) = lift-∙ ρ₂ y
 60 | 
 61 |   𝟙ˢ-∙ : ∀ {γ a} {x : a ∈ γ} → 𝟙ˢ ∙ x ≡ η x
 62 |   𝟙ˢ-∙ {x = x} = trans (lift-∙ 𝟙ʳ x) (cong η 𝟙ʳ-≡)
 63 | 
 64 |   𝟙ˢ-tabulate-η : ∀ {γ} → 𝟙ˢ {γ = γ} ≡ tabulate η
 65 |   𝟙ˢ-tabulate-η = shape-≡ (λ x → trans 𝟙ˢ-∙ (sym (tabulate-∙ η)))
 66 | 
 67 |   lift-tabulate : ∀ {γ δ} (f : ∀ {α} → α ∈ γ → α ∈ δ) {a} (x : a ∈ γ) →
 68 |                   lift (tabulate f) ∙ x ≡ η (f x)
 69 |   lift-tabulate f var-here = refl
 70 |   lift-tabulate f (var-left x) = lift-tabulate (λ z → f (var-left z)) x
 71 |   lift-tabulate f (var-right y) = lift-tabulate (λ z → f (var-right z)) y
 72 | 
 73 |   ∘ʳ-lift : ∀ {γ δ θ} (ρ : γ →ʳ δ) (τ : δ →ʳ θ) {a} (x : a ∈ γ) →
 74 |              lift (τ ∘ʳ ρ) ∙ x ≡  lift τ ∙ (ρ ∙ x)
 75 |   ∘ʳ-lift [ x ] τ var-here = sym (lift-∙ τ x)
 76 |   ∘ʳ-lift (ρ₁ ⊕ ρ₂) τ (var-left x) = ∘ʳ-lift ρ₁ τ x
 77 |   ∘ʳ-lift (ρ₁ ⊕ ρ₂) τ (var-right y) = ∘ʳ-lift ρ₂ τ y
 78 | 
 79 |   []ʳ-lift : ∀ {γ δ θ} (ρ : γ →ʳ δ) (τ : δ →ʳ θ) {a} (x : a ∈ γ) → [ ⇑ʳ τ ]ʳ (lift ρ ∙ x) ≡  lift (τ ∘ʳ ρ) ∙ x
 80 |   []ʳ-η : ∀ {γ δ} (ρ : γ →ʳ δ) {a} (x : a ∈ γ) → [ ⇑ʳ ρ ]ʳ η x ≡ η (ρ ∙ x)
 81 | 
 82 |   []ʳ-lift [ x ] τ var-here = []ʳ-η τ x
 83 |   []ʳ-lift (ρ₁ ⊕ ρ₂) τ (var-left x) = []ʳ-lift ρ₁ τ x
 84 |   []ʳ-lift (ρ₁ ⊕ ρ₂) τ (var-right x) = []ʳ-lift ρ₂ τ x
 85 | 
 86 |   ⇑ʳ-∘ʳ-tabulate-var-right : ∀ {γ δ θ} (ρ : γ →ʳ δ) →
 87 |                              (⇑ʳ {θ = θ} ρ ∘ʳ tabulate var-right) ≡ tabulate var-right
 88 |   ⇑ʳ-∘ʳ-tabulate-var-right {θ = θ} ρ = shape-≡ ξ
 89 |     where ξ : ∀ {a} (x : a ∈ θ) → (⇑ʳ ρ ∘ʳ tabulate var-right) ∙ x ≡ tabulate var-right ∙ x
 90 |           ξ x = trans
 91 |                   (trans
 92 |                       (∘ʳ-∙  {ρ = ⇑ʳ ρ} {τ = tabulate var-right} {x = x})
 93 |                       (trans (cong (⇑ʳ ρ ∙_) (tabulate-∙ var-right)) (tabulate-∙ var-right)))
 94 |                   (sym (tabulate-∙ var-right))
 95 | 
 96 |   [⇑ʳ]-lift-var-right : ∀ {γ δ θ} (ρ : γ →ʳ δ) {a} (x : a ∈ θ) →
 97 |                         [ ⇑ʳ (⇑ʳ ρ) ]ʳ lift (tabulate var-right) ∙ x  ≡ lift (tabulate var-right) ∙ x
 98 |   [⇑ʳ]-lift-var-right ρ x = trans ([]ʳ-lift (tabulate var-right) (⇑ʳ ρ) x) (cong (λ τ → lift τ ∙ x) (⇑ʳ-∘ʳ-tabulate-var-right ρ))
 99 | 
100 |   ʳ∘ˢ-lift-var-right : ∀ {γ δ θ} (ρ : γ →ʳ δ) {a} (x : a ∈ θ) →
101 |                        ((⇑ʳ {θ = θ} ρ) ʳ∘ˢ lift (tabulate var-right)) ∙ x ≡ lift (tabulate var-right) ∙ x
102 |   ʳ∘ˢ-lift-var-right ρ x =
103 |     trans
104 |       (ʳ∘ˢ-∙ {ρ = ⇑ʳ ρ} {ts = lift (tabulate var-right)})
105 |       ([⇑ʳ]-lift-var-right ρ x)
106 | 
107 |   []ʳ-η ρ x = ≡-` (map-∙ {f = var-left} {ps = ρ}) (λ z → ʳ∘ˢ-lift-var-right ρ z)
108 | 
109 | 
110 |   ʳ∘ˢ-lift : ∀ {γ δ θ} (ρ : γ →ʳ δ) (τ : δ →ʳ θ) {a} (x : a ∈ γ) →
111 |              (τ ʳ∘ˢ lift ρ) ∙ x ≡ lift (τ ∘ʳ ρ) ∙ x
112 |   ʳ∘ˢ-lift [ x ] τ var-here = ≡-` ( map-∙ {f = var-left} {ps = τ}) λ z → ʳ∘ˢ-lift-var-right τ z
113 |   ʳ∘ˢ-lift (ρ₁ ⊕ ρ₂) τ (var-left x) = ʳ∘ˢ-lift ρ₁ τ x
114 |   ʳ∘ˢ-lift (ρ₁ ⊕ ρ₂) τ (var-right x) = ʳ∘ˢ-lift ρ₂ τ x
115 | 
116 |   lift-map : ∀ {γ δ θ} (f : ∀ {α} → α ∈ γ → α ∈ δ) (ρ : θ →ʳ γ) →
117 |              lift (map f ρ) ≡ map [ ⇑ʳ (tabulate f) ]ʳ_ (lift ρ)
118 |   lift-map f 𝟘 = refl
119 |   lift-map f [ x ] = cong [_] (trans (cong η (sym (tabulate-∙ f))) (sym ([]ʳ-η (tabulate f) x)))
120 |   lift-map f (ρ₁ ⊕ ρ₂) = cong₂ _⊕_ (lift-map f ρ₁) (lift-map f ρ₂)
121 | 
122 |   ⇑ˢ-lift : ∀ {γ δ θ} (ρ : γ →ʳ δ) → ⇑ˢ {θ = θ} (lift ρ) ≡ lift (⇑ʳ ρ)
123 |   ⇑ˢ-lift ρ = cong₂ _⊕_ (sym (lift-map var-left ρ)) refl
124 | 
125 |   lift-⊕ : ∀ {γ δ θ} (ρ : γ →ʳ θ) (τ : δ →ʳ θ) →
126 |            lift (ρ ⊕ τ) ≡ lift ρ ⊕ lift τ
127 |   lift-⊕ ρ τ = refl
128 | 
129 |   -- Auxiliary substitution function
130 |   {-# TERMINATING #-}
131 |   sbs : ∀ {γ δ θ} (ρ : γ →ʳ θ) (f : δ →ˢ θ) {cl} → Expr (γ ⊕ δ) cl → Expr θ cl
132 |   sbs ρ f (var-left x ` ts) = ρ ∙ x `` λ z → sbs (in-left ∘ʳ ρ) (⇑ˢ f) ([ assoc-right ]ʳ ts ∙ z)
133 |   sbs ρ f (var-right x ` ts) = sbs 𝟙ʳ (tabulate (λ z → sbs (in-left ∘ʳ ρ) (⇑ˢ f) ([ assoc-right ]ʳ ts ∙ z))) (f ∙ x)
134 | 
135 |   -- The action of substitution
136 |   infixr 6 [_]ˢ_
137 |   [_]ˢ_ : ∀ {γ δ cl} (f : γ →ˢ δ) → Expr γ cl → Expr δ cl
138 |   [ f ]ˢ e = sbs 𝟙ʳ f ([ in-right ]ʳ e)
139 | 
140 |   -- Composition of substitutions
141 |   infixl 6 _∘ˢ_
142 |   _∘ˢ_ : ∀ {γ δ θ} (g : δ →ˢ θ) (f : γ →ˢ δ) → γ →ˢ θ
143 |   g ∘ˢ f = tabulate λ x → [ ⇑ˢ g ]ˢ f ∙ x
144 | 
145 |   -- -- Basic properties of substitution
146 |   -- ∘ˢ-∙ : ∀ {γ δ θ} (g : δ →ˢ θ) (f : γ →ˢ δ) {α} (x : α ∈ γ) →
147 |   --        (g ∘ˢ f) ∙ x ≡ [ ⇑ˢ g ]ˢ (f ∙ x)
148 |   -- ∘ˢ-∙ g f x = tabulate-∙ (λ x → [ ⇑ˢ g ]ˢ f ∙ x)
149 | 
150 |   -- [∘]ˢ : ∀ {γ δ θ} (g : δ →ˢ θ) (f : γ →ˢ δ) {cl} (e : Expr γ cl) →
151 |   --        [ g ∘ˢ f ]ˢ e ≡ [ g ]ˢ [ f ]ˢ e
152 |   -- [∘]ˢ f g (x ` ts) = {!!}
153 | 
154 |   sbs-lift : ∀ {γ δ θ} (ρ : γ →ʳ θ) (τ : δ →ʳ θ) {cl} (e : Expr (γ ⊕ δ) cl) →
155 |               sbs ρ (lift τ) e ≡ [ ρ ⊕ τ ]ʳ e
156 |   sbs-lift ρ τ (var-left x ` ts) =
157 |     ≡-`
158 |       refl
159 |       (λ z → trans
160 |                (tabulate-∙ (λ z → sbs (in-left ∘ʳ ρ) (⇑ˢ (lift τ)) ([ assoc-right ]ʳ ts ∙ z)))
161 |                (trans
162 |                   {!!}
163 |                   (sym (ʳ∘ˢ-∙ {ρ = ρ ⊕ τ} {ts = ts} {x = z}))))
164 |   sbs-lift ρ τ (var-right x ` ts) =
165 |     trans
166 |       (cong (sbs 𝟙ʳ _) (lift-∙ τ x))
167 |       (≡-` 𝟙ʳ-≡ λ z → trans {!!} {!!})
168 | 
169 |   [lift]ˢ : ∀ {γ δ cl} (ρ : γ →ʳ δ) (e : Expr γ cl) → [ lift ρ ]ˢ e ≡ [ ρ ]ʳ e
170 |   [lift]ˢ ρ (x ` ts) =
171 |     let open ≡-Reasoning in
172 |       begin
173 |         [ lift ρ ]ˢ x ` ts
174 |           ≡⟨ {!!} ⟩
175 |         {!!}
176 | 
177 | 
178 |   -- lift-∘ˢ : ∀ {γ δ θ} (ρ : δ →ʳ θ) (f : γ →ˢ δ) → lift ρ ∘ˢ f ≡ ρ ʳ∘ˢ f
179 |   -- lift-∘ˢ {γ = γ} ρ f = shape-≡ λ x → E x
180 |   --   where
181 |   --     open ≡-Reasoning
182 |   --     E : ∀ {α} (x : α ∈ γ) → (lift ρ ∘ˢ f) ∙ x ≡ (ρ ʳ∘ˢ f) ∙ x
183 |   --     E x =
184 |   --       begin
185 |   --         (lift ρ ∘ˢ f) ∙ x
186 |   --           ≡⟨ ∘ˢ-∙ (lift ρ) f x ⟩
187 |   --         [ ⇑ˢ (lift ρ) ]ˢ f ∙ x
188 |   --           ≡⟨ cong ([_]ˢ f ∙ x) (⇑ˢ-lift ρ) ⟩
189 |   --         [ lift (⇑ʳ ρ) ]ˢ f ∙ x
190 |   --           ≡⟨ [lift]ˢ (⇑ʳ ρ) (f ∙ x) ⟩
191 |   --         [ ⇑ʳ ρ ]ʳ f ∙ x
192 |   --           ≡⟨ sym (ʳ∘ˢ-∙ {ρ = ρ} {ts = f} {x = x})⟩
193 |   --         (ρ ʳ∘ˢ f) ∙ x
194 |   --       ∎
195 | 
196 | 
197 |   -- [𝟙]ˢ : ∀ {γ cl} {e : Expr γ cl} → [ 𝟙ˢ ]ˢ e ≡ e
198 |   -- [𝟙]ˢ {e = x ` ts} = trans (cong [ 𝟙ˢ ⊕ (𝟙ˢ ∘ˢ ts) ]ˢ_ 𝟙ˢ-∙) {!!}
199 | 


--------------------------------------------------------------------------------
/src/Syntax.agda:
--------------------------------------------------------------------------------
  1 | open import Agda.Primitive
  2 | open import Relation.Binary.PropositionalEquality
  3 | open import Relation.Unary hiding (_∈_)
  4 | open import Relation.Binary
  5 | open import Data.Product using (_×_; _,_)
  6 | open import Function using (_∘_)
  7 | 
  8 | {-
  9 | 
 10 |    A formalization of (raw) syntax with higher-rank binders.
 11 | 
 12 |    We define a notion of syntax which allows for higher-rank binders, variables and substitutions. Ordinary notions of
 13 |    variables are special cases:
 14 | 
 15 |    * rank 1: ordinary variables and substitutions, for example those of λ-calculus
 16 |    * rank 2: meta-variables and their instantiations
 17 |    * rank 3: symbols (term formers) in dependent type theory, such as Π, Σ, W, and syntactic transformations between theories
 18 | 
 19 |    The syntax is parameterized by a type Class of syntactic classes. For example, in dependent type theory there might
 20 |    be two syntactic classes, ty and tm, corresponding to type and term expressions. In the futre we would prefer to
 21 |    generalize the situation to any number of proof-relevant and proof-irrelevant judgements.
 22 | 
 23 | -}
 24 | 
 25 | 
 26 | module Syntax (Class : Set) where
 27 | 
 28 |   infixl 5 _⊕_
 29 | 
 30 |   {- Shapes are a kind of variable contexts. They assign to each variable its syntactic arity, which is a syntactic
 31 |      class and a binding shape. We model shapes as binary trees so that it is easy to concatenate two of them. A more
 32 |      traditional approach models shapes as lists, in which case one has to append lists. -}
 33 | 
 34 |   data Shape : Set
 35 | 
 36 |   Arity : Set
 37 |   Arity = Shape × Class
 38 | 
 39 |   arg : Arity → Shape
 40 |   arg (γ  , _) = γ
 41 | 
 42 |   class : Arity → Class
 43 |   class (_  , cl) = cl
 44 | 
 45 |   data Shape where
 46 |     𝟘 : Shape -- the empty shape
 47 |     [_] : Arity → Shape -- the shape with precisely one variable
 48 |     _⊕_ : ∀ (γ : Shape) (δ : Shape) → Shape -- disjoint sum of shapes
 49 | 
 50 |   -- -- Examples:
 51 | 
 52 |   -- postulate ty : Class -- type class
 53 |   -- postulate tm : Class -- term class
 54 | 
 55 |   -- ordinary-variable-arity : Class → Shape
 56 |   -- ordinary-variable-arity c = [ 𝟘 , c ]
 57 | 
 58 |   -- binary-type-metavariable-arity : Shape
 59 |   -- binary-type-metavariable-arity = [ [ 𝟘 , tm ] ⊕ [ 𝟘 , tm ] , ty ]
 60 | 
 61 |   -- Π-arity : Shape
 62 |   -- Π-arity = [ [ 𝟘 , ty ] ⊕ [ [ 𝟘 , tm ] , ty ] , ty ]
 63 | 
 64 |   infix 3 _∈_
 65 | 
 66 |   {- The de Bruijn indices are binary numbers because shapes are binary trees.
 67 |      α ∈ γ is the set of variable indices in γ whose arity is α. -}
 68 |   data _∈_ : Arity → Shape → Set where
 69 |     var-here : ∀ {α} → α ∈ [ α ]
 70 |     var-left :  ∀ {α} {γ} {δ} → α ∈ γ → α ∈ γ ⊕ δ
 71 |     var-right : ∀ {α} {γ} {δ} → α ∈ δ → α ∈ γ ⊕ δ
 72 | 
 73 |   -- In several cases we want a map defined on the positions of a shape.
 74 |   -- Defining such maps directly is difficult because the relevant recursion
 75 |   -- principle is not structural. Instead we use a method suggested by
 76 |   -- Guillaume Allais (http://gallais.github.io), which amounts to
 77 |   -- working with proof-relevant evidence that the function is defined.
 78 | 
 79 |   -- The definition of All, tabulate, lookup and map is taken from
 80 |   -- https://github.com/gallais/potpourri/blob/349d2f282a100ea5d82a548455b040939b04e67e/agda/poc/Syntax.agda
 81 | 
 82 |   -- A “predicate” witnessing that P is inhabited at all positions
 83 |   -- of a shape.
 84 |   data All (P : Arity → Set) : Shape → Set where
 85 |     𝟘 : All P 𝟘
 86 |     [_] : ∀ {α} → P α → All P [ α ]
 87 |     _⊕_ : ∀ {γ δ} → All P γ → All P δ → All P (γ ⊕ δ)
 88 | 
 89 |   -- Given a map on positions of a shape, we can produce evidence
 90 |   -- that it is defined at all positions.
 91 |   tabulate : ∀ {γ P} → (∀ {α} → α ∈ γ → P α) → All P γ
 92 |   tabulate {𝟘} f = 𝟘
 93 |   tabulate {[ _ , _ ]} f = [ f var-here ]
 94 |   tabulate {_ ⊕ _} f = tabulate (f ∘ var-left) ⊕ tabulate (f ∘ var-right)
 95 | 
 96 |   -- Extensionally equal maps give the same tabulations
 97 |   tabulate-ext : ∀ {P : Arity → Set} {γ} {f g : ∀ {α} → α ∈ γ → P α} →
 98 |                  (∀ {α} {x : α ∈ γ} → f x ≡ g x) → tabulate f ≡ tabulate g
 99 |   tabulate-ext {γ = 𝟘} ξ = refl
100 |   tabulate-ext {γ = [ x ]} ξ = cong [_] ξ
101 |   tabulate-ext {γ = γ ⊕ δ} ξ = cong₂ _⊕_ (tabulate-ext ξ) (tabulate-ext ξ)
102 | 
103 |   -- Given evidence that a map is defined at all positions of a shape,
104 |   -- we can lookup one of its values.
105 |   infixl 12 _∙_
106 |   _∙_ : ∀ {γ P} → All P γ → (∀ {α} → α ∈ γ → P α)
107 |   [ p ] ∙ var-here = p
108 |   (ps ⊕ _) ∙ (var-left x) = ps ∙ x
109 |   (_ ⊕ qs) ∙ (var-right y) = qs ∙ y
110 | 
111 |   -- Tabulation stores values correctly
112 |   tabulate-∙ : ∀ {P : Arity → Set} {γ} (f : (∀ {α} → α ∈ γ → P α)) {α} {x : α ∈ γ} → (tabulate f) ∙ x ≡ f x
113 |   tabulate-∙ f {x = var-here} = refl
114 |   tabulate-∙ f {x = var-left x} = tabulate-∙ (f ∘ var-left)
115 |   tabulate-∙ f {x = var-right y} = tabulate-∙ (f ∘ var-right)
116 | 
117 |   cong-∙ : ∀ {γ P} {f g : All P γ} {α} {x y : α ∈ γ} → f ≡ g → x ≡ y → f ∙ x ≡ g ∙ y
118 |   cong-∙ refl refl = refl
119 | 
120 |   map : ∀ {γ P Q} → (∀ {α} → P α → Q α) → All P γ → All Q γ
121 |   map f 𝟘 = 𝟘
122 |   map f [ x ] = [ f x ]
123 |   map f (ps ⊕ qs) = map f ps ⊕ map f qs
124 | 
125 |   map-map : ∀ {γ} {P Q R : Arity → Set} (f : ∀ {α} → P α → Q α) (g : ∀ {α} → Q α → R α) {p : All P γ} →
126 |               map (g ∘ f) p ≡ map g (map f p)
127 |   map-map f g {p = 𝟘} = refl
128 |   map-map f g {p = [ x ]} = refl
129 |   map-map f g {p = p₁ ⊕ p₂} = cong₂ _⊕_ (map-map f g) (map-map f g)
130 | 
131 |   -- map-ext : ∀ {γ P Q} (f g : ∀ {a} → P a → Q a) →
132 | 
133 |   shape-≡ : ∀ {γ P} {ps qs : All P γ} → (∀ {α} (x : α ∈ γ) → ps ∙ x ≡ qs ∙ x)
134 |             → ps ≡ qs
135 |   shape-≡ {ps = 𝟘} {qs = 𝟘} ξ = refl
136 |   shape-≡ {ps = [ x ]} {qs = [ y ]} ξ = cong [_] (ξ var-here)
137 |   shape-≡ {ps = ps₁ ⊕ ps₂} {qs = qs₁ ⊕ qs₂} ξ =
138 |     cong₂ _⊕_ (shape-≡ (ξ ∘ var-left)) (shape-≡ (ξ ∘ var-right))
139 | 
140 |   -- The interaction of map and tabulate
141 |   map-tabulate : ∀ {P Q : Arity → Set} {γ} {g : ∀ {α} → P α → Q α} → {f : (∀ {α} → α ∈ γ → P α)} →
142 |                  map g (tabulate f) ≡ tabulate (g ∘ f)
143 |   map-tabulate {γ = 𝟘} = refl
144 |   map-tabulate {γ = [ _ ]} = refl
145 |   map-tabulate {γ = _ ⊕ _} = cong₂ _⊕_ map-tabulate map-tabulate
146 | 
147 |   -- the interaction of map and ∙
148 |   map-∙ : ∀ {γ P} {Q : Arity → Set} → {f : ∀ {α} → P α → Q α} {ps : All P γ} {α : Arity} {x : α ∈ γ} → map f ps ∙ x  ≡ f (ps ∙ x)
149 |   map-∙ {ps = [ _ ]} {x = var-here} = refl
150 |   map-∙ {ps = ps₁ ⊕ ps₂} {x = var-left x} = map-∙ {ps = ps₁}
151 |   map-∙ {ps = ps₁ ⊕ ps₂} {x = var-right x} = map-∙ {ps = ps₂}
152 | 
153 |   {- Because everything is a variable, even symbols, there is a single expression constructor
154 |      x ` ts which forms and expression by applying the variable x to arguments ts. -}
155 | 
156 |   data Expr : Shape → Class → Set
157 | 
158 |   Arg : Shape → Arity → Set
159 |   Arg γ (δ , cl) = Expr (γ ⊕ δ) cl
160 | 
161 |   -- We define renamings and substitutions here so that they can be referred to.
162 | 
163 |   -- Renaming
164 |   infix 4 _→ʳ_
165 | 
166 |   _→ʳ_ : Shape → Shape → Set
167 |   γ →ʳ δ = All (_∈ δ) γ
168 | 
169 |   -- Substitution
170 |   infix 4 _→ˢ_
171 | 
172 |   _→ˢ_ : Shape → Shape → Set
173 |   γ →ˢ δ = All (Arg δ) γ
174 | 
175 |   -- Expressions
176 | 
177 |   infix 9 _`_
178 | 
179 |   data Expr where
180 |     _`_ : ∀ {γ δ} {cl} (x : (δ , cl) ∈ γ) → (ts : δ →ˢ γ) → Expr γ cl
181 | 
182 |   -- A common idiom
183 |   infix 9 _``_
184 | 
185 |   _``_ : ∀ {γ δ} {cl} (x : (δ , cl) ∈ γ) → (ts : ∀ {a} (z : a ∈ δ) → Arg γ a) → Expr γ cl
186 |   x `` ts = x ` tabulate ts
187 | 
188 |   -- Syntactic equality of expressions
189 | 
190 |   ≡-` : ∀ {α} {γ} {x y : (γ , class α) ∈ arg α} {ts us : γ →ˢ arg α} →
191 |           x ≡ y → (∀ {αᶻ} (z : αᶻ ∈ γ) → ts ∙ z ≡ us ∙ z) → x ` ts ≡ y ` us
192 |   ≡-` ζ ξ = cong₂ (_`_) ζ (shape-≡ ξ)
193 | 


--------------------------------------------------------------------------------