├── .gitignore ├── Preliminaries.agda ├── STLC-CBN.agda ├── STLC-CBV-Equivalence.agda ├── STLC-CBV-Ex.agda ├── STLC-CBV-Normalization.agda ├── STLC-CBV.agda └── STLC.agda /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | -------------------------------------------------------------------------------- /Preliminaries.agda: -------------------------------------------------------------------------------- 1 | open import Agda.Primitive using (Level; lzero; lsuc; _⊔_) 2 | 3 | module Preliminaries where 4 | 5 | -- ---------------------------------------------------------------------- 6 | -- functions 7 | 8 | _o_ : {A B C : Set} → (B → C) → (A → B) → A → C 9 | g o f = \ x → g (f x) 10 | infixr 10 _o_ 11 | 12 | -- ---------------------------------------------------------------------- 13 | -- identity type 14 | 15 | data _==_ {l : Level} {A : Set l} (M : A) : A → Set l where 16 | Refl : M == M 17 | 18 | {-# BUILTIN EQUALITY _==_ #-} 19 | {-# BUILTIN REFL Refl #-} 20 | 21 | transport : {l1 : Level} {l2 : Level} {A : Set l1} (B : A → Set l2) 22 | {a1 a2 : A} → a1 == a2 → (B a1 → B a2) 23 | transport B Refl = λ x → x 24 | 25 | ! : {l : Level} {A : Set l} {M N : A} → M == N → N == M 26 | ! Refl = Refl 27 | 28 | _∘_ : {l : Level} {A : Set l} {M N P : A} 29 | → N == P → M == N → M == P 30 | β ∘ Refl = β 31 | 32 | ap : {l1 l2 : Level} {A : Set l1} {B : Set l2} {M N : A} 33 | (f : A → B) → M == N → (f M) == (f N) 34 | ap f Refl = Refl 35 | 36 | ap2 : {l1 l2 l3 : Level} {A : Set l1} {B : Set l2} {C : Set l3} {M N : A} {M' N' : B} (f : A -> B -> C) -> M == N -> M' == N' -> (f M M') == (f N N') 37 | ap2 f Refl Refl = Refl 38 | 39 | ap3 : {l1 l2 l3 l4 : Level} {A : Set l1} {B : Set l2} {C : Set l3} {D : Set l4} {M N : A} {M' N' : B} {M'' N'' : C} (f : A -> B -> C -> D) -> M == N -> M' == N' -> M'' == N'' -> (f M M' M'') == (f N N' N'') 40 | ap3 f Refl Refl Refl = Refl 41 | -- is there a way to make this generic? 42 | 43 | postulate 44 | -- function extensionality 45 | λ= : {l1 l2 : Level} {A : Set l1} {B : A -> Set l2} {f g : (x : A) -> B x} -> ((x : A) -> (f x) == (g x)) -> f == g 46 | -- function extensionality for implicit functions 47 | λ=i : {l1 l2 : Level} {A : Set l1} {B : A -> Set l2} {f g : {x : A} -> B x} -> ((x : A) -> (f {x}) == (g {x})) -> _==_ {_}{ {x : A} → B x } f g 48 | 49 | private primitive primTrustMe : {l : Level} {A : Set l} {x y : A} -> x == y 50 | 51 | infixr 9 _==_ 52 | 53 | infix 2 _∎ 54 | infixr 2 _=〈_〉_ 55 | 56 | _=〈_〉_ : {l : Level} {A : Set l} (x : A) {y z : A} → x == y → y == z → x == z 57 | _ =〈 p1 〉 p2 = (p2 ∘ p1) 58 | 59 | _∎ : {l : Level} {A : Set l} (x : A) → x == x 60 | _∎ _ = Refl 61 | 62 | -- ---------------------------------------------------------------------- 63 | -- product types 64 | 65 | record Unit : Set where 66 | constructor <> 67 | 68 | record Σ {l1 l2 : Level} {A : Set l1} (B : A -> Set l2) : Set (l1 ⊔ l2) where 69 | constructor _,_ 70 | field 71 | fst : A 72 | snd : B fst 73 | open Σ public 74 | 75 | infixr 0 _,_ 76 | 77 | _×_ : {l1 l2 : Level} → Set l1 -> Set l2 -> Set (l1 ⊔ l2) 78 | A × B = Σ (\ (_ : A) -> B) 79 | 80 | infixr 10 _×_ 81 | 82 | -- ---------------------------------------------------------------------- 83 | -- booleans 84 | 85 | data Bool : Set where 86 | True : Bool 87 | False : Bool 88 | {-# COMPILED_DATA Bool Bool True False #-} 89 | {-# BUILTIN BOOL Bool #-} 90 | {-# BUILTIN TRUE True #-} 91 | {-# BUILTIN FALSE False #-} 92 | 93 | -- ---------------------------------------------------------------------- 94 | -- order 95 | 96 | data Order : Set where 97 | Less : Order 98 | Equal : Order 99 | Greater : Order 100 | 101 | -- ---------------------------------------------------------------------- 102 | -- sums 103 | 104 | data Void : Set where 105 | 106 | abort : {A : Set} → Void → A 107 | abort () 108 | 109 | data Either (A B : Set) : Set where 110 | Inl : A → Either A B 111 | Inr : B → Either A B 112 | 113 | DecEq : Set → Set 114 | DecEq A = (x y : A) → Either (x == y) (x == y → Void) 115 | 116 | -- ---------------------------------------------------------------------- 117 | -- natural numbers 118 | 119 | module Nat where 120 | data Nat : Set where 121 | Z : Nat 122 | S : Nat -> Nat 123 | 124 | -- let's you use numerals for Nat 125 | {-# BUILTIN NATURAL Nat #-} 126 | 127 | _+_ : Nat → Nat → Nat 128 | Z + n = n 129 | (S m) + n = S (m + n) 130 | 131 | max : Nat → Nat → Nat 132 | max Z n = n 133 | max m Z = m 134 | max (S m) (S n) = S (max m n) 135 | 136 | equal : Nat → Nat → Bool 137 | equal Z Z = True 138 | equal Z (S _) = False 139 | equal (S _) Z = False 140 | equal (S m) (S n) = equal m n 141 | 142 | compare : Nat → Nat → Order 143 | compare Z Z = Equal 144 | compare Z (S m) = Less 145 | compare (S n) Z = Greater 146 | compare (S n) (S m) = compare n m 147 | 148 | open Nat public using (Nat ; Z ; S) 149 | 150 | 151 | -- ---------------------------------------------------------------------- 152 | -- monad 153 | 154 | module Monad where 155 | 156 | record Monad : Set1 where 157 | field 158 | T : Set → Set 159 | return : ∀ {A} → A → T A 160 | _>>=_ : ∀ {A B} → T A → (A → T B) -> T B 161 | 162 | 163 | -- ---------------------------------------------------------------------- 164 | -- options 165 | 166 | module Maybe where 167 | 168 | data Maybe {l : Level} (A : Set l) : Set l where 169 | Some : A → Maybe A 170 | None : Maybe A 171 | 172 | Monad : Monad.Monad 173 | Monad = record { T = Maybe; return = Some; _>>=_ = (λ {None _ → None; (Some v) f → f v}) } 174 | 175 | open Maybe public using (Maybe;Some;None) 176 | 177 | -- ---------------------------------------------------------------------- 178 | -- lists 179 | 180 | module List where 181 | data List {l : Level} (A : Set l) : Set l where 182 | [] : List A 183 | _::_ : A -> List A -> List A 184 | 185 | {-# COMPILED_DATA List [] [] (:) #-} 186 | {-# BUILTIN LIST List #-} 187 | {-# BUILTIN NIL [] #-} 188 | {-# BUILTIN CONS _::_ #-} 189 | 190 | infixr 99 _::_ 191 | 192 | _++_ : {A : Set} → List A → List A → List A 193 | [] ++ ys = ys 194 | (x :: xs) ++ ys = x :: (xs ++ ys) 195 | 196 | infixr 10 _++_ 197 | 198 | map : {l1 l2 : Level} {A : Set l1} {B : Set l2} → (A → B) → List A → List B 199 | map f [] = [] 200 | map f (x :: xs) = f x :: map f xs 201 | 202 | map-id : {l : Level} {A : Set l} (l : List A) → map (\ (x : A) → x) l == l 203 | map-id [] = Refl 204 | map-id (x :: l) with map (\ x -> x) l | map-id l 205 | ... | ._ | Refl = Refl 206 | 207 | module Uninformative where 208 | -- simply typed version 209 | peelOff : {A : Set} (eq : A → A → Bool) → List A → List A → Maybe (List A) 210 | peelOff eq [] ys = Some ys 211 | peelOff eq (_ :: _) [] = None 212 | peelOff eq (x :: xs) (y :: ys) with eq x y 213 | ... | False = None 214 | ... | True = peelOff eq xs ys 215 | 216 | peelOff : {A : Set} (eq : DecEq A) → (xs ys : List A) → Maybe (Σ \ zs → (xs ++ zs) == ys ) 217 | peelOff eq [] ys = Some (ys , Refl) 218 | peelOff eq (_ :: _) [] = None 219 | peelOff eq (x :: xs) (y :: ys) with eq x y 220 | ... | Inr xyneq = None 221 | peelOff eq (x :: xs) (.x :: ys) | Inl Refl with peelOff eq xs ys 222 | peelOff eq (x :: xs) (.x :: .(xs ++ zs)) | Inl Refl | Some (zs , Refl) = Some (zs , Refl) 223 | ... | None = None 224 | 225 | [_] : {A : Set} → A → List A 226 | [ c ] = c :: [] 227 | 228 | ++-assoc : ∀ {A} (l1 l2 l3 : List A) → (l1 ++ l2) ++ l3 == l1 ++ (l2 ++ l3) 229 | ++-assoc [] l2 l3 = Refl 230 | ++-assoc (x :: xs) l2 l3 = ap (_::_ x) (++-assoc xs l2 l3) 231 | 232 | open List public using (List ; [] ; _::_) 233 | 234 | 235 | -- ---------------------------------------------------------------------- 236 | -- characters 237 | 238 | module Char where 239 | 240 | postulate {- Agda Primitive -} 241 | Char : Set 242 | 243 | {-# BUILTIN CHAR Char #-} 244 | {-# COMPILED_TYPE Char Char #-} 245 | 246 | private 247 | primitive 248 | primCharToNat : Char → Nat 249 | primCharEquality : Char → Char → Bool 250 | 251 | toNat : Char → Nat 252 | toNat = primCharToNat 253 | 254 | equalb : Char -> Char -> Bool 255 | equalb = primCharEquality 256 | 257 | -- need to go outside the real language a little to give the primitives good types, 258 | -- but from the outside this should be safe 259 | equal : DecEq Char 260 | equal x y with equalb x y 261 | ... | True = Inl primTrustMe 262 | ... | False = Inr canthappen where 263 | postulate canthappen : _ 264 | 265 | open Char public using (Char) 266 | 267 | -- ---------------------------------------------------------------------- 268 | -- vectors 269 | 270 | module Vector where 271 | 272 | data Vec (A : Set) : Nat → Set where 273 | [] : Vec A 0 274 | _::_ : ∀ {n} → A → Vec A n → Vec A (S n) 275 | 276 | infixr 99 _::_ 277 | 278 | Vec-elim : {A : Set} (P : {n : Nat} → Vec A n → Set) 279 | → (P []) 280 | → ({n : Nat} (x : A) (xs : Vec A n) → P xs → P (x :: xs)) 281 | → {n : Nat} (v : Vec A n) → P v 282 | Vec-elim P n c [] = n 283 | Vec-elim P n c (y :: ys) = c y ys (Vec-elim P n c ys) 284 | 285 | fromList : {A : Set} → List A → Σ \n → Vec A n 286 | fromList [] = _ , [] 287 | fromList (x :: xs) = _ , x :: snd (fromList xs) 288 | 289 | toList : {A : Set} {n : Nat} → Vec A n → List A 290 | toList [] = [] 291 | toList (x :: xs) = x :: (toList xs) 292 | 293 | toList' : {A : Set} → (Σ \ n → Vec A n) → List A 294 | toList' (._ , []) = [] 295 | toList' (._ , (x :: xs)) = x :: (toList' (_ , xs)) 296 | 297 | to-from : {A : Set} (l : List A) → toList' (fromList l) == l 298 | to-from [] = Refl 299 | to-from (x :: l) with toList' (fromList l) | to-from l 300 | to-from (x :: l) | .l | Refl = Refl 301 | 302 | from-to : {A : Set} (l : Σ \n → Vec A n) → fromList (toList' l) == l 303 | from-to (._ , []) = Refl 304 | from-to (._ , x :: l) with fromList (toList' (_ , l)) | from-to (_ , l) 305 | from-to (.(S n) , _::_ {n} x l) | .(n , l) | Refl = Refl 306 | 307 | 308 | 309 | -- ---------------------------------------------------------------------- 310 | -- strings 311 | 312 | module String where 313 | 314 | postulate {- Agda Primitive -} 315 | String : Set 316 | {-# BUILTIN STRING String #-} 317 | {-# COMPILED_TYPE String String #-} 318 | 319 | private 320 | primitive 321 | primStringToList : String -> List Char 322 | primStringFromList : List Char -> String 323 | primStringAppend : String -> String -> String 324 | primStringEquality : String -> String -> Bool 325 | 326 | equal : String -> String -> Bool 327 | equal = primStringEquality 328 | 329 | toList = primStringToList 330 | fromList = primStringFromList 331 | 332 | append = primStringAppend 333 | 334 | toVec : String -> Σ \ m → Vector.Vec Char m 335 | toVec = Vector.fromList o toList 336 | 337 | 338 | -- ---------------------------------------------------------------------- 339 | -- fancy order 340 | 341 | module FancyOrder where 342 | 343 | data FancyOrder {A : Set} {_≤_ : A → A → Set} (a1 a2 : A) : Set where 344 | Less : a1 ≤ a2 -> (a1 == a2 -> Void) → FancyOrder a1 a2 345 | Equal : a1 == a2 -> FancyOrder a1 a2 346 | Greater : a2 ≤ a1 → (a1 == a2 -> Void) -> FancyOrder a1 a2 347 | 348 | record DecidableOrder : Set1 where 349 | field 350 | A : Set 351 | _≤_ : A → A → Set 352 | ≤-refl : ∀ {a} → a ≤ a 353 | ≤-trans : ∀ {a1 a2 a3} → a1 ≤ a2 -> a2 ≤ a3 -> a1 ≤ a3 354 | ≤-saturated : ∀ {a1 a2} -> a1 ≤ a2 -> a2 ≤ a1 -> a1 == a2 355 | compare : (a1 a2 : A) → FancyOrder {A}{_≤_} a1 a2 356 | 357 | ≤-refl' : ∀ {a1 a2} → a1 == a2 -> a1 ≤ a2 358 | ≤-refl' Refl = ≤-refl 359 | 360 | min : A → A → A 361 | min a1 a2 with compare a1 a2 362 | ... | Less _ _ = a1 363 | ... | Equal _ = a1 364 | ... | Greater _ _ = a2 365 | 366 | min-≤-1 : {a1 a2 : A} → min a1 a2 ≤ a1 367 | min-≤-1 {a1}{a2} with compare a1 a2 368 | ... | Less lt _ = ≤-refl 369 | ... | Equal eq = ≤-refl 370 | ... | Greater gt _ = gt 371 | 372 | min-≤-2 : {a1 a2 : A} → min a1 a2 ≤ a2 373 | min-≤-2 {a1}{a2} with compare a1 a2 374 | ... | Less lt _ = lt 375 | min-≤-2 | Equal Refl = ≤-refl 376 | ... | Greater gt _ = ≤-refl 377 | 378 | min-sym : {a1 a2 : A} → min a1 a2 == min a2 a1 379 | min-sym {a1}{a2} with compare a1 a2 | compare a2 a1 380 | min-sym | Less lt12 _ | Less lt21 _ = ≤-saturated lt12 lt21 381 | min-sym | Less lt12 _ | Equal Refl = Refl 382 | min-sym | Less lt12 _ | Greater gt21 _ = Refl 383 | min-sym | Equal eq12 | Less lt21 _ = eq12 384 | min-sym | Equal eq12 | Equal eq21 = eq12 385 | min-sym | Equal eq12 | Greater gt21 _ = Refl 386 | min-sym | Greater gt12 _ | Less lt21 _ = Refl 387 | min-sym | Greater gt12 _ | Equal eq21 = Refl 388 | min-sym | Greater gt12 _ | Greater gt21 _ = ≤-saturated gt12 gt21 389 | 390 | min-≤ : {a1 a2 : A} → a1 ≤ a2 -> (min a1 a2) == a1 391 | min-≤ {a1} {a2} lt1 with compare a1 a2 392 | ... | Less lt _ = Refl 393 | ... | Equal eq = Refl 394 | ... | Greater gt _ = ≤-saturated gt lt1 395 | 396 | max : A → A → A 397 | max a1 a2 with compare a1 a2 398 | ... | Less _ _ = a2 399 | ... | Equal _ = a2 400 | ... | Greater _ _ = a1 401 | 402 | max-≥-1 : {a1 a2 : A} → a1 ≤ max a1 a2 403 | max-≥-1 {a1}{a2} with compare a1 a2 404 | ... | Less lt _ = lt 405 | max-≥-1 | Equal Refl = ≤-refl 406 | ... | Greater gt _ = ≤-refl 407 | 408 | max-≥-2 : {a1 a2 : A} → a2 ≤ max a1 a2 409 | max-≥-2 {a1}{a2} with compare a1 a2 410 | ... | Less lt _ = ≤-refl 411 | ... | Equal eq = ≤-refl 412 | ... | Greater gt _ = gt 413 | 414 | min-monotone : {a1 a1' a2 a2' : A} → a1 ≤ a1' -> a2 ≤ a2' -> min a1 a2 ≤ min a1' a2' 415 | min-monotone {a1}{a1'}{a2}{a2'} lt1 lt2 with compare a1 a2 | compare a1' a2' 416 | min-monotone lt1 lt2 | Less x x₁ | Less x₂ x₃ = lt1 417 | min-monotone lt1 lt2 | Less x x₁ | Equal x₂ = lt1 418 | min-monotone lt1 lt2 | Less x x₁ | Greater x₂ x₃ = ≤-trans x lt2 419 | min-monotone lt1 lt2 | Equal x | Less x₁ x₂ = lt1 420 | min-monotone lt1 lt2 | Equal x | Equal x₁ = lt1 421 | min-monotone lt1 lt2 | Equal Refl | Greater x₁ x₂ = lt2 422 | min-monotone lt1 lt2 | Greater x x₁ | Less x₂ x₃ = ≤-trans x lt1 423 | min-monotone lt1 lt2 | Greater x x₁ | Equal x₂ = ≤-trans x lt1 424 | min-monotone lt1 lt2 | Greater x x₁ | Greater x₂ x₃ = lt2 425 | 426 | max-sym : {a1 a2 : A} → max a1 a2 == max a2 a1 427 | max-sym {a1}{a2} with compare a1 a2 | compare a2 a1 428 | max-sym | Less lt12 _ | Less lt21 _ = ≤-saturated lt21 lt12 429 | max-sym | Less lt12 _ | Equal eq21 = eq21 430 | max-sym | Less lt12 _ | Greater gt21 _ = Refl 431 | max-sym | Equal eq12 | Less lt21 _ = ! eq12 432 | max-sym | Equal eq12 | Equal eq21 = eq21 433 | max-sym | Equal eq12 | Greater gt21 _ = Refl 434 | max-sym | Greater gt12 _ | Less lt21 _ = Refl 435 | max-sym | Greater gt12 _ | Equal eq21 = Refl 436 | max-sym | Greater gt12 _ | Greater gt21 _ = ≤-saturated gt21 gt12 437 | 438 | max-≤ : {a1 a2 : A} → a1 ≤ a2 -> (max a1 a2) == a2 439 | max-≤ {a1} {a2} lt1 with compare a1 a2 440 | ... | Less lt _ = Refl 441 | ... | Equal eq = Refl 442 | ... | Greater gt _ = ≤-saturated lt1 gt 443 | 444 | max-monotone : {a1 a1' a2 a2' : A} → a1 ≤ a1' -> a2 ≤ a2' -> max a1 a2 ≤ max a1' a2' 445 | max-monotone {a1}{a1'}{a2}{a2'} lt1 lt2 with compare a1 a2 | compare a1' a2' 446 | max-monotone lt1 lt2 | Less x x₁ | Less x₂ x₃ = lt2 447 | max-monotone lt1 lt2 | Less x x₁ | Equal x₂ = lt2 448 | max-monotone lt1 lt2 | Less x x₁ | Greater x₂ x₃ = ≤-trans lt2 x₂ 449 | max-monotone lt1 lt2 | Equal x | Less x₁ x₂ = lt2 450 | max-monotone lt1 lt2 | Equal x | Equal x₁ = lt2 451 | max-monotone lt1 lt2 | Equal Refl | Greater x₁ x₂ = lt1 452 | max-monotone lt1 lt2 | Greater x x₁ | Less x₂ x₃ = ≤-trans lt1 x₂ 453 | max-monotone lt1 lt2 | Greater x x₁ | Equal Refl = lt1 454 | max-monotone lt1 lt2 | Greater x x₁ | Greater x₂ x₃ = lt1 455 | -------------------------------------------------------------------------------- /STLC-CBN.agda: -------------------------------------------------------------------------------- 1 | open import Preliminaries 2 | open import STLC 3 | 4 | -- Technically, these easily turn into strong normalization proofs, by 5 | -- determinacy of the operational semantics. 6 | 7 | module STLC-CBN where 8 | 9 | module OpSemCBN where 10 | -- step relation 11 | data _↦_ : {τ : Tp} → [] ⊢ τ → [] ⊢ τ → Set where 12 | Step/app :{τ1 τ2 : Tp} {e e' : [] ⊢ τ1 ⇒ τ2} {e1 : [] ⊢ τ1} 13 | → e ↦ e' 14 | → (app e e1) ↦ (app e' e1) 15 | Step/β : {τ1 τ2 : Tp} {e : [] ,, τ1 ⊢ τ2} {e1 : [] ⊢ τ1} 16 | → (app (lam e) e1) ↦ subst1 e1 e 17 | Step/if-cond : {τ : Tp} {e e' : [] ⊢ bool} {e₁ e₂ : [] ⊢ τ} 18 | → e ↦ e' 19 | → if e then e₁ else e₂ ↦ if e' then e₁ else e₂ 20 | Step/if-true : {τ : Tp} {e e' : [] ⊢ τ} 21 | → if #t then e else e' ↦ e 22 | Step/if-false : {τ : Tp} {e e' : [] ⊢ τ} 23 | → if #f then e else e' ↦ e' 24 | 25 | -- reflexive/transitive closure 26 | data _↦*_ : {τ : Tp} → [] ⊢ τ → [] ⊢ τ → Set where 27 | Done : {τ : Tp} {e : [] ⊢ τ} → e ↦* e 28 | Step : {τ : Tp} {e1 e2 e3 : [] ⊢ τ} 29 | → e1 ↦ e2 → e2 ↦* e3 30 | → e1 ↦* e3 31 | 32 | Append : {τ : Tp} {e1 e2 e3 : [] ⊢ τ} 33 | → e1 ↦* e2 → e2 ↦* e3 34 | → e1 ↦* e3 35 | Append Done g = g 36 | Append (Step x f) g = Step x (Append f g) 37 | 38 | _⇓_ : {τ : Tp} → [] ⊢ τ → [] ⊢ τ → Set 39 | e ⇓ z = value z × e ↦* z 40 | 41 | _⇓ : {τ : Tp} → [] ⊢ τ → Set 42 | e ⇓ = Σ (λ z → e ⇓ z) 43 | 44 | lifts : {τ τ' : Tp} {E : [] ⊢ τ → [] ⊢ τ'} → ({e e' : [] ⊢ τ} → e ↦ e' → E e ↦ E e') → {e e' : [] ⊢ τ} 45 | → (e ↦* e') → (E e ↦* E e') 46 | lifts Step/rule Done = Done 47 | lifts Step/rule (Step e↦e' e'↦*e'') = Step (Step/rule e↦e') (lifts Step/rule e'↦*e'') 48 | 49 | module WeakNormalizationCBN where 50 | 51 | open OpSemCBN 52 | 53 | mutual 54 | WN' : (τ : Tp) → [] ⊢ τ → Set 55 | WN' bool e = Unit 56 | WN' (τ1 ⇒ τ2) e = (e1 : [] ⊢ τ1) → WN τ1 e1 → WN τ2 (app e e1) 57 | 58 | WN : (τ : Tp) → [] ⊢ τ → Set 59 | WN τ e = e ⇓ × WN' τ e 60 | 61 | WNc : (Γ : Ctx) → [] ⊢c Γ → Set 62 | WNc [] γ = Unit 63 | WNc (τ :: Γ) (γ , e) = WNc Γ γ × WN τ e 64 | 65 | open RenamingAndSubstitution using (addvar) 66 | --- you will want to use 67 | -- addvar : {Γ Γ' : Ctx} {τ : Tp} → Γ ⊢c Γ' → (Γ ,, τ) ⊢c (Γ' ,, τ) 68 | 69 | -- These lemmas show up in the CBV case, and are proved exactly the 70 | -- same way. However, CBN does NOT need a fwd-red lemma. 71 | bwd-red : {τ : Tp} {e e' : [] ⊢ τ} → e ↦ e' → WN τ e' → WN τ e 72 | bwd-red {bool} e↦e' ((z , vz , e'↦z) , <>) = 73 | (z , vz , Step e↦e' e'↦z) , <> 74 | bwd-red {τ₁ ⇒ τ₂} e↦e' ((z , vz , e'↦z) , WN'τ₁⇒τ₂[e']) = 75 | (z , vz , Step e↦e' e'↦z) , (λ e₁ WNτ₁[e₁] → bwd-red (Step/app e↦e') (WN'τ₁⇒τ₂[e'] e₁ WNτ₁[e₁])) 76 | 77 | bwd-red* : {τ : Tp} {e e' : [] ⊢ τ} → (e ↦* e') → WN τ e' → WN τ e 78 | bwd-red* Done wn = wn 79 | bwd-red* {τ} (Step x p) wn = bwd-red x (bwd-red* p wn) 80 | 81 | fund : {Γ : Ctx} {τ : Tp} {γ : [] ⊢c Γ} 82 | → (e : Γ ⊢ τ) 83 | → WNc Γ γ 84 | → WN τ (subst γ e) 85 | fund #t γ⊨Γ = (#t , Value/true , Done) , <> 86 | fund #f γ⊨Γ = (#f , Value/false , Done) , <> 87 | fund (if e₁ then e₂ else e₃) γ⊨Γ with fund e₁ γ⊨Γ 88 | fund (if e₁ then e₂ else e₃) γ⊨Γ | (.#t , Value/true , e₁↦*z) , <> = 89 | bwd-red* (lifts Step/if-cond e₁↦*z) (bwd-red Step/if-true (fund e₂ γ⊨Γ)) 90 | fund (if e₁ then e₂ else e₃) γ⊨Γ | (.#f , Value/false , e₁↦*z) , <> = 91 | bwd-red* (lifts Step/if-cond e₁↦*z) (bwd-red Step/if-false (fund e₃ γ⊨Γ)) 92 | fund (var i0) γ⊨Γ = snd γ⊨Γ 93 | fund (var (iS x)) γ⊨Γ = fund (var x) (fst γ⊨Γ) 94 | fund {γ = γ} (lam {τ2 = τ₂} e) γ⊨Γ = (lam (subst (addvar γ) e) , Value/lam , Done) , λ e₁ WNτ₁[e₁] → 95 | let IH = fund e (γ⊨Γ , WNτ₁[e₁]) 96 | in bwd-red Step/β (transport (WN τ₂) (subst-compose1 γ e₁ e) IH) 97 | -- notice we're done after we finish backwards-reducing! 98 | fund {γ = γ} (app e₁ e₂) γ⊨Γ = snd IH₁ (subst γ e₂) IH₂ 99 | where 100 | IH₁ = fund e₁ γ⊨Γ 101 | IH₂ = fund e₂ γ⊨Γ 102 | 103 | corollary : {τ : Tp} → (e : [] ⊢ τ) → e ⇓ 104 | corollary e = transport (λ e' → e' ⇓) (! subst-id) (fst (fund e <>)) 105 | -------------------------------------------------------------------------------- /STLC-CBV-Equivalence.agda: -------------------------------------------------------------------------------- 1 | open import Preliminaries 2 | open import STLC 3 | open import STLC-CBV 4 | 5 | -- Notation conventions: subscript numbers used for *positional* differences 6 | -- (they are not expected to have the same types) whereas ticks are used to 7 | -- indicate 'morally equivalent' terms, which are expected to be related in some 8 | -- way (e.g. 'reduces to' or 'equivalent to'). We're a little inconsistent about 9 | -- whether we number e e₁ e₂ or τ₁ τ₂; this is mostly because I like being 10 | -- consistent when there are multiples but Agda will always start with e and then 11 | -- tack on subscripts later. Sometimes we'll omit the tick when it's unambiguous. 12 | 13 | module STLC-CBV-Equivalence where 14 | 15 | -- One should always prefer an inductive definition, but the naive formulation 16 | -- is not strictly positive! 17 | {- 18 | module FailsStrictPositivity where 19 | mutual 20 | data V⟦_⟧ : (τ : Tp) → [] ⊢ τ → [] ⊢ τ → Set where 21 | V/bool-#t : V⟦ bool ⟧ #t #t 22 | V/bool-#f : V⟦ bool ⟧ #f #f 23 | V/⇒ : {τ₁ τ₂ : Tp} {e₁ e₂ : [] ,, τ₁ ⊢ τ₂} 24 | → ((v₁ v₂ : [] ⊢ τ₁) → V⟦ τ₁ ⟧ v₁ v₂ → E⟦ τ₂ ⟧ (subst1 v₁ e₁) (subst1 v₂ e₂)) 25 | → V⟦ τ₁ ⇒ τ₂ ⟧ (lam e₁) (lam e₂) 26 | 27 | data E⟦_⟧ (τ : Tp) (e₁ : [] ⊢ τ) (e₂ : [] ⊢ τ) : Set where 28 | E : (v₁ : [] ⊢ τ) → (v₂ : [] ⊢ τ) → e₁ ↦* v₁ → e₂ ↦* v₂ → V⟦ τ ⟧ v₁ v₂ → E⟦ τ ⟧ e₁ e₂ 29 | 30 | data G⟦_⟧ : (Γ : Ctx) → [] ⊢c Γ → [] ⊢c Γ → Set where 31 | G/[] : G⟦ [] ⟧ <> <> 32 | G/:: : {Γ : Ctx} {γ₁ γ₂ : [] ⊢c Γ} {τ : Tp} {v₁ v₂ : [] ⊢ τ} 33 | → G⟦ Γ ⟧ γ₁ γ₂ 34 | → V⟦ τ ⟧ v₁ v₂ 35 | → G⟦ τ :: Γ ⟧ (γ₁ , v₁) (γ₂ , v₂) 36 | -} 37 | 38 | mutual 39 | V⟦_⟧ : (τ : Tp) → [] ⊢ τ → [] ⊢ τ → Set 40 | V⟦ bool ⟧ #t #t = Unit 41 | V⟦ bool ⟧ #f #f = Unit 42 | V⟦ bool ⟧ _ _ = Void 43 | V⟦ τ₁ ⇒ τ₂ ⟧ (lam e) (lam e') = (v v' : [] ⊢ τ₁) → V⟦ τ₁ ⟧ v v' → E⟦ τ₂ ⟧ (subst1 v e) (subst1 v' e') 44 | V⟦ τ₁ ⇒ τ₂ ⟧ _ _ = Void 45 | 46 | E⟦_⟧ : (τ : Tp) → [] ⊢ τ → [] ⊢ τ → Set 47 | E⟦ τ ⟧ e e' = Σ (λ v → Σ (λ v' → e ↦* v × e' ↦* v' × V⟦ τ ⟧ v v')) 48 | 49 | G⟦_⟧ : (Γ : Ctx) → ([] ⊢c Γ) → ([] ⊢c Γ) → Set 50 | G⟦ [] ⟧ <> <> = Unit 51 | G⟦ τ :: Γ ⟧ (γ , v) (γ' , v') = G⟦ Γ ⟧ γ γ' × V⟦ τ ⟧ v v' 52 | 53 | equiv : (Γ : Ctx) → (τ : Tp) → Γ ⊢ τ → Γ ⊢ τ → Set 54 | equiv Γ τ e e' = (γ γ' : [] ⊢c Γ) → G⟦ Γ ⟧ γ γ' → E⟦ τ ⟧ (subst γ e) (subst γ' e') 55 | 56 | -- The fact that the LR is not inductive can be a bit painful for the proofs. 57 | -- So also define an unfolding which we can do case-analysis over: 58 | 59 | mutual 60 | data V'⟦_⟧ : (τ : Tp) → [] ⊢ τ → [] ⊢ τ → Set where 61 | V/bool-#t : V'⟦ bool ⟧ #t #t 62 | V/bool-#f : V'⟦ bool ⟧ #f #f 63 | V/⇒ : {τ₁ τ₂ : Tp} {e e' : [] ,, τ₁ ⊢ τ₂} 64 | → (V : (v v' : [] ⊢ τ₁) → V⟦ τ₁ ⟧ v v' {- the critical position! -} → E'⟦ τ₂ ⟧ (subst1 v e) (subst1 v' e')) 65 | → V'⟦ τ₁ ⇒ τ₂ ⟧ (lam e) (lam e') 66 | 67 | data E'⟦_⟧ (τ : Tp) (e : [] ⊢ τ) (e' : [] ⊢ τ) : Set where 68 | E' : {v v' : [] ⊢ τ} → (e↦*v : e ↦* v) → (e'↦*v' : e' ↦* v') → (V' : V'⟦ τ ⟧ v v') → E'⟦ τ ⟧ e e' 69 | 70 | data G'⟦_⟧ : (Γ : Ctx) → [] ⊢c Γ → [] ⊢c Γ → Set where 71 | G/[] : G'⟦ [] ⟧ <> <> 72 | G/:: : {Γ : Ctx} {γ γ' : [] ⊢c Γ} {τ : Tp} {v v' : [] ⊢ τ} 73 | → G'⟦ Γ ⟧ γ γ' 74 | → V'⟦ τ ⟧ v v' 75 | → G'⟦ τ :: Γ ⟧ (γ , v) (γ' , v') 76 | 77 | equiv' : (Γ : Ctx) → (τ : Tp) → Γ ⊢ τ → Γ ⊢ τ → Set 78 | equiv' Γ τ e e' = (γ γ' : [] ⊢c Γ) → G'⟦ Γ ⟧ γ γ' → E'⟦ τ ⟧ (subst γ e) (subst γ' e') 79 | 80 | -- Show that the non-inductive version implies the inductive version 81 | 82 | mutual 83 | pE : {τ : Tp} → {e e' : [] ⊢ τ} → E⟦ τ ⟧ e e' → E'⟦ τ ⟧ e e' 84 | pE (_ , _ , e↦v , e'↦v' , V) = E' e↦v e'↦v' (pV V) 85 | 86 | pV : {τ : Tp} → {e e' : [] ⊢ τ} → V⟦ τ ⟧ e e' → V'⟦ τ ⟧ e e' 87 | pV {bool} {#t} {#t} V = V/bool-#t 88 | pV {bool} {#t} {#f} () 89 | pV {bool} {#t} {if _ then _ else _} () 90 | pV {bool} {#t} {var _} () 91 | pV {bool} {#t} {app _ _} () 92 | pV {bool} {#f} {#t} () 93 | pV {bool} {#f} {#f} V = V/bool-#f 94 | pV {bool} {#f} {if _ then _ else _} () 95 | pV {bool} {#f} {var _} () 96 | pV {bool} {#f} {app _ _} () 97 | pV {bool} {if _ then _ else _} () 98 | pV {bool} {var _} () 99 | pV {bool} {app _ _} () 100 | pV {_ ⇒ _} {if _ then _ else _} () 101 | pV {_ ⇒ _} {var _} () 102 | pV {_ ⇒ _} {lam _} {if _ then _ else _} () 103 | pV {_ ⇒ _} {lam _} {var _} () 104 | pV {_ ⇒ _} {lam _} {lam _} f = V/⇒ (\ v v' V → pE (f v v' V)) 105 | pV {_ ⇒ _} {lam _} {app _ _} () 106 | pV {_ ⇒ _} {app _ _} () 107 | 108 | pG : {Γ : Ctx} → {γ γ' : [] ⊢c Γ} → G⟦ Γ ⟧ γ γ' → G'⟦ Γ ⟧ γ γ' 109 | pG {[]} _ = G/[] 110 | pG {τ :: Γ} (G , V) = G/:: (pG G) (pV V) 111 | 112 | -- Show the inverse 113 | 114 | mutual 115 | Vp : {τ : Tp} → {e e' : [] ⊢ τ} → V'⟦ τ ⟧ e e' → V⟦ τ ⟧ e e' 116 | Vp V/bool-#t = <> 117 | Vp V/bool-#f = <> 118 | Vp (V/⇒ f) = \ v v' V → Ep (f v v' V) 119 | 120 | Ep : {τ : Tp} → {e e' : [] ⊢ τ} → E'⟦ τ ⟧ e e' → E⟦ τ ⟧ e e' 121 | Ep (E' {v} {v'} e↦v e'↦v' V') = (v , v' , e↦v , e'↦v' , Vp V') 122 | 123 | Gp : {Γ : Ctx} → {γ γ' : [] ⊢c Γ} → G'⟦ Γ ⟧ γ γ' → G⟦ Γ ⟧ γ γ' 124 | Gp G/[] = <> 125 | Gp (G/:: G' V') = Gp G' , Vp V' 126 | 127 | -- Relies on both the forward and backwards direction 128 | 129 | pequiv : {Γ : Ctx} → {τ : Tp} → (e e' : Γ ⊢ τ) → equiv Γ τ e e' → equiv' Γ τ e e' 130 | pequiv _ _ eq = λ γ γ' G' → pE (eq γ γ' (Gp G')) 131 | 132 | equivp : {Γ : Ctx} → {τ : Tp} → (e e' : Γ ⊢ τ) → equiv' Γ τ e e' → equiv Γ τ e e' 133 | equivp _ _ eq = λ γ γ' G → Ep (eq γ γ' (pG G)) 134 | 135 | -- using the prime'd versions, we can prove some theorems easily 136 | 137 | V'-value : {τ : Tp} → {e e' : [] ⊢ τ} → V'⟦ τ ⟧ e e' → value e × value e' 138 | V'-value V/bool-#t = Value/true , Value/true 139 | V'-value V/bool-#f = Value/false , Value/false 140 | V'-value (V/⇒ _) = Value/lam , Value/lam 141 | 142 | V'-bool-equal : {e₁ e₂ : [] ⊢ bool} → V'⟦ bool ⟧ e₁ e₂ → e₁ == e₂ 143 | V'-bool-equal V/bool-#t = Refl 144 | V'-bool-equal V/bool-#f = Refl 145 | 146 | -- some parameters are delicately asked to be explicit, for fear of the 147 | -- underconstrained hole 148 | 149 | compat-if' : {Γ : Ctx} → {τ : Tp} → (e e' : Γ ⊢ bool) → (e₁ e₁' e₂ e₂' : Γ ⊢ τ) → equiv' Γ bool e e' → equiv' Γ τ e₁ e₁' → equiv' Γ τ e₂ e₂' → equiv' Γ τ (if e then e₁ else e₂) (if e' then e₁' else e₂') 150 | compat-if' _ _ _ _ _ _ e≈e' e₁≈e₁' e₂≈e₂' γ γ' G with e₁≈e₁' γ γ' G 151 | ... | E' e₁↦*v₁ e₁'↦*v₁' V₁ with e₂≈e₂' γ γ' G 152 | ... | E' e₂↦*v₂ e₂'↦*v₂' V₂ with e≈e' γ γ' G 153 | ... | E' e↦*v e'↦*v' V/bool-#t 154 | = E' (Append (lifts Step/if-cond e↦*v) (Step (Step/here Step/if-true) e₁↦*v₁)) 155 | (Append (lifts Step/if-cond e'↦*v') (Step (Step/here Step/if-true) e₁'↦*v₁')) V₁ 156 | ... | E' e↦*v e'↦*v' V/bool-#f 157 | = E' (Append (lifts Step/if-cond e↦*v) (Step (Step/here Step/if-false) e₂↦*v₂)) 158 | (Append (lifts Step/if-cond e'↦*v') (Step (Step/here Step/if-false) e₂'↦*v₂')) V₂ 159 | 160 | compat-app' : {Γ : Ctx} → {τ τ₁ : Tp} → (e e' : Γ ⊢ τ ⇒ τ₁) → (e₁ e₁' : Γ ⊢ τ) → equiv' Γ (τ ⇒ τ₁) e e' → equiv' Γ τ e₁ e₁' → equiv' Γ τ₁ (app e e₁) (app e' e₁') 161 | compat-app' _ _ _ _ e≈e' e₁≈e₁' γ γ' G with e≈e' γ γ' G 162 | ... | E' e↦*v e'↦*v' (V/⇒ f) with e₁≈e₁' γ γ' G 163 | ... | E' {v₁} {v₁'} e₁↦*v₁ e₁'↦*v₁' V' with f v₁ v₁' (Vp V') 164 | ... | E' v[v₁]↦*v₂ v'[v₁']↦*v₂' V'' 165 | = E' (Append (lifts Step/app1 e↦*v) 166 | (Append (lifts Step/app2 e₁↦*v₁) 167 | (Step (Step/here (Step/β (fst (V'-value V')))) v[v₁]↦*v₂))) 168 | (Append (lifts Step/app1 e'↦*v') 169 | (Append (lifts Step/app2 e₁'↦*v₁') 170 | (Step (Step/here (Step/β (snd (V'-value V')))) v'[v₁']↦*v₂'))) V'' 171 | 172 | compat-lam' : {Γ : Ctx} → {τ τ₁ : Tp} → (e e' : Γ ,, τ ⊢ τ₁) → equiv' (Γ ,, τ) τ₁ e e' → equiv' Γ (τ ⇒ τ₁) (lam e) (lam e') 173 | compat-lam' e e' e≈e' γ γ' G 174 | = E' Done Done (V/⇒ (λ v v' V → transport (λ p → E'⟦ _ ⟧ (fst p) (snd p)) 175 | (ap2 _,_ (subst-compose1 γ v e) (subst-compose1 γ' v' e')) 176 | (e≈e' (γ , v) (γ' , v') (G/:: G (pV V))))) 177 | 178 | -- these theorems can be projected back into the function versions 179 | 180 | V-value : {τ : Tp} → {e₁ e₂ : [] ⊢ τ} → V⟦ τ ⟧ e₁ e₂ → value e₁ × value e₂ 181 | V-value V = V'-value (pV V) 182 | 183 | V-bool-equal : {e₁ e₂ : [] ⊢ bool} → V⟦ bool ⟧ e₁ e₂ → e₁ == e₂ 184 | V-bool-equal V = V'-bool-equal (pV V) 185 | 186 | compat-if : {Γ : Ctx} → {τ : Tp} → (e e' : Γ ⊢ bool) → (e₁ e₁' e₂ e₂' : Γ ⊢ τ) → equiv Γ bool e e' → equiv Γ τ e₁ e₁' → equiv Γ τ e₂ e₂' → equiv Γ τ (if e then e₁ else e₂) (if e' then e₁' else e₂') 187 | compat-if e e' e₁ e₁' e₂ e₂' e≈e' e₁≈e₁' e₂≈e₂' = equivp (if e then e₁ else e₂) (if e' then e₁' else e₂') (compat-if' e e' e₁ e₁' e₂ e₂' (pequiv e e' e≈e') (pequiv e₁ e₁' e₁≈e₁') (pequiv e₂ e₂' e₂≈e₂')) 188 | 189 | compat-lam : {Γ : Ctx} → {τ τ₁ : Tp} → (e e' : Γ ,, τ ⊢ τ₁) → equiv (Γ ,, τ) τ₁ e e' → equiv Γ (τ ⇒ τ₁) (lam e) (lam e') 190 | compat-lam e e' e≈e' = equivp (lam e) (lam e') (compat-lam' e e' (pequiv e e' e≈e')) 191 | 192 | compat-app : {Γ : Ctx} → {τ τ₁ : Tp} → (e e' : Γ ⊢ τ ⇒ τ₁) → (e₁ e₁' : Γ ⊢ τ) → equiv Γ (τ ⇒ τ₁) e e' → equiv Γ τ e₁ e₁' → equiv Γ τ₁ (app e e₁) (app e' e₁') 193 | compat-app e e' e₁ e₁' e≈e' e₁≈e₁' = equivp (app e e₁) (app e' e₁') (compat-app' e e' e₁ e₁' (pequiv e e' e≈e') (pequiv e₁ e₁' e₁≈e₁')) 194 | 195 | -- some of the compatibility lemmas are simple enough to not benefit from the transformation 196 | 197 | compat-var : {Γ : Ctx} → {τ : Tp} → (x : τ ∈ Γ) → equiv Γ τ (var x) (var x) 198 | compat-var i0 (_ , v) (_ , v') (_ , V) = v , v' , Done , Done , V 199 | compat-var (iS x) (γ , _) (γ' , _) (G , _) = compat-var x γ γ' G 200 | 201 | fund : {Γ : Ctx} → {τ : Tp} → (e : Γ ⊢ τ) → equiv Γ τ e e 202 | fund #t = \ _ _ _ → #t , #t , Done , Done , <> -- these are sufficiently trivial... 203 | fund #f = \ _ _ _ → #f , #f , Done , Done , <> 204 | fund (if e then e₁ else e₂) = compat-if e e e₁ e₁ e₂ e₂ (fund e) (fund e₁) (fund e₂) 205 | fund (var x) = compat-var x 206 | fund (lam e) = compat-lam e e (fund e) 207 | fund (app e e₁) = compat-app e e e₁ e₁ (fund e) (fund e₁) 208 | 209 | -- Just ignore the right-hand-side... 210 | normalization : {τ : Tp} → (e : [] ⊢ τ) -> e ⇓ 211 | normalization e with fund e <> <> <> 212 | normalization e | v , _ , e↦*v , _ , V = v , fst (V-value V) , transport (λ e' → e' ↦* v) (! subst-id) e↦*v 213 | 214 | -- as in C 215 | -- apparently for technical reasons it is more convenient 216 | -- to build in weakening; perhaps we will see why later... 217 | data _⊢_↝_⊢_ : Ctx → Tp → Ctx → Tp → Set where 218 | -- Apparently, the weakening is only needed for the step-indexed version, 219 | -- and this is /exactly/ what makes this a Kripke logical relation 220 | -- (Check Andy Pitts chapter) 221 | -- (Other note: when you have an extra constructor which 222 | -- just says "well, whatever" then it really gets in the 223 | -- way of inductions) 224 | [·] : {Γ {- Γ' -} : Ctx} {τ : Tp} → {- Γ' ⊇ Γ → -} Γ ⊢ τ ↝ Γ ⊢ τ 225 | if[_]then_else_ : {Γ Γ' : Ctx} {τ τ' : Tp} 226 | → Γ ⊢ τ ↝ Γ' ⊢ bool 227 | → Γ' ⊢ τ' 228 | → Γ' ⊢ τ' 229 | → Γ ⊢ τ ↝ Γ' ⊢ τ' 230 | if_then[_]else_ : {Γ Γ' : Ctx} {τ τ' : Tp} 231 | → Γ' ⊢ bool 232 | → Γ ⊢ τ ↝ Γ' ⊢ τ' 233 | → Γ' ⊢ τ' 234 | → Γ ⊢ τ ↝ Γ' ⊢ τ' 235 | if_then_else[_] : {Γ Γ' : Ctx} {τ τ' : Tp} 236 | → Γ' ⊢ bool 237 | → Γ' ⊢ τ' 238 | → Γ ⊢ τ ↝ Γ' ⊢ τ' 239 | → Γ ⊢ τ ↝ Γ' ⊢ τ' 240 | lam[_] : {Γ Γ' : Ctx} {τ τ₁ τ₂ : Tp} 241 | → (Γ ,, τ₁) ⊢ τ ↝ (Γ' ,, τ₁) ⊢ τ₂ 242 | → (Γ ,, τ₁) ⊢ τ ↝ Γ' ⊢ (τ₁ ⇒ τ₂) 243 | app[_]_ : {Γ Γ' : Ctx} {τ τ₁ τ₂ : Tp} 244 | → Γ ⊢ τ ↝ Γ' ⊢ (τ₁ ⇒ τ₂) 245 | → Γ' ⊢ τ₁ 246 | → Γ ⊢ τ ↝ Γ' ⊢ τ₂ 247 | app_[_] : {Γ Γ' : Ctx} {τ τ₁ τ₂ : Tp} 248 | → Γ' ⊢ τ₁ ⇒ τ₂ 249 | → Γ ⊢ τ ↝ Γ' ⊢ τ₁ 250 | → Γ ⊢ τ ↝ Γ' ⊢ τ₂ 251 | 252 | fill : {Γ Γ' : Ctx} {τ τ' : Tp} → (Γ ⊢ τ ↝ Γ' ⊢ τ') → Γ ⊢ τ → Γ' ⊢ τ' 253 | -- fill ([·] x) e = rename x e 254 | fill [·] e = e 255 | fill (if[ C ]then x else x₁ ) e = if fill C e then x else x₁ 256 | fill (if x then[ C ]else x₁ ) e = if x then fill C e else x₁ 257 | fill (if x then x₁ else[ C ]) e = if x then x₁ else fill C e 258 | fill lam[ C ] e = lam (fill C e) 259 | fill (app[ C ] x ) e = app (fill C e) x 260 | fill (app x [ C ]) e = app x (fill C e) 261 | 262 | module ContextExamples where 263 | C1 : ([] ,, bool) ⊢ (bool ⇒ bool) ↝ [] ⊢ bool 264 | C1 = app[ app[ lam[ [·] ] ] #t ] #t 265 | 266 | e1 : ([] ,, bool) ⊢ (bool ⇒ bool) 267 | e1 = lam (if var i0 then var (iS i0) else var i0) 268 | 269 | Ce1 : [] ⊢ bool 270 | Ce1 = fill C1 e1 271 | 272 | eq1 : Ce1 == app (app (lam (lam (if var i0 then var (iS i0) else var i0))) #t) #t 273 | eq1 = Refl 274 | 275 | -- compatibility lemma for CONTEXTS! 276 | 277 | equiv-contexts : (Γ Γ' : Ctx) → (τ τ' : Tp) → (C C' : Γ ⊢ τ ↝ Γ' ⊢ τ') → Set 278 | equiv-contexts Γ Γ' τ τ' C C' = (e e' : Γ ⊢ τ) → equiv Γ τ e e' → equiv Γ' τ' (fill C e) (fill C e') 279 | 280 | compat-contexts : {Γ Γ' : Ctx} → {τ τ' : Tp} → (C : Γ ⊢ τ ↝ Γ' ⊢ τ') → equiv-contexts Γ Γ' τ τ' C C 281 | compat-contexts [·] e e' e≈e' = e≈e' 282 | compat-contexts (if[ C ]then x else x₁) e e' e≈e' 283 | = compat-if (fill C e) (fill C e') x x x₁ x₁ (compat-contexts C e e' e≈e') (fund x) (fund x₁) 284 | compat-contexts (if x then[ C ]else x₁) e e' e≈e' 285 | = compat-if x x (fill C e) (fill C e') x₁ x₁ (fund x) (compat-contexts C e e' e≈e') (fund x₁) 286 | compat-contexts if x then x₁ else[ C ] e e' e≈e' 287 | = compat-if x x x₁ x₁ (fill C e) (fill C e') (fund x) (fund x₁) (compat-contexts C e e' e≈e') 288 | compat-contexts lam[ C ] e e' e≈e' = compat-lam (fill C e) (fill C e') (compat-contexts C e e' e≈e') 289 | compat-contexts (app[ C ] x) e e' e≈e' 290 | = compat-app (fill C e) (fill C e') x x (compat-contexts C e e' e≈e') (fund x) 291 | compat-contexts app x [ C ] e e' e≈e' 292 | = compat-app x x (fill C e) (fill C e') (fund x) (compat-contexts C e e' e≈e') 293 | 294 | -- unidirectional version; other direction follows wlog, and combined 295 | -- form follows easily from determinacy 296 | 297 | -- If you're cross-referencing with the ESOP paper, note that because 298 | -- we don't have nontermination, we can't simply say "if e₁ terminates, then 299 | -- e₂ must too"; we have to say something stronger. Fortunately, we can 300 | -- specialize on bools. Determinacy helps here. 301 | 302 | ctx-equiv : (Γ : Ctx) → (τ : Tp) → Γ ⊢ τ → Γ ⊢ τ → Set 303 | ctx-equiv Γ τ e₁ e₂ = (C : Γ ⊢ τ ↝ [] ⊢ bool) → (v : [] ⊢ bool) → fill C e₁ ⇓ v → fill C e₂ ⇓ v --) × (fill C e₂ ⇓ v → fill C e₁ ⇓ v) 304 | 305 | soundness : {Γ : Ctx} {τ : Tp} (e e' : Γ ⊢ τ) → equiv Γ τ e e' → ctx-equiv Γ τ e e' 306 | soundness e e' pf C v C[e]⇓v with compat-contexts C e e' pf <> <> <> 307 | ... | v₀ , v' , sC[e]⇓v₀ , sC[e']⇓v' , V = fst C[e]⇓v , transport (λ □ → fill C e' ↦* □) (! (v₀=v' ∘ v=v₀)) 308 | (transport (λ □ → □ ↦* v') (! subst-id) sC[e']⇓v') 309 | where v=v₀ : v == v₀ 310 | v=v₀ = determinacy C[e]⇓v (fst (V-value V) , transport (λ □ → □ ↦* v₀) (! subst-id) sC[e]⇓v₀) 311 | v₀=v' : v₀ == v' 312 | v₀=v' = V-bool-equal V 313 | -------------------------------------------------------------------------------- /STLC-CBV-Ex.agda: -------------------------------------------------------------------------------- 1 | open import Preliminaries 2 | open import STLC 3 | open import STLC-CBV 4 | open import STLC-CBV-Equivalence 5 | 6 | module STLC-CBV-Ex where 7 | 8 | module Ex1 where 9 | 10 | prog1 : {Γ : Ctx} → Γ ⊢ bool ⇒ bool 11 | prog1 = lam (var i0) 12 | 13 | prog2 : {Γ : Ctx} → Γ ⊢ bool ⇒ bool 14 | prog2 = lam (if var i0 then var i0 else #f) 15 | 16 | sub : {v v' : [] ⊢ bool} → V'⟦ bool ⟧ v v' → E'⟦ bool ⟧ v (if v' then v' else #f) 17 | sub V/bool-#t = E' Done (Step (Step/here Step/if-true) Done) V/bool-#t 18 | sub V/bool-#f = E' Done (Step (Step/here Step/if-false) Done) V/bool-#f 19 | 20 | eq : {Γ : Ctx} → ctx-equiv Γ (bool ⇒ bool) prog1 prog2 21 | eq = soundness _ _ (equivp prog1 prog2 (λ _ _ _ → E' Done Done (V/⇒ (λ _ _ V → sub (pV V))))) 22 | 23 | module Ex2 where 24 | 25 | prog1 : {Γ : Ctx} → Γ ⊢ (bool ⇒ bool) ⇒ (bool ⇒ bool) 26 | prog1 = lam (var i0) 27 | 28 | prog2 : {Γ : Ctx} → Γ ⊢ (bool ⇒ bool) ⇒ (bool ⇒ bool) 29 | prog2 = lam (lam (app (var (iS i0)) (app (var (iS i0)) (app (var (iS i0)) (var i0))))) 30 | 31 | data Code (f : [] ⊢ bool ⇒ bool) : Set where 32 | c-id : E'⟦ bool ⇒ bool ⟧ f (lam (var i0)) → Code f 33 | c-not : E'⟦ bool ⇒ bool ⟧ f (lam (if (var i0) then #f else #t)) → Code f 34 | c-true : E'⟦ bool ⇒ bool ⟧ f (lam #t) → Code f 35 | c-false : E'⟦ bool ⇒ bool ⟧ f (lam #f) → Code f 36 | 37 | lem : (f : [] ⊢ bool ⇒ bool) → E⟦ bool ⇒ bool ⟧ f f 38 | lem f = transport (\ f → E⟦ bool ⇒ bool ⟧ f f) (! subst-id) (fund f <> <> <>) 39 | 40 | sub-true : {v v' : [] ⊢ bool} → {e' : bool :: [] ⊢ bool} 41 | → (subst1 #t e' ↦* #t) 42 | → (subst1 #f e' ↦* #t) 43 | → V'⟦ bool ⟧ v v' → E'⟦ bool ⟧ (subst1 v e') (subst1 v' #t) 44 | sub-true a b V/bool-#t = E' a Done V/bool-#t 45 | sub-true a b V/bool-#f = E' b Done V/bool-#t 46 | 47 | sub : {f : [] ⊢ bool ⇒ bool} → E'⟦ bool ⇒ bool ⟧ f f → Code f 48 | sub (E' {lam e} {lam e'} e↦*v e'↦*v' (V/⇒ V)) with (V #t #t <> , V #f #f <>) 49 | ... | E' e↦*v₁ e'↦*v'₁ V/bool-#t , E' e↦*v₂ e'↦*v'₂ V/bool-#t = c-true (E' e'↦*v' Done (V/⇒ (λ v v' x → sub-true {v} {v'} {e'} e'↦*v'₁ e'↦*v'₂ (pV x)))) 50 | ... | E' e↦*v₁ e'↦*v'₁ V/bool-#t , E' e↦*v₂ e'↦*v'₂ V/bool-#f = c-id {!!} 51 | ... | E' e↦*v₁ e'↦*v'₁ V/bool-#f , E' e↦*v₂ e'↦*v'₂ V/bool-#t = c-not {!!} 52 | ... | E' e↦*v₁ e'↦*v'₁ V/bool-#f , E' e↦*v₂ e'↦*v'₂ V/bool-#f = c-false {!!} 53 | 54 | eq : {Γ : Ctx} → ctx-equiv Γ ((bool ⇒ bool) ⇒ (bool ⇒ bool)) prog1 prog2 55 | eq = soundness _ _ (equivp prog1 prog2 (λ γ γ' x → E' Done Done (V/⇒ (λ v v' x₁ → E' Done Done {!!})))) 56 | -------------------------------------------------------------------------------- /STLC-CBV-Normalization.agda: -------------------------------------------------------------------------------- 1 | open import Preliminaries 2 | open import STLC 3 | open import STLC-CBV 4 | 5 | module STLC-CBV-Normalization where 6 | 7 | mutual 8 | WN' : (τ : Tp) → [] ⊢ τ → Set 9 | WN' bool e = Unit 10 | WN' (τ1 ⇒ τ2) e = (e1 : [] ⊢ τ1) → WN τ1 e1 → WN τ2 (app e e1) 11 | 12 | WN : (τ : Tp) → [] ⊢ τ → Set 13 | WN τ e = e ⇓ × WN' τ e 14 | 15 | WNc : (Γ : Ctx) → [] ⊢c Γ → Set 16 | WNc [] γ = Unit 17 | WNc (τ :: Γ) (γ , e) = WNc Γ γ × WN τ e 18 | 19 | open RenamingAndSubstitution using (addvar) 20 | 21 | mutual 22 | bwd-red : {τ : Tp} {e e' : [] ⊢ τ} → (e ↦ e') → WN τ e' → WN τ e 23 | bwd-red e↦e' ((v , vv , e'↦*v) , WN'τ[e']) = 24 | (v , vv , Step e↦e' e'↦*v) , bwd-red' e↦e' WN'τ[e'] 25 | 26 | bwd-red' : {τ : Tp} {e e' : [] ⊢ τ} → (e ↦ e') → WN' τ e' → WN' τ e 27 | bwd-red' {bool} _ _ = <> 28 | bwd-red' {τ₁ ⇒ τ₂} e↦e' WN'τ[e'] = λ e₁ WNτ₁[e₁] → 29 | bwd-red (Step/app1 e↦e') (WN'τ[e'] e₁ WNτ₁[e₁]) 30 | 31 | bwd-red* : {τ : Tp} {e e'' : [] ⊢ τ} → (e ↦* e'') → WN τ e'' → WN τ e 32 | bwd-red* Done wn = wn 33 | bwd-red* (Step x p) wn = bwd-red x (bwd-red* p wn) 34 | 35 | -- Forward reduction requires determinacy 36 | 37 | BackStep : {τ : Tp} {e e' v : [] ⊢ τ} → (e ↦ e') → value v → (e ↦* v) → (e' ↦* v) 38 | BackStep (Step/here ()) Value/true Done 39 | BackStep (Step/here ()) Value/false Done 40 | BackStep (Step/here ()) Value/lam Done 41 | BackStep (Step/app1 p) () Done 42 | BackStep (Step/app2 p) () Done 43 | BackStep (Step/if-cond p) () Done 44 | BackStep p _ (Step p' _) with det-↦ p p' 45 | BackStep _ _ (Step _ ps) | Refl = ps 46 | 47 | mutual 48 | fwd-red : {τ : Tp} {e e' : [] ⊢ τ} → (e ↦ e') → WN τ e → WN τ e' 49 | fwd-red e↦e' ((v , vv , e↦*v) , WN'τ[e]) = 50 | (v , vv , BackStep e↦e' vv e↦*v) , fwd-red' e↦e' WN'τ[e] 51 | 52 | fwd-red' : {τ : Tp} {e e' : [] ⊢ τ} → (e ↦ e') → WN' τ e → WN' τ e' 53 | fwd-red' {bool} _ _ = <> 54 | fwd-red' {τ₁ ⇒ τ₂} e↦e' WN'τ[e] = λ e₁ WNτ₁[e₁] → 55 | fwd-red (Step/app1 e↦e') (WN'τ[e] e₁ WNτ₁[e₁]) 56 | 57 | fwd-red* : {τ : Tp} {e e'' : [] ⊢ τ} → (e ↦* e'') → WN τ e → WN τ e'' 58 | fwd-red* Done WNτ[e] = WNτ[e] 59 | fwd-red* (Step e↦e' e'↦*e'') WNτ[e] = fwd-red* e'↦*e'' (fwd-red e↦e' WNτ[e]) 60 | 61 | fund : {Γ : Ctx} {τ : Tp} {γ : [] ⊢c Γ} 62 | → (e : Γ ⊢ τ) 63 | → WNc Γ γ 64 | → WN τ (subst γ e) 65 | fund #t γ⊨Γ = (#t , Value/true , Done) , <> 66 | fund #f γ⊨Γ = (#f , Value/false , Done) , <> 67 | fund (if e₁ then e₂ else e₃) γ⊨Γ with fund e₁ γ⊨Γ 68 | fund (if e₁ then e₂ else e₃) γ⊨Γ | (.#t , Value/true , e₁↦*v) , <> = 69 | bwd-red* (lifts Step/if-cond e₁↦*v) (bwd-red (Step/here Step/if-true) (fund e₂ γ⊨Γ)) 70 | fund (if e₁ then e₂ else e₃) γ⊨Γ | (.#f , Value/false , e₁↦*v) , <> = 71 | bwd-red* (lifts Step/if-cond e₁↦*v) (bwd-red (Step/here Step/if-false) (fund e₃ γ⊨Γ)) 72 | fund (var i0) γ⊨Γ = snd γ⊨Γ 73 | fund (var (iS x)) γ⊨Γ = fund (var x) (fst γ⊨Γ) 74 | fund {τ = τ₁ ⇒ τ₂} {γ = γ} (lam e) γ⊨Γ = (lam (subst (addvar γ) e) , Value/lam , Done) , (λ e₁ WNτ₁[e₁] → 75 | -- Proof idea: (lam e) e₁ ↦* (lam e) v₁ ↦ e[v₁/x] 76 | -- Go forwards and then backwards 77 | let (v₁ , e₁⇓v₁) , WN'τ₁[e₁] = WNτ₁[e₁] 78 | WNτ₁[v₁] = fwd-red* (snd e₁⇓v₁) WNτ₁[e₁] 79 | IH = fund e (γ⊨Γ , WNτ₁[v₁]) 80 | WNτ₂[γ[e[v₁/x]]] = transport (WN τ₂) (subst-compose1 γ v₁ e) IH 81 | in bwd-red* (lifts Step/app2 (snd e₁⇓v₁)) 82 | (bwd-red (Step/here (Step/β (fst e₁⇓v₁))) WNτ₂[γ[e[v₁/x]]])) 83 | fund {γ = γ} (app e₁ e₂) γ⊨Γ = snd IH₁ (subst γ e₂) IH₂ 84 | where 85 | IH₁ = fund e₁ γ⊨Γ 86 | IH₂ = fund e₂ γ⊨Γ 87 | 88 | corollary : {τ : Tp} → (e : [] ⊢ τ) → e ⇓ 89 | corollary e = transport (λ e' → e' ⇓) (! subst-id) (fst (fund e <>)) 90 | -------------------------------------------------------------------------------- /STLC-CBV.agda: -------------------------------------------------------------------------------- 1 | open import Preliminaries 2 | open import STLC 3 | 4 | -- Notation conventions: subscript numbers used for *positional* differences 5 | -- (they are not expected to have the same types) whereas ticks are used to 6 | -- indicate 'morally equivalent' terms, which are expected to be related in some 7 | -- way (e.g. 'reduces to' or 'equivalent to'). We're a little inconsistent about 8 | -- whether we number e e₁ e₂ or τ₁ τ₂; this is mostly because I like being 9 | -- consistent when there are multiples but Agda will always start with e and then 10 | -- tack on subscripts later. Sometimes we'll omit the tick when it's unambiguous. 11 | 12 | module STLC-CBV where 13 | 14 | -- local-step relation (computation rules: non-recursive) 15 | data _↦c_ : {τ : Tp} → [] ⊢ τ → [] ⊢ τ → Set where 16 | Step/β : {τ₁ τ₂ : Tp} {e : [] ,, τ₁ ⊢ τ₂} {v₁ : [] ⊢ τ₁} 17 | → value v₁ 18 | → (app (lam e) v₁) ↦c subst1 v₁ e -- vacuously lam e is also a value 19 | Step/if-true : {τ : Tp} {e₁ e₂ : [] ⊢ τ} 20 | → if #t then e₁ else e₂ ↦c e₁ 21 | Step/if-false : {τ : Tp} {e₁ e₂ : [] ⊢ τ} 22 | → if #f then e₁ else e₂ ↦c e₂ 23 | 24 | -- step relation in context (evaluation contexts) 25 | -- these are pretty verbose but I don't know how write them out evaluation 26 | -- context style 27 | data _↦_ : {τ : Tp} → [] ⊢ τ → [] ⊢ τ → Set where 28 | Step/here : {τ : Tp} {e e' : [] ⊢ τ} → e ↦c e' → e ↦ e' 29 | Step/app1 : {τ₁ τ₂ : Tp} {e e' : [] ⊢ τ₁ ⇒ τ₂} {e₁ : [] ⊢ τ₁} 30 | → e ↦ e' 31 | → (app e e₁) ↦ (app e' e₁) 32 | Step/app2 : {τ₁ τ₂ : Tp} {e : [] ,, τ₁ ⊢ τ₂} {e₁ e₁' : [] ⊢ τ₁} 33 | → e₁ ↦ e₁' 34 | → (app (lam e) e₁) ↦ (app (lam e) e₁') 35 | Step/if-cond : {τ : Tp} {e e' : [] ⊢ bool} {e₁ e₂ : [] ⊢ τ} 36 | → e ↦ e' 37 | → if e then e₁ else e₂ ↦ if e' then e₁ else e₂ 38 | 39 | -- reflexive/transitive closure 40 | data _↦*_ : {τ : Tp} → [] ⊢ τ → [] ⊢ τ → Set where 41 | Done : {τ : Tp} {e : [] ⊢ τ} → e ↦* e 42 | Step : {τ : Tp} {e e' e'' : [] ⊢ τ} 43 | → e ↦ e' → e' ↦* e'' 44 | → e ↦* e'' 45 | 46 | Append : {τ : Tp} {e e' e'' : [] ⊢ τ} 47 | → e ↦* e' → e' ↦* e'' 48 | → e ↦* e'' 49 | Append Done g = g 50 | Append (Step x f) g = Step x (Append f g) 51 | 52 | _⇓_ : {τ : Tp} → [] ⊢ τ → [] ⊢ τ → Set 53 | e ⇓ v = value v × e ↦* v 54 | 55 | _⇓ : {τ : Tp} → [] ⊢ τ → Set 56 | e ⇓ = Σ (λ v → e ⇓ v) 57 | 58 | lifts : {τ τ' : Tp} {E : [] ⊢ τ → [] ⊢ τ'} → ({e e' : [] ⊢ τ} → e ↦ e' → E e ↦ E e') → {e e' : [] ⊢ τ} 59 | → (e ↦* e') → (E e ↦* E e') 60 | lifts Step/rule Done = Done 61 | lifts Step/rule (Step e↦e' e'↦*e'') = Step (Step/rule e↦e') (lifts Step/rule e'↦*e'') 62 | 63 | det-↦cc : {τ : Tp} {e e₁ e₂ : [] ⊢ τ} → e ↦c e₁ → e ↦c e₂ → e₁ == e₂ 64 | det-↦cc (Step/β x) (Step/β y) = Refl 65 | det-↦cc Step/if-true Step/if-true = Refl 66 | det-↦cc Step/if-false Step/if-false = Refl 67 | 68 | det-↦c : {τ : Tp} {e e₁ e₂ : [] ⊢ τ} → e ↦ e₁ → e ↦c e₂ → e₁ == e₂ 69 | det-↦c (Step/here x) s2 = det-↦cc x s2 70 | det-↦c (Step/app1 (Step/here ())) (Step/β x₁) 71 | det-↦c (Step/app2 (Step/here ())) (Step/β Value/true) 72 | det-↦c (Step/app2 (Step/here ())) (Step/β Value/false) 73 | det-↦c (Step/app2 (Step/here ())) (Step/β Value/lam) 74 | det-↦c (Step/if-cond (Step/here ())) Step/if-true 75 | det-↦c (Step/if-cond (Step/here ())) Step/if-false 76 | 77 | det-↦ : {τ : Tp} {e e₁ e₂ : [] ⊢ τ} → e ↦ e₁ → e ↦ e₂ → e₁ == e₂ 78 | det-↦ (Step/here x) s2 = ! (det-↦c s2 x) 79 | det-↦ s1 (Step/here x) = det-↦c s1 x 80 | det-↦ (Step/app1 s1) (Step/app1 s2) = ap (λ y → app y _) (det-↦ s1 s2) 81 | det-↦ (Step/app1 (Step/here ())) (Step/app2 s2) 82 | det-↦ (Step/app2 s1) (Step/app1 (Step/here ())) 83 | det-↦ (Step/app2 s1) (Step/app2 s2) = ap (λ y → app _ y) (det-↦ s1 s2) 84 | det-↦ (Step/if-cond s1) (Step/if-cond s2) = ap (λ y → if y then _ else _) (det-↦ s1 s2) 85 | 86 | determinacy : {e v₁ v₂ : [] ⊢ bool} → e ⇓ v₁ → e ⇓ v₂ → v₁ == v₂ 87 | determinacy (_ , Done) (_ , Done) = Refl 88 | determinacy (Value/true , Done) (_ , Step (Step/here ()) _) 89 | determinacy (Value/false , Done) (_ , Step (Step/here ()) _) 90 | determinacy (_ , Step (Step/here ()) _) (Value/true , Done) 91 | determinacy (_ , Step (Step/here ()) _) (Value/false , Done) 92 | determinacy (_ , Step (Step/app1 _) _) (() , Done) 93 | determinacy (_ , Step (Step/app2 _) _) (() , Done) 94 | determinacy (_ , Step (Step/if-cond _) _) (() , Done) 95 | determinacy (fst , Step x snd) (fst₁ , Step x₁ snd₁) = determinacy (fst , snd) (transport (λ □ → □ ⇓ _) (! (det-↦ x x₁)) (fst₁ , snd₁)) 96 | -------------------------------------------------------------------------------- /STLC.agda: -------------------------------------------------------------------------------- 1 | open import Preliminaries 2 | 3 | {- 4 | The simply typed lambda calculus in Agda. 5 | 6 | This particular implementation was developed by Dan Licata for 7 | OPLSS 2013. The method for "correct-by-construction" lambda terms 8 | is standard, and the method for proving the lemmas about substitutions 9 | is described in "Strongly Typed Term Representations in Coq". 10 | -} 11 | module STLC where 12 | 13 | {- types of the STLC -} 14 | data Tp : Set where 15 | bool : Tp -- booleans (for non-trivial equivalence proofs) 16 | _⇒_ : Tp → Tp → Tp -- type \=> in agda-mode to get the ⇒ character 17 | 18 | {- contexts are lists of Tp's -} 19 | Ctx = List Tp 20 | _,,_ : Ctx → Tp → Ctx 21 | Γ ,, τ = τ :: Γ 22 | 23 | infixr 10 _⇒_ 24 | infixr 9 _,,_ 25 | infixr 8 _⊢_ -- type \entails or \|- 26 | 27 | {- de Bruijn indices are represented as proofs that 28 | an element is in a list -} 29 | data _∈_ {A : Set} : (x : A) (l : List A) → Set where -- type \in 30 | i0 : {x : A} {xs : List A} → x ∈ x :: xs 31 | iS : {x y : A} {xs : List A} → x ∈ xs → x ∈ y :: xs 32 | 33 | {- Γ ⊢ τ represents a term of type τ in context Γ -} 34 | data _⊢_ (Γ : Ctx) : Tp → Set where 35 | #t : Γ ⊢ bool 36 | #f : Γ ⊢ bool 37 | if_then_else_ : {τ : Tp} → Γ ⊢ bool → Γ ⊢ τ → Γ ⊢ τ → Γ ⊢ τ 38 | var : {τ : Tp} 39 | → τ ∈ Γ 40 | → Γ ⊢ τ 41 | lam : {τ1 τ2 : Tp} 42 | → Γ ,, τ1 ⊢ τ2 43 | → Γ ⊢ τ1 ⇒ τ2 44 | app : {τ1 τ2 : Tp} 45 | → Γ ⊢ τ1 ⇒ τ2 46 | → Γ ⊢ τ1 47 | → Γ ⊢ τ2 48 | 49 | {- values are true, false and lambda terms -} 50 | data value : {τ : Tp} → [] ⊢ τ → Set where 51 | Value/true : value #t 52 | Value/false : value #f 53 | Value/lam : {τ₁ τ₂ : Tp} {e : [] ,, τ₁ ⊢ τ₂} → value (lam e) 54 | 55 | module Examples where 56 | i : [] ⊢ bool ⇒ bool 57 | i = lam (var i0) -- \ x -> x 58 | 59 | k : [] ⊢ bool ⇒ bool ⇒ bool 60 | k = lam (lam (var (iS i0))) -- \ x -> \ y -> x 61 | 62 | k' : [] ⊢ bool ⇒ bool ⇒ bool 63 | k' = lam (lam (var i0)) 64 | 65 | 66 | {- The following proof is like a "0-ary" logical relation. 67 | It gives a semantics of the STLC in Agda. 68 | This shows that the STLC is sound, relative to Agda. 69 | -} 70 | module Semantics where 71 | 72 | -- function mapping STLC types to Agda types 73 | ⟦_⟧t : Tp → Set -- type \(0 and \)0 74 | ⟦ bool ⟧t = Bool 75 | ⟦ τ1 ⇒ τ2 ⟧t = ⟦ τ1 ⟧t → ⟦ τ2 ⟧t 76 | 77 | -- function mapping STLC contexts to Agda types 78 | ⟦_⟧c : Ctx → Set 79 | ⟦ [] ⟧c = Unit 80 | ⟦ τ :: Γ ⟧c = ⟦ Γ ⟧c × ⟦ τ ⟧t 81 | 82 | ⟦_⟧ : {Γ : Ctx} {τ : Tp} → Γ ⊢ τ → ⟦ Γ ⟧c → ⟦ τ ⟧t 83 | ⟦_⟧ #t γ = True 84 | ⟦_⟧ #f γ = False 85 | ⟦_⟧ (if e₁ then e₂ else e₃) γ with ⟦ e₁ ⟧ γ 86 | ⟦_⟧ (if e₁ then e₂ else e₃) γ | True = ⟦ e₂ ⟧ γ 87 | ⟦_⟧ (if e₁ then e₂ else e₃) γ | False = ⟦ e₃ ⟧ γ 88 | ⟦_⟧ (var i0) γ = snd γ 89 | ⟦_⟧ (var (iS x)) γ = ⟦ var x ⟧ (fst γ) 90 | ⟦_⟧ (lam e) γ = λ x → ⟦ e ⟧ (γ , x) 91 | ⟦_⟧ (app e e₁) γ = ⟦ e ⟧ γ (⟦ e₁ ⟧ γ) 92 | 93 | {- the following test should pass -} 94 | test : ⟦ Examples.k ⟧ == \ γ x y → x 95 | test = Refl 96 | 97 | module RenamingAndSubstitution where 98 | -- renamings = variable for variable substitutions. 99 | -- For simplicity, these are defined as tuples, by recursion on the context. 100 | -- It might clean up some of the proofs to use a functional view, 101 | -- {τ : Tp} → τ ∈ Γ → τ ∈ Γ' 102 | -- because then we could avoid some of the inductions here, 103 | -- and some of the associativity/unit properties would be free. 104 | module Renamings where 105 | 106 | infix 9 _⊇_ 107 | 108 | _⊇_ : Ctx → Ctx → Set -- type \sup= 109 | Γ' ⊇ [] = Unit 110 | Γ' ⊇ (τ :: Γ) = (Γ' ⊇ Γ) × (τ ∈ Γ') 111 | 112 | -- variables are functorial in the context 113 | rename-var : {Γ Γ' : Ctx} {τ : Tp} → Γ' ⊇ Γ → τ ∈ Γ → τ ∈ Γ' 114 | rename-var (ρ , x') i0 = x' 115 | rename-var (ρ , _) (iS x) = rename-var ρ x 116 | 117 | {- conceptually, we could define p and ⊇-compose and ⊇-id as primitive 118 | and derive this. 119 | but this works better inductively than ⊇-single does. 120 | -} 121 | p· : {Γ : Ctx} {Γ' : Ctx} → Γ ⊇ Γ' → {τ : Tp} → (Γ ,, τ) ⊇ Γ' 122 | p· {Γ' = []} ren = <> 123 | p· {Γ' = (τ :: Γ')} (ρ , x) = p· ρ , iS x 124 | 125 | idr : {Γ : Ctx} → Γ ⊇ Γ 126 | idr {[]} = <> 127 | idr {τ :: Γ} = p· idr , i0 128 | 129 | _·rr_ : {Γ1 Γ2 Γ3 : Ctx} → Γ1 ⊇ Γ2 → Γ2 ⊇ Γ3 → Γ1 ⊇ Γ3 130 | _·rr_ {Γ1} {Γ2} {[]} ρ2 ρ3 = <> 131 | _·rr_ {Γ1} {Γ2} {x :: Γ3} ρ2 (ρ3 , x3) = (ρ2 ·rr ρ3) , rename-var ρ2 x3 132 | 133 | -- category with families notation 134 | p : {Γ : Ctx} {τ : Tp} → (Γ ,, τ ⊇ Γ) 135 | p = p· idr 136 | 137 | -- next, we should show associativity and unit laws for ∘rr. 138 | -- However: 139 | -- (1) because renamings are defined using variables, this depends on (some of) functoriality of τ ∈ -, 140 | -- so we define that here, too. 141 | -- (2) we only need one of the unit laws 142 | 143 | rename-var-· : {Γ1 Γ2 Γ3 : Ctx} → (ρ2 : Γ1 ⊇ Γ2) (ρ3 : Γ2 ⊇ Γ3) {τ : Tp} (x : τ ∈ Γ3) 144 | → rename-var ρ2 (rename-var ρ3 x) == rename-var (_·rr_ ρ2 ρ3) x 145 | rename-var-· ρ2 ρ3 i0 = Refl 146 | rename-var-· ρ2 ρ3 (iS x) = rename-var-· ρ2 (fst ρ3) x 147 | 148 | ·rr-assoc : {Γ1 Γ2 Γ3 Γ4 : Ctx} → (ρ2 : Γ1 ⊇ Γ2) (ρ3 : Γ2 ⊇ Γ3) (ρ4 : Γ3 ⊇ Γ4) → _·rr_ ρ2 (_·rr_ ρ3 ρ4) == _·rr_ (_·rr_ ρ2 ρ3) ρ4 149 | ·rr-assoc {Γ4 = []} ρ2 ρ3 ρ4 = Refl 150 | ·rr-assoc {Γ4 = τ4 :: Γ4} ρ2 ρ3 (ρ4 , x4) = ap2 _,_ (·rr-assoc ρ2 ρ3 ρ4) (rename-var-· ρ2 ρ3 x4) 151 | 152 | -- rest of functoriality of rename-var 153 | mutual 154 | -- generalization to get the induction to go through 155 | rename-var-p' : {Γ Γ' : Ctx} {τ τ' : Tp} (ρ : Γ' ⊇ Γ) (x : τ ∈ Γ) → rename-var (p· ρ {τ'}) x == (iS (rename-var ρ x)) 156 | rename-var-p' ρ i0 = Refl 157 | rename-var-p' (ρ , _) (iS x) = rename-var-p' ρ x 158 | 159 | -- this would be definitional if renamings were functions. 160 | -- this instances is often needed below 161 | rename-var-p : {Γ : Ctx} {τ τ' : Tp} (x : τ ∈ Γ) → rename-var (p· idr {τ'}) x == (iS x) 162 | rename-var-p x = ap iS (rename-var-ident _ x) ∘ rename-var-p' idr x 163 | 164 | rename-var-ident : {τ : Tp} (Γ : Ctx) (x : τ ∈ Γ) → rename-var idr x == x 165 | rename-var-ident .(τ :: Γ) (i0 {τ} {Γ}) = Refl 166 | rename-var-ident .(τ' :: Γ) (iS {τ} {τ'} {Γ} x) = rename-var-p x 167 | 168 | -- beta reduction for p 169 | pβ1' : {Γ1 Γ2 Γ3 : Ctx} → (ρ2 : Γ1 ⊇ Γ2) (ρ3 : Γ2 ⊇ Γ3) {τ : Tp} (x : τ ∈ Γ1) 170 | → (ρ2 , x) ·rr (p· ρ3) == (ρ2 ·rr ρ3) 171 | pβ1' {Γ1} {_} {[]} ρ2 ρ3 x = Refl 172 | pβ1' {Γ1} {_} {τ3 :: Γ3} ρ2 (ρ3 , x3) x₁ = ap (λ x → x , rename-var ρ2 x3) (pβ1' ρ2 ρ3 _) 173 | 174 | mutual 175 | ·rr-unitr : {Γ1 Γ2 : Ctx} → (ρ2 : Γ1 ⊇ Γ2) 176 | → ρ2 ·rr idr == ρ2 177 | ·rr-unitr {Γ1} {[]} ρ2 = Refl 178 | ·rr-unitr {Γ1} {τ2 :: Γ2} (ρ2 , x2) = ap (λ x → x , x2) (pβ1 ρ2 x2) 179 | 180 | pβ1 : {Γ1 Γ2 : Ctx} → (ρ2 : Γ1 ⊇ Γ2) {τ : Tp} (x : τ ∈ Γ1) 181 | → (ρ2 , x) ·rr p == ρ2 182 | pβ1 ρ2 x = ·rr-unitr ρ2 ∘ pβ1' ρ2 idr x 183 | 184 | -- p· is equivalent to the alternate definition. 185 | p·-def : {Γ1 Γ2 : Ctx} {τ : Tp} (ρ : Γ1 ⊇ Γ2) → p· ρ {τ} == p ·rr ρ 186 | p·-def {_}{[]} ρ = Refl 187 | p·-def {_}{τ1 :: Γ1} (ρ , x) = ap2 _,_ (p·-def ρ) (! (rename-var-p x)) 188 | 189 | 190 | -- terms are functorial in renamings 191 | 192 | addvar-ren : {Γ Γ' : Ctx} {τ : Tp} → Γ' ⊇ Γ → Γ' ,, τ ⊇ Γ ,, τ 193 | addvar-ren ρ = (p· ρ , i0) 194 | 195 | rename : {Γ Γ' : Ctx} {τ : Tp} → Γ' ⊇ Γ → Γ ⊢ τ → Γ' ⊢ τ 196 | rename ρ #t = #t 197 | rename ρ #f = #f 198 | rename ρ (if e₁ then e₂ else e₃) = if rename ρ e₁ then rename ρ e₂ else rename ρ e₃ 199 | rename ρ (var x) = var (rename-var ρ x) 200 | rename ρ (lam e) = lam (rename (addvar-ren ρ) e) 201 | rename ρ (app e e') = app (rename ρ e) (rename ρ e') 202 | 203 | rename-· : {Γ1 Γ2 Γ3 : Ctx} → (ρ2 : Γ1 ⊇ Γ2) (ρ3 : Γ2 ⊇ Γ3) {τ : Tp} (e : Γ3 ⊢ τ) 204 | → rename ρ2 (rename ρ3 e) == rename (ρ2 ·rr ρ3) e 205 | rename-· ρ2 ρ3 #t = Refl 206 | rename-· ρ2 ρ3 #f = Refl 207 | rename-· ρ2 ρ3 (if e₁ then e₂ else e₃) = ap3 if_then_else_ (rename-· ρ2 ρ3 e₁) (rename-· ρ2 ρ3 e₂) (rename-· ρ2 ρ3 e₃) 208 | rename-· ρ2 ρ3 (var x) = ap var (rename-var-· ρ2 ρ3 x) 209 | rename-·{Γ1}{Γ2}{Γ3} ρ2 ρ3 (lam e) = ap lam (ap (λ x → rename (x , i0) e) lemma1 ∘ rename-· (addvar-ren ρ2) (addvar-ren ρ3) e) where 210 | lemma1 : (p· ρ2 , i0) ·rr (p· ρ3) == p· (ρ2 ·rr ρ3) 211 | lemma1 = (p· ρ2 , i0) ·rr (p· ρ3) =〈 pβ1' (p· ρ2) ρ3 i0 〉 212 | (p· ρ2) ·rr ρ3 =〈 ap (λ x → _·rr_ x ρ3) (p·-def ρ2) 〉 213 | (p ·rr ρ2) ·rr ρ3 =〈 ! (·rr-assoc p ρ2 ρ3) 〉 214 | p ·rr (ρ2 ·rr ρ3) =〈 ! (p·-def (ρ2 ·rr ρ3))〉 215 | p· (ρ2 ·rr ρ3) ∎ 216 | rename-· ρ2 ρ3 (app e e₁) = ap2 app (rename-· ρ2 ρ3 e) (rename-· ρ2 ρ3 e₁) 217 | 218 | -- not necessary for the proof, but an easy corollary of the above 219 | rename-id : {Γ : Ctx}{τ : Tp} (e : Γ ⊢ τ) → rename idr e == e 220 | rename-id #t = Refl 221 | rename-id #f = Refl 222 | rename-id (if e₁ then e₂ else e₃) = ap3 if_then_else_ (rename-id e₁) (rename-id e₂) (rename-id e₃) 223 | rename-id (var x) = ap var (rename-var-ident _ x) 224 | rename-id (lam e) = ap lam (rename-id e) 225 | rename-id (app e e₁) = ap2 app (rename-id e) (rename-id e₁) 226 | open Renamings 227 | 228 | -- expression-for-variable substitutions 229 | 230 | module Subst where 231 | 232 | _⊢c_ : Ctx → Ctx → Set 233 | Γ' ⊢c [] = Unit 234 | Γ' ⊢c (τ :: Γ) = (Γ' ⊢c Γ) × (Γ' ⊢ τ) 235 | 236 | _·rs_ : {Γ1 Γ2 Γ3 : Ctx} → Γ1 ⊇ Γ2 → Γ2 ⊢c Γ3 → Γ1 ⊢c Γ3 237 | _·rs_ {Γ1} {Γ2} {[]} ρ θ = <> 238 | _·rs_ {Γ1} {Γ2} {τ3 :: Γ3} ρ (θ , e) = ρ ·rs θ , rename ρ e 239 | 240 | addvar : {Γ Γ' : Ctx} {τ : Tp} → Γ ⊢c Γ' → (Γ ,, τ) ⊢c (Γ' ,, τ) 241 | addvar θ = p ·rs θ , var i0 242 | 243 | ids : {Γ : Ctx} → Γ ⊢c Γ 244 | ids {[]} = <> 245 | ids {τ :: Γ} = p ·rs ids , var i0 246 | 247 | subst-var : {Γ Γ' : Ctx}{τ : Tp} → Γ ⊢c Γ' → τ ∈ Γ' → Γ ⊢ τ 248 | subst-var (θ , e) i0 = e 249 | subst-var (θ , _) (iS x) = subst-var θ x 250 | 251 | subst : {Γ Γ' : Ctx}{τ : Tp} → Γ ⊢c Γ' → Γ' ⊢ τ → Γ ⊢ τ 252 | subst θ #t = #t 253 | subst θ #f = #f 254 | subst θ (if e₁ then e₂ else e₃) = if subst θ e₁ then subst θ e₂ else subst θ e₃ 255 | subst θ (var x) = subst-var θ x 256 | subst θ (lam e) = lam (subst (addvar θ) e) 257 | subst θ (app e e') = app (subst θ e) (subst θ e') 258 | 259 | subst1 : {τ τ0 : Tp} → [] ⊢ τ0 → ([] ,, τ0) ⊢ τ → [] ⊢ τ 260 | subst1 e0 e = subst (<> , e0) e 261 | 262 | -- composition of renamings and substitutions 263 | 264 | _·sr_ : {Γ1 Γ2 Γ3 : Ctx} → Γ1 ⊢c Γ2 → Γ2 ⊇ Γ3 → Γ1 ⊢c Γ3 265 | _·sr_ {Γ1} {Γ2} {[]} θ ρ = <> 266 | _·sr_ {Γ1} {Γ2} {τ3 :: Γ3} θ (ρ , x) = _·sr_ θ ρ , subst-var θ x 267 | 268 | _·ss_ : {Γ1 Γ2 Γ3 : Ctx} → Γ1 ⊢c Γ2 → Γ2 ⊢c Γ3 → Γ1 ⊢c Γ3 269 | _·ss_ {Γ3 = []} θ1 θ2 = <> 270 | _·ss_ {Γ1} {Γ2} {τ :: Γ3} θ1 (θ2 , e2) = θ1 ·ss θ2 , subst θ1 e2 271 | 272 | 273 | -- subst var functoriality 274 | 275 | subst-var-·rs : {Γ1 Γ2 Γ3 : Ctx} (ρ : Γ1 ⊇ Γ2) (θ : Γ2 ⊢c Γ3) {τ : Tp} (x : τ ∈ Γ3) 276 | → subst-var (ρ ·rs θ) x == rename ρ (subst-var θ x) 277 | subst-var-·rs ρ θ i0 = Refl 278 | subst-var-·rs ρ (θ , _) (iS x) = subst-var-·rs ρ θ x 279 | 280 | subst-var-∘ss : {Γ1 Γ2 Γ3 : Ctx} → (θ2 : Γ1 ⊢c Γ2) (θ3 : Γ2 ⊢c Γ3) {τ : Tp} (x : τ ∈ Γ3) 281 | → subst-var (_·ss_ θ2 θ3) x == subst θ2 (subst-var θ3 x) 282 | subst-var-∘ss θ2 θ3 i0 = Refl 283 | subst-var-∘ss θ2 (θ3 , _) (iS x) = subst-var-∘ss θ2 θ3 x 284 | 285 | subst-var-·sr : {Γ1 Γ2 Γ3 : Ctx} {τ : Tp} → (θ2 : Γ1 ⊢c Γ2) (ρ : Γ2 ⊇ Γ3) (x : τ ∈ Γ3) 286 | → (subst-var θ2 (rename-var ρ x)) == subst-var (_·sr_ θ2 ρ) x 287 | subst-var-·sr θ2 ρ i0 = Refl 288 | subst-var-·sr θ2 ρ (iS x) = subst-var-·sr θ2 (fst ρ) x 289 | 290 | subst-var-id : {Γ : Ctx} {τ : Tp} → (x : τ ∈ Γ) → var x == subst-var ids x 291 | subst-var-id i0 = Refl 292 | subst-var-id {τ :: Γ} (iS x) = ! 293 | (_ =〈 subst-var-·rs (p· idr) ids x 〉 294 | rename (p· idr) _ =〈 ! (ap (rename (p· idr)) (subst-var-id x)) 〉 295 | rename (p· idr) (var x) =〈 ap var (rename-var-p x) 〉 296 | var (iS x) ∎) 297 | 298 | 299 | -- associativity and unit laws for composition. 300 | -- also includes some β rules for composing with p. 301 | -- and functoriality of subst in the various compositions, since substitutions involve terms. 302 | 303 | ∘rsr-assoc : {Γ1 Γ2 Γ3 Γ4 : Ctx} → (ρ2 : Γ1 ⊇ Γ2) (θ3 : Γ2 ⊢c Γ3) (ρ4 : Γ3 ⊇ Γ4) 304 | → (ρ2 ·rs θ3) ·sr ρ4 == ρ2 ·rs (θ3 ·sr ρ4) 305 | ∘rsr-assoc {Γ1} {Γ2} {Γ3} {[]} ρ2 θ3 ρ4 = Refl 306 | ∘rsr-assoc {Γ1} {Γ2} {Γ3} {τ4 :: Γ4} ρ2 θ3 (ρ4 , x4) = ap2 _,_ (∘rsr-assoc ρ2 θ3 ρ4) (subst-var-·rs ρ2 θ3 x4) 307 | 308 | ·sr-pβ' : {Γ1 Γ2 Γ3 : Ctx} {τ : Tp} → (θ2 : Γ1 ⊢c Γ2) (ρ : Γ2 ⊇ Γ3) {e : _ ⊢ τ} 309 | → (θ2 , e) ·sr (p· ρ) == θ2 ·sr ρ 310 | ·sr-pβ' {Γ1} {Γ2} {[]} θ2 ρ = Refl 311 | ·sr-pβ' {Γ1} {Γ2} {τ :: Γ3} θ2 (ρ , x) = ap2 _,_ (·sr-pβ' θ2 ρ) Refl 312 | 313 | mutual 314 | ·sr-unitr : {Γ1 Γ2 : Ctx} → (θ : Γ1 ⊢c Γ2) → θ ·sr idr == θ 315 | ·sr-unitr {Γ1} {[]} θ = Refl 316 | ·sr-unitr {Γ1} {τ2 :: Γ2} (θ , e) = ap (λ x → x , e) (·sr-pβ θ) 317 | 318 | ·sr-pβ : {Γ1 Γ2 : Ctx} {τ : Tp} → (θ2 : Γ1 ⊢c Γ2) {e : _ ⊢ τ} 319 | → (θ2 , e) ·sr p == θ2 320 | ·sr-pβ θ2 = ·sr-unitr θ2 ∘ ·sr-pβ' θ2 idr 321 | 322 | subst-id : {Γ : Ctx} {τ : Tp} {e : Γ ⊢ τ} → e == subst (ids) e 323 | subst-id {e = #t} = Refl 324 | subst-id {e = #f} = Refl 325 | subst-id {e = if e₁ then e₂ else e₃} = ap3 if_then_else_ subst-id subst-id subst-id 326 | subst-id {e = var x} = subst-var-id x 327 | subst-id {e = lam e} = ap lam (subst-id) 328 | subst-id {e = app e e₁} = ap2 app subst-id subst-id 329 | 330 | subst-·rs : {Γ1 Γ2 Γ4 : Ctx} {τ : Tp} → (ρ : Γ4 ⊇ Γ1) (θ2 : Γ1 ⊢c Γ2) (e : Γ2 ⊢ τ) 331 | → rename ρ (subst θ2 e) == subst (ρ ·rs θ2) e 332 | subst-·rs ρ θ2 #t = Refl 333 | subst-·rs ρ θ2 #f = Refl 334 | subst-·rs ρ θ2 (if e₁ then e₂ else e₃) = ap3 if_then_else_ (subst-·rs ρ θ2 e₁) (subst-·rs ρ θ2 e₂) (subst-·rs ρ θ2 e₃) 335 | subst-·rs ρ θ2 (var x) = ! (subst-var-·rs ρ θ2 x) 336 | subst-·rs ρ θ2 (lam e) = ap lam (ap (λ x → subst x e) (ap (λ x → x , var i0) (lemma2 ρ θ2)) ∘ subst-·rs (addvar-ren ρ) (addvar θ2) e) where 337 | lemma1 : {Γ3 Γ5 : Ctx} (ρ₁ : Γ5 ⊇ Γ3) {τ3 : Tp} 338 | → (addvar-ren {_}{_}{τ3} ρ₁) ·rr (p· idr) == (p· idr) ·rr ρ₁ 339 | lemma1 {Γ3} {Γ5} ρ₁ = (p· ρ₁ , i0) ·rr (p· idr) =〈 Refl 〉 340 | (p· ρ₁ , i0) ·rr p =〈 ap (λ x → (x , i0) ·rr p) (p·-def ρ₁)〉 341 | (p ·rr ρ₁ , i0) ·rr p =〈 pβ1 (p ·rr ρ₁) i0 〉 342 | p ·rr ρ₁ =〈 Refl 〉 343 | (p· idr) ·rr ρ₁ ∎ 344 | 345 | lemma2 : {Γ1 Γ2 Γ4 : Ctx} {τ : Tp} → (ρ : Γ4 ⊇ Γ1) (θ2 : Γ1 ⊢c Γ2) 346 | → (addvar-ren{_}{_}{τ} ρ) ·rs (fst (addvar θ2)) == p ·rs (ρ ·rs θ2) 347 | lemma2 {Γ2 = []} ρ₁ θ3 = Refl 348 | lemma2 {Γ2 = τ2 :: Γ2} ρ₁ (θ3 , e3) = ap2 _,_ (lemma2 ρ₁ θ3) 349 | (! (rename-· (p· idr) ρ₁ e3) ∘ 350 | (ap (λ x → rename x e3) (lemma1 ρ₁) ∘ 351 | rename-· (addvar-ren ρ₁) (p· idr) e3)) 352 | subst-·rs ρ θ2 (app e e₁) = ap2 app (subst-·rs ρ θ2 e) (subst-·rs ρ θ2 e₁) 353 | 354 | ·rss-assoc : {Γ1 Γ2 Γ3 Γ4 : Ctx} → (ρ : Γ4 ⊇ Γ1) (θ2 : Γ1 ⊢c Γ2) (θ3 : Γ2 ⊢c Γ3) 355 | → ρ ·rs (θ2 ·ss θ3) == (ρ ·rs θ2) ·ss θ3 356 | ·rss-assoc {Γ1} {Γ2} {[]} ρ θ2 θ3 = Refl 357 | ·rss-assoc {Γ1} {Γ2} {x :: Γ3} ρ θ2 (θ3 , e3) = ap2 _,_ (·rss-assoc ρ θ2 θ3) (subst-·rs ρ θ2 e3) 358 | 359 | subst-·sr : {Γ1 Γ2 Γ3 : Ctx} {τ : Tp} → (θ2 : Γ1 ⊢c Γ2) (ρ : Γ2 ⊇ Γ3) (e : Γ3 ⊢ τ) 360 | → (subst θ2 (rename ρ e)) == subst (θ2 ·sr ρ) e 361 | subst-·sr θ2 ρ #t = Refl 362 | subst-·sr θ2 ρ #f = Refl 363 | subst-·sr θ2 ρ (if e₁ then e₂ else e₃) = ap3 if_then_else_ (subst-·sr θ2 ρ e₁) (subst-·sr θ2 ρ e₂) (subst-·sr θ2 ρ e₃) 364 | subst-·sr θ2 ρ (var x) = subst-var-·sr θ2 ρ x 365 | subst-·sr θ2 ρ (lam e) = ap lam (ap (λ x → subst x e) (ap (λ x → x , var i0) (lemma θ2 ρ)) ∘ subst-·sr (addvar θ2) (addvar-ren ρ) e) where 366 | lemma : {Γ1 Γ2 Γ3 : Ctx} {τ : Tp} → (θ2 : Γ1 ⊢c Γ2) (ρ : Γ2 ⊇ Γ3) → (addvar{_}{_}{τ} θ2) ·sr (p· ρ) == p ·rs (θ2 ·sr ρ) 367 | lemma θ2 ρ = ∘rsr-assoc (p· idr) θ2 ρ ∘ ·sr-pβ' (_·rs_ (p· idr) θ2) ρ {var i0} 368 | subst-·sr θ2 ρ (app e e₁) = ap2 app (subst-·sr θ2 ρ e) (subst-·sr θ2 ρ e₁) 369 | 370 | ·srs-assoc : {Γ1 Γ2 Γ3 Γ4 : Ctx} (θ : Γ1 ⊢c Γ2) (ρ : Γ2 ⊇ Γ3) (θ' : Γ3 ⊢c Γ4) 371 | → θ ·ss (ρ ·rs θ') == (θ ·sr ρ) ·ss θ' 372 | ·srs-assoc {Γ1} {Γ2} {Γ3} {[]} θ ρ θ' = Refl 373 | ·srs-assoc {Γ1} {Γ2} {Γ3} {x :: Γ4} θ ρ (θ' , e') = ap2 _,_ (·srs-assoc θ ρ θ') (subst-·sr θ ρ e') 374 | 375 | subst-·ss : {Γ1 Γ2 Γ3 : Ctx} → (θ2 : Γ1 ⊢c Γ2) (θ3 : Γ2 ⊢c Γ3) {τ : Tp} (e : Γ3 ⊢ τ) 376 | → subst (θ2 ·ss θ3) e == subst θ2 (subst θ3 e) 377 | subst-·ss θ2 θ3 #t = Refl 378 | subst-·ss θ2 θ3 #f = Refl 379 | subst-·ss θ2 θ3 (var x) = subst-var-∘ss θ2 θ3 x 380 | subst-·ss θ2 θ3 (lam e) = ap lam (subst-·ss (addvar θ2) (addvar θ3) e ∘ 381 | ap (λ x → subst x e) (ap (λ x → x , var i0) 382 | (lemma1 ∘ ·rss-assoc p θ2 θ3))) where 383 | lemma1 : (p ·rs θ2) ·ss θ3 == 384 | (addvar θ2) ·ss (fst (addvar θ3)) 385 | lemma1 = (p ·rs θ2) ·ss θ3 =〈 ! (ap (λ x → x ·ss θ3) (·sr-pβ (p ·rs θ2) {var i0})) 〉 386 | ((p ·rs θ2 , var i0) ·sr p) ·ss θ3 =〈 ! (·srs-assoc (p ·rs θ2 , var i0) p θ3) 〉 387 | (p ·rs θ2 , var i0) ·ss (p ·rs θ3) ∎ 388 | subst-·ss θ2 θ3 (app e e₁) = ap2 app (subst-·ss θ2 θ3 e) (subst-·ss θ2 θ3 e₁) 389 | subst-·ss θ2 θ3 (if e₁ then e₂ else e₃) = ap3 if_then_else_ (subst-·ss θ2 θ3 e₁) (subst-·ss θ2 θ3 e₂) (subst-·ss θ2 θ3 e₃) 390 | 391 | ·ss-unitl : {Γ1 Γ2 : Ctx} → (θ : Γ1 ⊢c Γ2) → ids ·ss θ == θ 392 | ·ss-unitl {Γ2 = []} θ = Refl 393 | ·ss-unitl {Γ2 = τ :: Γ2} (θ , e) = ap2 _,_ (·ss-unitl θ) (! subst-id) 394 | 395 | compose1 : {τ1 τ2 : Tp} {Γ : Ctx} (θ : [] ⊢c Γ) (e' : [] ⊢ τ1) 396 | → (θ , e') == (<> , e') ·ss (addvar θ) 397 | compose1 {τ1}{τ2} θ e' = ap (λ x → x , e') (! (·srs-assoc (<> , e') (p{_}{τ1}) θ) ∘ ! (·ss-unitl θ)) 398 | 399 | subst-compose1 : {τ1 τ2 : Tp} {Γ : Ctx} (θ : [] ⊢c Γ) (e' : [] ⊢ τ1) (e : Γ ,, τ1 ⊢ τ2) 400 | → subst (θ , e') e == subst1 e' (subst (addvar θ) e) 401 | subst-compose1{τ1}{τ2}{Γ} θ e' e = subst-·ss (<> , e') (addvar θ) e ∘ ap (λ x → subst x e) (compose1{τ1}{τ2}{Γ} θ e') 402 | 403 | open Subst public 404 | 405 | open RenamingAndSubstitution public -- using (_⊇_ ; rename ; subst1 ; _⊢c_ ; subst ; ident ; compose) 406 | --------------------------------------------------------------------------------