├── .gitignore ├── LICENSE.md ├── README.md ├── doc ├── types21-abstract.pdf └── types21-slides.pdf ├── k.agda-lib ├── scripts └── genhtml.sh └── src ├── Context.agda ├── Context ├── Base.agda └── Properties.agda ├── EUtil.agda ├── Everything.agda ├── FunExt.agda ├── HEUtil.agda ├── IK ├── Applications │ ├── Experiments.agda │ ├── Neutrality.agda │ └── WeakNorm.agda ├── Norm.agda ├── Norm │ ├── Base.agda │ ├── NbE │ │ ├── Model.agda │ │ └── Reification.agda │ └── Properties │ │ ├── Completeness.agda │ │ ├── Soundness.agda │ │ └── Soundness │ │ └── Trace.agda ├── Term.agda └── Term │ ├── Base.agda │ ├── Conversion.agda │ ├── NormalForm.agda │ ├── NormalForm │ ├── Base.agda │ └── Properties.agda │ ├── Properties.agda │ └── Reduction.agda ├── IS4 ├── Applications │ ├── IS4Plus.agda │ └── Purity.agda ├── Norm.agda ├── Norm │ ├── Base.agda │ ├── NbE │ │ ├── Model.agda │ │ └── Reification.agda │ └── Properties │ │ ├── Completeness.agda │ │ └── Soundness.agda ├── Term.agda └── Term │ ├── Base.agda │ ├── Conversion.agda │ ├── NormalForm.agda │ ├── NormalForm │ ├── Base.agda │ └── Properties.agda │ ├── Properties.agda │ └── Reduction.agda ├── PEUtil.agda ├── PUtil.agda ├── RUtil.agda ├── Semantics ├── Clouston │ └── Evaluation │ │ ├── IML.agda │ │ ├── IML │ │ ├── Base.agda │ │ └── Properties.agda │ │ ├── IS4.agda │ │ └── IS4 │ │ ├── Base.agda │ │ └── Properties.agda └── Presheaf │ ├── Base.agda │ ├── CartesianClosure.agda │ ├── Evaluation │ ├── IML.agda │ └── IS4.agda │ └── Necessity.agda ├── Type.agda └── Type ├── Base.agda └── Properties.agda /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | \#*\# 3 | .\#* 4 | 5 | *.agdai 6 | _build/ 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # k 2 | 3 | Normalization for Fitch-style Modal Calculi 4 | 5 | ## About 6 | 7 | Fitch-style modal lambda calculi enable programming with necessity 8 | modalities in a typed lambda calculus by extending the typing context 9 | with a delimiting operator that is denoted by a lock. The addition of 10 | locks simplifies the formulation of typing rules for calculi that 11 | incorporate different modal axioms, but each variant demands different, 12 | tedious and seemingly ad hoc syntactic lemmas to prove normalization. 13 | 14 | This repo contains a mechanization of some intrinsically-typed 15 | Fitch-style modal lambda calculi and a proof of normalization for them. 16 | Normalization is achieved using normalization by evaluation 17 | (NbE), by leveraging the possible-world semantics of 18 | Fitch-style calculi. The semantics-based approach 19 | of NbE yields a more modular approach to normalization 20 | that allows us to separate reasoning about the modal fragment 21 | from the rest of the calculus. 22 | 23 | ## Current status 24 | 25 | Implements executable normalization functions for IK (the calculus 26 | with the modal axiom K) and IS4 (the calculus with axioms K, T and 4), 27 | and a "tracing" function for each calculus that prints out a 28 | sequence of reduction steps that explain the result of the 29 | normalization function. This yields a proof of soundness 30 | for normalization, i.e., norm t = norm t' => t ~ t'. 31 | 32 | ## References 33 | 34 | * Ranald Clouston. 2018. [Fitch-Style Modal Lambda Calculi](https://arxiv.org/abs/1710.08326). 35 | * V.A.J. Borghuis. 1994. [Coming to terms with modal logic: on the interpretation of modalities in typed lambda-calculus](https://research.tue.nl/en/publications/coming-to-terms-with-modal-logic-on-the-interpretation-of-modalit). 36 | -------------------------------------------------------------------------------- /doc/types21-abstract.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nachivpn/k/dad9f2adbf4841b46e2ab6c3d1076dbb51d04abe/doc/types21-abstract.pdf -------------------------------------------------------------------------------- /doc/types21-slides.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nachivpn/k/dad9f2adbf4841b46e2ab6c3d1076dbb51d04abe/doc/types21-slides.pdf -------------------------------------------------------------------------------- /k.agda-lib: -------------------------------------------------------------------------------- 1 | name: k 2 | depend: 3 | -- agda-2.6.2.2 4 | standard-library-1.7.1 5 | include : 6 | src 7 | -------------------------------------------------------------------------------- /scripts/genhtml.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e -u 4 | 5 | REPO=nachivpn/k 6 | AGDA_FILE=src/Everything.agda 7 | 8 | GH_PAGES_BRANCH=gh-pages 9 | GH_PAGES_HTML_DIR=html 10 | 11 | REPO_PULL_URL=https://github.com/$REPO.git 12 | REPO_PUSH_URL=git@github.com:$REPO.git 13 | TREE_BASE_URL=https://github.com/$REPO/tree 14 | 15 | usage () { 16 | cat < 1) print $NF }' 41 | } 42 | 43 | _SCRIPTNAME=$(basename $0) 44 | 45 | [ $# -ne 1 ] && usage_and_exit_nonzero 46 | 47 | BRANCH=$1 48 | 49 | trap '_EXITCODE=$?; trap - INT QUIT TERM EXIT; clean_and_exit' INT QUIT TERM EXIT 50 | 51 | echo -n "Cloning $BRANCH..." 52 | REPO_CLONE_DIR=$(mktemp -d --tmpdir ${_SCRIPTNAME}_repo.XXXXXXX) 53 | git clone -q --single-branch --no-tags -b $BRANCH $REPO_PULL_URL $REPO_CLONE_DIR 54 | echo ' Done.' 55 | HTML_BUILD_DIR=$(mktemp -d --tmpdir ${_SCRIPTNAME}_html.XXXXXXX) 56 | if [ -d _build ] && [ ! -e $REPO_CLONE_DIR/_build ] 57 | then 58 | echo -n 'Copying _build directory...' 59 | cp -r _build $REPO_CLONE_DIR/ 60 | echo ' Done.' 61 | fi 62 | echo -n "Type checking $AGDA_FILE..." 63 | ( 64 | cd $REPO_CLONE_DIR/$(dirname $AGDA_FILE) 65 | agda -v 0 $(basename $AGDA_FILE) 66 | ) 67 | echo ' Done.' 68 | echo -n "Generating html for $AGDA_FILE..." 69 | ( 70 | cd $REPO_CLONE_DIR/$(dirname $AGDA_FILE) 71 | agda -v 0 --html --html-dir=$HTML_BUILD_DIR $(basename $AGDA_FILE) 72 | COMMIT_HASH=$(git show -s --format=%H HEAD) 73 | TREE_URL=$TREE_BASE_URL/$COMMIT_HASH 74 | #AGDA_FILE_EXT=.$(file_extension $AGDA_FILE) 75 | #HTML_FILE=$HTML_BUILD_DIR/$(basename $AGDA_FILE $AGDA_FILE_EXT).html 76 | find $HTML_BUILD_DIR -name \*.html -exec sed -i -e "s||

Generated from commit $COMMIT_HASH.

&|" {} \; 77 | ) 78 | echo ' Done.' 79 | 80 | echo -n "Updating $GH_PAGES_BRANCH..." 81 | GH_PAGES_CLONE_DIR=$(mktemp -d --tmpdir ${_SCRIPTNAME}_gh-pages.XXXXXXX) 82 | git clone -q --single-branch --no-tags -b $GH_PAGES_BRANCH $REPO_PULL_URL $GH_PAGES_CLONE_DIR 83 | git -C $GH_PAGES_CLONE_DIR rm -q -r $GH_PAGES_HTML_DIR 84 | cp -r $HTML_BUILD_DIR $GH_PAGES_CLONE_DIR/$GH_PAGES_HTML_DIR 85 | git -C $GH_PAGES_CLONE_DIR add $GH_PAGES_HTML_DIR 86 | if ! git -C $GH_PAGES_CLONE_DIR diff-index --quiet --cached HEAD 87 | then 88 | echo 89 | git -C $GH_PAGES_CLONE_DIR commit -q -m "Update html folder" 90 | DIFF=x 91 | while [ "$DIFF" != n ] && [ "$DIFF" != y ] 92 | do 93 | echo -n "Preview changes to $GH_PAGES_BRANCH? [y/N] " 94 | read DIFF 95 | [ -n "$DIFF" ] || DIFF=n 96 | done 97 | if [ "$DIFF" = y ] 98 | then 99 | git -C $GH_PAGES_CLONE_DIR log --format=fuller -p @{u}.. 100 | else 101 | git -C $GH_PAGES_CLONE_DIR --no-pager log --format=fuller @{u}.. 102 | fi 103 | PUSH=x 104 | while [ "$PUSH" != n ] && [ "$PUSH" != y ] 105 | do 106 | echo -n "Push changes to $GH_PAGES_BRANCH? [y/N] " 107 | read PUSH 108 | [ -n "$PUSH" ] || PUSH=n 109 | done 110 | if [ "$PUSH" = y ] 111 | then 112 | git -C $GH_PAGES_CLONE_DIR push $REPO_PUSH_URL -q 113 | echo 'Done.' 114 | else 115 | echo 'Aborted.' 116 | fi 117 | else 118 | echo ' Done. (was already up to date)' 119 | fi 120 | -------------------------------------------------------------------------------- /src/Context.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | 3 | open import Relation.Binary.Definitions using (Decidable) 4 | open import Relation.Binary.PropositionalEquality using (_≡_) 5 | 6 | module Context (Ty : Set) (Ty-Decidable : Decidable (_≡_ {A = Ty})) where 7 | 8 | open import Context.Base Ty public 9 | open import Context.Properties Ty Ty-Decidable public 10 | -------------------------------------------------------------------------------- /src/Context/Base.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module Context.Base (Ty : Set) where 3 | 4 | open import Data.Empty using (⊥ ; ⊥-elim) 5 | open import Data.Product using (Σ ; _×_ ; _,_ ; ∃ ; ∃₂ ; proj₂) 6 | open import Data.Unit using (⊤ ; tt) 7 | 8 | open import Relation.Binary.Definitions using (Reflexive ; Transitive) 9 | 10 | private 11 | variable 12 | a b c d : Ty 13 | 14 | infixl 6 _# _`,_ 15 | infix 5 _⊆_ 16 | infixl 5 _,,_ 17 | 18 | ----------- 19 | -- Contexts 20 | ----------- 21 | 22 | data Ctx : Set where 23 | [] : Ctx 24 | _`,_ : (Γ : Ctx) → (a : Ty) → Ctx 25 | _# : (Γ : Ctx) → Ctx -- a lock 🔒 26 | 27 | [#] : Ctx 28 | [#] = [] # 29 | 30 | [_] : Ty → Ctx 31 | [_] a = [] `, a 32 | 33 | variable 34 | Γ Γ' Γ'' ΓL ΓL' ΓL'' ΓLL ΓLR ΓR ΓR' ΓR'' ΓRL ΓRR : Ctx 35 | Δ Δ' Δ'' ΔL ΔL' ΔL'' ΔLL ΔLR ΔR ΔR' ΔR'' ΔRL ΔRR : Ctx 36 | Θ Θ' Θ'' ΘL ΘL' ΘL'' ΘLL ΘLR ΘR ΘR' ΘR'' ΘRL ΘRR : Ctx 37 | Ξ Ξ' Ξ'' ΞL ΞL' ΞL'' ΞLL ΞLR ΞR ΞR' ΞR'' ΞRL ΞRR : Ctx 38 | 39 | -- append contexts (++) 40 | _,,_ : Ctx → Ctx → Ctx 41 | Γ ,, [] = Γ 42 | Γ ,, (Δ `, x) = (Γ ,, Δ) `, x 43 | Γ ,, (Δ #) = (Γ ,, Δ) # 44 | 45 | -- contexts free of locks 46 | #-free : Ctx → Set 47 | #-free [] = ⊤ 48 | #-free (Γ `, _a) = #-free Γ 49 | #-free (_Γ #) = ⊥ 50 | 51 | -- context to left of the last lock 52 | ←# : Ctx → Ctx 53 | ←# [] = [] 54 | ←# (Γ `, _a) = ←# Γ 55 | ←# (Γ #) = Γ 56 | 57 | -- context to the right of the last lock 58 | #→ : Ctx → Ctx 59 | #→ [] = [] 60 | #→ (Γ `, a) = #→ Γ `, a 61 | #→ (_Γ #) = [] 62 | 63 | ------------- 64 | -- Weakenings 65 | ------------- 66 | 67 | -- weakening relation 68 | data _⊆_ : Ctx → Ctx → Set where 69 | base : [] ⊆ [] 70 | drop : (w : Γ ⊆ Δ) → Γ ⊆ Δ `, a 71 | keep : (w : Γ ⊆ Δ) → Γ `, a ⊆ Δ `, a 72 | keep# : (w : Γ ⊆ Δ) → Γ # ⊆ Δ # 73 | 74 | {- 75 | Notes on _⊆_: 76 | 77 | In addition to the regular definition of weakening (`base`, `drop` and `keep`), 78 | we also allow weakening in the presence of locks: 79 | 80 | - `keep#` allows weakening under locks 81 | 82 | Disallowing weakening with locks in general ensures that values 83 | that depend on "local" assumptions cannot be boxed by simply 84 | weakening with locks. 85 | 86 | -} 87 | 88 | pattern drop[_] a w = drop {a = a} w 89 | pattern keep[_] a w = keep {a = a} w 90 | 91 | variable 92 | w w' w'' : Γ ⊆ Γ' 93 | 94 | -- weakening is reflexive 95 | idWk[_] : (Γ : Ctx) → Γ ⊆ Γ 96 | idWk[_] [] = base 97 | idWk[_] (Γ `, _a) = keep idWk[ Γ ] 98 | idWk[_] (Γ #) = keep# idWk[ Γ ] 99 | 100 | idWk = λ {Γ} → idWk[ Γ ] 101 | 102 | -- weakening is transitive (or can be composed) 103 | _∙_ : Θ ⊆ Δ → Δ ⊆ Γ → Θ ⊆ Γ 104 | w ∙ base = w 105 | w ∙ drop w' = drop (w ∙ w') 106 | drop w ∙ keep w' = drop (w ∙ w') 107 | keep w ∙ keep w' = keep (w ∙ w') 108 | keep# w ∙ keep# w' = keep# (w ∙ w') 109 | 110 | -- weakening that "generates a fresh variable" 111 | fresh : Γ ⊆ Γ `, a 112 | fresh = drop idWk 113 | 114 | fresh[_] = λ {Γ} a → fresh {Γ} {a} 115 | 116 | ------------ 117 | -- Variables 118 | ------------ 119 | 120 | data Var : Ctx → Ty → Set where 121 | zero : Var (Γ `, a) a 122 | succ : (v : Var Γ a) → Var (Γ `, b) a 123 | 124 | pattern v0 = zero 125 | pattern v1 = succ v0 126 | pattern v2 = succ v1 127 | 128 | wkVar : Γ ⊆ Γ' → Var Γ a → Var Γ' a 129 | wkVar (drop e) v = succ (wkVar e v) 130 | wkVar (keep e) zero = zero 131 | wkVar (keep e) (succ v) = succ (wkVar e v) 132 | 133 | -- OBS: in general, Γ ⊈ Δ ,, Γ 134 | leftWkVar : (v : Var Γ a) → Var (Δ ,, Γ) a 135 | leftWkVar zero = zero 136 | leftWkVar (succ v) = succ (leftWkVar v) 137 | 138 | -------------------- 139 | -- Context extension 140 | -------------------- 141 | 142 | -- The three-place relation Ext θ relates contexts Γ, ΓL, and ΓR 143 | -- exactly when Γ = ΓL ,, ΓR (cf. lemmas extIs,, and ,,IsExt 144 | -- below). In other words, Ext θ is the graph of context concatenation 145 | -- _,,_. The relation Ext θ Γ ΓL ΓR may be read as "Γ is ΓL extended 146 | -- to the right with ΓR". 147 | -- 148 | -- The flag θ specifies whether the context ΓR we are extending with 149 | -- may contain locks (if set to tt) or not (if set to ff). 150 | -- 151 | -- Ext is used below to define lock-free and arbitrary context 152 | -- extensions LFExt and CExt, respectively, in a uniform way. The 153 | -- relations LFExt and CExt in turn are used to define the modal 154 | -- accessibility premises of the unbox term formers for λ_IK (see data 155 | -- Tm in IK.Term.Base) and λ_IS4 (see data Tm in IS4.Term.Base), 156 | -- respectively, in a uniform way. 157 | 158 | data Flag : Set where 159 | tt ff : Flag 160 | 161 | variable 162 | θ θ' : Flag 163 | 164 | -- with locks? 165 | WL : Flag → Set 166 | WL tt = ⊤ 167 | WL ff = ⊥ 168 | 169 | data Ext (θ : Flag) : Ctx → Ctx → Ctx → Set where 170 | nil : Ext θ Γ Γ [] 171 | ext : (e : Ext θ Γ ΓL ΓR) → Ext θ (Γ `, a) ΓL (ΓR `, a) 172 | ext# : WL θ → (e : Ext θ Γ ΓL ΓR) → Ext θ (Γ #) ΓL (ΓR #) 173 | 174 | pattern nil[_] Γ = nil {Γ = Γ} 175 | pattern ext[_] a e = ext {a = a} e 176 | pattern ext#- e = ext# tt e 177 | 178 | -- Lock-free context extension (w/o locks, Ext flag set to ff) 179 | -- 180 | -- The modal accessibility relation _◁_ for λ_IK defined in Figure 4 181 | -- in the paper can equivalently be defined by Δ ◁ Γ = ∃ ΔR. LFExt Γ 182 | -- (Δ #) ΔR. 183 | -- 184 | -- Lock-free context extensions are also used to represent sequences 185 | -- w : Γ ⊆ Γ `, a₁ `, … `, aₙ of drops in the "shift-unbox" conversion 186 | -- rule unbox t (w · e) ≈ unbox (wkTm w t) e (cf. discussion below 187 | -- Theorem 7 in the paper). 188 | LFExt : Ctx → Ctx → Ctx → Set 189 | LFExt = Ext ff 190 | 191 | _◁IK_ = λ Δ Γ → Σ Ctx λ ΔR → LFExt Γ (Δ #) ΔR 192 | 193 | -- Arbitrary context extension (possibly w/ locks, Ext flag set to tt) 194 | -- 195 | -- The modal accessibility relation _◁_ for λ_IS4 defined in Figure 10 196 | -- in the paper can equivalently be defined by Δ ◁ Γ = ∃ ΔR. CExt Γ Δ 197 | -- ΔR. 198 | CExt : Ctx → Ctx → Ctx → Set 199 | CExt = Ext tt 200 | 201 | _◁IS4_ = λ Δ Γ → Σ Ctx λ ΔR → CExt Γ Δ ΔR 202 | 203 | pattern nil◁ = _ , nil 204 | pattern ext◁ e = _ , ext e 205 | pattern ext#◁ e = _ , ext# tt e 206 | 207 | -- extension that "generates a new context frame" 208 | pattern new◁IK = _ , nil 209 | pattern new◁IS4 = _ , ext# tt nil 210 | 211 | variable 212 | e e' e'' : Ext θ Γ ΓL ΓR 213 | 214 | -- embed lock-free extensions into ones that extend with locks 215 | upLFExt : LFExt Γ ΓL ΓR → Ext θ Γ ΓL ΓR 216 | upLFExt nil = nil 217 | upLFExt (ext e) = ext (upLFExt e) 218 | 219 | -- left identity of extension 220 | extLId : CExt Γ [] Γ 221 | extLId {Γ = []} = nil 222 | extLId {Γ = _Γ `, _a} = ext extLId 223 | extLId {Γ = _Γ #} = ext# tt extLId 224 | 225 | -- right identity of extension 226 | extRId : Ext θ Γ Γ [] 227 | extRId = nil 228 | 229 | -- extension that "generates a fresh variable" 230 | freshExt : Ext θ (Γ `, a) Γ ([] `, a) 231 | freshExt = ext nil 232 | 233 | freshExt[_] = λ {θ} {Γ} a → freshExt {θ} {Γ} {a} 234 | 235 | -- lock-free extensions yield a "right" weakening (i.e., adding variables on the right) 236 | LFExtToWk : LFExt Γ ΓL ΓR → ΓL ⊆ Γ 237 | LFExtToWk nil = idWk 238 | LFExtToWk (ext e) = drop (LFExtToWk e) 239 | 240 | -- extension is assocative 241 | extRAssoc : Ext θ ΓL ΓLL ΓLR → Ext θ Γ ΓL ΓR → Ext θ Γ ΓLL (ΓLR ,, ΓR) 242 | extRAssoc el nil = el 243 | extRAssoc el (ext er) = ext (extRAssoc el er) 244 | extRAssoc el (ext# x er) = ext# x (extRAssoc el er) 245 | 246 | _∙Ext_ = extRAssoc 247 | 248 | ------------------------------------- 249 | -- Operations on lock-free extensions 250 | ------------------------------------- 251 | 252 | -- weaken the extension of a context 253 | wkLFExt : (e : LFExt Γ (ΓL #) ΓR) → (w : Γ ⊆ Γ') → LFExt Γ' ((←# Γ') #) (#→ Γ') 254 | wkLFExt e (drop w) = ext (wkLFExt e w) 255 | wkLFExt nil (keep# w) = nil 256 | wkLFExt (ext e) (keep w) = ext (wkLFExt e w) 257 | 258 | -- left weaken the (lock-free) extension of a context 259 | leftWkLFExt : (e : LFExt Γ ΓL ΓR) → LFExt (Δ ,, Γ) (Δ ,, ΓL) ΓR 260 | leftWkLFExt nil = nil 261 | leftWkLFExt (ext e) = ext (leftWkLFExt e) 262 | 263 | -- slice a weakening to the left of a lock 264 | sliceLeft : (e : LFExt Γ (ΓL #) ΓR) → (w : Γ ⊆ Γ') → ΓL ⊆ ←# Γ' 265 | sliceLeft e (drop w) = sliceLeft e w 266 | sliceLeft (ext e) (keep w) = sliceLeft e w 267 | sliceLeft nil (keep# w) = w 268 | 269 | -- slice a weakening to the right of a lock 270 | sliceRight : (e : LFExt Γ (ΓL #) ΓR) → (w : Γ ⊆ Γ') → ←# Γ' # ⊆ Γ' 271 | sliceRight e w = LFExtToWk (wkLFExt e w) 272 | 273 | ----------------------------------- 274 | -- Operations on general extensions 275 | ----------------------------------- 276 | 277 | ◁IS4-refl : Reflexive _◁IS4_ 278 | ◁IS4-refl = nil◁ 279 | 280 | ◁IS4-trans : Transitive _◁IS4_ 281 | ◁IS4-trans (_ , Γ◁Δ) (_ , Δ◁Ε) = _ , extRAssoc Γ◁Δ Δ◁Ε 282 | 283 | private 284 | -- we don't use factor1 anymore 285 | factor1 : Γ ◁IS4 Δ → Γ' ⊆ Γ → ∃ λ Δ' → Δ' ⊆ Δ × Γ' ◁IS4 Δ' 286 | factor1 nil◁ Γ'⊆Γ 287 | = _ , Γ'⊆Γ , nil◁ 288 | factor1 (ext◁ Γ◁Δ) Γ'⊆Γ with factor1 (_ , Γ◁Δ) Γ'⊆Γ 289 | ... | Δ' , Δ'⊆Δ , Γ'◁Δ' 290 | = Δ' , drop Δ'⊆Δ , Γ'◁Δ' 291 | factor1 (ext#◁ Γ◁Δ) Γ'⊆Γ with factor1 (_ , Γ◁Δ) Γ'⊆Γ 292 | ... | Δ' , Δ'⊆Δ , Γ'◁Δ' 293 | = Δ' # , keep# Δ'⊆Δ , ◁IS4-trans Γ'◁Δ' (ext#◁ extRId) 294 | 295 | -- not used directly, but serves as a specification of 296 | -- what is expected from factorExt and factorWk 297 | factor2 : Γ ◁IS4 Δ → Δ ⊆ Δ' → ∃ λ Γ' → Γ ⊆ Γ' × Γ' ◁IS4 Δ' 298 | factor2 nil◁ Δ⊆Δ' 299 | = _ , Δ⊆Δ' , nil◁ 300 | factor2 (ext◁ Γ◁Δ) Δ⊆Δ' 301 | = factor2 (_ , Γ◁Δ) (fresh ∙ Δ⊆Δ') 302 | factor2 (ext#◁ Γ◁Δ) Δ⊆Δ' with factor2 (_ , Γ◁Δ) (sliceLeft extRId Δ⊆Δ') 303 | ... | Γ' , Γ⊆Γ' , Γ'◁Δ' 304 | = Γ' , Γ⊆Γ' , ◁IS4-trans Γ'◁Δ' (◁IS4-trans (ext#◁ extRId) (_ , upLFExt (wkLFExt extRId Δ⊆Δ'))) 305 | 306 | -- "Left" context of factoring (see type of factorWk and factorExt) 307 | -- lCtx e w == proj₁ (factor2 (_ , e) w) 308 | lCtx : Ext θ Γ ΓL ΓR → Γ ⊆ Γ' → Ctx 309 | lCtx {Γ = Γ} {Γ' = Γ'} nil w 310 | = Γ' 311 | lCtx {Γ = Γ `, a} {Γ' = Γ' `, b} (ext e) (drop w) 312 | = lCtx (ext e) w 313 | lCtx {Γ = Γ `, a} {Γ' = Γ' `, .a} (ext e) (keep w) 314 | = lCtx e w 315 | lCtx {Γ = Γ #} {Γ' = Γ' `, a} (ext# f e) (drop w) 316 | = lCtx (ext# f e) w 317 | lCtx {Γ = Γ #} {Γ' = Γ' #} (ext# f e) (keep# w) 318 | = lCtx e w 319 | 320 | -- factorWk e w == proj₁ (proj₂ (factor2 (_ , e) w)) 321 | factorWk : (e : Ext θ Γ ΓL ΓR) → (w : Γ ⊆ Γ') → ΓL ⊆ lCtx e w 322 | factorWk nil w = w 323 | factorWk (ext e) (drop w) = factorWk (ext e) w 324 | factorWk (ext e) (keep w) = factorWk e w 325 | factorWk (ext# f e) (drop w) = factorWk (ext# f e) w 326 | factorWk (ext# f e) (keep# w) = factorWk e w 327 | 328 | -- "Right" context of factoring (see type of factorExt) 329 | -- rCtx e w == proj₁ (proj₂ (proj₂ (factor2 (_ , e) w))) 330 | rCtx : Ext θ Γ ΓL ΓR → Γ ⊆ Γ' → Ctx 331 | rCtx {Γ = Γ} {Γ' = Γ'} nil w 332 | = [] 333 | rCtx {Γ = Γ `, a} {Γ' = Γ' `, b} (ext e) (drop w) 334 | = rCtx (ext e) w `, b 335 | rCtx {Γ = Γ `, a} {Γ' = Γ' `, .a} (ext e) (keep w) 336 | = rCtx e w `, a 337 | rCtx {Γ = Γ #} {Γ' = Γ' `, a} (ext# f e) (drop {a = a} w) 338 | = rCtx (ext# f e) w `, a 339 | rCtx {Γ = Γ #} {Γ' = Γ' #} (ext# f e) (keep# w) 340 | = (rCtx e w) # 341 | 342 | -- factorExt e w == proj₂ (proj₂ (proj₂ (factor2 (_ , e) w))) 343 | factorExt : (e : Ext θ Γ ΓL ΓR) → (w : Γ ⊆ Γ') → Ext θ Γ' (lCtx e w) (rCtx e w) 344 | factorExt nil w = nil 345 | factorExt (ext e) (drop w) = ext (factorExt (ext e) w) 346 | factorExt (ext e) (keep w) = ext (factorExt e w) 347 | factorExt (ext# f e) (drop w) = ext (factorExt (ext# f e) w) 348 | factorExt (ext# f e) (keep# w) = ext# f (factorExt e w) 349 | 350 | ------------------------------------------------------------------------------------- 351 | -- Substitutions (parameterized by terms `Tm` and modal accessibility relation `Acc`) 352 | ------------------------------------------------------------------------------------- 353 | 354 | module Substitution 355 | (Tm : (Γ : Ctx) → (a : Ty) → Set) 356 | (var : {Γ : Ctx} → {a : Ty} → (v : Var Γ a) → Tm Γ a) 357 | (wkTm : {Γ' Γ : Ctx} → {a : Ty} → (w : Γ ⊆ Γ') → (t : Tm Γ a) → Tm Γ' a) 358 | (Acc : (Δ Γ ΓR : Ctx) → Set) 359 | {newR : (Γ : Ctx) → Ctx} 360 | (new : ∀ {Γ : Ctx} → Acc (Γ #) Γ (newR Γ)) 361 | (lCtx : {Δ Γ ΓR Δ' : Ctx} → (e : Acc Δ Γ ΓR) → (w : Δ ⊆ Δ') → Ctx) 362 | (factorWk : ∀ {Δ Γ ΓR Δ' : Ctx} (e : Acc Δ Γ ΓR) (w : Δ ⊆ Δ') → Γ ⊆ lCtx e w) 363 | (rCtx : {Δ Γ ΓR Δ' : Ctx} → (e : Acc Δ Γ ΓR) → (w : Δ ⊆ Δ') → Ctx) 364 | (factorExt : ∀ {Δ Γ ΓR Δ' : Ctx} (e : Acc Δ Γ ΓR) (w : Δ ⊆ Δ') → Acc Δ' (lCtx e w) (rCtx e w)) 365 | where 366 | 367 | data Sub : Ctx → Ctx → Set where 368 | [] : Sub Δ [] 369 | _`,_ : (σ : Sub Δ Γ) → (t : Tm Δ a) → Sub Δ (Γ `, a) 370 | lock : (σ : Sub ΔL Γ) → (e : Acc Δ ΔL ΔR) → Sub Δ (Γ #) 371 | 372 | Sub- : Ctx → Ctx → Set 373 | Sub- Δ Γ = Sub Γ Δ 374 | 375 | variable 376 | s s' s'' : Sub Δ Γ 377 | σ σ' σ'' : Sub Δ Γ 378 | τ τ' τ'' : Sub Δ Γ 379 | 380 | -- composition operation for weakening after substitution 381 | trimSub : Δ ⊆ Γ → Sub Γ' Γ → Sub Γ' Δ 382 | trimSub base [] = [] 383 | trimSub (drop w) (s `, x) = trimSub w s 384 | trimSub (keep w) (s `, x) = (trimSub w s) `, x 385 | trimSub (keep# w) (lock s x) = lock (trimSub w s) x 386 | 387 | -- apply substitution to a variable 388 | substVar : Sub Γ Δ → Var Δ a → Tm Γ a 389 | substVar (s `, t) zero = t 390 | substVar (s `, _t) (succ v) = substVar s v 391 | 392 | -- weaken a substitution 393 | wkSub : Γ ⊆ Γ' → Sub Γ Δ → Sub Γ' Δ 394 | wkSub w [] = [] 395 | wkSub w (s `, t) = wkSub w s `, wkTm w t 396 | wkSub w (lock s e) = lock (wkSub (factorWk e w) s) (factorExt e w) 397 | 398 | -- NOTE: composition requires parallel substitution for terms 399 | 400 | -- "drop" the last variable in the context 401 | dropₛ : Sub Γ Δ → Sub (Γ `, a) Δ 402 | dropₛ s = wkSub fresh s 403 | 404 | -- "keep" the last variable in the context 405 | keepₛ : Sub Γ Δ → Sub (Γ `, a) (Δ `, a) 406 | keepₛ s = dropₛ s `, var zero 407 | 408 | -- "keep" the lock in the context 409 | keep#ₛ : Sub Γ Δ → Sub (Γ #) (Δ #) 410 | keep#ₛ s = lock s new 411 | 412 | -- embed a weakening to substitution 413 | embWk : Δ ⊆ Γ → Sub Γ Δ 414 | embWk base = [] 415 | embWk (drop w) = dropₛ (embWk w) 416 | embWk (keep w) = keepₛ (embWk w) 417 | embWk (keep# w) = keep#ₛ (embWk w) 418 | 419 | -- identity substitution 420 | idₛ : Sub Γ Γ 421 | idₛ = embWk idWk 422 | 423 | idₛ[_] = λ Γ → idₛ {Γ} 424 | 425 | ExtToSub : Acc Γ ΓL ΓR → Sub Γ (ΓL #) 426 | ExtToSub e = lock idₛ e 427 | 428 | module Composition 429 | (substTm : {Δ Γ : Ctx} → {a : Ty} → (σ : Sub Δ Γ) → (t : Tm Γ a) → Tm Δ a) 430 | (lCtxₛ : {Δ Γ ΓR Θ : Ctx} → (e : Acc Δ Γ ΓR) → (σ : Sub Θ Δ) → Ctx) 431 | (factorSubₛ : ∀ {Δ Γ ΓR Θ : Ctx} (e : Acc Δ Γ ΓR) (σ : Sub Θ Δ) → Sub (lCtxₛ e σ) Γ) 432 | (rCtxₛ : {Δ Γ ΓR Θ : Ctx} → (e : Acc Δ Γ ΓR) → (σ : Sub Θ Δ) → Ctx) 433 | (factorExtₛ : ∀ {Δ Γ ΓR Θ : Ctx} (e : Acc Δ Γ ΓR) (σ : Sub Θ Δ) → Acc Θ (lCtxₛ e σ) (rCtxₛ e σ)) 434 | where 435 | 436 | infixr 20 _∙ₛ_ 437 | 438 | -- substitution composition 439 | _∙ₛ_ : Sub Δ Γ → Sub Δ' Δ → Sub Δ' Γ 440 | [] ∙ₛ s = [] 441 | (s' `, t) ∙ₛ s = s' ∙ₛ s `, substTm s t 442 | lock s' e ∙ₛ s = lock (s' ∙ₛ factorSubₛ e s) (factorExtₛ e s) 443 | -------------------------------------------------------------------------------- /src/EUtil.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module EUtil where 3 | 4 | open import Data.Empty using (⊥-elim) 5 | 6 | open import Relation.Nullary using (¬_) 7 | 8 | contradiction : ∀ {A B : Set} → (a : A) → (¬a : ¬ A) → B 9 | contradiction a ¬a = ⊥-elim (¬a a) 10 | -------------------------------------------------------------------------------- /src/Everything.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module Everything where 3 | 4 | import Type 5 | import Context 6 | 7 | import IK.Term 8 | import IK.Term.Conversion 9 | import IK.Term.NormalForm 10 | import IK.Term.Reduction 11 | 12 | import IK.Norm 13 | import IK.Norm.NbE.Model 14 | import IK.Norm.NbE.Reification 15 | import IK.Norm.Properties.Completeness 16 | import IK.Norm.Properties.Soundness 17 | import IK.Norm.Properties.Soundness.Trace 18 | 19 | import IK.Applications.Experiments 20 | import IK.Applications.Neutrality 21 | import IK.Applications.WeakNorm 22 | 23 | import IS4.Term 24 | import IS4.Term.Conversion 25 | import IS4.Term.NormalForm 26 | import IS4.Term.Reduction 27 | 28 | import Semantics.Clouston.Evaluation.IML 29 | import Semantics.Clouston.Evaluation.IS4 30 | 31 | import Semantics.Presheaf.Base 32 | import Semantics.Presheaf.CartesianClosure 33 | import Semantics.Presheaf.Evaluation.IML 34 | import Semantics.Presheaf.Evaluation.IS4 35 | import Semantics.Presheaf.Necessity 36 | 37 | import IS4.Norm 38 | import IS4.Norm.NbE.Model 39 | import IS4.Norm.NbE.Reification 40 | import IS4.Norm.Properties.Completeness 41 | import IS4.Norm.Properties.Soundness 42 | 43 | import IS4.Applications.IS4Plus 44 | import IS4.Applications.Purity 45 | -------------------------------------------------------------------------------- /src/FunExt.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module FunExt where 3 | 4 | open import Level renaming (zero to ℓ0) 5 | open import Relation.Binary.PropositionalEquality using (_≡_; trans) 6 | open import Axiom.Extensionality.Propositional 7 | 8 | postulate 9 | funext : Extensionality ℓ0 ℓ0 10 | 11 | funexti' : ∀ {A : Set} {B : A → Set} {f g : {x : A} → B x} 12 | → ((x : A) → f {x} ≡ g {x}) → _≡_ {A = {x : A} → B x} f g 13 | funexti' x = implicit-extensionality funext (x _) 14 | -------------------------------------------------------------------------------- /src/HEUtil.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --with-K #-} 2 | module HEUtil where 3 | 4 | infixr 2 step-≅ 5 | 6 | open import Level using (Level) 7 | 8 | open import Relation.Unary using (Pred) 9 | 10 | open import Relation.Binary using (REL) 11 | import Relation.Binary.HeterogeneousEquality as HE 12 | open import Relation.Binary.PropositionalEquality 13 | using (_≡_ ; subst ; subst₂) 14 | renaming (refl to ≡-refl ; trans to ≡-trans) 15 | 16 | open HE public 17 | using (_≅_ ; ≅-to-≡ ; ≡-to-≅ ; ≡-subst-removable) 18 | renaming (refl to ≅-refl ; sym to ≅-sym ; trans to ≅-trans ; icong to ≅-cong) 19 | 20 | private 21 | variable 22 | ℓ : Level 23 | A : Set ℓ 24 | B : Set ℓ 25 | 26 | ≡-subst-addable : ∀ (P : Pred A ℓ) {x y} (eq : x ≡ y) (z : P x) → z ≅ subst P eq z 27 | ≡-subst-addable P p z = ≅-sym (≡-subst-removable P p z) 28 | 29 | -- stole it from history of master 30 | ≡-subst₂-removable : ∀ (R : REL A B ℓ) {x y u v} (eq₁ : x ≡ y) (eq₂ : u ≡ v) (z : R x u) → subst₂ R eq₁ eq₂ z ≅ z 31 | ≡-subst₂-removable P ≡-refl ≡-refl z = ≅-refl 32 | 33 | ≡-subst₂-addable : ∀ (R : REL A B ℓ) {x y u v} (eq₁ : x ≡ y) (eq₂ : u ≡ v) (z : R x u) → z ≅ subst₂ R eq₁ eq₂ z 34 | ≡-subst₂-addable P p q z = ≅-sym (≡-subst₂-removable P p q z) 35 | 36 | step-≅ : ∀ (x {y z} : A) → y ≡ z → x ≅ y → x ≡ z 37 | step-≅ _ y≡z x≅y = ≡-trans (≅-to-≡ x≅y) y≡z 38 | 39 | syntax step-≅ x y≡z x≅y = x ≅⟨ x≅y ⟩ y≡z 40 | 41 | -- Custom combinator to prove syntactic lemmas about unbox, lock, etc. 42 | module _ 43 | {C : Set} 44 | (T : C → Set) -- Type of indexed sets (terms, etc.) 45 | (E : C → C → Set) -- Type of context extensions 46 | {R : {ΓL ΓR : C} → T ΓL → E ΓL ΓR → Set} -- ... (unbox, lock, etc.) 47 | where 48 | 49 | xcong : {i1 i2 j1 j2 : C} → 50 | i1 ≡ i2 → j1 ≡ j2 → 51 | {t1 : T i1} {t2 : T i2} {e1 : E i1 j1} {e2 : E i2 j2} 52 | (unb : {i j : C} → (t : T i ) (e : E i j) → R t e) → 53 | t1 ≅ t2 → 54 | e1 ≅ e2 → 55 | unb t1 e1 ≅ unb t2 e2 56 | xcong ≡-refl ≡-refl _ ≅-refl ≅-refl = ≅-refl 57 | -------------------------------------------------------------------------------- /src/IK/Applications/Experiments.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module IK.Applications.Experiments where 3 | 4 | import Context 5 | 6 | open import IK.Norm.Base 7 | open import IK.Term 8 | 9 | open import IK.Applications.Neutrality 10 | 11 | open import Data.Empty 12 | open import Relation.Nullary 13 | open import Relation.Binary.PropositionalEquality 14 | 15 | -- if `a` isn't a subformula (sf) of `Γ`, 16 | -- then it isn't a sf of its prefix. 17 | sfPrefix : ¬ (a ⊲ᶜ Γ) → Ext θ Γ ΓL ΓR → ¬ (a ⊲ᶜ ΓL) 18 | sfPrefix noA nil = noA 19 | sfPrefix noA (ext e) = sfPrefix (λ z → noA (there z)) e 20 | sfPrefix noA (ext# x e) = sfPrefix (λ z → noA (there# z)) e 21 | 22 | -- if ι is not a subformula of Γ, then any normal form 23 | -- of the type `Nf Γ (ι ⇒ ι)` must be the identity function 24 | uniqIdFun : ¬ (ι ⊲ᶜ Γ) → (n : Nf Γ (ι ⇒ ι)) → n ≡ lam (up (var zero)) 25 | uniqIdFun noB (lam (up (var zero))) = refl 26 | uniqIdFun noB (lam (up (var (succ x)))) = ⊥-elim (noB (neutrVar x)) 27 | uniqIdFun noB (lam (up (app m n))) with neutrality m 28 | ... | there p = 29 | ⊥-elim (noB (⊲-lift (sbr⇒ ⊲-refl) p)) 30 | uniqIdFun noB (lam (up (unbox n (ext e)))) = 31 | ⊥-elim (sfPrefix noB e (⊲-lift (sb□ ⊲-refl) (there# (neutrality n)))) 32 | 33 | -- if there are no boxed-formulas in `Γ`, then there are no neutrals in `Γ #` 34 | noLeftPeek : ({x : Ty} → ¬ (□ x ⊲ᶜ Γ)) → ¬ (Ne (Γ #) a) 35 | noLeftPeek f (app n x) = noLeftPeek f n 36 | noLeftPeek f (unbox n nil) = f (neutrality n) 37 | 38 | -- strengthening relation 39 | data _⋗_ : Ctx → Ctx → Set where 40 | add# : [] ⋗ [#] 41 | keep : Γ ⋗ Δ → (Γ `, a) ⋗ (Δ `, a) 42 | keep# : Γ ⋗ Δ → (Γ #) ⋗ (Δ #) 43 | 44 | -- strengthening is the identity on variables 45 | strenVar : Γ' ⋗ Γ → Var Γ a → Var Γ' a 46 | strenVar (keep w) zero = zero 47 | strenVar (keep w) (succ x) = succ (strenVar w x) 48 | 49 | strenNe : Γ' ⋗ Γ → Ne Γ a → Ne Γ' a 50 | strenNf : Γ' ⋗ Γ → Nf Γ a → Nf Γ' a 51 | 52 | strenNe r (var x) = var (strenVar r x) 53 | strenNe r (app n x) = app (strenNe r n) (strenNf r x) 54 | strenNe add# (unbox n nil) = ⊥-elim (noClosedNe n) 55 | strenNe (keep# r) (unbox n nil) = unbox (strenNe r n) nil 56 | strenNe (keep r) (unbox n (ext x)) = wkNe fresh (strenNe r (unbox n x)) 57 | 58 | strenNf r (up x) = up (strenNe r x) 59 | strenNf r (lam n) = lam (strenNf (keep r) n) 60 | strenNf r (box n) = box (strenNf (keep# r) n) 61 | 62 | -- NOTE: 63 | -- direct induction to show strengthing for terms fails; 64 | -- consider a `t : Tm [] (□ a)` and defining 65 | -- `strenTm : Γ' ⋗ Γ → Tm Γ a → Tm Γ' a`, 66 | -- what should `strenTm add# (unbox t nil) : Tm [] a` be? 67 | 68 | strenTm : Γ' ⋗ Γ → Tm Γ a → Tm Γ' a 69 | strenTm r t = embNf (strenNf r (norm t)) 70 | 71 | module _ where 72 | 73 | -- Show that `a` is a theorem iff `□ a` is a theorem, 74 | -- i.e., [] ⊢ a iff [] ⊢ □ a. 75 | 76 | -- forth : Tm [] a → Tm Γ (□ a) 77 | -- forth t = {!!} 78 | 79 | back : Tm [] (□ a) → Tm [] a 80 | back t = embNf (strenNf add# (norm (unbox t nil))) 81 | 82 | noFreeUnbox : ¬ (Nf [] (□ ι ⇒ ι)) 83 | noFreeUnbox (lam (up (var (succ ())))) 84 | noFreeUnbox (lam (up (app n _))) with neutrality n 85 | ... | here (sb□ ()) 86 | noFreeUnbox (lam (up (unbox x (ext ())))) 87 | 88 | noFreeBox : ¬ (Nf [] (ι ⇒ □ ι)) 89 | noFreeBox (lam (box (up (app n _)))) with neutrality n 90 | ... | there# (here ()) 91 | ... | there# (there ()) 92 | noFreeBox (lam (box (up (unbox (var (succ ())) nil)))) 93 | noFreeBox (lam (box (up (unbox (app n _) nil)))) with neutrality n 94 | ... | here () 95 | ... | there () 96 | noFreeBox (lam (box (up (unbox (unbox _ (ext ())) nil)))) 97 | -------------------------------------------------------------------------------- /src/IK/Applications/Neutrality.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module IK.Applications.Neutrality where 3 | 4 | open import Data.Empty 5 | 6 | open import Relation.Binary using (Transitive) 7 | 8 | open import IK.Norm.Base 9 | open import IK.Term 10 | 11 | infixr 3 _⊲_ 12 | infixr 3 _⊲ᶜ_ 13 | 14 | -- positive subformulas? 15 | data _⊲_ : Ty → Ty → Set where 16 | ⊲-refl : a ⊲ a 17 | sbr⇒ : a ⊲ c → a ⊲ (b ⇒ c) 18 | sb□ : a ⊲ b → a ⊲ □ b 19 | 20 | data _⊲ᶜ_ : (a : Ty) → (Γ : Ctx) → Set where 21 | here : a ⊲ b → a ⊲ᶜ (Γ `, b) 22 | there : a ⊲ᶜ Γ → a ⊲ᶜ (Γ `, b) 23 | there# : a ⊲ᶜ Γ → a ⊲ᶜ Γ # 24 | 25 | noClosedNe : Ne [] a → ⊥ 26 | noClosedNe (app n x) = noClosedNe n 27 | 28 | neutrVar : Var Γ a → a ⊲ᶜ Γ 29 | neutrVar zero = here ⊲-refl 30 | neutrVar (succ x) = there (neutrVar x) 31 | 32 | ⊲-trans : Transitive _⊲_ 33 | ⊲-trans x ⊲-refl = x 34 | ⊲-trans x (sbr⇒ y) = sbr⇒ (⊲-trans x y) 35 | ⊲-trans x (sb□ y) = sb□ (⊲-trans x y) 36 | 37 | ⊲-lift : a ⊲ b → b ⊲ᶜ Γ → a ⊲ᶜ Γ 38 | ⊲-lift p (here x) = here (⊲-trans p x) 39 | ⊲-lift p (there q) = there (⊲-lift p q) 40 | ⊲-lift p (there# q) = there# (⊲-lift p q) 41 | 42 | neutrality : Ne Γ a → a ⊲ᶜ Γ 43 | neutrality (var x) = neutrVar x 44 | neutrality (app n x) = ⊲-lift (sbr⇒ ⊲-refl) (neutrality n) 45 | neutrality (unbox n nil) = there# (⊲-lift (sb□ ⊲-refl) (neutrality n)) 46 | neutrality (unbox n (ext e)) = there (neutrality (unbox n e)) 47 | -------------------------------------------------------------------------------- /src/IK/Applications/WeakNorm.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module IK.Applications.WeakNorm where 3 | 4 | open import Data.Empty 5 | open import Data.Unit 6 | open import Data.Product using (Σ ; _×_ ; _,_ ; ∃ ; ∃₂) 7 | 8 | open import Relation.Nullary 9 | 10 | open import IK.Norm.Base 11 | open import IK.Norm.Properties.Soundness.Trace 12 | 13 | open import IK.Term 14 | 15 | -- defines a beta-reduction relation (_⟶β_) 16 | BetaRule : {t u : Tm Γ a} → t ⟶ u → Set 17 | BetaRule red-fun = ⊤ 18 | BetaRule exp-fun = ⊥ 19 | BetaRule red-box = ⊤ 20 | BetaRule exp-box = ⊥ 21 | BetaRule (cong-lam r) = BetaRule r 22 | BetaRule (cong-app1 r) = BetaRule r 23 | BetaRule (cong-app2 r) = BetaRule r 24 | BetaRule (cong-box r) = BetaRule r 25 | BetaRule (cong-unbox r) = BetaRule r 26 | 27 | BetaShort : Tm Γ a → Set 28 | BetaShort {Γ} {a} t = {t' : Tm Γ a} → ¬ Σ (t ⟶ t') BetaRule 29 | 30 | neBetaShort : (n : Ne Γ a) → BetaShort (embNe n) 31 | nfBetaShort : (n : Nf Γ a) → BetaShort (embNf n) 32 | 33 | neBetaShort (app (var _) m) (cong-app2 r , p) = nfBetaShort m (r , p) 34 | neBetaShort (app (app n m') m) (cong-app1 r , p) = neBetaShort (app n m') (r , p) 35 | neBetaShort (app (app n m') m) (cong-app2 r , p) = nfBetaShort m (r , p) 36 | neBetaShort (app (unbox n m') m) (cong-app1 r , p) = neBetaShort (unbox n m') (r , p) 37 | neBetaShort (app (unbox n m') m) (cong-app2 r , p) = nfBetaShort m (r , p) 38 | neBetaShort (unbox (app n m') m) (cong-unbox r , p) = neBetaShort (app n m') (r , p) 39 | neBetaShort (unbox (unbox n m') m) (cong-unbox r , p) = neBetaShort (unbox n m') (r , p) 40 | neBetaShort (var x) (exp-fun , p) = p 41 | neBetaShort (var x) (exp-box , p) = p 42 | neBetaShort (app (var x) _) (cong-app1 r , p) = neBetaShort (var x) (r , p) 43 | neBetaShort (app (app n m) _) (exp-fun , p) = p 44 | neBetaShort (app (app n m) _) (exp-box , p) = p 45 | neBetaShort (unbox (var x) _) (cong-unbox r , p) = neBetaShort (var x) (r , p) 46 | neBetaShort (unbox (var x) _) (exp-fun , p) = p 47 | neBetaShort (unbox (var x) _) (exp-box , p) = p 48 | neBetaShort (unbox (app n m) _) (exp-fun , p) = p 49 | neBetaShort (unbox (app n m) _) (exp-box , p) = p 50 | neBetaShort (unbox (unbox n e) _) (exp-fun , p) = p 51 | neBetaShort (unbox (unbox n e) _) (exp-box , p) = p 52 | 53 | nfBetaShort (up x) (r , p) = neBetaShort x (r , p) 54 | nfBetaShort (lam n) (cong-lam r , p) = nfBetaShort n (r , p) 55 | nfBetaShort (box n) (cong-box r , p) = nfBetaShort n (r , p) 56 | 57 | -- defines an eta-expansion relation (_⟶η_) 58 | -- TODO: this definition could be very wrong, need to check this up! 59 | EtaRule : (t : Tm Γ a) → {u : Tm Γ a} → t ⟶ u → Set 60 | EtaRule _ red-fun = ⊥ 61 | EtaRule _ red-box = ⊥ 62 | EtaRule (lam t) exp-fun = ⊥ 63 | EtaRule (box t) exp-box = ⊥ 64 | EtaRule _ (cong-app1 r) = ⊥ 65 | EtaRule _ (cong-unbox r) = ⊥ 66 | EtaRule _ exp-fun = ⊤ 67 | EtaRule _ exp-box = ⊤ 68 | EtaRule _ (cong-lam r) = EtaRule _ r 69 | EtaRule _ (cong-app2 r) = EtaRule _ r 70 | EtaRule _ (cong-box r) = EtaRule _ r 71 | 72 | -- NOTE: Eta expansion must not create a β-redex, thus they 73 | -- cannot be performed on constructors (lam, box) 74 | -- or in an elimination frame (app [.] m, unbox [.] e) 75 | -- c.f. η-rules in "Extensional rewriting with sums" by Lindley (after Proposition 4) 76 | 77 | EtaLong : Tm Γ a → Set 78 | EtaLong {Γ} {a} t = {t' : Tm Γ a} → ¬ Σ (t ⟶ t') (EtaRule t) 79 | 80 | -- Note: not all neutrals are eta-long, only ones of base type 81 | neEtaLong : (n : Ne Γ ι) → EtaLong (embNe n) 82 | nfEtaLong : (n : Nf Γ a) → EtaLong (embNf n) 83 | 84 | neEtaLong (app (var _) m) (cong-app2 r , p) = nfEtaLong m (r , p) 85 | neEtaLong (app (app _ _) m) (cong-app2 r , p) = nfEtaLong m (r , p) 86 | neEtaLong (app (unbox _ _) m) (cong-app2 r , p) = nfEtaLong m (r , p) 87 | neEtaLong (unbox (var _) _) (cong-unbox r , p) = p 88 | neEtaLong (unbox (app _ _) _) (cong-unbox r , p) = p 89 | neEtaLong (unbox (unbox _ _) _) (cong-unbox r , p) = p 90 | 91 | nfEtaLong (up x) (r , p) = neEtaLong x (r , p) 92 | nfEtaLong (lam _) (exp-fun , p) = p 93 | nfEtaLong (lam n) (cong-lam r , p) = nfEtaLong n (r , p) 94 | nfEtaLong (box _) (exp-box , p) = p 95 | nfEtaLong (box n) (cong-box r , p) = nfEtaLong n (r , p) 96 | 97 | BetaEtaNormal : (t : Tm Γ a) → Set 98 | BetaEtaNormal t = BetaShort t × EtaLong t 99 | 100 | WeakNorm : (t : Tm Γ a) → Set 101 | WeakNorm {Γ} {a} t = Σ (Nf Γ a) λ n → (t ⟶* embNf n) × BetaEtaNormal (embNf n) 102 | 103 | weakNorm : (t : Tm Γ a) → WeakNorm t 104 | weakNorm t = n , trace t , nfBetaShort n , nfEtaLong n 105 | where n = norm t 106 | -------------------------------------------------------------------------------- /src/IK/Norm.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module IK.Norm where 3 | 4 | open import IK.Norm.Base public 5 | open import IK.Norm.Properties.Completeness public 6 | open import IK.Norm.Properties.Soundness public 7 | -------------------------------------------------------------------------------- /src/IK/Norm/Base.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module IK.Norm.Base where 3 | 4 | open import Data.Unit using (⊤ ; tt) 5 | open import Data.Product using (Σ ; _×_ ; _,_) 6 | 7 | open import IK.Norm.NbE.Model 8 | open import IK.Norm.NbE.Reification 9 | 10 | open import IK.Term 11 | 12 | ------------------------- 13 | -- Normalization function 14 | ------------------------- 15 | 16 | -- retraction of interpretation 17 | quot : (Sub'- Γ →̇ Tm'- a) → Nf Γ a 18 | quot f = reify (f idₛ') 19 | 20 | -- normalization function 21 | norm : Tm Γ a → Nf Γ a 22 | norm t = quot (eval t) 23 | 24 | ---------------------------------- 25 | -- Normalization for substitutions 26 | ---------------------------------- 27 | 28 | -- (simply "do everything pointwise") 29 | 30 | -- retraction of evalₛ 31 | quotₛ : Sub'- Γ →̇ Nfₛ- Γ 32 | quotₛ {[]} tt = [] 33 | quotₛ {Γ `, _} (s , x) = (quotₛ s) `, (reify x) 34 | quotₛ {Γ #} (lock s e) = lock (quotₛ s) e 35 | 36 | -- normalization function, for substitutions 37 | normₛ : Sub Δ Γ → Nfₛ Δ Γ 38 | normₛ s = quotₛ (evalₛ s idₛ') 39 | -------------------------------------------------------------------------------- /src/IK/Norm/NbE/Model.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module IK.Norm.NbE.Model where 3 | 4 | open import Data.Unit using (⊤ ; tt) 5 | open import Data.Product using (Σ ; _×_ ; _,_) 6 | 7 | open import Relation.Binary.PropositionalEquality using (_≡_ ; subst ; refl ; sym ; trans ; cong ; cong₂) 8 | 9 | open import IK.Term 10 | 11 | open import FunExt 12 | 13 | ------------ 14 | -- NbE Model 15 | ------------ 16 | 17 | -- family of maps between interpretations 18 | _→̇_ : (Ctx → Set) → (Ctx → Set) → Set 19 | _→̇_ A B = {Δ : Ctx} → A Δ → B Δ 20 | 21 | -- semantic counterpart of `box` from `Tm` 22 | record Box (A : Ctx → Set) (Γ : Ctx) : Set where 23 | constructor box' 24 | field 25 | unbox' : A (Γ #) 26 | 27 | -- semantic counterpart of `lock` from `Sub` 28 | data Lock (A : Ctx → Set) : Ctx → Set where 29 | lock : A ΓL → LFExt Γ (ΓL #) ΓR → Lock A Γ 30 | -- equivalently, `lock : #-free Γ' → A Γ → Lock A (Γ # ,, Γ')` 31 | 32 | -- interpretation of types 33 | 34 | Tm' : Ctx → Ty → Set 35 | Tm' Γ ι = Nf Γ ι 36 | Tm' Γ (a ⇒ b) = {Γ' : Ctx} → Γ ⊆ Γ' → (Tm' Γ' a → Tm' Γ' b) 37 | Tm' Γ (□ a) = Box (λ Γ' → Tm' Γ' a) Γ 38 | 39 | Tm'- : Ty → Ctx → Set 40 | Tm'- a Γ = Tm' Γ a 41 | 42 | -- interpretation of contexts 43 | Sub' : Ctx → Ctx → Set 44 | Sub' Δ [] = ⊤ 45 | Sub' Δ (Γ `, a) = Sub' Δ Γ × Tm' Δ a 46 | Sub' Δ (Γ #) = Lock (λ Γ' → Sub' Γ' Γ) Δ 47 | 48 | Sub'- : Ctx → Ctx → Set 49 | Sub'- Δ Γ = Sub' Γ Δ 50 | 51 | -- values in the model can be weakened 52 | wkTm' : Γ ⊆ Γ' → Tm' Γ a → Tm' Γ' a 53 | wkTm' {a = ι} e n = wkNf e n 54 | wkTm' {a = a ⇒ b} e f = λ e' y → f (e ∙ e') y 55 | wkTm' {a = □ a} e b = let box' x = b in box' (wkTm' (keep# e) x) 56 | 57 | -- substitutions in the model can be weakened 58 | wkSub' : Γ ⊆ Γ' → Sub' Γ Δ → Sub' Γ' Δ 59 | wkSub' {Δ = []} w tt = tt 60 | wkSub' {Δ = Δ `, a} w (s , x) = wkSub' w s , wkTm' w x 61 | wkSub' {Δ = Δ #} w (lock s e) = lock (wkSub' (sliceLeft e w) s) (wkLFExt e w) 62 | 63 | -- semantic counterpart of `unbox` from `Tm` 64 | unbox' : Box (λ Δ → Tm' Δ a) ΓL → LFExt Γ (ΓL #) ΓR → Tm' Γ a 65 | unbox' b e = let box' x = b in wkTm' (LFExtToWk e) x 66 | 67 | unlock' : Sub' Δ (Γ #) → Σ (Ctx × Ctx) λ { (ΔL , ΔR) → Sub' ΔL Γ × LFExt Δ (ΔL #) ΔR } 68 | unlock' (lock γ e) = _ , γ , e 69 | 70 | -- interpretation of variables 71 | substVar' : Var Γ a → (Sub'- Γ →̇ Tm'- a) 72 | substVar' zero (_ , x) = x 73 | substVar' (succ v) (γ , _) = substVar' v γ 74 | 75 | LFExt' : LFExt Γ (ΓL #) ΓR → Sub'- Γ →̇ Sub'- (ΓL #) 76 | LFExt' nil γ = γ -- = id 77 | LFExt' (ext e) (γ , _) = LFExt' e γ -- = LFExt' e ∘ π₁ 78 | 79 | -- interpretation of terms 80 | eval : Tm Γ a → (Sub'- Γ →̇ Tm'- a) 81 | eval (var v) s = substVar' v s 82 | eval (lam t) s = λ e x → eval t (wkSub' e s , x) 83 | eval (app t u) s = (eval t s) idWk (eval u s) 84 | eval (box t) s = box' (eval t (lock s new)) 85 | eval (unbox t e) s = let (_ , s' , e') = unlock' (LFExt' e s) in unbox' (eval t s') e' -- = ^(eval t) ∘ LFExt' e 86 | 87 | -- interpretation of substitutions (simply "do everything pointwise") 88 | evalₛ : Sub Γ Δ → Sub'- Γ →̇ Sub'- Δ 89 | evalₛ [] γ = tt 90 | evalₛ (s `, t) γ = evalₛ s γ , eval t γ 91 | evalₛ (lock s e) γ = let (_ , γ' , e') = unlock' (LFExt' e γ) in lock (evalₛ s γ') e' -- = Lock (evalₛ s ∘ LFExt' e) 92 | 93 | ----------------------------- 94 | -- Presheaf refinement of Tm' 95 | ----------------------------- 96 | 97 | -- Used to ensure that the domain of interpretation is indeed presheafs 98 | Psh : Tm' Γ a → Set 99 | Psh {Γ} {ι} n = ⊤ 100 | Psh {Γ} {a ⇒ b} f = ∀ {Γ' : Ctx} (w : Γ ⊆ Γ') 101 | → (x : Tm' Γ' a) → Psh x 102 | -- naturality of presheaf exponentials 103 | → ({Γ⁰ : Ctx} → (w' : Γ' ⊆ Γ⁰) → f (w ∙ w') (wkTm' w' x) ≡ wkTm' w' (f w x)) 104 | × Psh (f w x) 105 | Psh {Γ} {□ a} b = let box' x = b in Psh x 106 | 107 | -- Psh extended to interpretation of contexts 108 | Pshₛ : Sub' Γ Δ → Set 109 | Pshₛ {Γ} {[]} tt = ⊤ 110 | Pshₛ {Γ} {Δ `, a} (s , x) = Pshₛ s × Psh x 111 | Pshₛ {Γ} {Δ #} (lock s e) = Pshₛ s 112 | 113 | ----------------------------------- 114 | -- Psh(ₛ) is preserved by weakening 115 | ----------------------------------- 116 | 117 | -- wkTm' preserves Psh 118 | wkTm'PresPsh : (w : Γ ⊆ Γ') (x : Tm' Γ a) → Psh x → Psh (wkTm' w x) 119 | wkTm'PresPsh {a = ι} w n p = tt 120 | wkTm'PresPsh {a = a ⇒ b} w f p = λ w' y q → 121 | -- nf gives us that f obeys naturality (ind. hyp enabled by PSh) 122 | -- pfx gives us that the codomain of f is a presheaf, i.e., `PSh (f _ x)` 123 | let (nf , pfx) = p (w ∙ w') y q 124 | in (λ {Γ⁰} w'' → 125 | subst (λ z → f z _ ≡ wkTm' _ _) (assocWk w w' w'') (nf w'')) 126 | , pfx 127 | wkTm'PresPsh {a = □ a} w b p = let box' x = b in wkTm'PresPsh (keep# w) x p 128 | 129 | -- wkSub' preserves Pshₛ 130 | wkSub'PresPsh : (w : Γ ⊆ Γ') (s : Sub' Γ Δ) → Pshₛ s → Pshₛ (wkSub' w s) 131 | wkSub'PresPsh {Δ = []} w s p = 132 | tt 133 | wkSub'PresPsh {Δ = Δ `, a} w (s , x) (ps , px) = 134 | wkSub'PresPsh w s ps , wkTm'PresPsh w x px 135 | wkSub'PresPsh {Δ = Δ #} w (lock s e) p = 136 | wkSub'PresPsh (sliceLeft e w) s p 137 | 138 | ------------------------- 139 | -- `Tm'- a` is a presheaf 140 | ------------------------- 141 | 142 | -- Given `a : Ty`, 143 | -- (object map) Tm'- a : Ctx → Set 144 | -- (morphism map) wkTm' : Γ' ≤ Γ → Tm'- a Γ → Tm'- a Γ' 145 | 146 | -- identity functor law of `Tm'- a` 147 | wkTm'PresId : (x : Tm' Γ a) → wkTm' idWk x ≡ x 148 | wkTm'PresId {a = ι} n 149 | = wkNfPresId n 150 | wkTm'PresId {a = a ⇒ b} f 151 | = funexti' (λ _ → funext (λ _ → cong f (leftIdWk _))) 152 | wkTm'PresId {a = □ a} b 153 | = let box' x = b in cong box' (wkTm'PresId x) 154 | 155 | -- composition functor law of `Tm'- a` 156 | wkTm'Pres∙ : (w : Γ ⊆ Γ') (w' : Γ' ⊆ Γ'') (x : Tm' Γ a) 157 | → wkTm' w' (wkTm' w x) ≡ wkTm' (w ∙ w') x 158 | wkTm'Pres∙ {a = ι} w w' n 159 | = wkNfPres∙ w w' n 160 | wkTm'Pres∙ {a = a ⇒ b} w w' f 161 | = funexti' (λ _ → funext (λ w'' → 162 | cong f (sym (assocWk w w' w'')))) 163 | wkTm'Pres∙ {a = □ a} w w' b 164 | = let box' x = b in cong box' (wkTm'Pres∙ (keep# w) (keep# w') x) 165 | 166 | -------------------------- 167 | -- `Sub'- Δ` is a presheaf 168 | -------------------------- 169 | 170 | -- Given `Δ : Ctx`, 171 | -- (object map) Sub'- Δ : Ctx → Set 172 | -- (morphism map) wkSub' : Γ' ≤ Γ → Sub'- Δ Γ → Sub'- Δ Γ' 173 | 174 | -- identity functor law of `Sub'- Γ` 175 | wkSub'PresId : (s : Sub' Γ Δ) → wkSub' idWk s ≡ s 176 | wkSub'PresId {Δ = []} tt = refl 177 | wkSub'PresId {Δ = Δ `, a} (s , x) = cong₂ _,_ (wkSub'PresId s) (wkTm'PresId x) 178 | wkSub'PresId {Δ = Δ #} (lock s e) with ←#IsPre# e | #→IsPost# e 179 | ... | refl | refl = cong₂ lock 180 | (trans (cong₂ wkSub' (sliceLeftId e) refl) (wkSub'PresId s)) 181 | (wkLFExtPresId e) 182 | 183 | -- composition functor law of `Sub'- Γ` 184 | wkSub'Pres∙ : (w : Γ ⊆ Γ') (w' : Γ' ⊆ Γ'') (s : Sub' Γ Δ) 185 | → wkSub' w' (wkSub' w s) ≡ wkSub' (w ∙ w') s 186 | wkSub'Pres∙ {Δ = []} w w' tt = refl 187 | wkSub'Pres∙ {Δ = Δ `, a} w w' (s , x) = cong₂ _,_ (wkSub'Pres∙ w w' s) (wkTm'Pres∙ w w' x) 188 | wkSub'Pres∙ {Δ = Δ #} w w' (lock s e) = cong₂ lock 189 | (trans (wkSub'Pres∙ _ _ s) (cong₂ wkSub' (sliceLeftPres∙ w w' e) refl)) 190 | (wkLFExtPres∙ w w' e) 191 | 192 | ------------------------------------------- 193 | -- `subsVar' x` is a natural transformation 194 | ------------------------------------------- 195 | 196 | -- for `v : Var Γ a`, 197 | -- substVar v : Sub'- Γ →̇ Tm'- a 198 | 199 | -- naturality of substVar' 200 | nat-substVar' : (w : Δ ⊆ Δ') (x : Var Γ a) (s : Sub' Δ Γ) 201 | → substVar' x (wkSub' w s) ≡ wkTm' w (substVar' x s) 202 | nat-substVar' w zero s = refl 203 | nat-substVar' w (succ v) (s , _) = nat-substVar' w v s 204 | 205 | -- substVar' obeys Psh 206 | psh-substVar' : (x : Var Γ a) (s : Sub' Δ Γ) → Pshₛ s → Psh (substVar' x s) 207 | psh-substVar' zero (_ , x) (_ , px) = px 208 | psh-substVar' (succ v) (s , _) (ps , _) = psh-substVar' v s ps 209 | 210 | --------------------------------------- 211 | -- `eval t` is a natural transformation 212 | --------------------------------------- 213 | 214 | -- for `t : Tm Γ a`, 215 | -- eval t : Sub'- Γ →̇ Tm'- a 216 | 217 | -- (mutually defined functions below) 218 | 219 | -- result of evaluation is in Psh 220 | psh-eval : (t : Tm Γ a) (s : Sub' Δ Γ) 221 | → Pshₛ s → Psh (eval t s) 222 | -- naturality of `eval t` 223 | nat-eval : (t : Tm Γ a) (w : Δ ⊆ Δ') (s : Sub' Δ Γ) 224 | → Pshₛ s → eval t (wkSub' w s) ≡ wkTm' w (eval t s) 225 | 226 | -- psh-eval 227 | psh-eval (var v) s ps 228 | = psh-substVar' v s ps 229 | psh-eval (lam t) s ps 230 | = λ w x px 231 | → (λ w' → trans 232 | -- rewrite using wkSub'Pres∙ 233 | (cong (λ z → (eval t (z , _))) (sym (wkSub'Pres∙ w w' s))) 234 | -- follows directly from nat-eval 235 | (nat-eval t w' (wkSub' w s , x) (wkSub'PresPsh w s ps , px))) 236 | , (psh-eval t _ (wkSub'PresPsh w s ps , px)) 237 | psh-eval (app t u) s ps 238 | = let (_ , fxp) = psh-eval t s ps idWk _ (psh-eval u s ps) in fxp 239 | psh-eval (box t) s ps 240 | = psh-eval t (lock s new) ps 241 | psh-eval (unbox t nil) (lock s e') ps with eval t s | psh-eval t s ps 242 | ... | b | px 243 | = let box' x = b in wkTm'PresPsh (LFExtToWk e') x px 244 | psh-eval (unbox t (ext e)) (s , _) (ps , _) 245 | = psh-eval (unbox t e) s ps 246 | 247 | -- nat-eval 248 | nat-eval (var v) w s ps 249 | = nat-substVar' w v s 250 | nat-eval (lam t) w s ps 251 | = funexti' (λ _ → funext λ _ → funext (λ _ 252 | → cong (λ z → eval t (z , _)) (wkSub'Pres∙ _ _ _))) 253 | nat-eval (app t u) w s ps with 254 | (psh-eval t s ps idWk (eval u s) (psh-eval u s ps)) 255 | ... | (g , _) 256 | rewrite nat-eval t w s ps | nat-eval u w s ps 257 | = trans 258 | (cong 259 | (λ z → eval t s z (wkTm' w (eval u s))) 260 | (trans (rightIdWk w) (sym (leftIdWk w)))) 261 | (g w) 262 | nat-eval (box t) w s ps 263 | = cong box' (nat-eval t (keep# w) (lock s new) ps) 264 | nat-eval (unbox t nil) w (lock s e) ps = trans 265 | (cong (λ z → unbox' z (wkLFExt e w)) (nat-eval t (sliceLeft e w) s ps)) 266 | (gsLemma w e (eval t s)) 267 | where 268 | gsLemma : (w : Δ ⊆ Δ') (e : LFExt Δ (ΓL #) ΓR) (x : Tm' ΓL (□ a)) 269 | → unbox' (wkTm' (sliceLeft e w) x) (wkLFExt e w) ≡ wkTm' w (unbox' x e) 270 | gsLemma w e b = let box' x = b in trans (wkTm'Pres∙ _ _ _) 271 | (sym (trans 272 | (wkTm'Pres∙ _ _ _) 273 | (cong (λ z → wkTm' z x) (slicingLemma w e)))) 274 | nat-eval (unbox t (ext e)) w (s , _) (ps , _) 275 | = nat-eval (unbox t e) w s ps 276 | 277 | --------------------------------------- 278 | -- `evalₛ s` is a natural transformation 279 | --------------------------------------- 280 | 281 | -- for `s : Sub Γ Δ`, 282 | -- evalₛ s : Sub'- Γ →̇ Sub'- Δ 283 | 284 | psh-evalₛ : (s : Sub Γ Γ') (s' : Sub' Δ Γ) 285 | → Pshₛ s' → Pshₛ (evalₛ s s') 286 | psh-evalₛ [] s' ps' 287 | = tt 288 | psh-evalₛ (s `, t) s' ps' 289 | = (psh-evalₛ s s' ps') , (psh-eval t s' ps') 290 | psh-evalₛ (lock s nil) (lock s' e) ps' 291 | = psh-evalₛ s s' ps' 292 | psh-evalₛ (lock s (ext e)) (s' , _) (ps' , _) 293 | = psh-evalₛ (lock s e) s' ps' 294 | 295 | -- naturality of evalₛ 296 | nat-evalₛ : (w : Δ ⊆ Δ') (s : Sub Γ' Γ) (s' : Sub' Δ Γ') (ps' : Pshₛ s') 297 | → evalₛ s (wkSub' w s') ≡ wkSub' w (evalₛ s s') 298 | nat-evalₛ w [] s' ps' 299 | = refl 300 | nat-evalₛ w (s `, t) s' ps' 301 | = cong₂ _,_ (nat-evalₛ w s s' ps') (nat-eval t w s' ps') 302 | nat-evalₛ w (lock s nil) (lock s' e) ps' 303 | = cong₂ lock (nat-evalₛ (sliceLeft e w) s s' ps') refl 304 | nat-evalₛ w (lock s (ext e)) (s' , _) (ps' , _) 305 | = nat-evalₛ w (lock s e) s' ps' 306 | 307 | -- semantic counterpart of trimSub 308 | trimSub' : Γ ⊆ Γ' → Sub'- Γ' →̇ Sub'- Γ 309 | trimSub' base tt = tt 310 | trimSub' (drop w) (s , _) = trimSub' w s 311 | trimSub' (keep w) (s , x) = trimSub' w s , x 312 | trimSub' (keep# w) (lock s e) = lock (trimSub' w s) e 313 | 314 | -- naturality of trimSub' 315 | nat-trimSub' : (w' : Δ' ⊆ Δ) (w : Γ ⊆ Γ') (s : Sub' Γ Δ) 316 | → trimSub' w' (wkSub' w s) ≡ wkSub' w (trimSub' w' s) 317 | nat-trimSub' base w tt = refl 318 | nat-trimSub' (drop w') w (s , _) = nat-trimSub' w' w s 319 | nat-trimSub' (keep w') w (s , x) = cong₂ _,_ (nat-trimSub' w' w s) refl 320 | nat-trimSub' (keep# w') w (lock s e) = cong₂ lock (nat-trimSub' w' (sliceLeft e w) s) refl 321 | 322 | -- trimSub' preserves identity 323 | trimSub'PresId : (s : Sub' Γ Δ) → trimSub' idWk s ≡ s 324 | trimSub'PresId {Δ = []} tt = refl 325 | trimSub'PresId {Δ = Δ `, _} (s , _) = cong₂ _,_ (trimSub'PresId s) refl 326 | trimSub'PresId {Δ = Δ #} (lock s e) = cong₂ lock (trimSub'PresId s) refl 327 | 328 | -- semantic counterpart of coh-trimSub-wkVar in Substitution.agda 329 | coh-trimSub'-wkVar' : (w : Γ ⊆ Γ') (s : Sub' Δ Γ') (x : Var Γ a) 330 | → substVar' (wkVar w x) s ≡ substVar' x (trimSub' w s) 331 | coh-trimSub'-wkVar' (drop w) (s , _) zero = coh-trimSub'-wkVar' w s zero 332 | coh-trimSub'-wkVar' (drop w) (s , _) (succ v) = coh-trimSub'-wkVar' w s (succ v) 333 | coh-trimSub'-wkVar' (keep w) (s , _) zero = refl 334 | coh-trimSub'-wkVar' (keep w) (s , _) (succ v) = coh-trimSub'-wkVar' w s v 335 | 336 | -- semantic counterpart of coh-trimSub-wkTm in HellOfSyntacticLemmas.agda 337 | coh-trimSub'-wkTm : (w : Γ ⊆ Γ') (s : Sub' Δ Γ') (t : Tm Γ a) 338 | → eval (wkTm w t) s ≡ eval t (trimSub' w s) 339 | coh-trimSub'-wkTm w s (var v) 340 | = coh-trimSub'-wkVar' w s v 341 | coh-trimSub'-wkTm w s (lam t) 342 | = funexti' (λ _ → funext (λ w' → funext (λ x → 343 | trans 344 | (coh-trimSub'-wkTm (keep w) (wkSub' w' s , x) t) 345 | (cong (λ z → eval t (z , x)) (nat-trimSub' w w' s))))) 346 | coh-trimSub'-wkTm w s (app t u) 347 | = trans 348 | (cong (λ f → f idWk (eval (wkTm w u) s)) (coh-trimSub'-wkTm w s t)) 349 | (cong (eval t (trimSub' w s) idWk) (coh-trimSub'-wkTm w s u)) 350 | coh-trimSub'-wkTm w s (box t) 351 | = cong box' (coh-trimSub'-wkTm (keep# w) (lock s new) t) 352 | coh-trimSub'-wkTm (drop w) (s , _) (unbox t e) 353 | = coh-trimSub'-wkTm w s (unbox t e) 354 | coh-trimSub'-wkTm (keep w) (s , _) (unbox t (ext e)) 355 | = coh-trimSub'-wkTm w s (unbox t e) 356 | coh-trimSub'-wkTm (keep# w) (lock s e) (unbox t nil) 357 | = cong (λ b → unbox' b e) (coh-trimSub'-wkTm w s t) 358 | 359 | -- semantic counterpart of coh-trimSub-wkSub in `HellOfSyntacticLemmas.agda` 360 | coh-trimSub'-wkSub : (w : Γ ⊆ Γ') (s : Sub Γ Δ) (s' : Sub' Δ' Γ') 361 | → evalₛ (wkSub w s) s' ≡ evalₛ s (trimSub' w s') 362 | coh-trimSub'-wkSub w [] s' 363 | = refl 364 | coh-trimSub'-wkSub w (s `, t) s' 365 | = cong₂ _,_ (coh-trimSub'-wkSub w s s') (coh-trimSub'-wkTm w s' t) 366 | coh-trimSub'-wkSub (drop w) (lock s e) (s' , _) 367 | = coh-trimSub'-wkSub w (lock s e) s' 368 | coh-trimSub'-wkSub (keep w) (lock s (ext e)) (s' , _) 369 | = coh-trimSub'-wkSub w (lock s e) s' 370 | coh-trimSub'-wkSub (keep# w) (lock s nil) (lock s' e') 371 | = cong₂ lock (coh-trimSub'-wkSub w s s') refl 372 | 373 | -- evalₛ preserves identity 374 | evalₛPresId : (s' : Sub' Γ Δ) → evalₛ idₛ s' ≡ s' 375 | evalₛPresId {Δ = []} tt 376 | = refl 377 | evalₛPresId {Δ = Δ `, _} (s' , x) 378 | = cong₂ (_,_) 379 | (trans 380 | (coh-trimSub'-wkSub fresh idₛ (s' , x)) 381 | (trans 382 | (cong (evalₛ idₛ) (trimSub'PresId s')) 383 | (evalₛPresId s'))) 384 | refl 385 | evalₛPresId {Δ = Δ #} (lock s' e) 386 | = cong₂ lock (evalₛPresId s') refl 387 | -------------------------------------------------------------------------------- /src/IK/Norm/NbE/Reification.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module IK.Norm.NbE.Reification where 3 | 4 | open import Data.Unit using (⊤ ; tt) 5 | open import Data.Product using (Σ ; _×_ ; _,_) 6 | 7 | open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; sym ; trans ; cong ; cong₂) 8 | 9 | open import FunExt 10 | 11 | open import IK.Norm.NbE.Model 12 | 13 | open import IK.Term 14 | 15 | reify : Tm' Γ a → Nf Γ a 16 | reflect : Ne Γ a → Tm' Γ a 17 | 18 | var0' : Tm' (Γ `, a) a 19 | var0' = reflect (var zero) 20 | 21 | -- interpretation of neutrals 22 | reflect {a = ι} n = up n 23 | reflect {a = a ⇒ b} n = λ e x → reflect (app (wkNe e n) (reify x)) 24 | reflect {a = □ a} n = box' (reflect (unbox n new)) 25 | 26 | -- reify values to normal forms 27 | reify {a = ι} n = n 28 | reify {a = a ⇒ b} f = lam (reify (f (drop idWk) var0')) 29 | reify {a = □ a} b = let box' x = b in box (reify x) 30 | 31 | -- identity substitution 32 | idₛ' : Sub' Γ Γ 33 | idₛ' {[]} = tt 34 | idₛ' {Γ `, x} = wkSub' (drop idWk) idₛ' , var0' 35 | idₛ' {Γ #} = lock (idₛ' {Γ}) new 36 | 37 | ------------------------------------------------ 38 | -- reflect and reify are natural transformations 39 | ------------------------------------------------ 40 | 41 | -- reflect : Ne- a →̇ Tm'- a 42 | -- reify : Tm'- a →̇ Nf'- a 43 | 44 | -- naturality of reflect 45 | nat-reflect : (w : Γ ⊆ Γ') (n : Ne Γ a) → reflect (wkNe w n) ≡ wkTm' w (reflect n) 46 | nat-reflect {a = ι} w n = refl 47 | nat-reflect {a = a ⇒ b} w n = funexti' (λ _ → funext (λ _ → funext (λ _ 48 | → cong (λ z → reflect (app z (reify _))) (wkNePres∙ w _ n)))) 49 | nat-reflect {a = □ a} w n = cong box' (nat-reflect (keep# w) (unbox n nil)) 50 | 51 | -- image of reflect is in Psh 52 | psh-reflect : (n : Ne Γ a) → Psh (reflect n) 53 | -- naturality of reify 54 | nat-reify : (w : Γ ⊆ Γ') (x : Tm' Γ a) → Psh x → reify (wkTm' w x) ≡ wkNf w (reify x) 55 | 56 | -- psh-reflect 57 | psh-reflect {a = ι} n = tt 58 | psh-reflect {a = a ⇒ b} n = λ w x px 59 | → (λ w' → trans 60 | (cong reflect 61 | (cong₂ app (sym (wkNePres∙ _ _ _)) (nat-reify _ _ px))) 62 | (nat-reflect w' (app (wkNe w n) (reify x)))) 63 | , psh-reflect (app (wkNe w n) _) 64 | psh-reflect {a = □ a} n = psh-reflect (unbox n nil) 65 | 66 | -- nat-reify 67 | nat-reify {a = ι} w x pn 68 | = refl 69 | nat-reify {Γ} {a = a ⇒ b} w f pf 70 | = let (nf , pfx) = pf fresh var0' (psh-reflect {Γ = _ `, a} var0) 71 | in cong lam 72 | (trans 73 | (cong reify 74 | (trans 75 | (cong₂ f 76 | (cong drop (trans (rightIdWk _) (sym (leftIdWk _)))) 77 | (nat-reflect (keep w) var0)) 78 | (nf (keep w)))) 79 | (nat-reify (keep w) (f fresh var0') pfx)) 80 | nat-reify {a = □ a} w b pb 81 | = let box' x = b in cong box (nat-reify (keep# w) x pb) 82 | 83 | -- idₛ' is in Pshₛ 84 | psh-idₛ' : Pshₛ (idₛ' {Γ}) 85 | psh-idₛ' {[]} = tt 86 | psh-idₛ' {Γ `, a} = wkSub'PresPsh fresh (idₛ' {Γ}) (psh-idₛ' {Γ}) , psh-reflect {Γ `, a} var0 87 | psh-idₛ' {Γ #} = psh-idₛ' {Γ} 88 | -------------------------------------------------------------------------------- /src/IK/Norm/Properties/Completeness.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module IK.Norm.Properties.Completeness where 3 | 4 | 5 | -- 6 | -- This module proves the soundness of evaluation (eval-sound), 7 | -- from which the completeness of normalization (norm-complete) follows. 8 | -- 9 | 10 | open import Data.Unit 11 | using (⊤ ; tt) 12 | open import Data.Product 13 | using (Σ ; _×_ ; _,_ ; ∃) 14 | 15 | open import Relation.Binary.PropositionalEquality 16 | 17 | open import IK.Norm.Base 18 | 19 | open import IK.Norm.NbE.Model 20 | open import IK.Norm.NbE.Reification 21 | 22 | open import IK.Term 23 | 24 | -- soundness relation on semantic values 25 | _≋_ : Tm' Γ a → Tm' Γ a → Set 26 | _≋_ {Γ} {a = ι} n m 27 | = n ≡ m 28 | _≋_ {Γ} {a = a ⇒ b} f g 29 | = {Γ' : Ctx} (w : Γ ⊆ Γ') → {x y : Tm' Γ' a} 30 | → Psh x → Psh y 31 | → x ≋ y → f w x ≋ g w y 32 | _≋_ {Γ} {a = □ a} b c 33 | = let box' x = b ; box' y = c in x ≋ y 34 | 35 | -- soundness relation on semantic substitutions 36 | data _≋ₛ_ : Sub' Γ Δ → Sub' Γ Δ → Set where 37 | [] : _≋ₛ_ {Γ = Γ} {Δ = []} tt tt 38 | _`,_ : {s : Sub' Γ Δ} {s' : Sub' Γ Δ} {x : Tm' Γ a} {y : Tm' Γ a} 39 | → s ≋ₛ s' → x ≋ y → (s , x) ≋ₛ (s' , y) 40 | lock : {s : Sub' Γ Δ} {s' : Sub' Γ Δ} 41 | → s ≋ₛ s' → (e : LFExt Γ' (Γ #) (ΓR)) 42 | → _≋ₛ_ {Γ = Γ'} {Δ = Δ #} (lock s e) (lock s' e) 43 | 44 | ------------------------ 45 | -- Properties of ≋ and ≋ₛ 46 | ------------------------ 47 | 48 | -- ≋ is symmetric 49 | sym-≋ : {x y : Tm' Γ a} 50 | → x ≋ y → y ≋ x 51 | sym-≋ {a = ι} n≡m 52 | = sym n≡m 53 | sym-≋ {a = a ⇒ b} f≋g 54 | = λ w px' py' x'≋y' → sym-≋ {a = b} (f≋g w py' px' (sym-≋ {a = a} x'≋y')) 55 | sym-≋ {a = □ a} b≋c 56 | = sym-≋ {a = a} b≋c 57 | 58 | -- ≋ is transitive 59 | trans-≋ : {x y z : Tm' Γ a} 60 | → x ≋ y → y ≋ z → x ≋ z 61 | trans-≋ {a = ι} n≡m m≡o 62 | = trans n≡m m≡o 63 | trans-≋ {a = a ⇒ b} {f} {g} {h} f≋g g≋h w {x = x} {y = y} px py x≋y 64 | = trans-≋ {a = b} 65 | (f≋g w px py x≋y) 66 | (g≋h w py py ((trans-≋ {a = a} (sym-≋ {a = a} x≋y) x≋y))) 67 | trans-≋ {a = □ a} b≋c c≋d 68 | = trans-≋ {a = a} b≋c c≋d 69 | 70 | -- WTH should this thing be called? 71 | pseudo-refl-≋ : {x y : Tm' Γ a} 72 | → x ≋ y → x ≋ x 73 | pseudo-refl-≋ {a = a} x≋y = trans-≋ {a = a} x≋y (sym-≋ {a = a} x≋y) 74 | 75 | -- ≋ₛ is symmetric 76 | sym-≋ₛ : {s s' : Sub' Γ Δ} 77 | → s ≋ₛ s' → s' ≋ₛ s 78 | sym-≋ₛ {Δ = []} s≋s' 79 | = s≋s' 80 | sym-≋ₛ {Δ = Δ `, a} (s≋s' `, x≋y) 81 | = sym-≋ₛ s≋s' `, sym-≋ {a = a} x≋y 82 | sym-≋ₛ {Δ = Δ #} (lock s≋s' e) 83 | = lock (sym-≋ₛ s≋s') e 84 | 85 | -- ≋ₛ is transitive 86 | trans-≋ₛ : {s s' s'' : Sub' Γ Δ} 87 | → s ≋ₛ s' → s' ≋ₛ s'' → s ≋ₛ s'' 88 | trans-≋ₛ {Δ = []} s≋s' s'≋s'' 89 | = [] 90 | trans-≋ₛ {Δ = Δ `, a} (s≋s' `, x≋x') (s'≋s'' `, x'≋x'') 91 | = trans-≋ₛ s≋s' s'≋s'' `, trans-≋ {a = a} x≋x' x'≋x'' 92 | trans-≋ₛ {Δ = Δ #} (lock s≋s' e) (lock s'≋s'' e) 93 | = lock (trans-≋ₛ s≋s' s'≋s'') e 94 | 95 | -- WTH should this thing be called? 96 | pseudo-refl-≋ₛ : {s s' : Sub' Γ Δ} 97 | → s ≋ₛ s' → s ≋ₛ s 98 | pseudo-refl-≋ₛ x≋y = trans-≋ₛ x≋y (sym-≋ₛ x≋y) 99 | 100 | -- wkTm' preserves the relation _≋_ 101 | wkTm'Pres≋ : {x : Tm' Γ a} {y : Tm' Γ a} 102 | → (w : Γ ⊆ Δ) 103 | → x ≋ y 104 | → wkTm' w x ≋ wkTm' w y 105 | wkTm'Pres≋ {a = ι} w n≡m 106 | = cong (wkNf w) n≡m 107 | wkTm'Pres≋ {a = a ⇒ b} {x = f} {y = g} w f≋g 108 | = λ w' px py x≋y → f≋g (w ∙ w') px py x≋y 109 | wkTm'Pres≋ {a = □ a} w b≋c 110 | = wkTm'Pres≋ {a = a} (keep# w) b≋c 111 | 112 | -- wkSub' preserves the relation _≋_ 113 | wkSub'Pres≋ : {s s' : Sub' Γ Δ} 114 | → (w : Γ ⊆ Γ') 115 | → s ≋ₛ s' 116 | → wkSub' w s ≋ₛ wkSub' w s' 117 | wkSub'Pres≋ w [] 118 | = [] 119 | wkSub'Pres≋ {Δ = Δ `, a} w (s≋s' `, x) 120 | = wkSub'Pres≋ w s≋s' `, wkTm'Pres≋ {a = a} w x 121 | wkSub'Pres≋ w (lock s≋s e) 122 | = lock (wkSub'Pres≋ (sliceLeft e w) s≋s) (wkLFExt e w) 123 | 124 | -------------------------------------- 125 | -- The Fundamental theorem of ≋ and ≋ₛ 126 | -------------------------------------- 127 | 128 | private 129 | 130 | substVar'Pres≋ : (x : Var Γ a) {s s' : Sub' Δ Γ} 131 | → s ≋ₛ s' 132 | → substVar' x s ≋ substVar' x s' 133 | substVar'Pres≋ zero {s = _ , x} {s' = _ , y} (_ `, x≋y) 134 | = x≋y 135 | substVar'Pres≋ (succ x) {s = s , _} {s' = s' , _} (s≋s' `, _) 136 | = substVar'Pres≋ x s≋s' 137 | 138 | unbox'Pres≋ : {b c : Box (Tm'- a) Γ} 139 | → (e : LFExt Γ' (Γ #) ΓR) 140 | → b ≋ c 141 | → unbox' b e ≋ unbox' c e 142 | unbox'Pres≋ {a = a} e b≋c 143 | = wkTm'Pres≋ {a = a} (LFExtToWk e) b≋c 144 | 145 | -- 146 | fund : (t : Tm Γ a) {s s' : Sub' Δ Γ} 147 | → Pshₛ s → Pshₛ s' 148 | → s ≋ₛ s' → eval t s ≋ eval t s' 149 | fund (var x) ps ps' s≋s' 150 | = substVar'Pres≋ x s≋s' 151 | fund (lam t) {s = s} {s' = s'} ps ps' s≋s' w px py x≋y 152 | = fund t 153 | (wkSub'PresPsh w s ps , px) 154 | (wkSub'PresPsh w s' ps' , py) 155 | (wkSub'Pres≋ w s≋s' `, x≋y) 156 | fund (app t u) {s = s} {s' = s'} ps ps' s≋s' 157 | = fund t ps ps' s≋s' idWk (psh-eval u s ps) (psh-eval u s' ps') (fund u ps ps' s≋s') 158 | fund (box t) ps ps' s≋s' 159 | = fund t ps ps' (lock s≋s' nil) 160 | fund (unbox t nil) {s = lock s e} {s' = lock s' .e} ps ps' (lock s≋s' .e) 161 | = unbox'Pres≋ {b = eval t s} e (fund t ps ps' s≋s') 162 | fund (unbox t (ext e)) (ps , _) (ps' , _) (s≋s' `, _) 163 | = fund (unbox t e) ps ps' s≋s' 164 | 165 | -- 166 | fundₛ : (s₀ : Sub Γ Δ) {s s' : Sub' Δ' Γ} 167 | → Pshₛ s → Pshₛ s' 168 | → s ≋ₛ s' → evalₛ s₀ s ≋ₛ evalₛ s₀ s' 169 | fundₛ [] ps ps' s≋s' 170 | = [] 171 | fundₛ (s₀ `, t) ps ps' s≋s' 172 | = (fundₛ s₀ ps ps' s≋s') `, fund t ps ps' s≋s' 173 | fundₛ (lock s₀ (ext e)) {s = s , _} {s' = s' , _} (ps , _) (ps' , _) (s≋s' `, _) 174 | = fundₛ (lock s₀ e) ps ps' s≋s' 175 | fundₛ (lock s₀ nil) {s = lock s e} {s' = lock s' e} ps ps' (lock s≋s' e) 176 | = lock (fundₛ s₀ ps ps' s≋s') e 177 | 178 | -------------------------- 179 | -- Soundness of evaluation 180 | -------------------------- 181 | 182 | coh-substVar-evalₛ : (x : Var Γ a) (s₀ : Sub Δ Γ) {s s' : Sub' Δ' Δ} 183 | → Pshₛ s → Pshₛ s' → s ≋ₛ s' → substVar' x (evalₛ s₀ s') ≋ eval (substVar s₀ x) s' 184 | coh-substVar-evalₛ zero (_ `, t) {s} {s'} ps ps' s≋s' 185 | = pseudo-refl-≋ {x = eval t s'} (sym-≋ {x = eval t s} (fund t ps ps' s≋s')) 186 | coh-substVar-evalₛ (succ x) (s₀ `, _) ps ps' s≋s' 187 | = coh-substVar-evalₛ x s₀ ps ps' s≋s' 188 | 189 | coh-substTm-evalₛ : (t : Tm Γ a) (s₀ : Sub Δ Γ) {s s' : Sub' Δ' Δ} 190 | → Pshₛ s → Pshₛ s' → s ≋ₛ s' → eval t (evalₛ s₀ s') ≋ eval (substTm s₀ t) s' 191 | coh-substTm-evalₛ (var x) s₀ ps ps' s≋s' 192 | = coh-substVar-evalₛ x s₀ ps ps' s≋s' 193 | coh-substTm-evalₛ (lam t) s₀ {s} {s'} ps ps' s≋s' w {x = x} {y} px py x≋y 194 | rewrite sym (nat-evalₛ w s₀ s' ps') 195 | = trans-≋ {z = eval (substTm (wkSub fresh s₀ `, var zero) t) (wkSub' w s' , y)} 196 | ((subst (λ z → _ ≋ eval t (z , y)) 197 | (trans 198 | (cong (evalₛ s₀) (sym (trimSub'PresId _))) 199 | (sym (coh-trimSub'-wkSub fresh s₀ (wkSub' w s' , y)))) 200 | (fund t 201 | (psh-evalₛ s₀ _ (wkSub'PresPsh w s' ps') , px) 202 | (psh-evalₛ s₀ _ (wkSub'PresPsh w s' ps') , py) 203 | (fundₛ s₀ 204 | (wkSub'PresPsh w s' ps') 205 | (wkSub'PresPsh w s' ps') 206 | (wkSub'Pres≋ w ((pseudo-refl-≋ₛ {s = s'} (sym-≋ₛ s≋s')))) `, x≋y)))) 207 | ((coh-substTm-evalₛ t 208 | (keepₛ s₀) 209 | (wkSub'PresPsh w s ps , px) 210 | (wkSub'PresPsh w s' ps' , py) 211 | (wkSub'Pres≋ w s≋s' `, x≋y))) 212 | coh-substTm-evalₛ (app t u) s₀ ps ps' s≋s' 213 | = coh-substTm-evalₛ t s₀ ps ps' s≋s' idWk 214 | (psh-eval u _ (psh-evalₛ s₀ _ ps')) 215 | (psh-eval (substTm s₀ u) _ ps') 216 | (coh-substTm-evalₛ u s₀ ps ps' s≋s') 217 | coh-substTm-evalₛ (box t) s₀ ps ps' s≋s' 218 | = coh-substTm-evalₛ t (lock s₀ nil) ps ps' (lock s≋s' nil) 219 | coh-substTm-evalₛ (unbox t (ext e)) (s₀ `, _) ps ps' s≋s' 220 | = coh-substTm-evalₛ (unbox t e) s₀ ps ps' s≋s' 221 | coh-substTm-evalₛ (unbox t nil) (lock s₀ (ext e)) (ps , _) (ps' , _) (s≋s' `, _) 222 | = coh-substTm-evalₛ (unbox t nil) (lock s₀ e) ps ps' s≋s' 223 | coh-substTm-evalₛ (unbox t nil) (lock s₀ nil) {s = lock s e} {s' = lock s' e'} ps ps' (lock s≋s' e') 224 | = unbox'Pres≋ {b = eval t (evalₛ s₀ s')} e' (coh-substTm-evalₛ t s₀ ps ps' s≋s') 225 | 226 | private 227 | lemma1 : {t : Tm (ΓL #) a} (e : LFExt Γ (ΓL #) ΓR) {s s' : Sub' Δ Γ} 228 | → Pshₛ s → Pshₛ s' 229 | → s ≋ₛ s' 230 | → eval (unbox (box t) e) s ≋ eval t (trimSub' (LFExtToWk e) s') 231 | lemma1 {t = t} nil {s = lock s e} {s' = lock s' e} ps ps' (lock s≋s' e) 232 | with ←#IsPre# e | #→IsPost# e 233 | ... | refl | refl 234 | rewrite sym (nat-eval t (LFExtToWk e) (lock s nil) ps) 235 | | ExtIsProp (wkLFExt nil (LFExtToWk e)) e 236 | = fund t 237 | (wkSub'PresPsh (sliceLeft nil (LFExtToWk e)) s ps) 238 | (subst Pshₛ (sym (trimSub'PresId s')) ps') 239 | (lock lemma1-2 e) 240 | where 241 | lemma1-1' : ∀ (e : LFExt Γ ΓL ΓR) → (p : ΓL ≡ ←# Γ #) → sliceLeft nil (LFExtToWk (subst (λ ΓL → LFExt Γ ΓL ΓR) p e)) ≡ idWk 242 | lemma1-1' {Γ = Γ #} nil p rewrite Ctx-K p = refl 243 | lemma1-1' {Γ = Γ `, a} (ext e) refl = lemma1-1' e refl 244 | lemma1-1 : ∀ (e : LFExt Γ (←# Γ #) ΓR) → sliceLeft nil (LFExtToWk e) ≡ idWk 245 | lemma1-1 e = lemma1-1' e refl 246 | lemma1-2 : wkSub' (sliceLeft nil (LFExtToWk e)) s ≋ₛ trimSub' idWk s' 247 | lemma1-2 rewrite lemma1-1 e 248 | | trimSub'PresId s' 249 | | wkSub'PresId s = s≋s' 250 | lemma1 {t = t} (ext e) (s , _) (s' , _) (s≋s' `, _) 251 | = lemma1 {t = t} e s s' s≋s' 252 | 253 | lemma2 : {b c : Tm' Γ (□ a)} 254 | → b ≋ c 255 | → b ≋ box' (unbox' c new) 256 | lemma2 {c = c} b≋c rewrite (let box' y = c in wkTm'PresId y) 257 | = b≋c 258 | 259 | -- soundness of evaluation wrt single-step reduction 260 | eval-sound-red : {t t' : Tm Γ a} {s s' : Sub' Δ Γ} 261 | → t ⟶ t' 262 | → Pshₛ s → Pshₛ s' → s ≋ₛ s' → eval t s ≋ eval t' s' 263 | eval-sound-red {Γ = Γ} {Δ = Δ} {t = app (lam {b = b} t) u} {s = s} {s' = s'} red-fun ps ps' s≋s' 264 | rewrite wkSub'PresId s 265 | | evalₛPresId s' 266 | = trans-≋ {Γ = Δ} {a = b} 267 | (fund t 268 | (ps , (psh-eval u s ps)) 269 | (subst Pshₛ (sym (evalₛPresId s')) ps' , psh-eval u s' ps') 270 | (subst (s ≋ₛ_) (sym (evalₛPresId s')) s≋s' `, fund u ps ps' s≋s')) 271 | (coh-substTm-evalₛ t (idₛ `, u) {s} {s'} ps ps' s≋s') 272 | eval-sound-red {t = t} {s = s} {s'} exp-fun ps ps' s≋s' w {x = x} px py x≋y 273 | rewrite sym (rightIdWk w) 274 | | sym (cong (λ f → f idWk x) (nat-eval t w s ps)) 275 | | sym (trimSub'PresId (wkSub' w s)) 276 | | rightIdWk w 277 | | sym (coh-trimSub'-wkTm fresh (wkSub' w s , x) t) 278 | = fund (wkTm (drop idWk) t) 279 | (wkSub'PresPsh w s ps , px) 280 | (wkSub'PresPsh w s' ps' , py) 281 | (wkSub'Pres≋ w s≋s' `, x≋y) 282 | idWk 283 | px 284 | py 285 | x≋y 286 | eval-sound-red {t = unbox (box t) e} {s = s} {s' = s'} red-box ps ps' s≋s' 287 | rewrite coh-trimSub'-wkTm (LFExtToWk e) s' t 288 | = lemma1 {t = t} e ps ps' s≋s' 289 | eval-sound-red {t = t} {s = s} {s'} exp-box ps ps' s≋s' 290 | = lemma2 {b = eval t s} (fund t ps ps' s≋s') 291 | eval-sound-red {t = t} {s = s} {s'} (cong-lam r) ps ps' s≋s' w {x = x} px py x≋y 292 | = eval-sound-red r 293 | (wkSub'PresPsh w s ps , px) 294 | (wkSub'PresPsh w s' ps' , py) 295 | ((wkSub'Pres≋ w s≋s') `, x≋y) 296 | eval-sound-red {t = app t u} {t' = app t' u'} {s = s} {s' = s'} (cong-app1 r) ps ps' s≋s' 297 | = eval-sound-red r ps ps' s≋s' 298 | idWk 299 | (psh-eval u s ps) 300 | (psh-eval u s' ps') 301 | (fund u ps ps' s≋s') 302 | eval-sound-red {t = app t u} {t' = app t' u'} {s = s} {s' = s'} (cong-app2 r) ps ps' s≋s' 303 | = fund t ps ps' s≋s' idWk (psh-eval u s ps) (psh-eval u' s' ps') (eval-sound-red r ps ps' s≋s') 304 | eval-sound-red (cong-box r) ps ps' s≋s' 305 | = eval-sound-red r ps ps' (lock s≋s' nil) 306 | eval-sound-red {s = lock s e} {s' = lock s' .e} (cong-unbox {t = t} {e = nil} r) ps ps' (lock s≋s' e) 307 | = unbox'Pres≋ {b = eval t s} e (eval-sound-red r ps ps' s≋s') 308 | eval-sound-red {s = s , _} {s' = s' , _} (cong-unbox {t = t} {e = ext e} r) (ps , _) (ps' , _) (s≋s' `, _) 309 | = eval-sound-red (cong-unbox {e = e} r) ps ps' s≋s' 310 | 311 | -- soundness of evaluation wrt multi-step reduction 312 | eval-sound-red* : {t t' : Tm Γ a} {s s' : Sub' Δ Γ} 313 | → t ⟶* t' 314 | → Pshₛ s → Pshₛ s' → s ≋ₛ s' → eval t s ≋ eval t' s' 315 | eval-sound-red* {t = t} {t' = .t} ε ps ps' s≋s' 316 | = fund t ps ps' s≋s' 317 | eval-sound-red* {a = a} {t = t} {t' = t'} (r ◅ rs) ps ps' s≋s' 318 | = trans-≋ {a = a} (eval-sound-red r ps ps' s≋s') (eval-sound-red* rs ps' ps' (pseudo-refl-≋ₛ (sym-≋ₛ s≋s'))) 319 | 320 | -- soundness of evaluation wrt conversion 321 | eval-sound : {t t' : Tm Γ a} {s s' : Sub' Δ Γ} 322 | → t ≈ t' 323 | → Pshₛ s → Pshₛ s' → s ≋ₛ s' → eval t s ≋ eval t' s' 324 | eval-sound {t = t} ε ps ps' s≋s' 325 | = eval-sound-red* {t = t} ⟶*-refl ps ps' s≋s' 326 | eval-sound {a = a} (inj₁ r ◅ t≈t') ps ps' s≋s' 327 | = trans-≋ {a = a} (eval-sound-red r ps ps' s≋s') (eval-sound t≈t' ps' ps' (pseudo-refl-≋ₛ (sym-≋ₛ s≋s'))) 328 | eval-sound {a = a} {t = t} {s = s} {s' = s'} (inj₂ r ◅ t≈t') ps ps' s≋s' 329 | = trans-≋ {a = a} 330 | (sym-≋ {y = eval t s} (eval-sound-red r ps' ps (sym-≋ₛ s≋s'))) 331 | (eval-sound t≈t' ps' ps' (pseudo-refl-≋ₛ (sym-≋ₛ s≋s'))) 332 | 333 | -------------------------------------------------------- 334 | -- Uniqueness of reification and soundness of reflection 335 | -------------------------------------------------------- 336 | 337 | unique-reify : {x y : Tm' Γ a} 338 | → x ≋ y → reify x ≡ reify y 339 | sound-reflect : {n n' : Ne Γ a} 340 | → n ≡ n' → reflect n ≋ reflect n' 341 | 342 | unique-reify {a = ι} n≡m = n≡m 343 | unique-reify {a = a ⇒ b} f≋g = cong lam 344 | (unique-reify 345 | (f≋g fresh (psh-reflect {a = a} (var zero)) (psh-reflect {a = a} (var zero)) 346 | (sound-reflect {a = a} refl))) 347 | unique-reify {a = □ a} b≋c 348 | = cong box (unique-reify b≋c) 349 | 350 | sound-reflect {a = ι} n≡n' 351 | = cong up n≡n' 352 | sound-reflect {a = a ⇒ b} n≡n' w px py x≋y 353 | = sound-reflect {a = b} (cong₂ app (cong (wkNe w) n≡n') (unique-reify x≋y)) 354 | sound-reflect {a = □ a} n≡n' 355 | = sound-reflect {a = a} (cong₂ unbox n≡n' refl) 356 | 357 | -------------------------------- 358 | -- Completeness of normalization 359 | -------------------------------- 360 | 361 | idₛ'≋idₛ' : {Γ : Ctx} → idₛ' {Γ} ≋ₛ idₛ' 362 | idₛ'≋idₛ' {[]} = [] 363 | idₛ'≋idₛ' {Γ `, a} = (wkSub'Pres≋ fresh (idₛ'≋idₛ' {Γ})) `, (sound-reflect {a = a} refl) 364 | idₛ'≋idₛ' {Γ #} = lock idₛ'≋idₛ' nil 365 | 366 | norm-complete-red* : {t t' : Tm Γ a} → t ⟶* t' → norm t ≡ norm t' 367 | norm-complete-red* {Γ = Γ} r = unique-reify (eval-sound-red* r (psh-idₛ' {Γ}) (psh-idₛ' {Γ}) idₛ'≋idₛ') 368 | 369 | norm-complete : {t t' : Tm Γ a} → t ≈ t' → norm t ≡ norm t' 370 | norm-complete {Γ = Γ} p = unique-reify (eval-sound p (psh-idₛ' {Γ}) (psh-idₛ' {Γ}) idₛ'≋idₛ') 371 | -------------------------------------------------------------------------------- /src/IK/Norm/Properties/Soundness.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module IK.Norm.Properties.Soundness where 3 | 4 | open import Relation.Binary.PropositionalEquality 5 | using (_≡_ ; cong ; cong₂ ; trans) 6 | 7 | open import IK.Norm.Base 8 | 9 | open import IK.Norm.NbE.Model 10 | open import IK.Norm.NbE.Reification 11 | 12 | open import IK.Norm.Properties.Soundness.Trace 13 | 14 | open import IK.Term 15 | 16 | -- 17 | -- This module proves the completeness of evaluation (eval-complete), 18 | -- from which the soundness of normalization (norm-sound) follows. 19 | -- 20 | 21 | eval-complete : {t t' : Tm Γ a} 22 | → ({Δ : Ctx} {γ : Sub' Δ Γ} → eval t γ ≡ eval t' γ) 23 | → t ≈ t' 24 | eval-complete {t = t} {t'} f with f {_} {idₛ'} 25 | ... | p = ≈-trans 26 | (≈-trans 27 | (⟶*-to-≈ (trace t)) 28 | (≈-reflexive (cong embNf (cong reify p)))) 29 | (≈-sym (⟶*-to-≈ (trace t'))) 30 | 31 | norm-sound : norm t ≡ norm u → t ≈ u 32 | norm-sound {t = t} {u} t'≡u' = ≈-trans 33 | (⟶*-to-≈ (trace t)) 34 | (≈-trans 35 | (≈-reflexive (cong embNf t'≡u')) 36 | (≈-sym (⟶*-to-≈ (trace u)))) 37 | -------------------------------------------------------------------------------- /src/IK/Norm/Properties/Soundness/Trace.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module IK.Norm.Properties.Soundness.Trace where 3 | 4 | open import Data.Unit 5 | using (⊤ ; tt) 6 | open import Data.Product 7 | using (Σ ; _×_ ; _,_ ; ∃) 8 | 9 | open import Relation.Binary.PropositionalEquality 10 | 11 | open import PEUtil 12 | 13 | open import IK.Norm.Base 14 | 15 | open import IK.Norm.NbE.Model 16 | open import IK.Norm.NbE.Reification 17 | 18 | open import IK.Term 19 | 20 | quotTm : Tm' Γ a → Tm Γ a 21 | quotTm x = embNf (reify x) 22 | 23 | ----------------------- 24 | -- Logical Relations -- 25 | ----------------------- 26 | 27 | L : (a : Ty) → (t : Tm Γ a) → (x : Tm' Γ a) → Set 28 | L ι t n = 29 | t ⟶* quotTm n 30 | L {Γ} (a ⇒ b) t f = 31 | ∀ {Γ' : Ctx} {u : Tm Γ' a} {x : Tm' Γ' a} 32 | → (w : Γ ⊆ Γ') → (uLx : L a u x) → L b (app (wkTm w t) u) (f w x) 33 | L (□ a) t b = let box' x = b in 34 | L a (unbox t new) x 35 | 36 | data Lₛ {Γ : Ctx} : (Δ : Ctx) → Sub Γ Δ → Sub' Γ Δ → Set where 37 | [] : Lₛ [] [] tt 38 | _`,_ : {s : Sub Γ Δ} {δ : Sub' Γ Δ} {t : Tm Γ a} {x : Tm' Γ a} 39 | → (sLδ : Lₛ Δ s δ) → (tLx : L a t x) → Lₛ (Δ `, a) (s `, t) (δ , x) 40 | lock : {s : Sub Γ' Δ} {δ : Sub' Γ' Δ} 41 | → (sLδ : Lₛ Δ s δ) → (e : LFExt Γ (Γ' #) ΓR) → Lₛ (Δ #) (lock s e) (lock δ e) 42 | 43 | ---------------------------- 44 | -- Standard LR properties -- 45 | ---------------------------- 46 | 47 | -- prepend a reduction trace to the "trace builder" L 48 | L-prepend : {t : Tm Γ a} {x : Tm' Γ a} 49 | → (t⟶*u : t ⟶* u) 50 | → (uLx : L a u x) 51 | → L a t x 52 | L-prepend {a = ι} t⟶*u uLn 53 | = multi t⟶*u uLn 54 | L-prepend {a = a ⇒ b} t⟶*u uLf 55 | = λ w uRy → L-prepend (cong-app1* (wkTmPres⟶* w t⟶*u)) (uLf w uRy) 56 | L-prepend {a = □ a} t⟶*u uLb 57 | = L-prepend (cong-unbox* t⟶*u) uLb 58 | 59 | -- reduction-free version of L-prepend 60 | L-cast : {t u : Tm Γ a} {x : Tm' Γ a} 61 | → (t≡u : t ≡ u) 62 | → (uLx : L a u x) 63 | → L a t x 64 | L-cast refl uLx = uLx 65 | 66 | -- extract reduction trace from L 67 | L-build : {t : Tm Γ a} {x : Tm' Γ a} 68 | → (tLx : L a t x) → t ⟶* quotTm x 69 | -- a neutral element is related to its reflection 70 | L-reflect : (n : Ne Γ a) 71 | → L a (embNe n) (reflect n) 72 | 73 | L-build {a = ι} tLn 74 | = tLn 75 | L-build {a = a ⇒ b} tLf 76 | = ⟶-multi exp-fun (cong-lam* (L-build (tLf fresh (L-reflect {a = a} var0)))) 77 | L-build {a = □ a} tLb 78 | = ⟶-multi exp-box (cong-box* (L-build tLb)) 79 | 80 | L-reflect {a = ι} n 81 | = ⟶*-refl 82 | L-reflect {a = a ⇒ b} n {_Γ'} {_t} {x} 83 | = λ w tLx → L-prepend 84 | (cong-app≡* (nat-embNe w n) (L-build tLx)) 85 | (L-reflect (app (wkNe w n) (reify x))) 86 | L-reflect {a = □ a} n 87 | = L-reflect (unbox n new) 88 | 89 | -- L is invariant under weakening 90 | wkTmPresL : {t : Tm Γ a} {x : Tm' Γ a} 91 | → (w : Γ ⊆ Γ') 92 | → (tLx : L a t x) 93 | → L a (wkTm w t) (wkTm' w x) 94 | wkTmPresL {a = ι} {x = x} w tLn 95 | = multi-≡ (wkTmPres⟶* w tLn) (nat-embNf w (reify x)) 96 | wkTmPresL {a = a ⇒ b} {t = t} w tLf 97 | = λ w' y → L-cast (cong₂ app (wkTmPres∙ w w' t) refl) (tLf (w ∙ w') y) 98 | wkTmPresL {a = □ a} w tLb 99 | = wkTmPresL {a = a} (keep# w) tLb 100 | 101 | -- Lₛ is invariant under weakening 102 | wkSubPresLₛ : {s : Sub Γ Δ} {δ : Sub' Γ Δ} 103 | → (w : Γ ⊆ Γ') 104 | → (sLδ : Lₛ Δ s δ) 105 | → Lₛ Δ (wkSub w s) (wkSub' w δ) 106 | wkSubPresLₛ {Δ = []} w [] 107 | = [] 108 | wkSubPresLₛ {Δ = _Δ `, a} w (sLδ `, tLx) 109 | = wkSubPresLₛ w sLδ `, wkTmPresL {a = a} w tLx 110 | wkSubPresLₛ {Δ = _Δ #} w (lock sLδ e) 111 | = lock (wkSubPresLₛ (sliceLeft e w) sLδ) (wkLFExt e w) 112 | 113 | -- syntactic identity is related to semantic identity 114 | idLₛ : Lₛ Δ idₛ idₛ' 115 | idLₛ {[]} = [] 116 | idLₛ {_Δ `, a} = wkSubPresLₛ fresh[ a ] idLₛ `, L-reflect {a = a} var0 117 | idLₛ {_Δ #} = lock idLₛ nil 118 | 119 | ----------------------------- 120 | -- The Fundamental Theorem -- 121 | ----------------------------- 122 | 123 | -- local lemmas for the proof of fundamental theorem 124 | private 125 | substVarPresL : (v : Var Δ a) {s : Sub Γ Δ} {δ : Sub' Γ Δ} 126 | → (sLδ : Lₛ Δ s δ) 127 | → L a (substVar s v) (substVar' v δ) 128 | substVarPresL zero (_sLδ `, tLx) = tLx 129 | substVarPresL (succ v) (sLδ `, _tLx) = substVarPresL v sLδ 130 | 131 | beta-lemma : (w : Γ ⊆ Γ') (s : Sub Γ Δ) (t : Tm (Δ `, a) b) (u : Tm Γ' a) 132 | → app (wkTm w (substTm s (lam t))) u ⟶* substTm (wkSub w s `, u) t 133 | beta-lemma w s t u = ≡-single-≡ 134 | (cong1 app (cong lam (trans 135 | (sym (nat-subsTm t (keepₛ s) (keep w))) 136 | (cong (λ p → substTm (p `, var0) t) 137 | (trans 138 | (wkSubPres∙ fresh (keep w) s) 139 | (cong1 wkSub (cong drop (leftIdWk w)))))))) 140 | red-fun 141 | (trans 142 | (substTmPres∙ _ _ t ) 143 | (cong (λ p → substTm (p `, u) t) (trans 144 | (sym (coh-trimSub-wkSub s _ _)) 145 | (trans (coh-trimSub-wkSub s idₛ w) (rightIdSub _))))) 146 | 147 | box-beta-lemma : (t : Tm (Γ #) a) → unbox (box t) new ⟶* t 148 | box-beta-lemma t = single-≡ red-box (wkTmPresId t) 149 | 150 | module _ {t : Tm Γ (□ a)} {b : Box (Tm'- a) Γ} where 151 | unboxPresL : (tLb : L (□ a) t b) 152 | → (e : LFExt Δ (Γ #) ΓR) 153 | → L a (unbox t e) (unbox' b e) 154 | unboxPresL tLb e = 155 | L-cast (unbox-universal t e) (wkTmPresL {a = a} (LFExtToWk e) tLb) 156 | 157 | -- The Fundamental theorem, for terms 158 | 159 | Fund : Tm Δ a → Set 160 | Fund {Δ} {a} t = ∀ {Γ} {s : Sub Γ Δ} {δ : Sub' Γ Δ} 161 | → (sLδ : Lₛ Δ s δ) 162 | → L a (substTm s t) (eval t δ) 163 | 164 | fund : (t : Tm Δ a) → Fund t 165 | fund (var v) sLδ 166 | = substVarPresL v sLδ 167 | fund (lam t) {_Γ} {s} sLδ {_Γ'} {u} 168 | = λ w uLx → L-prepend (beta-lemma w s t u) 169 | (fund t {s = wkSub w s `, u} (wkSubPresLₛ w sLδ `, uLx)) 170 | fund (app t u) {_Γ} {s} sLδ 171 | = L-cast (cong1 app (sym (wkTmPresId (substTm s t)))) 172 | (fund t sLδ idWk (fund u sLδ)) 173 | fund (box t) {_Γ} {s} sRδ 174 | = L-prepend (box-beta-lemma (substTm (keep#ₛ s) t)) (fund t (lock sRδ new)) 175 | fund (unbox t nil) {_Γ} {lock s e} (lock sRδ e) 176 | = unboxPresL {t = substTm s t} (fund t sRδ) e 177 | fund (unbox t (ext e)) (sRδ `, _uRx) 178 | = fund (unbox t e) sRδ 179 | 180 | -- The Fundamental theorem, extended to substitutions 181 | -- (not needed for tracing reduction of terms) 182 | 183 | Fundₛ : (S : Sub Δ Θ) → Set 184 | Fundₛ {Δ} {Θ} S = ∀ {Γ} {s : Sub Γ Δ} {δ : Sub' Γ Δ} 185 | → (sLδ : Lₛ Δ s δ) 186 | → Lₛ Θ (S ∙ₛ s) (evalₛ S δ) 187 | 188 | fundₛ : (S : Sub Δ Θ) → Fundₛ S 189 | fundₛ [] sLδ 190 | = [] 191 | fundₛ (S `, t) sLδ 192 | = fundₛ S sLδ `, fund t sLδ 193 | fundₛ (lock S nil) (lock sLδ e) 194 | = lock (fundₛ S sLδ) e 195 | fundₛ (lock S (ext e)) (sLδ `, _a) 196 | = fundₛ (lock S e) sLδ 197 | 198 | -- reduction trace for norm 199 | trace : (t : Tm Γ a) → t ⟶* embNf (norm t) 200 | trace t = L-build (L-cast (sym (substTmPresId t)) (fund t idLₛ)) 201 | -------------------------------------------------------------------------------- /src/IK/Term.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IK.Term where 3 | 4 | open import IK.Term.Base public 5 | open import IK.Term.Conversion public 6 | open import IK.Term.NormalForm public 7 | open import IK.Term.Properties public 8 | open import IK.Term.Reduction public 9 | 10 | pattern var0 = var v0 11 | pattern var1 = var v1 12 | pattern var2 = var v2 13 | -------------------------------------------------------------------------------- /src/IK/Term/Base.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IK.Term.Base where 3 | 4 | -- 5 | -- Implementation of the IK (Intuitionistic K) calculus from 6 | -- "Fitch-Style Modal Lambda Calculi" by Ranald Clouston (2018) 7 | -- 8 | 9 | open import Data.Product using (Σ ; ∃ ; _×_ ; _,_ ; proj₁ ; proj₂) 10 | 11 | open import Type as Type using (Ty ; Ty-Decidable) 12 | 13 | open import Context Ty Ty-Decidable as Context 14 | 15 | open Context public 16 | open Type public 17 | 18 | ------------------------------------- 19 | -- Variables, terms and substitutions 20 | ------------------------------------- 21 | 22 | data Tm : Ctx → Ty → Set where 23 | 24 | var : (v : Var Γ a) 25 | --------------- 26 | → Tm Γ a 27 | 28 | lam : (t : Tm (Γ `, a) b) 29 | ------------------- 30 | → Tm Γ (a ⇒ b) 31 | 32 | app : (t : Tm Γ (a ⇒ b)) 33 | → (u : Tm Γ a) 34 | ------------------ 35 | → Tm Γ b 36 | 37 | box : (t : Tm (Γ #) a) 38 | ------------------ 39 | → Tm Γ (□ a) 40 | 41 | unbox : (t : Tm ΓL (□ a)) 42 | → (e : LFExt Γ (ΓL #) ΓR) 43 | ------------------------- 44 | → Tm Γ a 45 | 46 | variable 47 | t t' t'' t''' : Tm Γ a 48 | u u' u'' u''' : Tm Γ a 49 | 50 | wkTm : Γ ⊆ Γ' → Tm Γ a → Tm Γ' a 51 | wkTm w (var x) = var (wkVar w x) 52 | wkTm w (lam t) = lam (wkTm (keep w) t) 53 | wkTm w (app t u) = app (wkTm w t) (wkTm w u) 54 | wkTm w (box t) = box (wkTm (keep# w) t) 55 | wkTm w (unbox t e) = unbox (wkTm (sliceLeft e w) t) (wkLFExt e w) 56 | 57 | leftWkTm : (t : Tm Γ a) → Tm (Δ ,, Γ) a 58 | leftWkTm (var v) = var (leftWkVar v) 59 | leftWkTm (lam t) = lam (leftWkTm t) 60 | leftWkTm (app t u) = app (leftWkTm t) (leftWkTm u) 61 | leftWkTm (box t) = box (leftWkTm t) 62 | leftWkTm (unbox t e) = unbox (leftWkTm t) (leftWkLFExt e) 63 | 64 | -- extension that "generates a new context frame" 65 | pattern new = nil 66 | pattern new[_] Γ = nil {Γ} 67 | 68 | open Substitution Tm var wkTm (λ Γ ΓL ΓR → LFExt Γ (ΓL #) ΓR) new (λ {_Δ} {_Γ} {_ΓR} {Δ'} _e _w → ←# Δ') sliceLeft (λ {_Δ} {_Γ} {_ΓR} {Δ'} _e _w → #→ Δ') wkLFExt public 69 | renaming (module Composition to SubstitutionComposition) 70 | 71 | -- "Left" context of factoring with a substitution (see factorSubₛ and factorExtₛ) 72 | lCtxₛ : (e : LFExt Γ (ΓL #) ΓR) (s : Sub Δ Γ) → Ctx 73 | lCtxₛ nil (lock {ΔL = ΔL} s e) = ΔL 74 | lCtxₛ (ext e) (s `, t) = lCtxₛ e s 75 | 76 | factorSubₛ : ∀ (e : LFExt Γ (ΓL #) ΓR) (s : Sub Δ Γ) → Sub (lCtxₛ e s) ΓL 77 | factorSubₛ nil (lock s e) = s 78 | factorSubₛ (ext e) (s `, t) = factorSubₛ e s 79 | 80 | -- "Right" context of factoring with a substitution (see factorExtₛ) 81 | rCtxₛ : (e : LFExt Γ (ΓL #) ΓR) (s : Sub Δ Γ) → Ctx 82 | rCtxₛ nil (lock {ΔR = ΔR} s e) = ΔR 83 | rCtxₛ (ext e) (s `, t) = rCtxₛ e s 84 | 85 | factorExtₛ : ∀ (e : LFExt Γ (ΓL #) ΓR) (s : Sub Δ Γ) → LFExt Δ (lCtxₛ e s #) (rCtxₛ e s) 86 | factorExtₛ nil (lock s e) = e 87 | factorExtₛ (ext e) (s `, _) = factorExtₛ e s 88 | 89 | -- apply substitution to a term 90 | substTm : Sub Δ Γ → Tm Γ a → Tm Δ a 91 | substTm s (var x) = substVar s x 92 | substTm s (lam t) = lam (substTm (keepₛ s) t) 93 | substTm s (app t u) = app (substTm s t) (substTm s u) 94 | substTm s (box t) = box (substTm (keep#ₛ s) t) 95 | substTm s (unbox t e) = unbox (substTm (factorSubₛ e s) t) (factorExtₛ e s) 96 | 97 | open SubstitutionComposition substTm lCtxₛ factorSubₛ rCtxₛ factorExtₛ public 98 | -------------------------------------------------------------------------------- /src/IK/Term/Conversion.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IK.Term.Conversion where 3 | 4 | open import PEUtil 5 | 6 | open import IK.Term.Base 7 | open import IK.Term.Reduction 8 | as Reduction 9 | 10 | import Data.Sum as Sum 11 | 12 | open import Relation.Nullary 13 | using (¬_) 14 | 15 | open import Relation.Binary 16 | using (Setoid) 17 | 18 | open import Relation.Binary.Construct.Closure.Equivalence 19 | using (setoid) 20 | import Relation.Binary.Construct.Closure.Equivalence.Properties 21 | as EquivalenceProperties 22 | 23 | open import Relation.Binary.Construct.Closure.ReflexiveTransitive 24 | as ReflexiveTransitive 25 | using (Star) 26 | 27 | open import Relation.Binary.PropositionalEquality 28 | using (_≡_ ; cong ; cong₂) 29 | renaming (refl to ≡-refl ; sym to ≡-sym ; trans to ≡-trans) 30 | 31 | open Sum public 32 | using (inj₁ ; inj₂) 33 | open ReflexiveTransitive public 34 | using (ε ; _◅_) 35 | open EquivalenceProperties public 36 | using () 37 | renaming (a—↠b⇒a↔b to ⟶*-to-≈) 38 | 39 | -- Convertibility is defined by taking the equivalence closure of the 40 | -- reduction relation `_⟶_`, i.e. two terms `t` and `u` are 41 | -- convertible (written `t ≈ u`) if and only if there is a sequence of 42 | -- terms `sᵢ` for i = 0,…,n such that 1. `s₀ = t`, 2. `sₙ = u`, and 43 | -- 3. `sᵢ ⟶ sᵢ₊₁` or `sᵢ₊₁ ⟶ sᵢ` for all i. 44 | -- 45 | -- Note that `_⟶_` is already a congruence, i.e. `u ⟶ v` implies `t[u] 46 | -- ⟶ t[v]`, and being a congruence preserved by closing under 47 | -- reflexivity, symmetry and transitivity. 48 | Tm-setoid : (Γ : Ctx) → (a : Ty) → Setoid _ _ 49 | Tm-setoid Γ a = setoid (_⟶_ {Γ} {a}) 50 | 51 | module _ {Γ : Ctx} {a : Ty} where 52 | open Setoid (Tm-setoid Γ a) public 53 | using (_≈_) 54 | renaming (refl to ≈-refl ; reflexive to ≈-reflexive ; sym to ≈-sym ; trans to ≈-trans ; isEquivalence to ≈-equiv) 55 | 56 | ≈-reflexive˘ : t' ≡ t → t ≈ t' 57 | ≈-reflexive˘ t'≡t = ≈-reflexive (≡-sym t'≡t) 58 | 59 | ⟶-to-≈ : t ⟶ t' → t ≈ t' 60 | ⟶-to-≈ p = inj₁ p ◅ ε 61 | 62 | module _ {t : Tm Γ a → Tm Δ b} (cong-t : ∀ {u u' : Tm Γ a} → (u⟶u' : u ⟶ u') → t u ⟶ t u') where 63 | -- XXX: fold 64 | cong-⟶-to-cong-≈ : ∀ (u≈u' : u ≈ u') → t u ≈ t u' 65 | cong-⟶-to-cong-≈ ε = ε 66 | cong-⟶-to-cong-≈ (inj₁ u⟶u'' ◅ u''≈u') = inj₁ (cong-t u⟶u'') ◅ cong-⟶-to-cong-≈ u''≈u' 67 | cong-⟶-to-cong-≈ (inj₂ u⟵u'' ◅ u''≈u') = inj₂ (cong-t u⟵u'') ◅ cong-⟶-to-cong-≈ u''≈u' 68 | 69 | red-fun≈ : (t : Tm (Γ `, a) b) (u : Tm Γ a) → (app (lam t) u) ≈ substTm (idₛ `, u) t 70 | red-fun≈ t u = ⟶-to-≈ Reduction.red-fun 71 | 72 | exp-fun≈ : (t : Tm Γ (a ⇒ b)) → t ≈ lam (app (wkTm fresh t) (var zero)) 73 | exp-fun≈ t = ⟶-to-≈ Reduction.exp-fun 74 | 75 | red-box≈ : (t : Tm (ΓL #) a) (e : LFExt Γ (ΓL #) ΓR) → unbox (box t) e ≈ wkTm (LFExtToWk e) t 76 | red-box≈ t e = ⟶-to-≈ Reduction.red-box 77 | 78 | exp-box≈ : (t : Tm Γ (□ a)) → t ≈ box (unbox t new) 79 | exp-box≈ t = ⟶-to-≈ Reduction.exp-box 80 | 81 | cong-lam≈ : ∀ (t≈t' : t ≈ t') → lam t ≈ lam t' 82 | cong-lam≈ = cong-⟶-to-cong-≈ Reduction.cong-lam 83 | 84 | cong-app≈≡ : ∀ (t≈t' : t ≈ t') (u≡u' : u ≡ u') → app t u ≈ app t' u 85 | cong-app≈≡ t≈t' ≡-refl = cong-⟶-to-cong-≈ Reduction.cong-app1 t≈t' 86 | 87 | cong-app1≈ : ∀ (t≈t' : t ≈ t') → app t u ≈ app t' u 88 | cong-app1≈ t≈t' = cong-app≈≡ t≈t' ≡-refl 89 | 90 | cong-app≡≈ : ∀ (t≡t' : t ≡ t') (u≈u' : u ≈ u') → app t u ≈ app t' u' 91 | cong-app≡≈ ≡-refl u≈u' = cong-⟶-to-cong-≈ Reduction.cong-app2 u≈u' 92 | 93 | cong-app2≈ : ∀ (u≈u' : u ≈ u') → app t u ≈ app t u' 94 | cong-app2≈ u≈u' = cong-app≡≈ ≡-refl u≈u' 95 | 96 | cong-app≈ : ∀ (t≈t' : t ≈ t') (u≈u' : u ≈ u') → app t u ≈ app t' u' 97 | cong-app≈ t≈t' u≈u' = ≈-trans (cong-app1≈ t≈t') (cong-app2≈ u≈u') 98 | 99 | cong-box≈ : ∀ (t≈t' : t ≈ t') → box t ≈ box t' 100 | cong-box≈ = cong-⟶-to-cong-≈ Reduction.cong-box 101 | 102 | cong-unbox≈ : ∀ (t≈t' : t ≈ t') → unbox t e ≈ unbox t' e 103 | cong-unbox≈ = cong-⟶-to-cong-≈ Reduction.cong-unbox 104 | 105 | module _ {t : Tm ΓL (□ a)} {e : LFExt Γ (ΓL #) ΓR} {e' : LFExt Γ (ΓL #) ΓR'} where 106 | cong-unbox2≈ : unbox t e ≈ unbox t e' 107 | cong-unbox2≈ = ≈-reflexive (dcong₂ (λ _ΓR → unbox t) (extRUniq e e') (ExtIsProp′ e e')) 108 | 109 | cong-unbox≈′ : ∀ (t≈t' : t ≈ t') → unbox t e ≈ unbox t' e' 110 | cong-unbox≈′ t≈t' = ≈-trans (cong-unbox≈ t≈t') cong-unbox2≈ 111 | 112 | cong-unbox≈′′ : ∀ (Γ≡Γ' : Γ ≡ Γ') (t≈t' : subst1 Tm Γ≡Γ' t ≈ t') → unbox t e ≈ unbox t' e' 113 | cong-unbox≈′′ ≡-refl = cong-unbox≈′ 114 | 115 | -------------------- 116 | -- Derived equations 117 | -------------------- 118 | -------------------------------------------------------------------------------- /src/IK/Term/NormalForm.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IK.Term.NormalForm where 3 | 4 | open import IK.Term.NormalForm.Base public 5 | open import IK.Term.NormalForm.Properties public 6 | -------------------------------------------------------------------------------- /src/IK/Term/NormalForm/Base.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IK.Term.NormalForm.Base where 3 | 4 | open import IK.Term.Base 5 | 6 | --------------- 7 | -- Normal forms 8 | --------------- 9 | 10 | data Ne : Ctx → Ty → Set 11 | data Nf : Ctx → Ty → Set 12 | 13 | data Ne where 14 | var : Var Γ a → Ne Γ a 15 | app : Ne Γ (a ⇒ b) → Nf Γ a → Ne Γ b 16 | unbox : Ne ΓL (□ a) → LFExt Γ (ΓL #) ΓR → Ne Γ a 17 | 18 | data Nf where 19 | up : Ne Γ ι → Nf Γ ι 20 | lam : Nf (Γ `, a) b → Nf Γ (a ⇒ b) 21 | box : Nf (Γ #) a → Nf Γ (□ a) 22 | 23 | -- normal forms of substitutions (simply "do everything pointwise") 24 | data Nfₛ : Ctx → Ctx → Set where 25 | [] : Nfₛ Γ [] 26 | _`,_ : Nfₛ Γ Δ → Nf Γ a → Nfₛ Γ (Δ `, a) 27 | lock : Nfₛ ΔL Γ → LFExt Δ (ΔL #) ΔR → Nfₛ Δ (Γ #) 28 | 29 | Nfₛ- : Ctx → Ctx → Set 30 | Nfₛ- Δ Γ = Nfₛ Γ Δ 31 | 32 | -- embedding into terms 33 | 34 | embNe : Ne Γ a → Tm Γ a 35 | embNf : Nf Γ a → Tm Γ a 36 | 37 | embNe (var x) = var x 38 | embNe (app m n) = app (embNe m) (embNf n) 39 | embNe (unbox n x) = unbox (embNe n) x 40 | 41 | embNf (up x) = embNe x 42 | embNf (lam n) = lam (embNf n) 43 | embNf (box n) = box (embNf n) 44 | 45 | -- embeddding of substitution normal forms back into substitutions (simply "do everything pointwise") 46 | embNfₛ : Nfₛ Γ Δ → Sub Γ Δ 47 | embNfₛ [] = [] 48 | embNfₛ (n `, s) = embNfₛ n `, embNf s 49 | embNfₛ (lock n s) = lock (embNfₛ n) s 50 | 51 | -- weakening lemmas 52 | 53 | wkNe : Γ ⊆ Γ' → Ne Γ a → Ne Γ' a 54 | wkNf : Γ ⊆ Γ' → Nf Γ a → Nf Γ' a 55 | 56 | wkNe w (var x) = var (wkVar w x) 57 | wkNe w (app m n) = app (wkNe w m) (wkNf w n) 58 | wkNe w (unbox n e) = unbox (wkNe (sliceLeft e w) n) (wkLFExt e w) 59 | 60 | wkNf e (up x) = up (wkNe e x) 61 | wkNf e (lam n) = lam (wkNf (keep e) n) 62 | wkNf e (box n) = box (wkNf (keep# e) n) 63 | -------------------------------------------------------------------------------- /src/IK/Term/NormalForm/Properties.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IK.Term.NormalForm.Properties where 3 | 4 | open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; trans ; cong ; cong₂) 5 | 6 | open import IK.Term.Base 7 | 8 | open import IK.Term.NormalForm.Base 9 | 10 | wkNePresId : (n : Ne Γ a) → wkNe idWk n ≡ n 11 | wkNfPresId : (n : Nf Γ a) → wkNf idWk n ≡ n 12 | 13 | wkNePresId (var v) = cong var (wkVarPresId v) 14 | wkNePresId (app n m) = cong₂ app (wkNePresId n) (wkNfPresId m) 15 | wkNePresId (unbox n e) with ←#IsPre# e | #→IsPost# e 16 | ... | refl | refl = cong₂ unbox 17 | (trans (cong₂ wkNe (sliceLeftId e) refl) (wkNePresId n)) 18 | (wkLFExtPresId e) 19 | 20 | wkNfPresId (up n) = cong up (wkNePresId n) 21 | wkNfPresId (lam n) = cong lam (wkNfPresId n) 22 | wkNfPresId (box n) = cong box (wkNfPresId n) 23 | 24 | wkNePres∙ : (w : Γ ⊆ Γ') (w' : Γ' ⊆ Δ) (n : Ne Γ a) 25 | → wkNe w' (wkNe w n) ≡ wkNe (w ∙ w') n 26 | wkNfPres∙ : (w : Γ ⊆ Γ') (w' : Γ' ⊆ Δ) (n : Nf Γ a) 27 | → wkNf w' (wkNf w n) ≡ wkNf (w ∙ w') n 28 | 29 | wkNePres∙ w w' (var v) = cong var (wkVarPres∙ w w' v) 30 | wkNePres∙ w w' (app n m) = cong₂ app (wkNePres∙ w w' n) (wkNfPres∙ w w' m) 31 | wkNePres∙ w w' (unbox n e) = cong₂ unbox 32 | (trans (wkNePres∙ _ _ _) (cong₂ wkNe (sliceLeftPres∙ w w' e) refl)) (wkLFExtPres∙ w w' e) 33 | 34 | wkNfPres∙ w w' (up n) = cong up (wkNePres∙ w w' n) 35 | wkNfPres∙ w w' (lam n) = cong lam (wkNfPres∙ (keep w) (keep w') n) 36 | wkNfPres∙ w w' (box n) = cong box (wkNfPres∙ (keep# w) (keep# w') n) 37 | 38 | ------------------------ 39 | -- Naturality conditions 40 | ------------------------ 41 | 42 | -- Normal forms and neutrals obey "naturality" of embeddding, i.e., 43 | -- weakening can be commuted with embedding. 44 | 45 | -- the mutual brothers normal forms and neutrals who, 46 | -- as always, must be handled (mutually) together 47 | nat-embNe : (w : Γ ⊆ Γ') (n : Ne Γ a) 48 | → wkTm w (embNe n) ≡ embNe (wkNe w n) 49 | nat-embNf : (w : Γ ⊆ Γ') (n : Nf Γ a) 50 | → wkTm w (embNf n) ≡ embNf (wkNf w n) 51 | 52 | nat-embNf w (up x) = nat-embNe w x 53 | nat-embNf w (lam n) = cong lam (nat-embNf (keep w) n) 54 | nat-embNf w (box n) = cong box (nat-embNf (keep# w) n) 55 | 56 | nat-embNe w (var x) = refl 57 | nat-embNe w (app n x) = cong₂ app (nat-embNe w n) (nat-embNf w x) 58 | nat-embNe w (unbox n x) = cong₂ unbox (nat-embNe (sliceLeft x w) n) refl 59 | -------------------------------------------------------------------------------- /src/IK/Term/Reduction.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IK.Term.Reduction where 3 | 4 | open import Relation.Nullary 5 | using (¬_) 6 | 7 | open import Relation.Binary 8 | using (Preorder) 9 | 10 | open import Relation.Binary.Construct.Closure.ReflexiveTransitive 11 | as ReflexiveTransitive 12 | using (Star) 13 | open import Relation.Binary.Construct.Closure.ReflexiveTransitive.Properties 14 | using (preorder) 15 | 16 | open import Relation.Binary.PropositionalEquality 17 | using (_≡_ ; refl ; cong ; cong₂) 18 | 19 | open ReflexiveTransitive public 20 | using (ε ; _◅_) 21 | 22 | import RUtil 23 | 24 | open import IK.Term.Base 25 | 26 | ------------------- 27 | -- Reduction rules 28 | ------------------- 29 | 30 | data _⟶_ : Tm Γ a → Tm Γ a → Set where 31 | 32 | red-fun : {t : Tm (Γ `, a) b} {u : Tm Γ a} 33 | → app (lam t) u ⟶ substTm (idₛ `, u) t 34 | 35 | exp-fun : {t : Tm Γ (a ⇒ b)} 36 | → t ⟶ lam (app (wkTm fresh t) (var zero)) 37 | 38 | red-box : {t : Tm (ΓL #) a} {e : LFExt Γ (ΓL #) ΓR} 39 | → unbox (box t) e ⟶ wkTm (LFExtToWk e) t 40 | 41 | exp-box : {t : Tm Γ (□ a)} 42 | → t ⟶ box (unbox t nil) 43 | 44 | cong-lam : {t t' : Tm (Γ `, a) b} 45 | → t ⟶ t' 46 | → lam t ⟶ lam t' 47 | 48 | cong-app1 : {t t' : Tm Γ (a ⇒ b)} {u : Tm Γ a} 49 | → t ⟶ t' 50 | → app t u ⟶ app t' u 51 | 52 | cong-app2 : {t : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 53 | → u ⟶ u' 54 | → app t u ⟶ app t u' 55 | 56 | cong-box : {t t' : Tm (Γ #) a} 57 | → t ⟶ t' 58 | → box t ⟶ box t' 59 | 60 | cong-unbox : {t t' : Tm ΓL (□ a)} {e : LFExt Γ (ΓL #) ΓR} 61 | → t ⟶ t' 62 | → unbox t e ⟶ unbox t' e 63 | 64 | module _ {Γ : Ctx} {a : Ty} where 65 | open RUtil (_⟶_ {Γ} {a}) public 66 | 67 | -- zero or more steps of reduction 68 | Tm-preorder : (Γ : Ctx) → (a : Ty) → Preorder _ _ _ 69 | Tm-preorder Γ a = preorder (_⟶_ {Γ} {a}) 70 | 71 | module _ {Γ : Ctx} {a : Ty} where 72 | open Preorder (Tm-preorder Γ a) public 73 | using () 74 | renaming (_∼_ to _⟶*_ ; refl to ⟶*-refl ; reflexive to none ; trans to multi) 75 | 76 | single : (t⟶t' : t ⟶ t') → t ⟶* t' 77 | single t⟶t' = t⟶t' ◅ ε 78 | 79 | single-≡ : (t⟶t' : t ⟶ t') → (t'≡t'' : t' ≡ t'') → t ⟶* t'' 80 | single-≡ t⟶t' refl = single t⟶t' 81 | 82 | ≡-single : (t≡t' : t ≡ t') → (t'⟶t'' : t' ⟶ t'') → t ⟶* t'' 83 | ≡-single refl t'⟶t'' = single t'⟶t'' 84 | 85 | ≡-single-≡ : (t≡t' : t ≡ t') → (t'⟶t'' : t' ⟶ t'') → (t''≡t''' : t'' ≡ t''') → t ⟶* t''' 86 | ≡-single-≡ refl t'⟶t'' refl = single t'⟶t'' 87 | 88 | multi-≡ : (t⟶*t' : t ⟶* t') → (t'≡t'' : t' ≡ t'') → t ⟶* t'' 89 | multi-≡ t⟶*t' refl = t⟶*t' 90 | 91 | ≡-multi : (t≡t' : t ≡ t') → (t'⟶*t'' : t' ⟶* t'') → t ⟶* t'' 92 | ≡-multi refl t'⟶*t'' = t'⟶*t'' 93 | 94 | ≡-multi-≡ : (t≡t' : t ≡ t') → (t'⟶*t'' : t' ⟶* t'') → (t''≡t''' : t'' ≡ t''') → t ⟶* t''' 95 | ≡-multi-≡ refl t'⟶*t'' refl = t'⟶*t'' 96 | 97 | ⟶-multi : (t⟶t' : t ⟶ t') → (t'⟶*t'' : t' ⟶* t'') → t ⟶* t'' 98 | ⟶-multi t⟶t' t'⟶*t'' = multi (single t⟶t') t'⟶*t'' 99 | 100 | multi-⟶ : (t⟶*t' : t ⟶* t') → (t'⟶t'' : t' ⟶ t'') → t ⟶* t'' 101 | multi-⟶ t⟶*t' t'⟶t'' = multi t⟶*t' (single t'⟶t'') 102 | 103 | module _ {t : Tm Γ a → Tm Δ b} (cong-t : ∀ {u u' : Tm Γ a} → (u⟶u' : u ⟶ u') → t u ⟶* t u') where 104 | cong-⟶*-to-cong-⟶* : ∀ (u⟶*u' : u ⟶* u') → t u ⟶* t u' 105 | cong-⟶*-to-cong-⟶* ε = ε 106 | cong-⟶*-to-cong-⟶* (u⟶u'' ◅ u''⟶*u') = multi (cong-t u⟶u'') (cong-⟶*-to-cong-⟶* u''⟶*u') 107 | 108 | cong-⟶-to-cong-⟶* : {t : Tm Γ a → Tm Δ b} (cong-t : ∀ {u u' : Tm Γ a} → (u⟶u' : u ⟶ u') → t u ⟶ t u') (u⟶*u' : u ⟶* u') → t u ⟶* t u' 109 | cong-⟶-to-cong-⟶* cong-t = cong-⟶*-to-cong-⟶* (λ u⟶u' → single (cong-t u⟶u')) 110 | 111 | cong-app : {t t' : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 112 | → t ⟶ t' → u ⟶ u' 113 | → app t u ⟶* app t' u' 114 | cong-app t⟶t' u⟶u' = cong-app1 t⟶t' ◅ cong-app2 u⟶u' ◅ ε 115 | 116 | cong-box* : {t t' : Tm (Γ #) a} 117 | → t ⟶* t' 118 | → box t ⟶* box t' 119 | cong-box* = cong-⟶-to-cong-⟶* cong-box 120 | 121 | cong-unbox* : {t t' : Tm ΓL (□ a)} {e : LFExt Γ (ΓL #) ΓR} 122 | → t ⟶* t' 123 | → unbox t e ⟶* unbox t' e 124 | cong-unbox* = cong-⟶-to-cong-⟶* cong-unbox 125 | 126 | cong-lam* : {t t' : Tm (Γ `, a) b} 127 | → t ⟶* t' 128 | → lam t ⟶* lam t' 129 | cong-lam* = cong-⟶-to-cong-⟶* cong-lam 130 | 131 | cong-app*≡ : {t t' : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 132 | → t ⟶* t' 133 | → u ≡ u' 134 | → app t u ⟶* app t' u' 135 | cong-app*≡ t⟶*t' refl = cong-⟶-to-cong-⟶* cong-app1 t⟶*t' 136 | 137 | cong-app1* : {t t' : Tm Γ (a ⇒ b)} {u : Tm Γ a} 138 | → t ⟶* t' 139 | → app t u ⟶* app t' u 140 | cong-app1* t⟶*t' = cong-app*≡ t⟶*t' refl 141 | 142 | cong-app≡* : {t t' : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 143 | → t ≡ t' 144 | → u ⟶* u' 145 | → app t u ⟶* app t' u' 146 | cong-app≡* refl u⟶*u' = cong-⟶-to-cong-⟶* cong-app2 u⟶*u' 147 | 148 | cong-app2* : {t : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 149 | → u ⟶* u' 150 | → app t u ⟶* app t u' 151 | cong-app2* u⟶*u' = cong-app≡* refl u⟶*u' 152 | 153 | cong-app* : {t t' : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 154 | → t ⟶* t' → u ⟶* u' 155 | → app t u ⟶* app t' u' 156 | cong-app* t⟶*t' u⟶*u' = multi (cong-app1* t⟶*t') (cong-app2* u⟶*u') 157 | -------------------------------------------------------------------------------- /src/IS4/Applications/IS4Plus.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Applications.IS4Plus where 3 | 4 | open import Relation.Nullary using (_because_; yes; no) 5 | 6 | open import Relation.Binary.Definitions using (Decidable) 7 | open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; cong ; cong₂) 8 | 9 | -- IS4 with extensions 10 | 11 | data Ty : Set where 12 | Unit : Ty 13 | 𝕔 : Ty 14 | _⇒_ : Ty → Ty → Ty 15 | ◻_ : Ty → Ty 16 | Bool : Ty 17 | 18 | variable 19 | a b c d : Ty 20 | 21 | Ty-Decidable : Decidable (_≡_ {A = Ty}) 22 | Ty-Decidable Unit Unit = yes refl 23 | Ty-Decidable Unit Bool = no λ () 24 | Ty-Decidable Unit 𝕔 = no λ () 25 | Ty-Decidable Unit (a ⇒ b) = no λ () 26 | Ty-Decidable Unit (◻ a) = no λ () 27 | Ty-Decidable Bool Unit = no λ () 28 | Ty-Decidable Bool Bool = yes refl 29 | Ty-Decidable Bool 𝕔 = no λ () 30 | Ty-Decidable Bool (a ⇒ b) = no λ () 31 | Ty-Decidable Bool (◻ a) = no λ () 32 | Ty-Decidable 𝕔 Unit = no λ () 33 | Ty-Decidable 𝕔 Bool = no λ () 34 | Ty-Decidable 𝕔 𝕔 = yes refl 35 | Ty-Decidable 𝕔 (a ⇒ b) = no λ () 36 | Ty-Decidable 𝕔 (◻ a) = no λ () 37 | Ty-Decidable (a ⇒ b) Unit = no λ () 38 | Ty-Decidable (a ⇒ b) Bool = no λ () 39 | Ty-Decidable (a ⇒ b) 𝕔 = no λ () 40 | Ty-Decidable (a ⇒ b) (c ⇒ d) with Ty-Decidable a c | Ty-Decidable b d 41 | ... | yes a≡c | yes b≡d = yes (cong₂ _⇒_ a≡c b≡d) 42 | ... | yes a≡c | no ¬b≡d = no λ { refl → ¬b≡d refl } 43 | ... | no ¬a≡c | yes b≡d = no λ { refl → ¬a≡c refl } 44 | ... | no ¬a≡c | no ¬b≡d = no λ { refl → ¬a≡c refl } 45 | Ty-Decidable (a ⇒ b) (◻ c) = no λ () 46 | Ty-Decidable (◻ a) Unit = no λ () 47 | Ty-Decidable (◻ a) Bool = no λ () 48 | Ty-Decidable (◻ a) 𝕔 = no λ () 49 | Ty-Decidable (◻ a) (b ⇒ c) = no λ () 50 | Ty-Decidable (◻ a) (◻ b) with Ty-Decidable a b 51 | ... | yes a≡b = yes (cong ◻_ a≡b) 52 | ... | no ¬a≡b = no λ { refl → ¬a≡b refl } 53 | 54 | open import Context Ty Ty-Decidable hiding (ext#) public 55 | 56 | ------------------------------------ 57 | -- Variables, terms and substituions 58 | ------------------------------------ 59 | 60 | data Tm : Ctx → Ty → Set where 61 | 62 | var : Var Γ a 63 | --------- 64 | → Tm Γ a 65 | 66 | lam : Tm (Γ `, a) b 67 | ------------- 68 | → Tm Γ (a ⇒ b) 69 | 70 | app : Tm Γ (a ⇒ b) → Tm Γ a 71 | --------------------- 72 | → Tm Γ b 73 | 74 | box : Tm (Γ #) a 75 | ------------ 76 | → Tm Γ (◻ a) 77 | 78 | unbox : Tm ΓL (◻ a) → CExt Γ ΓL ΓR 79 | ---------------------------- 80 | → Tm Γ a 81 | 82 | unit : Tm Γ Unit 83 | 84 | true : Tm Γ Bool 85 | 86 | false : Tm Γ Bool 87 | 88 | ifte : CExt Γ ΓL ΓR → Tm ΓL Bool → Tm Γ a → Tm Γ a → Tm Γ a 89 | 90 | TM : Ty → Ctx → Set 91 | TM a Γ = Tm Γ a 92 | 93 | wkTm : Γ ⊆ Γ' → Tm Γ a → Tm Γ' a 94 | wkTm w (var x) = var (wkVar w x) 95 | wkTm w (lam t) = lam (wkTm (keep w) t) 96 | wkTm w (app t u) = app (wkTm w t) (wkTm w u) 97 | wkTm w (box t) = box (wkTm (keep# w) t) 98 | wkTm w (unbox t e) = unbox (wkTm (factorWk e w) t) (factorExt e w) 99 | wkTm w unit = unit 100 | wkTm w true = true 101 | wkTm w false = false 102 | wkTm w (ifte e t t₁ t₂) = ifte (factorExt e w) (wkTm (factorWk e w) t) (wkTm w t₁) (wkTm w t₂) 103 | 104 | open import Data.Unit using (⊤ ; tt) 105 | open import Data.Product using (Σ ; _×_ ; _,_ ) renaming (proj₂ to snd) 106 | 107 | --------------- 108 | -- Normal forms 109 | --------------- 110 | data Ne : Ctx → Ty → Set 111 | data Nf : Ctx → Ty → Set 112 | 113 | data Ne where 114 | var : Var Γ a → Ne Γ a 115 | app : Ne Γ (a ⇒ b) → Nf Γ a → Ne Γ b 116 | unbox : Ne ΓL (◻ a) → CExt Γ ΓL ΓR → Ne Γ a 117 | 118 | data Nf where 119 | up : Ne Γ 𝕔 → Nf Γ 𝕔 120 | lam : Nf (Γ `, a) b → Nf Γ (a ⇒ b) 121 | box : Nf (Γ #) a → Nf Γ (◻ a) 122 | true : Nf Γ Bool 123 | false : Nf Γ Bool 124 | ifte : CExt Γ ΓL ΓR → Ne ΓL Bool → Nf Γ a → Nf Γ a → Nf Γ a 125 | unit : Nf Γ Unit 126 | 127 | -- embedding into terms 128 | 129 | embNe : Ne Γ a → Tm Γ a 130 | embNf : Nf Γ a → Tm Γ a 131 | 132 | embNe (var x) = var x 133 | embNe (app m n) = app (embNe m) (embNf n) 134 | embNe (unbox n x) = unbox (embNe n) x 135 | 136 | embNf (up x) = embNe x 137 | embNf (lam n) = lam (embNf n) 138 | embNf (box n) = box (embNf n) 139 | embNf true = true 140 | embNf false = false 141 | embNf (ifte x x₁ n n₁) = ifte x true (embNf n) (embNf n₁) 142 | embNf unit = unit 143 | 144 | -- weakening lemmas 145 | 146 | wkNe : Γ ⊆ Γ' → Ne Γ a → Ne Γ' a 147 | wkNf : Γ ⊆ Γ' → Nf Γ a → Nf Γ' a 148 | 149 | wkNe w (var x) = var (wkVar w x) 150 | wkNe w (app m n) = app (wkNe w m) (wkNf w n) 151 | wkNe w (unbox n e) = unbox (wkNe (factorWk e w) n) (factorExt e w) 152 | 153 | wkNf w (up x) = up (wkNe w x) 154 | wkNf w (lam n) = lam (wkNf (keep w) n) 155 | wkNf w (box n) = box (wkNf (keep# w) n) 156 | wkNf w true = true 157 | wkNf w false = false 158 | wkNf w (ifte e m n n₁) = ifte (factorExt e w) (wkNe (factorWk e w) m) (wkNf w n) (wkNf w n₁) 159 | wkNf w unit = unit 160 | 161 | NF NE : Ty → Ctx → Set 162 | NF a Γ = Nf Γ a 163 | NE a Γ = Ne Γ a 164 | 165 | ------------ 166 | -- NbE Model 167 | ------------ 168 | 169 | variable 170 | A B C : Ctx → Set 171 | 172 | -- family of maps between interpretations 173 | _→̇_ : (Ctx → Set) → (Ctx → Set) → Set 174 | _→̇_ A B = {Δ : Ctx} → A Δ → B Δ 175 | 176 | infixr 10 _→̇_ 177 | 178 | -- constructions on context-indexed families of sets 179 | _⇒'_ : (Ctx → Set) → (Ctx → Set) → (Ctx → Set) 180 | _⇒'_ A B Γ = {Γ' : Ctx} → Γ ⊆ Γ' → A Γ' → B Γ' 181 | 182 | _×'_ : (Ctx → Set) → (Ctx → Set) → (Ctx → Set) 183 | _×'_ A B Γ = A Γ × B Γ 184 | 185 | Box : (Ctx → Set) → (Ctx → Set) 186 | Box A ΓL = {ΓL' Γ ΓR : Ctx} → ΓL ⊆ ΓL' → CExt Γ ΓL' ΓR → A Γ 187 | 188 | -- semantic counterpart of `lock` from `Sub` 189 | data Lock (A : Ctx → Set) : Ctx → Set where 190 | lock : A ΓL → CExt Γ ΓL ΓR → Lock A Γ 191 | 192 | ⊤' : (Ctx → Set) 193 | ⊤' = λ Γ → ⊤ 194 | 195 | data Cov (A : Ctx → Set) : Ctx → Set where 196 | ret : A Γ → Cov A Γ 197 | ifte' : CExt Γ ΓL ΓR → NE Bool ΓL → Cov A Γ → Cov A Γ → Cov A Γ 198 | 199 | wkCov : (Γ ⊆ Γ' → A Γ → A Γ') → Γ ⊆ Γ' → Cov A Γ → Cov A Γ' 200 | wkCov wk w (ret x) 201 | = ret (wk w x) 202 | wkCov wk w (ifte' e n m m₁) 203 | = ifte' (factorExt e w) (wkNe (factorWk e w) n) (wkCov wk w m) (wkCov wk w m₁) 204 | 205 | fmapCov : (A →̇ B) → (Cov A →̇ Cov B) 206 | fmapCov f (ret x) = ret (f x) 207 | fmapCov f (ifte' e x m m₁) = ifte' e x (fmapCov f m) (fmapCov f m₁) 208 | 209 | mapCov : (A ⇒' B) →̇ (Cov A ⇒' Cov B) 210 | mapCov f w (ret x) = ret (f w x) 211 | mapCov f w (ifte' e x m m₁) = ifte' e x (mapCov f w m) (mapCov f w m₁) 212 | 213 | joinCov : Cov (Cov A) →̇ Cov A 214 | joinCov (ret m) = m 215 | joinCov (ifte' e x m m₁) = ifte' e x (joinCov m₁) (joinCov m₁) 216 | 217 | bindCov : (A ⇒' Cov B) →̇ (Cov A ⇒' Cov B) 218 | bindCov f e m = joinCov (mapCov f e m) 219 | 220 | collect : Cov (NF a) →̇ NF a 221 | collect (ret x) = x 222 | collect (ifte' e x m m₁) = ifte e x (collect m) (collect m₁) 223 | 224 | open import Data.Bool renaming (Bool to Bool') 225 | 226 | Tm'- : Ty → (Ctx → Set) 227 | Tm'- Unit = ⊤' 228 | Tm'- 𝕔 = Cov (NE 𝕔) 229 | Tm'- (a ⇒ b) = (Tm'- a) ⇒' (Tm'- b) 230 | Tm'- (◻ a) = Box (Tm'- a) 231 | Tm'- Bool = Cov (λ _ → Bool') 232 | 233 | Sub'- : Ctx → (Ctx → Set) 234 | Sub'- [] = ⊤' 235 | Sub'- (Γ `, a) = Sub'- Γ ×' Tm'- a 236 | Sub'- (Γ #) = Lock (Sub'- Γ) 237 | 238 | -- values in the model can be weakened 239 | wkTm'- : Γ ⊆ Γ' → Tm'- a Γ → Tm'- a Γ' 240 | wkTm'- {a = 𝕔} w m = wkCov wkNe w m 241 | wkTm'- {a = a ⇒ b} w f = λ w' y → f (w ∙ w') y 242 | wkTm'- {a = ◻ a} w bx = λ w' e → bx (w ∙ w') e 243 | wkTm'- {a = Unit} w n = tt 244 | wkTm'- {a = Bool} w m = wkCov (λ _ z → z) w m 245 | 246 | -- substitutions in the model can be weakened 247 | wkSub'- : Γ ⊆ Γ' → Sub'- Δ Γ → Sub'- Δ Γ' 248 | wkSub'- {Δ = []} w tt = tt 249 | wkSub'- {Δ = Δ `, a} w (s , x) = wkSub'- {Δ = Δ} w s , wkTm'- {a = a} w x 250 | wkSub'- {Δ = Δ #} w (lock s e) = lock (wkSub'- {Δ = Δ} (factorWk e w) s) (factorExt e w) 251 | 252 | -- semantic counterpart of `unbox` from `Tm` 253 | unbox' : Box (Tm'- a) ΓL → CExt Γ ΓL ΓR → Tm'- a Γ 254 | unbox' bx e = bx idWk e 255 | 256 | unboxCov : Cov (Box (Tm'- a)) Δ → CExt Γ Δ ΓR → Cov (Tm'- a) Γ 257 | unboxCov (ret x) e 258 | = ret (x idWk e) 259 | unboxCov {a = a} (ifte' e' x m1 m2) e 260 | = ifte' (extRAssoc e' e) x (unboxCov {a = a} m1 e) (unboxCov {a = a} m2 e) 261 | 262 | appCov : Cov (Tm'- (a ⇒ b)) Γ → Cov (Tm'- a) Γ → Cov (Tm'- b) Γ 263 | runCov : Cov (Tm'- a) →̇ Tm'- a 264 | 265 | appCov {a = a} (ret f) m 266 | = ret (f idWk (runCov {a = a} m)) 267 | appCov {a = a} {b = b} (ifte' e n m1 m2) m 268 | = ifte' e n (appCov {a = a} {b = b} m1 m) (appCov {a = a} {b = b} m2 m) 269 | 270 | runCov {Unit} m 271 | = tt 272 | runCov {𝕔} m 273 | = joinCov m 274 | runCov {a ⇒ b} m 275 | = λ w x → runCov {b} (appCov {a = a} {b = b} (wkCov (wkTm'- {a = a ⇒ b}) w m) (ret x)) 276 | runCov {◻ a} m 277 | = λ w e → runCov {a} (unboxCov {a = a} (wkCov (wkTm'- {a = ◻ a}) w m) e) 278 | runCov {Bool} m 279 | = joinCov m 280 | 281 | ------------------------- 282 | -- Normalization function 283 | ------------------------- 284 | 285 | VAR : Ty → Ctx → Set 286 | VAR a Γ = Var Γ a 287 | 288 | reify : Tm'- a →̇ NF a 289 | reflect : NE a →̇ Tm'- a 290 | 291 | reify {Unit} x = unit 292 | reify {𝕔} x = collect (mapCov (λ _ n → up n) idWk x) 293 | reify {a ⇒ b} x = lam (reify {b} (x (drop idWk) (reflect {a} (var zero)))) 294 | reify {◻ a} x = box (reify (x idWk (ext#- nil))) 295 | reify {Bool} x = true 296 | 297 | reflect {Unit} n = tt 298 | reflect {𝕔} n = ret n 299 | reflect {a ⇒ b} n = λ e t → reflect {b} (app (wkNe e n) (reify t)) 300 | reflect {◻ a} n = λ w e → reflect (unbox (wkNe w n) e) 301 | reflect {Bool} n = ifte' nil n (ret true) (ret false) 302 | 303 | -- identity substitution 304 | idₛ' : Sub'- Γ Γ 305 | idₛ' {[]} = tt 306 | idₛ' {Γ `, a} = wkSub'- {Δ = Γ} (drop idWk) (idₛ' {Γ = Γ}) , reflect {a} (var zero) 307 | idₛ' {Γ #} = lock (idₛ' {Γ}) (ext#- nil) 308 | 309 | -- interpretation of variables 310 | substVar' : Var Γ a → (Sub'- Γ →̇ Tm'- a) 311 | substVar' zero (_ , x) = x 312 | substVar' (succ x) (γ , _) = substVar' x γ 313 | 314 | unlock' : Sub'- (Γ #) Δ → Σ (Ctx × Ctx) λ { (ΔL , ΔR) → Sub'- Γ ΔL × CExt Δ ΔL ΔR } 315 | unlock' (lock γ e) = _ , γ , e 316 | 317 | CExt' : CExt Γ ΓL ΓR → Sub'- Γ →̇ Sub'- (ΓL #) 318 | CExt' nil γ = lock γ nil 319 | CExt' (ext e) (γ , _) = CExt' e γ 320 | CExt' {Γ = Γ} {ΓL} {ΓR} (ext#- e) (lock γ e') with unlock' {Γ = ΓL} (CExt' e γ) .snd 321 | ... | (γ' , e'') = lock γ' (extRAssoc e'' e') 322 | 323 | eval-ifte : CExt Γ ΓL ΓR → Cov (λ _ → Bool') ΓL → Cov A Γ → Cov A Γ → Cov A Γ 324 | eval-ifte e (ret false) m1 m2 = m2 325 | eval-ifte e (ret true) m1 m2 = m2 326 | eval-ifte e (ifte' e' n c1 c2) m1 m2 = ifte' (extRAssoc e' e) n (eval-ifte e c1 m1 m2) (eval-ifte e c2 m1 m2) 327 | 328 | -- interpretation of terms 329 | eval : Tm Γ a → (Sub'- Γ →̇ Tm'- a) 330 | eval (var x) s 331 | = substVar' x s 332 | eval {Γ = Γ} (lam t) s 333 | = λ e x → eval t (wkSub'- {Δ = Γ} e s , x) 334 | eval (app t u) s 335 | = (eval t s) idWk (eval u s) 336 | eval {Γ = Γ} (box t) s 337 | = λ w e → eval t (lock (wkSub'- {Δ = Γ} w s) e) 338 | eval {a = a} (unbox t nil) s 339 | = unbox' {a = a} (eval t s) nil 340 | eval (unbox t (ext e)) (s , _) 341 | = eval (unbox t e) s 342 | eval (unbox t (ext#- e)) (lock s nil) 343 | = eval (unbox t e) s 344 | eval {a = a} (unbox t (ext#- e)) (lock s (ext {a = b} e')) 345 | = wkTm'- {_} {_} {a} fresh[ b ] (eval (unbox t (ext#- e)) (lock s e')) 346 | eval {a = a} (unbox t (ext#- nil)) (lock s (ext#- e')) 347 | = unbox' {a} (eval t s) (ext#- e') 348 | eval (unbox t (ext#- (ext e))) (lock (s , _) (ext#- e')) 349 | = eval (unbox t (ext#- e)) (lock s (ext#- e')) 350 | eval (unbox t (ext#- (ext#- e))) (lock (lock s e'') (ext#- e')) 351 | = eval (unbox t (ext#- e)) (lock s (ext#- (extRAssoc e'' e'))) 352 | eval unit s 353 | = tt 354 | eval true s 355 | = ret true 356 | eval false s 357 | = ret false 358 | eval {Γ = Γ} {a = a} (ifte {ΓL = ΓL} e t t₁ t₂) {Δ = Δ} s with unlock' {Γ = ΓL} (CExt' e s) 359 | ... | ((ΓL' , ΓR') , s' , e') 360 | = runCov {a = a} (eval-ifte e' (eval t s') (ret (eval t₁ s)) (ret (eval t₁ s))) 361 | 362 | -- retraction of interpretation 363 | quot : (Sub'- Γ →̇ Tm'- a) → Nf Γ a 364 | quot {Γ} f = reify (f (idₛ' {Γ})) 365 | 366 | -- normalization function 367 | norm : Tm Γ a → Nf Γ a 368 | norm t = quot (eval t) 369 | -------------------------------------------------------------------------------- /src/IS4/Norm.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Norm where 3 | 4 | open import IS4.Norm.Base public 5 | open import IS4.Norm.Properties.Completeness public 6 | open import IS4.Norm.Properties.Soundness public 7 | -------------------------------------------------------------------------------- /src/IS4/Norm/Base.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Norm.Base where 3 | 4 | open import Data.Unit using (tt) 5 | open import Data.Product using (_,_) 6 | 7 | open import IS4.Norm.NbE.Model 8 | open import IS4.Norm.NbE.Reification 9 | 10 | open import IS4.Term 11 | 12 | -- retraction of interpretation 13 | quot : Sub'- Γ →̇ Tm'- a → Nf Γ a 14 | quot {Γ} {a} f = reify a (f (idₛ' Γ)) 15 | 16 | -- retraction of evalₛ (simply "do everything pointwise") 17 | quotₛ : Sub'- Γ →̇ Nfₛ- Γ 18 | quotₛ {[]} tt = [] 19 | quotₛ {Γ `, a} (elem (s , x)) = quotₛ s `, reify a x 20 | quotₛ {Γ #} (elem (ΓL , (ΓR , e) , s)) = lock (quotₛ s) e 21 | 22 | -- normalization function 23 | norm : Tm Γ a → Nf Γ a 24 | norm t = quot (eval t) 25 | 26 | -- normalization function, for substitutions 27 | normₛ : Sub Δ Γ → Nfₛ Δ Γ 28 | normₛ {Γ} s = quotₛ (evalₛ s (idₛ' Γ)) 29 | -------------------------------------------------------------------------------- /src/IS4/Norm/NbE/Model.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Norm.NbE.Model where 3 | 4 | open import Data.Product using (Σ ; ∃ ; _×_ ; _,_ ; -,_ ; proj₁ ; proj₂) 5 | 6 | open import Relation.Binary 7 | using (Reflexive ; Transitive ; Irrelevant) 8 | open import Relation.Binary.PropositionalEquality 9 | using (_≡_ ; subst ; cong ; cong₂ ; cong-id ; subst-application) 10 | renaming (refl to ≡-refl ; sym to ≡-sym ; trans to ≡-trans ; isEquivalence to ≡-equiv) 11 | 12 | open import PUtil 13 | 14 | open import IS4.Term as Term hiding (factorWk) 15 | 16 | import Semantics.Presheaf.Evaluation.IS4 17 | 18 | factor : ∀ (Γ◁Δ : Γ ◁IS4 Δ) (w : Δ ⊆ Δ') → ∃ λ Γ' → Γ ⊆ Γ' × Γ' ◁IS4 Δ' 19 | factor (_ , Γ◁Δ) w = -, Term.factorWk Γ◁Δ w , -, factorExt Γ◁Δ w 20 | 21 | factorWk : ∀ (Γ◁Δ : Γ ◁IS4 Δ) (w : Δ ⊆ Δ') → Γ ⊆ _ 22 | factorWk r w = factor r w .proj₂ .proj₁ 23 | 24 | factor◁ : ∀ (Γ◁Δ : Γ ◁IS4 Δ) (w : Δ ⊆ Δ') → _ ◁IS4 Δ' 25 | factor◁ r w = factor r w .proj₂ .proj₂ 26 | 27 | private 28 | factor-pres-id : ∀ (Γ◁Δ : Γ ◁IS4 Δ) → factor Γ◁Δ idWk ≡ (-, idWk , Γ◁Δ) 29 | factor-pres-id (_ , Γ◁Δ) = Σ×-≡,≡,≡→≡ (lCtxPresId Γ◁Δ , factorWkPresId Γ◁Δ , ◁IS4-irrel _ _) 30 | 31 | factor-pres-∙ : ∀ (Γ◁Δ : Γ ◁IS4 Δ) (w : Δ ⊆ Δ') (w' : Δ' ⊆ Δ'') → factor Γ◁Δ (w ∙ w') ≡ (-, factorWk Γ◁Δ w ∙ factorWk (factor◁ Γ◁Δ w) w' , factor◁ (factor◁ Γ◁Δ w) w') 32 | factor-pres-∙ (_ , Γ◁Δ) w w' = Σ×-≡,≡,≡→≡ (lCtxPres∙ Γ◁Δ w w' , factorWkPres∙ Γ◁Δ w w' , ◁IS4-irrel _ _) 33 | 34 | factor-pres-refl : ∀ (w : Γ ⊆ Γ') → factor ◁IS4-refl w ≡ (-, w , ◁IS4-refl) 35 | factor-pres-refl w = Σ-≡,≡→≡ (lCtxPresRefl {θ = tt} w , ×-≡,≡→≡ (factorWkPresRefl {θ = tt} w , ◁IS4-irrel _ _)) 36 | 37 | factor-pres-trans : ∀ (Γ◁Δ : Γ ◁IS4 Δ) (Δ◁Θ : Δ ◁IS4 Θ) (w : Θ ⊆ Θ') → factor (◁IS4-trans Γ◁Δ Δ◁Θ) w ≡ (-, factorWk Γ◁Δ (factorWk Δ◁Θ w) , ◁IS4-trans (factor◁ Γ◁Δ (factorWk Δ◁Θ w)) (factor◁ Δ◁Θ w)) 38 | factor-pres-trans (_ , Γ◁Δ) (_ , Δ◁Θ) w = Σ×-≡,≡,≡→≡ (lCtxPresTrans Γ◁Δ Δ◁Θ w , factorWkPresTrans Γ◁Δ Δ◁Θ w , ◁IS4-irrel _ _) 39 | 40 | module PresheafEvaluationIS4 = Semantics.Presheaf.Evaluation.IS4 41 | Ctx 42 | _⊆_ _∙_ (λ w w' w'' → ≡-sym (assocWk w w' w'')) idWk rightIdWk leftIdWk 43 | _◁IS4_ ◁IS4-trans ◁IS4-trans-assoc ◁IS4-refl ◁IS4-refl-unit-left ◁IS4-refl-unit-right 44 | factor factor-pres-id factor-pres-∙ factor-pres-refl factor-pres-trans 45 | 46 | open PresheafEvaluationIS4 public 47 | hiding (_→̇_ ; unbox') 48 | renaming (module Eval to PresheafEvaluationIS4Eval ; module EvalProperties to PresheafEvaluationIS4EvalProperties) 49 | 50 | 𝒩ℯ : (a : Ty) → Psh 51 | 𝒩ℯ a = record 52 | { Fam = λ Γ → Ne Γ a 53 | ; _≋_ = _≡_ 54 | ; ≋-equiv = λ _ → ≡-equiv 55 | ; wk = wkNe 56 | ; wk-pres-≋ = λ w → cong (wkNe w) 57 | ; wk-pres-refl = wkNePresId 58 | ; wk-pres-trans = λ w w' n → ≡-sym (wkNePres∙ w w' n) 59 | } 60 | 61 | open PresheafEvaluationIS4Eval (𝒩ℯ ι) public 62 | hiding (Sub' ; Tm') 63 | open PresheafEvaluationIS4EvalProperties (𝒩ℯ ι) public 64 | 65 | 𝒩𝒻 : (a : Ty) → Psh 66 | 𝒩𝒻 a = record 67 | { Fam = λ Γ → Nf Γ a 68 | ; _≋_ = _≡_ 69 | ; ≋-equiv = λ _ → ≡-equiv 70 | ; wk = wkNf 71 | ; wk-pres-≋ = λ w → cong (wkNf w) 72 | ; wk-pres-refl = wkNfPresId 73 | ; wk-pres-trans = λ w w' n → ≡-sym (wkNfPres∙ w w' n) 74 | } 75 | 76 | -- renaming environments, representable presheaf, Yoneda embedding 77 | ℛℯ𝓃 : (Γ : Ctx) → Psh 78 | ℛℯ𝓃 Γ = record 79 | { Fam = Γ ⊆_ 80 | ; _≋_ = _≡_ 81 | ; ≋-equiv = λ _ → ≡-equiv 82 | ; wk = λ w w' → w' ∙ w 83 | ; wk-pres-≋ = λ w → cong (_∙ w) 84 | ; wk-pres-refl = rightIdWk 85 | ; wk-pres-trans = λ w w' w'' → ≡-sym (assocWk w'' w w') 86 | } 87 | 88 | 𝒯𝓂 : (a : Ty) → Psh 89 | 𝒯𝓂 a = record 90 | { Fam = λ Γ → Tm Γ a 91 | ; _≋_ = _≡_ 92 | ; ≋-equiv = λ _ → ≡-equiv 93 | ; wk = wkTm 94 | ; wk-pres-≋ = λ w → cong (wkTm w) 95 | ; wk-pres-refl = wkTmPresId 96 | ; wk-pres-trans = λ w w' t → ≡-sym (wkTmPres∙ w w' t) 97 | } 98 | 99 | 𝒮𝓊𝒷 : (Γ : Ctx) → Psh 100 | 𝒮𝓊𝒷 Γ = record 101 | { Fam = λ Δ → Sub Δ Γ 102 | ; _≋_ = _≡_ 103 | ; ≋-equiv = λ _ → ≡-equiv 104 | ; wk = wkSub 105 | ; wk-pres-≋ = λ w → cong (wkSub w) 106 | ; wk-pres-refl = wkSubPresId 107 | ; wk-pres-trans = λ w w' s → ≡-sym (wkSubPres∙ w w' s) 108 | } 109 | 110 | -- family of maps between interpretations 111 | _→̇_ : (Ctx → Set) → (Ctx → Set) → Set 112 | _→̇_ A B = {Δ : Ctx} → A Δ → B Δ 113 | 114 | -- interpretation of types 115 | Tm' : (Γ : Ctx) → (a : Ty) → Set 116 | Tm' Γ a = evalTy a ₀ Γ 117 | 118 | Tm'- : Ty → Ctx → Set 119 | Tm'- a Γ = Tm' Γ a 120 | 121 | -- interpretation of contexts ("environments") 122 | Sub' : (Γ : Ctx) → (Δ : Ctx) → Set 123 | Sub' Γ Δ = evalCtx Δ ₀ Γ 124 | 125 | Sub'- : Ctx → Ctx → Set 126 | Sub'- Δ Γ = Sub' Γ Δ 127 | 128 | variable 129 | ρ ρ' ρ'' : Sub' Γ Δ 130 | 131 | -- values in the model can be weakened 132 | wkTy' wkTm' : (a : Ty) → (w : Γ ⊆ Γ') → (x : Tm' Γ a) → Tm' Γ' a 133 | wkTy' a = wk[ evalTy a ] 134 | wkTm' = wkTy' 135 | 136 | -- environments in the model can be weakened 137 | wkSub' : (Δ : Ctx) → (w : Γ ⊆ Γ') → (ρ : Sub' Γ Δ) → Sub' Γ' Δ 138 | wkSub' Δ = wk[ evalCtx Δ ] 139 | 140 | -- semantic counterpart of `unbox` from `Tm` 141 | unbox' : Tm' ΓL (□ a) → CExt Γ ΓL ΓR → Tm' Γ a 142 | unbox' (elem bx _bx-nat) e = bx idWk (-, e) 143 | 144 | unlock' : Sub' Δ (Γ #) → Σ (Ctx × Ctx) λ { (ΔL , ΔR) → Sub' ΔL Γ × CExt Δ ΔL ΔR } 145 | unlock' (elem (ΔL , (ΔR , e), s)) = (ΔL , ΔR) , (s , e) 146 | 147 | -- interpretation of variables 148 | substVar' : Var Γ a → Sub'- Γ →̇ Tm'- a 149 | substVar' v = evalVar v .apply 150 | 151 | CExt' : CExt Γ ΓL ΓR → Sub'- Γ →̇ Sub'- (ΓL #) 152 | CExt' e = evalAcc e .apply 153 | 154 | module _ (e : CExt Γ ΓL ΓR) (s : Sub' Δ Γ) (let elem (ΔL , (ΔR , e') , s') = evalAcc e .apply s) where 155 | -- "Left" context of factoring with a substitution (see factorExtₛ) 156 | lCtxₛ' : Ctx 157 | lCtxₛ' = ΔL 158 | 159 | -- "Right" context of factoring with a substitution (see factorExtₛ) 160 | rCtxₛ' : Ctx 161 | rCtxₛ' = ΔR 162 | 163 | -- same as factorExtₛ 164 | factorExtₛ' : CExt Δ lCtxₛ' rCtxₛ' 165 | factorExtₛ' = e' 166 | 167 | -- same as factorSubₛ 168 | factorSubₛ' : Sub' lCtxₛ' ΓL 169 | factorSubₛ' = s' 170 | 171 | -- interpretation of terms 172 | eval : Tm Γ a → (Sub'- Γ →̇ Tm'- a) 173 | eval t s = evalTm t .apply s 174 | 175 | -- interpretation of substitutions 176 | evalₛ : Sub Γ Δ → Sub'- Γ →̇ Sub'- Δ 177 | evalₛ s γ = evalSub s .apply γ 178 | -------------------------------------------------------------------------------- /src/IS4/Norm/NbE/Reification.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Norm.NbE.Reification where 3 | 4 | open import Data.Unit using (⊤; tt) renaming () 5 | open import Data.Product using (Σ; ∃; _,_; -,_) renaming (_×_ to _∧_; proj₁ to fst; proj₂ to snd) 6 | 7 | open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; subst; cong; cong₂; module ≡-Reasoning) 8 | 9 | import Relation.Binary.Reasoning.Setoid as EqReasoning 10 | 11 | open import IS4.Norm.NbE.Model 12 | 13 | open import IS4.Term hiding (factorWk) 14 | 15 | reflect : (a : Ty) → (n : Ne Γ a) → Tm' Γ a 16 | reflect-pres-≋ : ∀ (a : Ty) {n n' : Ne Γ a} (n≡n' : n ≡ n') → reflect a n ≋[ evalTy a ] reflect a n' 17 | reflect-natural : ∀ (a : Ty) (n : Ne Γ a) (w : Γ ⊆ Γ') → reflect a (wkNe w n) ≋[ evalTy a ] wk[ evalTy a ] w (reflect a n) 18 | 19 | reify : (a : Ty) → (x : Tm' Γ a) → Nf Γ a 20 | reify-pres-≋ : ∀ (a : Ty) {x x' : Tm' Γ a} (x≋x' : x ≋[ evalTy a ] x') → reify a x ≡ reify a x' 21 | reify-natural : ∀ (a : Ty) (x : Tm' Γ a) (w : Γ ⊆ Γ') → reify a (wk[ evalTy a ] w x) ≡ wkNf w (reify a x) 22 | 23 | var0' : (a : Ty) → Tm' (Γ `, a) a 24 | var0' a = reflect a (var zero) 25 | 26 | -- interpretation of neutrals 27 | reflect ι n = n 28 | reflect (a ⇒ b) n = record 29 | { fun = λ w p → reflect b (app (wkNe w n) (reify a p)) 30 | ; pres-≋ = λ w p≋p' → reflect-pres-≋ b (cong (app (wkNe w n)) (reify-pres-≋ a p≋p')) 31 | ; natural = λ w w' p → let open EqReasoning ≋[ evalTy b ]-setoid in begin 32 | wk[ evalTy b ] w' (reflect b (app (wkNe w n) (reify a p))) ≈˘⟨ reflect-natural b _ w' ⟩ 33 | reflect b (wkNe w' (app (wkNe w n) (reify a p))) ≡⟨⟩ 34 | reflect b (app (wkNe w' (wkNe w n)) (wkNf w' (reify a p))) ≡˘⟨ cong (λ m → reflect b (app _ m)) (reify-natural a p w') ⟩ 35 | reflect b (app (wkNe w' (wkNe w n)) (reify a (wk[ evalTy a ] w' p))) ≡⟨ cong (λ n → reflect b (app n _)) (wkNePres∙ w w' n) ⟩ 36 | reflect b (app (wkNe (w ∙ w') n) (reify a (wk[ evalTy a ] w' p))) ∎ 37 | } 38 | reflect (□ a) n = record 39 | { fun = λ w (_ , e) → reflect a (unbox (wkNe w n) e) 40 | ; natural = λ w r@(_ , e) w' → let open EqReasoning ≋[ evalTy a ]-setoid in begin 41 | reflect a (unbox (wkNe (w ∙ factorWk r w') n) (factorExt e w')) ≡˘⟨ cong (λ n → reflect a (unbox n _)) (wkNePres∙ w (factorWk r w') n) ⟩ 42 | reflect a (unbox (wkNe (factorWk r w') (wkNe w n)) (factorExt e w')) ≡⟨⟩ 43 | reflect a (wkNe w' (unbox (wkNe w n) e)) ≈⟨ reflect-natural a (unbox (wkNe w n) e) w' ⟩ 44 | wk[ evalTy a ] w' (reflect a (unbox (wkNe w n) e)) ∎ 45 | } 46 | 47 | reflect-pres-≋ = λ a n≡n' → ≋[ evalTy a ]-reflexive (cong (reflect a) n≡n') 48 | 49 | reflect-natural ι n w = ≋[ evalTy ι ]-refl 50 | reflect-natural (a ⇒ b) n w = record 51 | { pw = λ w' p → let open EqReasoning ≋[ evalTy b ]-setoid in begin 52 | reflect (a ⇒ b) (wkNe w n) .apply w' p ≡⟨⟩ 53 | reflect b (app (wkNe w' (wkNe w n)) (reify a p)) ≡⟨ cong (λ n → reflect b (app n (reify a p))) (wkNePres∙ w w' n) ⟩ 54 | reflect b (app (wkNe (w ∙ w') n) (reify a p)) ≡⟨⟩ 55 | wk[ evalTy (a ⇒ b) ] w (reflect (a ⇒ b) n) .apply w' p ∎ 56 | } 57 | reflect-natural (□ a) n w = record 58 | { pw = λ w' r@(_ , e) → let open EqReasoning ≋[ evalTy a ]-setoid in begin 59 | reflect (□ a) (wkNe w n) .apply w' r ≡⟨⟩ 60 | reflect a (unbox (wkNe w' (wkNe w n)) e) ≡⟨ cong (λ n → reflect a (unbox n e)) (wkNePres∙ w w' n) ⟩ 61 | reflect a (unbox (wkNe (w ∙ w') n) e) ≡⟨⟩ 62 | wk[ evalTy (□ a) ] w (reflect (□ a) n) .apply w' r ∎ 63 | } 64 | 65 | -- reify values to normal forms 66 | reify ι n = up n 67 | reify (a ⇒ b) f = lam (reify b (f .apply fresh[ a ] (var0' a))) 68 | reify (□ a) b = box (reify a (b .apply idWk new◁IS4)) 69 | 70 | reify-pres-≋ ι x≋x' = cong up x≋x' 71 | reify-pres-≋ (a ⇒ b) x≋x' = cong lam (reify-pres-≋ b (x≋x' .pw fresh[ a ] (var0' a))) 72 | reify-pres-≋ (□ a) x≋x' = cong box (reify-pres-≋ a (x≋x' .pw idWk new◁IS4)) 73 | 74 | reify-natural ι x w = refl 75 | reify-natural (a ⇒ b) x w = let open ≡-Reasoning in begin 76 | reify (a ⇒ b) (wk[ evalTy (a ⇒ b) ] w x) ≡⟨⟩ 77 | lam (reify b (x .apply (w ∙ fresh[ a ]) (var0' a))) ≡˘⟨ cong₂ (λ w n → lam (reify b (x .apply w (reflect a n)))) fresh-keep refl ⟩ 78 | lam (reify b (x .apply (fresh[ a ] ∙ keep[ a ] w) (reflect a (wkNe (keep[ a ] w) var0)))) ≡⟨ cong lam (reify-pres-≋ b (x .apply-≋ _ (reflect-natural a var0 (keep[ a ] w)))) ⟩ 79 | lam (reify b (x .apply (fresh[ a ] ∙ keep[ a ] w) (wk[ evalTy a ] (keep[ a ] w) (var0' a)))) ≡˘⟨ cong lam (reify-pres-≋ b (x .natural fresh[ a ] (keep[ a ] w) _)) ⟩ 80 | lam (reify b (wk[ evalTy b ] (keep[ a ] w) (x .apply fresh[ a ] (var0' a)))) ≡⟨ cong lam (reify-natural b _ (keep[ a ] w)) ⟩ 81 | lam (wkNf (keep[ a ] w) (reify b (x .apply fresh[ a ] (var0' a)))) ≡⟨⟩ 82 | wkNf w (reify (a ⇒ b) x) ∎ 83 | reify-natural (□ a) x w = let open ≡-Reasoning in begin 84 | reify (□ a) (wk[ evalTy (□ a) ] w x) ≡⟨⟩ 85 | box (reify a (wk[ evalTy (□ a) ] w x .apply idWk new◁IS4)) ≡⟨⟩ 86 | box (reify a (x .apply (w ∙ idWk) new◁IS4)) ≡⟨ cong (λ w → box (reify a (x .apply w new◁IS4))) (rightIdWk w) ⟩ 87 | box (reify a (x .apply w new◁IS4)) ≡˘⟨ cong (λ w → box (reify a (x .apply w new◁IS4))) (leftIdWk w) ⟩ 88 | box (reify a (x .apply (idWk ∙ w) new◁IS4)) ≡⟨⟩ 89 | box (reify a (x .apply (idWk ∙ factorWk new◁IS4 (keep# w)) (factor◁ new◁IS4 (keep# w)))) ≡⟨ cong box (reify-pres-≋ a (x .natural idWk new◁IS4 (keep# w))) ⟩ 90 | box (reify a (wk[ evalTy a ] (keep# w) (x .apply idWk new◁IS4))) ≡⟨ cong box (reify-natural a (x .apply idWk new◁IS4) (keep# w)) ⟩ 91 | box (wkNf (keep# w) (reify a (x .apply idWk new◁IS4))) ≡⟨⟩ 92 | wkNf w (reify (□ a) x) ∎ 93 | 94 | -- (reflected) identity substitution (one direction of the prinicipal lemma?) 95 | idₛ' : (Γ : Ctx) → Sub' Γ Γ 96 | idₛ' [] = tt 97 | idₛ' (Γ `, a) = record { elem = (wkSub' Γ fresh[ a ] (idₛ' Γ) , (var0' a)) } 98 | idₛ' (Γ #) = elem (-, new◁IS4 , idₛ' Γ) 99 | -------------------------------------------------------------------------------- /src/IS4/Norm/Properties/Completeness.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Norm.Properties.Completeness where 3 | 4 | open import Relation.Binary.PropositionalEquality using (_≡_) 5 | 6 | open import IS4.Norm.Base 7 | 8 | open import IS4.Norm.NbE.Model 9 | open import IS4.Norm.NbE.Reification 10 | 11 | open import IS4.Term 12 | 13 | norm-complete : (t≈u : t ≈ u) → norm t ≡ norm u 14 | norm-complete {Γ} {a} t≈u = reify-pres-≋ a (apply-sq (evalTm-sound' t≈u) ≋[ evalCtx Γ ]-refl) 15 | -------------------------------------------------------------------------------- /src/IS4/Norm/Properties/Soundness.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Norm.Properties.Soundness where 3 | 4 | open import Data.Unit using (⊤ ; tt) 5 | open import Data.Product using (Σ ; _×_ ; _,_ ; -,_) 6 | 7 | open import Relation.Binary.PropositionalEquality 8 | using (_≡_ ; refl ; sym ; trans ; subst ; subst₂ ; cong ; cong₂ ; module ≡-Reasoning) 9 | 10 | open import PEUtil 11 | 12 | open import IS4.Norm.Base 13 | 14 | open import IS4.Norm.NbE.Model hiding (factorWk) 15 | open import IS4.Norm.NbE.Reification 16 | 17 | open import IS4.Term 18 | 19 | quotTm : Tm' Γ a → Tm Γ a 20 | quotTm x = embNf (reify _ x) 21 | 22 | ----------------------- 23 | -- Logical Relations -- 24 | ----------------------- 25 | 26 | L : (a : Ty) → (t : Tm Γ a) → (x : Tm' Γ a) → Set 27 | L ι t n = 28 | t ≈ quotTm n 29 | L {Γ} (a ⇒ b) t f = 30 | ∀ {Γ' : Ctx} {u : Tm Γ' a} {x : Tm' Γ' a} 31 | → (w : Γ ⊆ Γ') → (uLx : L a u x) → L b (app (wkTm w t) u) (f .apply w x) 32 | L {Γ} (□ a) t b = 33 | ∀ {Γ' Δ ΓR' : Ctx} 34 | → (w : Γ ⊆ Γ') → (e : CExt Δ Γ' ΓR') → L a (unbox (wkTm w t) e) (b .apply w (-, e)) 35 | 36 | data Lₛ {Γ : Ctx} : (Δ : Ctx) → Sub Γ Δ → Sub' Γ Δ → Set where 37 | [] : Lₛ [] [] tt 38 | _`,_ : {s : Sub Γ Δ} {δ : Sub' Γ Δ} {t : Tm Γ a} {x : Tm' Γ a} 39 | → (sLδ : Lₛ Δ s δ) → (tLx : L a t x) → Lₛ (Δ `, a) (s `, t) (elem (δ , x)) 40 | lock : {s : Sub Γ' Δ} {δ : Sub' Γ' Δ} 41 | → (sLδ : Lₛ Δ s δ) → (e : CExt Γ Γ' ΓR') → Lₛ (Δ #) (lock s e) (elem (Γ' , (ΓR' , e) , δ)) 42 | 43 | ---------------------------- 44 | -- Standard LR properties -- 45 | ---------------------------- 46 | 47 | -- prepend a reduction trace to the "trace builder" L 48 | L-prepend : {t u : Tm Γ a} {x : Tm' Γ a} 49 | → (t≈u : t ≈ u) 50 | → (uLx : L a u x) 51 | → L a t x 52 | L-prepend {a = ι} t≈u uLn 53 | = ≈-trans t≈u uLn 54 | L-prepend {a = a ⇒ b} t≈u uLf 55 | = λ w uRy → L-prepend (cong-app≈ (wkTmPres≈ w t≈u) ≈-refl) (uLf w uRy) 56 | L-prepend {a = □ a} t≈u uLb 57 | = λ w e → L-prepend (cong-unbox≈ (wkTmPres≈ w t≈u)) (uLb w e) 58 | 59 | -- reduction-free version of L-prepend 60 | L-cast : {t u : Tm Γ a} {x y : Tm' Γ a} 61 | → (t≡u : t ≡ u) 62 | → (x≡y : x ≡ y) 63 | → (uLy : L a u y) 64 | → L a t x 65 | L-cast refl refl uLy = uLy 66 | 67 | -- extract reduction trace from L 68 | L-build : {t : Tm Γ a} {x : Tm' Γ a} 69 | → (tLx : L a t x) → t ≈ quotTm x 70 | -- a neutral element is related to its reflection 71 | L-reflect : (n : Ne Γ a) 72 | → L a (embNe n) (reflect a n) 73 | 74 | L-build {a = ι} tLn 75 | = tLn 76 | L-build {a = a ⇒ b} tLf 77 | = ≈-trans 78 | (⟶-to-≈ (exp-fun _)) 79 | (cong-lam≈ (L-build (tLf fresh[ a ] (L-reflect var0)))) 80 | L-build {a = □ a} {t} tLb 81 | = ≈-trans 82 | (⟶-to-≈ (exp-box _)) 83 | (cong-box≈ (L-build (L-cast (cong1 unbox (sym (wkTmPresId t))) refl (tLb idWk new)))) 84 | 85 | L-reflect {a = ι} n 86 | = ≈-refl 87 | L-reflect {a = a ⇒ b} n {_Γ'} {_t} {x} 88 | = λ w tLx → L-prepend 89 | (cong-app≈ (≈-reflexive (nat-embNe w n)) (L-build tLx)) 90 | (L-reflect (app (wkNe w n) (reify a x))) 91 | L-reflect {a = □ a} n 92 | = λ w e → L-prepend 93 | (cong-unbox≈ (≈-reflexive (nat-embNe w n))) 94 | (L-reflect (unbox (wkNe w n) e)) 95 | 96 | -- L is invariant under weakening 97 | wkTmPresL : {t : Tm Γ a} {x : Tm' Γ a} 98 | → (w : Γ ⊆ Γ') 99 | → (tLx : L a t x) 100 | → L a (wkTm w t) (wkTm' a w x) 101 | wkTmPresL {a = ι} {x = x} w tLn 102 | = ≈-trans (wkTmPres≈ w tLn) (≈-reflexive (nat-embNf w (reify ι x))) 103 | wkTmPresL {a = a ⇒ b} {t = t} w tLf 104 | = λ w' y → L-cast (cong1 app (wkTmPres∙ w w' t)) refl (tLf (w ∙ w') y) 105 | wkTmPresL {a = □ a} {t = t} w tLb 106 | = λ w' e → L-cast (cong1 unbox (wkTmPres∙ w w' t)) refl (tLb (w ∙ w') e) 107 | 108 | -- Lₛ is invariant under weakening 109 | wkSubPresLₛ : {s : Sub Γ Δ} {δ : Sub' Γ Δ} 110 | → (w : Γ ⊆ Γ') 111 | → (sLδ : Lₛ Δ s δ) 112 | → Lₛ Δ (wkSub w s) (wkSub' Δ w δ) 113 | wkSubPresLₛ {Δ = []} w [] 114 | = [] 115 | wkSubPresLₛ {Δ = _Δ `, _a} w (sLδ `, tLx) 116 | = wkSubPresLₛ w sLδ `, wkTmPresL w tLx 117 | wkSubPresLₛ {Δ = _Δ #} w (lock sLδ e) 118 | = lock (wkSubPresLₛ (factorWk e w) sLδ) (factorExt e w) 119 | 120 | -- syntactic identity is related to semantic identity 121 | idLₛ : Lₛ Δ idₛ (idₛ' Δ) 122 | idLₛ {[]} = [] 123 | idLₛ {_Δ `, a} = wkSubPresLₛ fresh[ a ] idLₛ `, L-reflect var0 124 | idLₛ {_Δ #} = lock idLₛ new 125 | 126 | ----------------------------- 127 | -- The Fundamental Theorem -- 128 | ----------------------------- 129 | 130 | -- local lemmas for the proof of fundamental theorem 131 | private 132 | substVarPresL : (v : Var Δ a) {s : Sub Γ Δ} {δ : Sub' Γ Δ} 133 | → (sLδ : Lₛ Δ s δ) 134 | → L a (substVar s v) (substVar' v δ) 135 | substVarPresL zero (_sLδ `, tLx) = tLx 136 | substVarPresL (succ v) ( sLδ `, _tLx) = substVarPresL v sLδ 137 | 138 | beta-lemma : (w : Γ ⊆ Γ') (s : Sub Γ Δ) (t : Tm (Δ `, a) b) (u : Tm Γ' a) 139 | → app (wkTm w (substTm s (lam t))) u ≈ substTm (wkSub w s `, u) t 140 | beta-lemma w s t u = ≈-trans (≈-reflexive (cong1 app (cong lam (trans 141 | (sym (nat-substTm t (keepₛ s) (keep w))) 142 | (cong (λ p → substTm (p `, var0) t) 143 | (trans 144 | (wkSubPres∙ fresh (keep w) s) 145 | (cong1 wkSub (cong drop (leftIdWk w))))))))) 146 | (≈-trans 147 | (⟶-to-≈ (red-fun _ _)) 148 | (≈-trans 149 | (≈-reflexive (substTmPres∙ _ _ t)) 150 | (substTmPres≈ t 151 | (cong-`,≈ₛ 152 | (≈ₛ-trans 153 | (≈ₛ-reflexive˘ (coh-trimSub-wkSub s _ _)) 154 | (≈ₛ-trans (≈ₛ-reflexive (coh-trimSub-wkSub s idₛ w)) (≈ₛ-sym (rightIdSub _)))) 155 | ≈-refl)))) 156 | 157 | lCtxₛ'∼lCtxₛ : {s : Sub Γ Δ} {δ : Sub' Γ Δ} 158 | → (e : CExt Δ ΔL ΔR) 159 | → (sLδ : Lₛ Δ s δ) 160 | → lCtxₛ' e δ ≡ lCtxₛ e s 161 | lCtxₛ'∼lCtxₛ nil _sLδ = refl 162 | lCtxₛ'∼lCtxₛ (ext e) (sLδ `, _tLx) = lCtxₛ'∼lCtxₛ e sLδ 163 | lCtxₛ'∼lCtxₛ (ext#- e) (lock sLδ _e') = lCtxₛ'∼lCtxₛ e sLδ 164 | 165 | rCtxₛ'∼rCtxₛ : {s : Sub Γ Δ} {δ : Sub' Γ Δ} 166 | → (e : CExt Δ ΔL ΔR) 167 | → (sLδ : Lₛ Δ s δ) 168 | → rCtxₛ' e δ ≡ rCtxₛ e s 169 | rCtxₛ'∼rCtxₛ nil _sLδ = refl 170 | rCtxₛ'∼rCtxₛ (ext e) (sLδ `, _tLx) = rCtxₛ'∼rCtxₛ e sLδ 171 | rCtxₛ'∼rCtxₛ (ext#- e) (lock sLδ _e') = cong (_,, _) (rCtxₛ'∼rCtxₛ e sLδ) 172 | 173 | factorSubPresLₛ : {s : Sub Γ Δ} {δ : Sub' Γ Δ} 174 | → (e : CExt Δ ΔL ΔR) 175 | → (sLδ : Lₛ Δ s δ) 176 | → Lₛ ΔL (factorSubₛ e s) (subst (λ Γ → Sub' Γ ΔL) (lCtxₛ'∼lCtxₛ e sLδ) (factorSubₛ' e δ)) 177 | factorSubPresLₛ nil sLδ = sLδ 178 | factorSubPresLₛ (ext e) (sLδ `, _tLx) = factorSubPresLₛ e sLδ 179 | factorSubPresLₛ (ext#- e) (lock sLδ _e') = factorSubPresLₛ e sLδ 180 | 181 | module _ (w : Γ ⊆ Γ') (s : Sub Γ Δ) (t : Tm (Δ #) a) (e : CExt Θ Γ' ΓR') where 182 | unbox-box-reduces : unbox (wkTm w (substTm s (box t))) e ≈ substTm (lock (wkSub w s) e) t 183 | unbox-box-reduces = begin 184 | unbox (wkTm w (substTm s (box t))) e 185 | ≡⟨⟩ 186 | unbox (box (wkTm (keep# w) (substTm (lock s new) t))) e 187 | ≈⟨ ⟶-to-≈ (red-box _ _) ⟩ 188 | substTm (lock idₛ e) (wkTm (keep# w) (substTm (lock s new) t)) 189 | ≡⟨ cong (substTm _) (sym (nat-substTm t _ _)) ⟩ 190 | substTm (lock idₛ e) (substTm (wkSub (keep# w) (lock s new)) t) 191 | ≡⟨ substTmPres∙ _ _ t ⟩ 192 | substTm (wkSub (keep# w) (lock s new) ∙ₛ (lock idₛ e) ) t 193 | ≡⟨⟩ 194 | substTm (lock (wkSub w s ∙ₛ idₛ) (extRAssoc nil e)) t 195 | ≈˘⟨ substTmPres≈ t (cong-lock≈ₛ′ (rightIdSub (wkSub w s))) ⟩ 196 | substTm (lock (wkSub w s) e) t ∎ 197 | where 198 | open import Relation.Binary.Reasoning.Setoid (Tm-setoid Θ a) 199 | 200 | -- The Fundamental theorem, for terms 201 | 202 | Fund : Tm Δ a → Set 203 | Fund {Δ} {a} t = ∀ {Γ} {s : Sub Γ Δ} {δ : Sub' Γ Δ} 204 | → (sLδ : Lₛ Δ s δ) 205 | → L a (substTm s t) (eval t δ) 206 | 207 | fund : (t : Tm Γ a) → Fund t 208 | fund (var v) sLδ 209 | = substVarPresL v sLδ 210 | fund (lam t) {_Γ} {s} sLδ {_Γ'} {u} 211 | = λ w uLx → L-prepend (beta-lemma w s t u) 212 | (fund t {s = wkSub w s `, u} (wkSubPresLₛ w sLδ `, uLx)) 213 | fund (app t u) {_Γ} {s} sLδ 214 | = L-cast 215 | (cong1 app (sym (wkTmPresId (substTm s t)))) 216 | refl 217 | (fund t sLδ idWk (fund u sLδ)) 218 | fund (box t) {_Γ} {s} sLδ 219 | = λ w e → L-prepend (unbox-box-reduces w s t e) (fund t (lock (wkSubPresLₛ w sLδ) e)) 220 | fund (unbox {ΔL} t e) {Γ} {s} {δ} sLδ 221 | = L-cast 222 | (cong-unbox≡′ (sym (wkTmPresId (substTm (factorSubₛ e s) t)))) 223 | (dcong₄ (λ Γ δ w r → eval t {Γ} δ .apply {Γ} w r) 224 | (lCtxₛ'∼lCtxₛ e sLδ) 225 | refl 226 | (subst-application′′ idWk (lCtxₛ'∼lCtxₛ e sLδ)) 227 | (trans (subst-application′ -,_ (lCtxₛ'∼lCtxₛ e sLδ)) (dcong₂ _,_ (rCtxₛ'∼rCtxₛ e sLδ) (ExtIsProp _ _)))) 228 | (fund t 229 | {s = factorSubₛ e s} 230 | {δ = subst (λ Δ → Sub' Δ ΔL) (lCtxₛ'∼lCtxₛ e sLδ) (factorSubₛ' e δ)} 231 | (factorSubPresLₛ e sLδ) 232 | idWk[ lCtxₛ e s ] 233 | (subst₂ (CExt Γ) (lCtxₛ'∼lCtxₛ e sLδ) (rCtxₛ'∼rCtxₛ e sLδ) (factorExtₛ' e δ))) 234 | 235 | -- reduction trace for norm 236 | trace : (t : Tm Γ a) → t ≈ embNf (norm t) 237 | trace t = L-build (L-prepend (substTmPresId t) (fund t idLₛ)) 238 | 239 | norm-sound : norm t ≡ norm u → t ≈ u 240 | norm-sound {t = t} {u} t'≡u' = ≈-trans (trace t) (≡-≈-trans˘ (cong embNf t'≡u') (trace u)) 241 | -------------------------------------------------------------------------------- /src/IS4/Term.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Term where 3 | 4 | open import IS4.Term.Base public 5 | open import IS4.Term.Conversion public 6 | open import IS4.Term.NormalForm public 7 | open import IS4.Term.Properties public 8 | open import IS4.Term.Reduction public 9 | 10 | pattern var0 = var v0 11 | pattern var1 = var v1 12 | pattern var2 = var v2 13 | -------------------------------------------------------------------------------- /src/IS4/Term/Base.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Term.Base where 3 | 4 | -- 5 | -- Implementation of the IS4 (Intuitionistic S4) calculus from 6 | -- "Fitch-Style Modal Lambda Calculi" by Ranald Clouston (2018) 7 | -- 8 | 9 | open import Data.Product using (∃ ; _×_ ; _,_ ; -,_ ; proj₁ ; proj₂) 10 | 11 | open import Relation.Binary.PropositionalEquality using (sym ; subst) 12 | 13 | open import Type as Type using (Ty ; Ty-Decidable) 14 | 15 | import Context Ty Ty-Decidable as Context 16 | 17 | open Context public hiding (ext#) 18 | open Type public 19 | 20 | ------------------------------------- 21 | -- Variables, terms and substitutions 22 | ------------------------------------- 23 | 24 | data Tm : Ctx → Ty → Set where 25 | 26 | var : (v : Var Γ a) 27 | --------------- 28 | → Tm Γ a 29 | 30 | lam : (t : Tm (Γ `, a) b) 31 | ------------------- 32 | → Tm Γ (a ⇒ b) 33 | 34 | app : (t : Tm Γ (a ⇒ b)) 35 | → (u : Tm Γ a) 36 | ------------------ 37 | → Tm Γ b 38 | 39 | box : (t : Tm (Γ #) a) 40 | ------------------ 41 | → Tm Γ (□ a) 42 | 43 | unbox : (t : Tm ΓL (□ a)) 44 | → (e : CExt Γ ΓL ΓR) 45 | -------------------- 46 | → Tm Γ a 47 | 48 | variable 49 | t t' t'' t''' : Tm Γ a 50 | u u' u'' u''' : Tm Γ a 51 | 52 | pattern var0 = var v0 53 | pattern var1 = var v1 54 | pattern var2 = var v2 55 | 56 | wkTm : Γ ⊆ Γ' → Tm Γ a → Tm Γ' a 57 | wkTm w (var x) = var (wkVar w x) 58 | wkTm w (lam t) = lam (wkTm (keep w) t) 59 | wkTm w (app t u) = app (wkTm w t) (wkTm w u) 60 | wkTm w (box t) = box (wkTm (keep# w) t) 61 | wkTm w (unbox t e) = unbox (wkTm (factorWk e w) t) (factorExt e w) 62 | 63 | -- extension that "generates a new context frame" 64 | new : CExt (Γ #) Γ ([] #) -- Γ R Γ # 65 | new = ext#- nil 66 | 67 | new[_] = λ Γ → new {Γ} 68 | 69 | open Substitution Tm var wkTm CExt new lCtx factorWk rCtx factorExt public 70 | renaming (module Composition to SubstitutionComposition) 71 | 72 | -- "Left" context of factoring with a substitution (see factorSubₛ and factorExtₛ) 73 | lCtxₛ : (e : CExt Γ ΓL ΓR) (s : Sub Δ Γ) → Ctx 74 | lCtxₛ {Δ = Δ} nil s = Δ 75 | lCtxₛ (ext e) (s `, t) = lCtxₛ e s 76 | lCtxₛ (ext#- e) (lock s e') = lCtxₛ e s 77 | 78 | factorSubₛ : (e : CExt Γ ΓL ΓR) (s : Sub Δ Γ) → Sub (lCtxₛ e s) ΓL 79 | factorSubₛ nil s = s 80 | factorSubₛ (ext e) (s `, t) = factorSubₛ e s 81 | factorSubₛ (ext#- e) (lock s e') = factorSubₛ e s 82 | 83 | -- "Right" context of factoring with a substitution (see factorExtₛ) 84 | rCtxₛ : (e : CExt Γ ΓL ΓR) (s : Sub Δ Γ) → Ctx 85 | rCtxₛ nil s = [] 86 | rCtxₛ (ext e) (s `, t) = rCtxₛ e s 87 | rCtxₛ (ext#- e) (lock {ΔR = ΔR} s e') = rCtxₛ e s ,, ΔR 88 | 89 | factorExtₛ : (e : CExt Γ ΓL ΓR) (s : Sub Δ Γ) → CExt Δ (lCtxₛ e s) (rCtxₛ e s) 90 | factorExtₛ nil s = nil 91 | factorExtₛ (ext e) (s `, _) = factorExtₛ e s 92 | factorExtₛ (ext#- e) (lock s e') = extRAssoc (factorExtₛ e s) e' 93 | 94 | -- apply substitution to a term 95 | substTm : Sub Δ Γ → Tm Γ a → Tm Δ a 96 | substTm s (var x) = substVar s x 97 | substTm s (lam t) = lam (substTm (keepₛ s) t) 98 | substTm s (app t u) = app (substTm s t) (substTm s u) 99 | substTm s (box t) = box (substTm (keep#ₛ s) t) 100 | substTm s (unbox t e) = unbox (substTm (factorSubₛ e s) t) (factorExtₛ e s) 101 | 102 | open SubstitutionComposition substTm lCtxₛ factorSubₛ rCtxₛ factorExtₛ public 103 | -------------------------------------------------------------------------------- /src/IS4/Term/Conversion.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Term.Conversion where 3 | 4 | open import Data.Product using (Σ ; _,_) 5 | 6 | import Data.Sum as Sum 7 | 8 | open import Relation.Binary using (Setoid) 9 | 10 | open import Relation.Binary.Construct.Closure.Equivalence using (setoid) 11 | import Relation.Binary.Construct.Closure.Equivalence.Properties as EquivalenceProperties 12 | 13 | import Relation.Binary.Construct.Closure.ReflexiveTransitive as ReflexiveTransitive 14 | 15 | open import Relation.Binary.PropositionalEquality 16 | using (_≡_ ; cong ; cong₂ ; subst ; subst₂ ; module ≡-Reasoning) 17 | renaming (refl to ≡-refl ; sym to ≡-sym ; trans to ≡-trans) 18 | 19 | open import PUtil 20 | open import PEUtil 21 | 22 | open import IS4.Term.Base 23 | open import IS4.Term.Reduction as Reduction 24 | 25 | open Sum public using (inj₁ ; inj₂) 26 | open ReflexiveTransitive public using (ε ; _◅_) 27 | open EquivalenceProperties public using () renaming (a—↠b⇒a↔b to ⟶*-to-≈) 28 | 29 | -- Convertibility is defined by taking the equivalence closure of the 30 | -- reduction relation `_⟶_`, i.e. two terms `t` and `u` are 31 | -- convertible (written `t ≈ u`) if and only if there is a sequence of 32 | -- terms `sᵢ` for i = 0,…,n such that 1. `s₀ = t`, 2. `sₙ = u`, and 33 | -- 3. `sᵢ ⟶ sᵢ₊₁` or `sᵢ₊₁ ⟶ sᵢ` for all i. 34 | -- 35 | -- Note that `_⟶_` is already a congruence, i.e. `u ⟶ v` implies `t[u] 36 | -- ⟶ t[v]`, and being a congruence preserved by closing under 37 | -- reflexivity, symmetry and transitivity. 38 | Tm-setoid : (Γ : Ctx) → (a : Ty) → Setoid _ _ 39 | Tm-setoid Γ a = setoid (_⟶_ {Γ} {a}) 40 | 41 | module _ {Γ : Ctx} {a : Ty} where 42 | open Setoid (Tm-setoid Γ a) public 43 | using (_≈_) 44 | renaming (refl to ≈-refl ; reflexive to ≈-reflexive ; sym to ≈-sym ; trans to ≈-trans ; isEquivalence to ≈-equiv) 45 | 46 | ≈-reflexive˘ : t' ≡ t → t ≈ t' 47 | ≈-reflexive˘ t'≡t = ≈-reflexive (≡-sym t'≡t) 48 | 49 | ≡-to-≈ = ≈-reflexive 50 | 51 | ≈-˘trans : t' ≈ t → t' ≈ t'' → t ≈ t'' 52 | ≈-˘trans t'≈t t'≈t'' = ≈-trans (≈-sym t'≈t) t'≈t'' 53 | 54 | ≈-trans˘ : t ≈ t' → t'' ≈ t' → t ≈ t'' 55 | ≈-trans˘ t≈t' t''≈t' = ≈-trans t≈t' (≈-sym t''≈t') 56 | 57 | ≡-≈-trans˘ : t ≡ t' → t'' ≈ t' → t ≈ t'' 58 | ≡-≈-trans˘ t≡t' t''≈t' = ≈-trans˘ (≡-to-≈ t≡t') t''≈t' 59 | 60 | ⟶-to-≈ : t ⟶ t' → t ≈ t' 61 | ⟶-to-≈ p = inj₁ p ◅ ε 62 | 63 | ⟵-to-≈ : t' ⟶ t → t ≈ t' 64 | ⟵-to-≈ p = inj₂ p ◅ ε 65 | 66 | module _ {t : Tm Γ a → Tm Δ b} (cong-t : ∀ {u u' : Tm Γ a} → (u⟶u' : u ⟶ u') → t u ⟶ t u') where 67 | -- XXX: fold 68 | cong-⟶-to-cong-≈ : ∀ (u≈u' : u ≈ u') → t u ≈ t u' 69 | cong-⟶-to-cong-≈ ε = ε 70 | cong-⟶-to-cong-≈ (inj₁ u⟶u'' ◅ u''≈u') = inj₁ (cong-t u⟶u'') ◅ cong-⟶-to-cong-≈ u''≈u' 71 | cong-⟶-to-cong-≈ (inj₂ u⟵u'' ◅ u''≈u') = inj₂ (cong-t u⟵u'') ◅ cong-⟶-to-cong-≈ u''≈u' 72 | 73 | red-fun≈ : (t : Tm (Γ `, a) b) (u : Tm Γ a) → (app (lam t) u) ≈ substTm (idₛ `, u) t 74 | red-fun≈ t u = ⟶-to-≈ (Reduction.red-fun t u) 75 | 76 | exp-fun≈ : (t : Tm Γ (a ⇒ b)) → t ≈ lam (app (wkTm fresh t) (var zero)) 77 | exp-fun≈ t = ⟶-to-≈ (Reduction.exp-fun t) 78 | 79 | red-box≈ : (t : Tm (ΓL #) a) (e : CExt Γ ΓL ΓR) → unbox (box t) e ≈ substTm (lock idₛ e) t 80 | red-box≈ t e = ⟶-to-≈ (Reduction.red-box t e) 81 | 82 | exp-box≈ : (t : Tm Γ (□ a)) → t ≈ box (unbox t new) 83 | exp-box≈ t = ⟶-to-≈ (Reduction.exp-box t) 84 | 85 | cong-lam≈ : ∀ (t≈t' : t ≈ t') → lam t ≈ lam t' 86 | cong-lam≈ = cong-⟶-to-cong-≈ Reduction.cong-lam 87 | 88 | cong-app≈≡ : ∀ (t≈t' : t ≈ t') (u≡u' : u ≡ u') → app t u ≈ app t' u 89 | cong-app≈≡ t≈t' ≡-refl = cong-⟶-to-cong-≈ Reduction.cong-app1 t≈t' 90 | 91 | cong-app1≈ : ∀ (t≈t' : t ≈ t') → app t u ≈ app t' u 92 | cong-app1≈ t≈t' = cong-app≈≡ t≈t' ≡-refl 93 | 94 | cong-app≡≈ : ∀ (t≡t' : t ≡ t') (u≈u' : u ≈ u') → app t u ≈ app t' u' 95 | cong-app≡≈ ≡-refl u≈u' = cong-⟶-to-cong-≈ Reduction.cong-app2 u≈u' 96 | 97 | cong-app2≈ : ∀ (u≈u' : u ≈ u') → app t u ≈ app t u' 98 | cong-app2≈ u≈u' = cong-app≡≈ ≡-refl u≈u' 99 | 100 | cong-app≈ : ∀ (t≈t' : t ≈ t') (u≈u' : u ≈ u') → app t u ≈ app t' u' 101 | cong-app≈ t≈t' u≈u' = ≈-trans (cong-app1≈ t≈t') (cong-app2≈ u≈u') 102 | 103 | cong-box≈ : ∀ (t≈t' : t ≈ t') → box t ≈ box t' 104 | cong-box≈ = cong-⟶-to-cong-≈ Reduction.cong-box 105 | 106 | cong-unbox≈ : ∀ (t≈t' : t ≈ t') → unbox t e ≈ unbox t' e 107 | cong-unbox≈ = cong-⟶-to-cong-≈ Reduction.cong-unbox 108 | 109 | module _ {t : Tm ΓL (□ a)} {e : CExt Γ ΓL ΓR} {e' : CExt Γ ΓL ΓR'} where 110 | cong-unbox2≈ : unbox t e ≈ unbox t e' 111 | cong-unbox2≈ = ≡-to-≈ (dcong₂ (λ _ΓR → unbox t) (extRUniq e e') (ExtIsProp′ e e')) 112 | 113 | cong-unbox≈′ : ∀ (t≈t' : t ≈ t') → unbox t e ≈ unbox t' e' 114 | cong-unbox≈′ t≈t' = ≈-trans (cong-unbox≈ t≈t') cong-unbox2≈ 115 | 116 | cong-unbox≈′′ : ∀ (Γ≡Γ' : Γ ≡ Γ') (t≈t' : subst1 Tm Γ≡Γ' t ≈ t') → unbox t e ≈ unbox t' e' 117 | cong-unbox≈′′ ≡-refl = cong-unbox≈′ 118 | 119 | shift-unbox≈ : ∀ (t : Tm Γ (□ a)) (w : LFExt Γ' Γ ΓR) → unbox t e ≈ unbox (wkTm (LFExtToWk w) t) e' 120 | shift-unbox≈ t w = ≈-trans cong-unbox2≈ (⟶-to-≈ (Reduction.shift-unbox t w _)) 121 | 122 | ---------------------------------------------------------------------- 123 | -- Congruence closure of the relation that identifies substitutions up 124 | -- to "built-in" weakenings (see `shift-lock≈ₛ`) 125 | ---------------------------------------------------------------------- 126 | 127 | data _⟶ₛ_ : Sub Δ Γ → Sub Δ Γ → Set where 128 | cong-`,⟶ₛ1 : {s s' : Sub Δ Γ} {t : Tm Δ a} 129 | → s ⟶ₛ s' → (s `, t) ⟶ₛ (s' `, t) 130 | cong-`,⟶ₛ2 : {s : Sub Δ Γ} {t t' : Tm Δ a} 131 | → t ≈ t' → (s `, t) ⟶ₛ (s `, t') 132 | cong-lock⟶ₛ : {s s' : Sub ΔL ΓL} {e : CExt Δ ΔL ΔR} 133 | → s ⟶ₛ s' → lock s e ⟶ₛ lock s' e 134 | shift-lock⟶ₛ : {ΔLL ΔLR : Ctx} {s : Sub ΔLL Γ} (w : LFExt ΔL ΔLL ΔLR) {e : CExt Δ ΔL ΔR} 135 | → lock s (extRAssoc (upLFExt w) e) ⟶ₛ lock (wkSub (LFExtToWk w) s) e 136 | 137 | Sub-setoid : (Δ Γ : Ctx) → Setoid _ _ 138 | Sub-setoid Δ Γ = setoid (_⟶ₛ_ {Δ} {Γ}) 139 | 140 | module _ {Δ Γ : Ctx} where 141 | open Setoid (Sub-setoid Δ Γ) public 142 | using () 143 | renaming (_≈_ to _≈ₛ_ ; reflexive to ≈ₛ-reflexive ; refl to ≈ₛ-refl ; sym to ≈ₛ-sym ; trans to ≈ₛ-trans) 144 | 145 | ≈ₛ-reflexive˘ : σ' ≡ σ → σ ≈ₛ σ' 146 | ≈ₛ-reflexive˘ σ'≡σ = ≈ₛ-reflexive (≡-sym σ'≡σ) 147 | 148 | ⟶ₛ-to-≈ₛ : σ ⟶ₛ σ' → σ ≈ₛ σ' 149 | ⟶ₛ-to-≈ₛ p = inj₁ p ◅ ε 150 | 151 | module _ {σ : Sub Δ Γ → Sub Δ' Γ'} (cong-σ : ∀ {τ τ' : Sub Δ Γ} → (τ⟶τ' : τ ⟶ₛ τ') → σ τ ⟶ₛ σ τ') where 152 | -- XXX: fold 153 | cong-⟶ₛ-to-cong-≈ₛ : ∀ (τ≈τ' : τ ≈ₛ τ') → σ τ ≈ₛ σ τ' 154 | cong-⟶ₛ-to-cong-≈ₛ ε = ε 155 | cong-⟶ₛ-to-cong-≈ₛ (inj₁ τ⟶τ'' ◅ τ''≈τ') = inj₁ (cong-σ τ⟶τ'') ◅ cong-⟶ₛ-to-cong-≈ₛ τ''≈τ' 156 | cong-⟶ₛ-to-cong-≈ₛ (inj₂ τ⟵τ'' ◅ τ''≈τ') = inj₂ (cong-σ τ⟵τ'') ◅ cong-⟶ₛ-to-cong-≈ₛ τ''≈τ' 157 | 158 | cong-`,1≈ₛ : (σ≈σ' : σ ≈ₛ σ') → (σ `, t) ≈ₛ (σ' `, t) 159 | cong-`,1≈ₛ = cong-⟶ₛ-to-cong-≈ₛ cong-`,⟶ₛ1 160 | 161 | cong-`,2≈ₛ : (t≈t' : t ≈ t') → (σ `, t) ≈ₛ (σ `, t') 162 | cong-`,2≈ₛ t≈t' = ⟶ₛ-to-≈ₛ (cong-`,⟶ₛ2 t≈t') 163 | 164 | cong-`,≈ₛ : (σ≈σ' : σ ≈ₛ σ') → (t≈t' : t ≈ t') → (σ `, t) ≈ₛ (σ' `, t') 165 | cong-`,≈ₛ σ≈σ' t≈t' = ≈ₛ-trans (cong-`,1≈ₛ σ≈σ') (cong-`,2≈ₛ t≈t') 166 | 167 | cong-lock≈ₛ : ∀ (σ≈σ' : σ ≈ₛ σ') → lock σ e ≈ₛ lock σ' e 168 | cong-lock≈ₛ = cong-⟶ₛ-to-cong-≈ₛ cong-lock⟶ₛ 169 | 170 | module _ {σ : Sub ΓL Δ} {e : CExt Γ ΓL ΓR} {e' : CExt Γ ΓL ΓR'} where 171 | cong-lock2≈ₛ : lock σ e ≈ₛ lock σ e' 172 | cong-lock2≈ₛ = ≈ₛ-reflexive (dcong₂ (λ _ΓR → lock σ) (extRUniq e e') (ExtIsProp′ e e')) 173 | 174 | cong-lock≈ₛ′ : ∀ (σ≈σ' : σ ≈ₛ σ') → lock σ e ≈ₛ lock σ' e' 175 | cong-lock≈ₛ′ σ≈σ' = ≈ₛ-trans (cong-lock≈ₛ σ≈σ') cong-lock2≈ₛ 176 | 177 | cong-lock≈ₛ′′ : ∀ (Γ≡Γ' : Γ ≡ Γ') (σ≈σ' : subst1 Sub Γ≡Γ' σ ≈ₛ σ') → lock σ e ≈ₛ lock σ' e' 178 | cong-lock≈ₛ′′ ≡-refl = cong-lock≈ₛ′ 179 | 180 | shift-lock≈ₛ : (w : LFExt Δ' Δ ΔR) → lock σ (extRAssoc (upLFExt w) e) ≈ₛ lock (wkSub (LFExtToWk w) σ) e 181 | shift-lock≈ₛ w = ⟶ₛ-to-≈ₛ (shift-lock⟶ₛ w) 182 | 183 | -------------------- 184 | -- Derived equations 185 | -------------------- 186 | -------------------------------------------------------------------------------- /src/IS4/Term/NormalForm.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Term.NormalForm where 3 | 4 | open import IS4.Term.NormalForm.Base public 5 | open import IS4.Term.NormalForm.Properties public 6 | -------------------------------------------------------------------------------- /src/IS4/Term/NormalForm/Base.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Term.NormalForm.Base where 3 | 4 | open import IS4.Term.Base 5 | 6 | --------------- 7 | -- Normal forms 8 | --------------- 9 | 10 | data Ne : Ctx → Ty → Set 11 | data Nf : Ctx → Ty → Set 12 | 13 | data Ne where 14 | var : (v : Var Γ a) → Ne Γ a 15 | app : (n : Ne Γ (a ⇒ b)) → (m : Nf Γ a) → Ne Γ b 16 | unbox : (n : Ne ΓL (□ a)) → (e : CExt Γ ΓL ΓR) → Ne Γ a 17 | 18 | data Nf where 19 | up : (n : Ne Γ ι) → Nf Γ ι 20 | lam : (n : Nf (Γ `, a) b) → Nf Γ (a ⇒ b) 21 | box : (n : Nf (Γ #) a) → Nf Γ (□ a) 22 | 23 | -- normal forms of substitutions (simply "do everything pointwise") 24 | data Nfₛ : Ctx → Ctx → Set where 25 | [] : Nfₛ Γ [] 26 | _`,_ : (n : Nfₛ Γ Δ) → (m : Nf Γ a) → Nfₛ Γ (Δ `, a) 27 | lock : (n : Nfₛ ΔL Γ) → (e : CExt Δ ΔL ΔR) → Nfₛ Δ (Γ #) 28 | 29 | Nfₛ- : (Δ : Ctx) → (Γ : Ctx) → Set 30 | Nfₛ- Δ Γ = Nfₛ Γ Δ 31 | 32 | -- embedding into terms 33 | 34 | embNe : (n : Ne Γ a) → Tm Γ a 35 | embNf : (n : Nf Γ a) → Tm Γ a 36 | 37 | embNe (var v) = var v 38 | embNe (app m n) = app (embNe m) (embNf n) 39 | embNe (unbox n e) = unbox (embNe n) e 40 | 41 | embNf (up n) = embNe n 42 | embNf (lam n) = lam (embNf n) 43 | embNf (box n) = box (embNf n) 44 | 45 | -- embeddding of substitution normal forms back into substitutions (simply "do everything pointwise") 46 | embNfₛ : (N : Nfₛ Γ Δ) → Sub Γ Δ 47 | embNfₛ [] = [] 48 | embNfₛ (n `, m) = embNfₛ n `, embNf m 49 | embNfₛ (lock n e) = lock (embNfₛ n) e 50 | 51 | -- weakening lemmas 52 | 53 | wkNe : (w : Γ ⊆ Γ') → (n : Ne Γ a) → Ne Γ' a 54 | wkNf : (w : Γ ⊆ Γ') → (n : Nf Γ a) → Nf Γ' a 55 | 56 | wkNe w (var v) = var (wkVar w v) 57 | wkNe w (app n m) = app (wkNe w n) (wkNf w m) 58 | wkNe w (unbox n e) = unbox (wkNe (factorWk e w) n) (factorExt e w) 59 | 60 | wkNf e (up n) = up (wkNe e n) 61 | wkNf e (lam n) = lam (wkNf (keep e) n) 62 | wkNf e (box n) = box (wkNf (keep# e) n) 63 | -------------------------------------------------------------------------------- /src/IS4/Term/NormalForm/Properties.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Term.NormalForm.Properties where 3 | 4 | open import Relation.Binary.PropositionalEquality 5 | using (_≡_ ; refl ; trans ; subst₂ ; cong ; cong₂ ; module ≡-Reasoning) 6 | 7 | open import PEUtil 8 | 9 | open import IS4.Term.Base 10 | open import IS4.Term.NormalForm.Base 11 | 12 | private 13 | module _ {e : CExt Δ Γ ΓR} {e' : CExt Δ Γ' ΓR'} where 14 | cong-unbox≡′′ : {n : Ne Γ (□ a)} {n' : Ne Γ' (□ a)} 15 | → (Γ≡Γ' : Γ ≡ Γ') 16 | → (n≡n' : subst1 Ne Γ≡Γ' n ≡ n') 17 | → unbox n e ≡[ Ne Δ a ] unbox n' e' 18 | cong-unbox≡′′ Γ≡Γ' n≡n' = 19 | idcong₄ unbox Γ≡Γ' (extRUniq′ Γ≡Γ' e e') n≡n' (ExtIsProp _ _) 20 | 21 | cong-unbox≡ : {n : Ne Γ (□ a)} {n' : Ne Γ (□ a)} 22 | → (n≡n' : n ≡ n') 23 | → unbox n e ≡[ Ne _ a ] unbox n' e 24 | cong-unbox≡ = cong-unbox≡′′ refl 25 | 26 | cong-unbox≡2 : {n : Ne Γ (□ a)} 27 | → unbox n e ≡[ Ne _ a ] unbox n e' 28 | cong-unbox≡2 = cong-unbox≡′′ refl refl 29 | 30 | cong-unbox≡′ : {n : Ne Γ (□ a)} {n' : Ne Γ (□ a)} 31 | → (n≡n' : n ≡ n') 32 | → unbox n e ≡[ Ne _ a ] unbox n' e' 33 | cong-unbox≡′ = cong-unbox≡′′ refl 34 | 35 | ------------------------ 36 | -- Naturality conditions 37 | ------------------------ 38 | 39 | -- Normal forms and neutrals obey "naturality" of embeddding, i.e., 40 | -- weakening can be commuted with embedding. 41 | 42 | -- the mutual brothers normal forms and neutrals who, 43 | -- as always, must be handled (mutually) together 44 | nat-embNe : (w : Γ ⊆ Γ') (n : Ne Γ a) 45 | → wkTm w (embNe n) ≡ embNe (wkNe w n) 46 | nat-embNf : (w : Γ ⊆ Γ') (n : Nf Γ a) 47 | → wkTm w (embNf n) ≡ embNf (wkNf w n) 48 | 49 | nat-embNf w (up n) = nat-embNe w n 50 | nat-embNf w (lam n) = cong lam (nat-embNf (keep w) n) 51 | nat-embNf w (box n) = cong box (nat-embNf (keep# w) n) 52 | 53 | nat-embNe w (var v) = refl 54 | nat-embNe w (app n m) = cong₂ app (nat-embNe w n) (nat-embNf w m) 55 | nat-embNe w (unbox n e) = cong1 unbox (nat-embNe (factorWk e w) n) 56 | 57 | wkNePresId : (n : Ne Γ a) → wkNe idWk n ≡ n 58 | wkNfPresId : (n : Nf Γ a) → wkNf idWk n ≡ n 59 | 60 | wkNePresId (var v) = cong var (wkVarPresId v) 61 | wkNePresId (app n m) = cong₂ app (wkNePresId n) (wkNfPresId m) 62 | wkNePresId (unbox n e) = let open ≡-Reasoning in begin 63 | wkNe idWk (unbox n e) 64 | ≡⟨⟩ 65 | unbox (wkNe (factorWk e idWk) n) (factorExt e idWk) 66 | ≡⟨ cong-unbox≡′′ 67 | (lCtxPresId e) 68 | (trans 69 | (subst-application1′ wkNe (lCtxPresId e)) 70 | (cong1 wkNe (factorWkPresId e))) 71 | ⟩ 72 | unbox (wkNe idWk n) e 73 | ≡⟨ cong1 unbox (wkNePresId n) ⟩ 74 | unbox n e ∎ 75 | 76 | wkNfPresId (up n) = cong up (wkNePresId n) 77 | wkNfPresId (lam n) = cong lam (wkNfPresId n) 78 | wkNfPresId (box n) = cong box (wkNfPresId n) 79 | 80 | wkNePres∙ : (w : Γ ⊆ Γ') (w' : Γ' ⊆ Γ'') (n : Ne Γ a) 81 | → wkNe w' (wkNe w n) ≡ wkNe (w ∙ w') n 82 | wkNfPres∙ : (w : Γ ⊆ Γ') (w' : Γ' ⊆ Γ'') (n : Nf Γ a) 83 | → wkNf w' (wkNf w n) ≡ wkNf (w ∙ w') n 84 | 85 | wkNePres∙ w w' (var v) = cong var (wkVarPres∙ w w' v) 86 | wkNePres∙ w w' (app n m) = cong₂ app (wkNePres∙ w w' n) (wkNfPres∙ w w' m) 87 | wkNePres∙ {Γ'' = Γ''} {a} w w' (unbox {ΓL} n e) = let open ≡-Reasoning in begin 88 | wkNe w' (wkNe w (unbox n e)) 89 | ≡⟨⟩ 90 | unbox 91 | (wkNe (factorWk (factorExt e w) w') (wkNe (factorWk e w) n)) 92 | (factorExt (factorExt e w) w') 93 | ≡⟨ cong-unbox≡′ (wkNePres∙ _ _ n) ⟩ 94 | unbox 95 | (wkNe (factorWk e w ∙ factorWk (factorExt e w) w') n) 96 | (factorExt (factorExt e w) w') 97 | ≡˘⟨ cong-unbox≡′′ 98 | (lCtxPres∙ e w w') 99 | (trans 100 | (subst-application1′ wkNe (lCtxPres∙ e w w')) 101 | (cong1 wkNe (factorWkPres∙ e w w'))) 102 | ⟩ 103 | unbox (wkNe (factorWk e (w ∙ w')) n) (factorExt e (w ∙ w')) 104 | ≡⟨⟩ 105 | wkNe (w ∙ w') (unbox n e) ∎ 106 | 107 | wkNfPres∙ w w' (up n) = cong up (wkNePres∙ w w' n) 108 | wkNfPres∙ w w' (lam n) = cong lam (wkNfPres∙ (keep w) (keep w') n) 109 | wkNfPres∙ w w' (box n) = cong box (wkNfPres∙ (keep# w) (keep# w') n) 110 | -------------------------------------------------------------------------------- /src/IS4/Term/Reduction.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module IS4.Term.Reduction where 3 | 4 | open import Relation.Binary using (Preorder) 5 | 6 | import Relation.Binary.Construct.Closure.ReflexiveTransitive as ReflexiveTransitive 7 | open import Relation.Binary.Construct.Closure.ReflexiveTransitive.Properties using (preorder) 8 | 9 | open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; sym ; trans ; cong ; cong₂) 10 | 11 | import RUtil 12 | 13 | open import IS4.Term.Base 14 | 15 | open ReflexiveTransitive public using (ε ; _◅_) 16 | 17 | ------------------- 18 | -- Reduction rules 19 | ------------------- 20 | 21 | data _⟶_ : Tm Γ a → Tm Γ a → Set where 22 | 23 | red-fun : (t : Tm (Γ `, a) b) (u : Tm Γ a) 24 | → app (lam t) u ⟶ substTm (idₛ `, u) t 25 | 26 | exp-fun : (t : Tm Γ (a ⇒ b)) 27 | → t ⟶ lam (app (wkTm fresh t) (var zero)) 28 | 29 | red-box : (t : Tm (ΓL #) a) (e : CExt Γ ΓL ΓR) 30 | → unbox (box t) e ⟶ substTm (lock idₛ e) t 31 | 32 | exp-box : (t : Tm Γ (□ a)) 33 | → t ⟶ box (unbox t new) 34 | 35 | cong-lam : {t t' : Tm (Γ `, a) b} 36 | → t ⟶ t' 37 | → lam t ⟶ lam t' 38 | 39 | cong-app1 : {t t' : Tm Γ (a ⇒ b)} {u : Tm Γ a} 40 | → t ⟶ t' 41 | → app t u ⟶ app t' u 42 | 43 | cong-app2 : {t : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 44 | → u ⟶ u' 45 | → app t u ⟶ app t u' 46 | 47 | cong-box : {t t' : Tm (Γ #) a} 48 | → t ⟶ t' 49 | → box t ⟶ box t' 50 | 51 | cong-unbox : {t t' : Tm ΓL (□ a)} {e : CExt Γ ΓL ΓR} 52 | → t ⟶ t' 53 | → unbox t e ⟶ unbox t' e 54 | 55 | shift-unbox : {ΓLL : Ctx} {a : Ty} (t : Tm ΓLL (□ a)) {ΓLR ΓL : Ctx} (w : LFExt ΓL ΓLL ΓLR) {ΓR Γ : Ctx} (e : CExt Γ ΓL ΓR) 56 | → unbox t (extRAssoc (upLFExt w) e) ⟶ unbox (wkTm (LFExtToWk w) t) e 57 | 58 | module _ {Γ : Ctx} {a : Ty} where 59 | open RUtil (_⟶_ {Γ} {a}) public 60 | 61 | -- zero or more steps of reduction 62 | Tm-preorder : (Γ : Ctx) → (a : Ty) → Preorder _ _ _ 63 | Tm-preorder Γ a = preorder (_⟶_ {Γ} {a}) 64 | 65 | module _ {Γ : Ctx} {a : Ty} where 66 | open Preorder (Tm-preorder Γ a) public 67 | using () 68 | renaming (_∼_ to _⟶*_ ; refl to ⟶*-refl ; reflexive to none ; trans to multi) 69 | 70 | single : (t⟶t' : t ⟶ t') → t ⟶* t' 71 | single t⟶t' = t⟶t' ◅ ε 72 | 73 | single-≡ : (t⟶t' : t ⟶ t') → (t'≡t'' : t' ≡ t'') → t ⟶* t'' 74 | single-≡ t⟶t' refl = single t⟶t' 75 | 76 | ≡-single : (t≡t' : t ≡ t') → (t'⟶t'' : t' ⟶ t'') → t ⟶* t'' 77 | ≡-single refl t'⟶t'' = single t'⟶t'' 78 | 79 | ≡-single-≡ : (t≡t' : t ≡ t') → (t'⟶t'' : t' ⟶ t'') → (t''≡t''' : t'' ≡ t''') → t ⟶* t''' 80 | ≡-single-≡ refl t'⟶t'' refl = single t'⟶t'' 81 | 82 | multi-≡ : (t⟶*t' : t ⟶* t') → (t'≡t'' : t' ≡ t'') → t ⟶* t'' 83 | multi-≡ t⟶*t' refl = t⟶*t' 84 | 85 | ≡-multi : (t≡t' : t ≡ t') → (t'⟶*t'' : t' ⟶* t'') → t ⟶* t'' 86 | ≡-multi refl t'⟶*t'' = t'⟶*t'' 87 | 88 | ≡-multi-≡ : (t≡t' : t ≡ t') → (t'⟶*t'' : t' ⟶* t'') → (t''≡t''' : t'' ≡ t''') → t ⟶* t''' 89 | ≡-multi-≡ refl t'⟶*t'' refl = t'⟶*t'' 90 | 91 | ⟶-multi : (t⟶t' : t ⟶ t') → (t'⟶*t'' : t' ⟶* t'') → t ⟶* t'' 92 | ⟶-multi t⟶t' t'⟶*t'' = multi (single t⟶t') t'⟶*t'' 93 | 94 | multi-⟶ : (t⟶*t' : t ⟶* t') → (t'⟶t'' : t' ⟶ t'') → t ⟶* t'' 95 | multi-⟶ t⟶*t' t'⟶t'' = multi t⟶*t' (single t'⟶t'') 96 | 97 | module _ {t : Tm Γ a → Tm Δ b} (cong-t : ∀ {u u' : Tm Γ a} → (u⟶u' : u ⟶ u') → t u ⟶* t u') where 98 | cong-⟶*-to-cong-⟶* : ∀ (u⟶*u' : u ⟶* u') → t u ⟶* t u' 99 | cong-⟶*-to-cong-⟶* ε = ε 100 | cong-⟶*-to-cong-⟶* (u⟶u'' ◅ u''⟶*u') = multi (cong-t u⟶u'') (cong-⟶*-to-cong-⟶* u''⟶*u') 101 | 102 | cong-⟶-to-cong-⟶* : {t : Tm Γ a → Tm Δ b} (cong-t : ∀ {u u' : Tm Γ a} → (u⟶u' : u ⟶ u') → t u ⟶ t u') (u⟶*u' : u ⟶* u') → t u ⟶* t u' 103 | cong-⟶-to-cong-⟶* cong-t = cong-⟶*-to-cong-⟶* (λ u⟶u' → single (cong-t u⟶u')) 104 | 105 | cong-app : {t t' : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 106 | → t ⟶ t' → u ⟶ u' 107 | → app t u ⟶* app t' u' 108 | cong-app t⟶t' u⟶u' = cong-app1 t⟶t' ◅ cong-app2 u⟶u' ◅ ε 109 | 110 | cong-box* : {t t' : Tm (Γ #) a} 111 | → t ⟶* t' 112 | → box t ⟶* box t' 113 | cong-box* = cong-⟶-to-cong-⟶* cong-box 114 | 115 | cong-unbox* : {t t' : Tm ΓL (□ a)} {e : CExt Γ ΓL ΓR} 116 | → t ⟶* t' 117 | → unbox t e ⟶* unbox t' e 118 | cong-unbox* = cong-⟶-to-cong-⟶* cong-unbox 119 | 120 | cong-lam* : {t t' : Tm (Γ `, a) b} 121 | → t ⟶* t' 122 | → lam t ⟶* lam t' 123 | cong-lam* = cong-⟶-to-cong-⟶* cong-lam 124 | 125 | cong-app*≡ : {t t' : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 126 | → t ⟶* t' 127 | → u ≡ u' 128 | → app t u ⟶* app t' u' 129 | cong-app*≡ t⟶*t' refl = cong-⟶-to-cong-⟶* cong-app1 t⟶*t' 130 | 131 | cong-app1* : {t t' : Tm Γ (a ⇒ b)} {u : Tm Γ a} 132 | → t ⟶* t' 133 | → app t u ⟶* app t' u 134 | cong-app1* t⟶*t' = cong-app*≡ t⟶*t' refl 135 | 136 | cong-app≡* : {t t' : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 137 | → t ≡ t' 138 | → u ⟶* u' 139 | → app t u ⟶* app t' u' 140 | cong-app≡* refl u⟶*u' = cong-⟶-to-cong-⟶* cong-app2 u⟶*u' 141 | 142 | cong-app2* : {t : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 143 | → u ⟶* u' 144 | → app t u ⟶* app t u' 145 | cong-app2* u⟶*u' = cong-app≡* refl u⟶*u' 146 | 147 | cong-app* : {t t' : Tm Γ (a ⇒ b)} {u u' : Tm Γ a} 148 | → t ⟶* t' → u ⟶* u' 149 | → app t u ⟶* app t' u' 150 | cong-app* t⟶*t' u⟶*u' = multi (cong-app1* t⟶*t') (cong-app2* u⟶*u') 151 | -------------------------------------------------------------------------------- /src/PEUtil.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module PEUtil where 3 | 4 | open import Relation.Binary.Definitions 5 | using (Decidable) 6 | 7 | open import Relation.Binary.PropositionalEquality 8 | using (_≡_ ; refl ; sym ; trans ; cong ; subst ; subst₂) 9 | 10 | ≡[]-syntax = _≡_ ; syntax ≡[]-syntax {A = A} a b = a ≡[ A ] b 11 | 12 | module _ {a} {A : Set a} {x y z : A} where 13 | trans˘ : x ≡ y → z ≡ y → x ≡ z 14 | trans˘ x≡y z≡y = trans x≡y (sym z≡y) 15 | 16 | ˘trans : y ≡ x → y ≡ z → x ≡ z 17 | ˘trans y≡x y≡z = trans (sym y≡x) y≡z 18 | 19 | module _ {a} {A : Set a} {b} {B : Set b} {x y : A} where 20 | cong˘ : (f : A → B) → y ≡ x → f x ≡ f y 21 | cong˘ f y≡x = cong f (sym y≡x) 22 | 23 | module _ {a} {b} {c} where 24 | cong1 : ∀ {A : Set a} {B : Set b} {C : Set c} 25 | (f : A → B → C) {x₁ x₂ y} 26 | → (p : x₁ ≡ x₂) 27 | → f x₁ y ≡ f x₂ y 28 | cong1 _f refl = refl 29 | 30 | cong1˘ : ∀ {A : Set a} {B : Set b} {C : Set c} 31 | (f : A → B → C) {x₁ x₂ y} 32 | → (p : x₂ ≡ x₁) 33 | → f x₁ y ≡ f x₂ y 34 | cong1˘ _f refl = refl 35 | 36 | module _ {a} {b} {c} where 37 | cong2 : ∀ {A : Set a} {B : Set b} {C : Set c} 38 | (f : A → B → C) {x y₁ y₂} 39 | → (p : y₁ ≡ y₂) 40 | → f x y₁ ≡ f x y₂ 41 | cong2 _f refl = refl 42 | 43 | module _ {a} {A : Set a} {p} (P : A → Set p) where 44 | subst˘ : ∀ {x₁ x₂} → x₂ ≡ x₁ → P x₁ → P x₂ 45 | subst˘ x₂≡x₁ = subst P (sym x₂≡x₁) 46 | 47 | module _ {a} {A : Set a} {b} {B : Set b} {r} (R : A → B → Set r) where 48 | subst1 : ∀ {x₁ x₂ y} → x₁ ≡ x₂ → R x₁ y → R x₂ y 49 | subst1 {_x₁} {_x₂} {y} = subst (λ x → R x y) 50 | 51 | subst1˘ : ∀ {x₁ x₂ y} → x₂ ≡ x₁ → R x₁ y → R x₂ y 52 | subst1˘ x₂≡x₁ = subst1 (sym x₂≡x₁) 53 | 54 | module _ {a} {b} {c} where 55 | dcong₂ : ∀ {A : Set a} {B : A → Set b} {C : Set c} 56 | (f : (x : A) → B x → C) {x₁ x₂ y₁ y₂} 57 | → (p : x₁ ≡ x₂) → subst B p y₁ ≡ y₂ 58 | → f x₁ y₁ ≡ f x₂ y₂ 59 | dcong₂ _f refl refl = refl 60 | 61 | module _ {a} {b} {c} {d} where 62 | dcong₃ : ∀ {A : Set a} {B : A → Set b} {C : A → Set c} {D : Set d} 63 | (f : (x : A) → B x → C x → D) {x₁ x₂ y₁ y₂ z₁ z₂} 64 | → (p : x₁ ≡ x₂) → subst B p y₁ ≡ y₂ → subst C p z₁ ≡ z₂ 65 | → f x₁ y₁ z₁ ≡ f x₂ y₂ z₂ 66 | dcong₃ _f refl refl refl = refl 67 | 68 | module _ {a} {b} {c} {d} {e} where 69 | idcong₄ : ∀ {A : Set a} {B : Set b} {C : A → Set c} {D : A → B → Set d} {E : Set e} 70 | (f : {x : A} → {y : B} → C x → D x y → E) {w₁ w₂ x₁ x₂ y₁ y₂ z₁ z₂} 71 | → (p : w₁ ≡ w₂) → (q : x₁ ≡ x₂) → subst C p y₁ ≡ y₂ → subst₂ D p q z₁ ≡ z₂ 72 | → f {w₁} {x₁} y₁ z₁ ≡ f {w₂} {x₂} y₂ z₂ 73 | idcong₄ _f refl refl refl refl = refl 74 | 75 | module _ {a} {b} {c} {d} {e} where 76 | dcong₄ : ∀ {A : Set a} {B : A → Set b} {C : A → Set c} {D : A → Set d} {E : Set e} 77 | (f : (w : A) → B w → C w → D w → E) {w₁ w₂ x₁ x₂ y₁ y₂ z₁ z₂} 78 | → (p : w₁ ≡ w₂) → subst B p x₁ ≡ x₂ → subst C p y₁ ≡ y₂ → subst D p z₁ ≡ z₂ 79 | → f w₁ x₁ y₁ z₁ ≡ f w₂ x₂ y₂ z₂ 80 | dcong₄ _f refl refl refl refl = refl 81 | 82 | subst-sym : ∀ {a p} {A : Set a} {P : A → Set p} 83 | {x₁ x₂ : A} {y₁ : P x₁} {y₂ : P x₂} 84 | (eq : x₁ ≡ x₂) 85 | → subst P eq y₁ ≡ y₂ 86 | → y₁ ≡ subst P (sym eq) y₂ 87 | subst-sym refl y₁≡y₂ = y₁≡y₂ 88 | 89 | module _ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q} 90 | (g : {x : A} → P x → Q x) where 91 | subst-application′ : ∀ {x₁ x₂ y} → (eq : x₁ ≡ x₂) 92 | → subst Q eq (g y) ≡ g (subst P eq y) 93 | subst-application′ refl = refl 94 | 95 | subst˘-application′ : ∀ {x₁ x₂ y} → (eq : x₂ ≡ x₁) 96 | → subst˘ Q eq (g y) ≡ g (subst˘ P eq y) 97 | subst˘-application′ refl = refl 98 | 99 | module _ {a p} {A : Set a} {P : A → Set p} 100 | (g : {x : A} → P x) where 101 | subst-application′′ : ∀ {x₁ x₂} → (eq : x₁ ≡ x₂) 102 | → subst P eq g ≡ g 103 | subst-application′′ refl = refl 104 | 105 | module _ {a p b q} {A : Set a} {P : A → Set p} {B : Set b} {Q : A → Set q} 106 | (g : {x : A} → P x → B → Q x) where 107 | subst-application1′ : ∀ {x₁ x₂ y z} → (eq : x₁ ≡ x₂) 108 | → subst Q eq (g y z) ≡ g (subst P eq y) z 109 | subst-application1′ refl = refl 110 | 111 | subst˘-application1′ : ∀ {x₁ x₂ y z} → (eq : x₂ ≡ x₁) 112 | → subst˘ Q eq (g y z) ≡ g (subst˘ P eq y) z 113 | subst˘-application1′ refl = refl 114 | 115 | module _ {a} (A : Set a) where 116 | K : Set a 117 | K = {a : A} → (p : a ≡ a) → p ≡ refl 118 | 119 | module Decidable⇒K {a} {A : Set a} (_≟_ : Decidable (_≡_ {A = A})) where 120 | open import Axiom.UniquenessOfIdentityProofs using (module Decidable⇒UIP) 121 | 122 | open Decidable⇒UIP _≟_ public 123 | using () 124 | renaming (≡-irrelevant to Decidable⇒UIP) 125 | 126 | Decidable⇒K : K A 127 | Decidable⇒K p = Decidable⇒UIP p refl 128 | -------------------------------------------------------------------------------- /src/PUtil.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module PUtil where 3 | 4 | open import Data.Product using (Σ ; _,_ ; proj₁ ; proj₂ ; ∃ ; _×_) 5 | open import Data.Product.Properties using (Σ-≡,≡↔≡; ×-≡,≡↔≡) 6 | 7 | open import Function using (Inverse) 8 | 9 | open import Relation.Binary.PropositionalEquality using (_≡_ ; trans ; subst) 10 | 11 | open import PEUtil 12 | 13 | module _ {a} {b} {A : Set a} {B : A → Set b} {p₁ p₂ : Σ A B} where 14 | open import Function 15 | open import Data.Product.Properties 16 | open Inverse (Σ-≡,≡↔≡ {p₁ = p₁} {p₂ = p₂}) public 17 | using () 18 | renaming (f to Σ-≡,≡→≡) 19 | 20 | ×-≡,≡→≡ : {A B : Set} {p₁@(a₁ , b₁) p₂@(a₂ , b₂) : A × B} → a₁ ≡ a₂ × b₁ ≡ b₂ → p₁ ≡ p₂ 21 | ×-≡,≡→≡ = ×-≡,≡↔≡ .Inverse.f 22 | 23 | Σ×-≡,≡,≡→≡ : {A : Set} {B B' : A → Set} {p₁@(a₁ , b₁ , b₁') p₂@(a₂ , b₂ , b₂') : ∃ λ (a : A) → B a × B' a} → (∃ λ (p : a₁ ≡ a₂) → subst B p b₁ ≡ b₂ × subst B' p b₁' ≡ b₂') → p₁ ≡ p₂ 24 | Σ×-≡,≡,≡→≡ {A} {_B} {_B'} {p₁} {p₂} (p , q , q') = Σ-≡,≡→≡ (p , ×-≡,≡→≡ (˘trans (subst-application′ proj₁ p) q , ˘trans (subst-application′ proj₂ p) q')) 25 | -------------------------------------------------------------------------------- /src/RUtil.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module RUtil {a} {A : Set a} {r} (R : A → A → Set r) where 3 | 4 | open import Relation.Binary.PropositionalEquality using (_≡_ ; refl) 5 | 6 | private 7 | variable 8 | x x' y y' z z' : A 9 | 10 | ≡-step-≡ : (x'≡x : x' ≡ x) → (xRy : R x y) → (y≡y' : y ≡ y') → R x' y' 11 | ≡-step-≡ refl xRy refl = xRy 12 | 13 | step-≡ : (xRy : R x y) → (y≡y' : y ≡ y') → R x y' 14 | step-≡ xRy refl = xRy 15 | 16 | ≡-step : (x'≡x : x' ≡ x) → (xRy : R x y) → R x' y 17 | ≡-step refl xRy = xRy 18 | -------------------------------------------------------------------------------- /src/Semantics/Clouston/Evaluation/IML.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | open import Data.Product using (∃; _,_; -,_) renaming (_×_ to _∧_; proj₁ to fst; proj₂ to snd) 3 | 4 | open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst) 5 | 6 | module Semantics.Clouston.Evaluation.IML 7 | (Ctx' : Set₁) 8 | 9 | (_→̇_ : (P Q : Ctx') → Set) (let infixr 19 _→̇_; _→̇_ = _→̇_) 10 | 11 | (_≈̇_ : {P Q : Ctx'} → (φ ψ : P →̇ Q) → Set) (let infix 18 _≈̇_; _≈̇_ = _≈̇_) 12 | (≈̇-refl : ∀ {P Q : Ctx'} {φ : P →̇ Q} → φ ≈̇ φ) 13 | (≈̇-sym : ∀ {P Q : Ctx'} {φ ψ : P →̇ Q} → (φ≈̇ψ : φ ≈̇ ψ) → ψ ≈̇ φ) 14 | (≈̇-trans : ∀ {P Q : Ctx'} {φ ψ ω : P →̇ Q} → (φ≈̇ψ : φ ≈̇ ψ) → (ψ≈̇ω : ψ ≈̇ ω) → φ ≈̇ ω) 15 | 16 | (_∘_ : {P Q R : Ctx'} → (ψ : Q →̇ R) → (φ : P →̇ Q) → (P →̇ R)) (let infixr 19 _∘_; _∘_ = _∘_) 17 | (∘-pres-≈̇ : ∀ {P Q R : Ctx'} {ψ ψ' : Q →̇ R} {φ φ' : P →̇ Q} (ψ≈̇ψ' : ψ ≈̇ ψ') (φ≈̇φ' : φ ≈̇ φ') → ψ ∘ φ ≈̇ ψ' ∘ φ') 18 | (∘-assoc : {P Q R S : Ctx'} → (ω : R →̇ S) → (ψ : Q →̇ R) → (φ : P →̇ Q) → (ω ∘ ψ) ∘ φ ≈̇ ω ∘ ψ ∘ φ) 19 | (let _[_]' = _∘_) 20 | 21 | (id'[_] : (P : Ctx') → P →̇ P) 22 | (id'-unit-left : ∀ {P : Ctx'} (Q : Ctx') (φ : P →̇ Q) → id'[ Q ] ∘ φ ≈̇ φ) 23 | (id'-unit-right : ∀ (P : Ctx') {Q : Ctx'} (φ : P →̇ Q) → φ ∘ id'[ P ] ≈̇ φ) 24 | 25 | ([]' : Ctx') 26 | (unit' : {P : Ctx'} → P →̇ []') 27 | ([]'-eta : ∀ {P : Ctx'} {φ : P →̇ []'} → φ ≈̇ unit') 28 | 29 | (_×'_ : (P Q : Ctx') → Ctx') 30 | (⟨_,_⟩' : {R P Q : Ctx'} → (φ : R →̇ P) → (ψ : R →̇ Q) → R →̇ P ×' Q) 31 | (⟨,⟩'-pres-≈̇ : ∀ {R P Q : Ctx'} {φ φ' : R →̇ P} {ψ ψ' : R →̇ Q} (φ≈̇φ' : φ ≈̇ φ') (ψ≈̇ψ' : ψ ≈̇ ψ') → ⟨ φ , ψ ⟩' ≈̇ ⟨ φ' , ψ' ⟩') 32 | (π₁'[_] : {P : Ctx'} → (Q : Ctx') → P ×' Q →̇ P) 33 | (π₂'[_] : (P : Ctx') → {Q : Ctx'} → P ×' Q →̇ Q) 34 | (let fst'[_]_ = λ {R} {P} Q φ → _∘_ {R} {P ×' Q} {P} π₁'[ Q ] φ) 35 | (let snd'[_]_ = λ {R} P {Q} φ → _∘_ {R} {P ×' Q} {Q} π₂'[ P ] φ) 36 | (×'-beta-left : ∀ {R P Q : Ctx'} {φ : R →̇ P} (ψ : R →̇ Q) → π₁'[ Q ] ∘ ⟨ φ , ψ ⟩' ≈̇ φ) 37 | (×'-beta-right : ∀ {R P Q : Ctx'} (φ : R →̇ P) {ψ : R →̇ Q} → π₂'[ P ] ∘ ⟨ φ , ψ ⟩' ≈̇ ψ) 38 | (×'-eta : ∀ {R P Q : Ctx'} {φ : R →̇ P ×' Q} → φ ≈̇ ⟨ fst'[ Q ] φ , snd'[ P ] φ ⟩') 39 | (⟨,⟩'-nat : ∀ {R' R P Q : Ctx'} (φ : R →̇ P) (ψ : R →̇ Q) (ω : R' →̇ R) → ⟨ φ , ψ ⟩' ∘ ω ≈̇ ⟨ φ ∘ ω , ψ ∘ ω ⟩') 40 | (let _×'-map_ = λ {P} {P'} {Q} {Q'} φ ψ → ⟨_,_⟩' {P ×' Q} {P'} {Q'} (φ ∘ π₁'[ Q ]) (ψ ∘ π₂'[ P ])) 41 | 42 | (let Ty' = Ctx') 43 | 44 | (_⇒'_ : (P Q : Ty') → Ty') 45 | (lam' : {R P Q : Ty'} → (φ : R ×' P →̇ Q) → R →̇ P ⇒' Q) 46 | (lam'-pres-≈̇ : ∀ {R P Q : Ty'} {φ φ' : R ×' P →̇ Q} (φ≈̇φ' : φ ≈̇ φ') → lam' φ ≈̇ lam' φ') 47 | (app' : {R P Q : Ty'} → (φ : R →̇ P ⇒' Q) → (ψ : R →̇ P) → R →̇ Q) 48 | (app'-pres-≈̇ : ∀ {R P Q : Ty'} {φ φ' : R →̇ P ⇒' Q} {ψ ψ' : R →̇ P} (φ≈̇φ' : φ ≈̇ φ') (ψ≈̇ψ' : ψ ≈̇ ψ') → app' φ ψ ≈̇ app' φ' ψ') 49 | (⇒'-beta : ∀ {R P Q : Ty'} (φ : R ×' P →̇ Q) (ψ : R →̇ P) → app' (lam' φ) ψ ≈̇ φ [ ⟨ id'[ R ] , ψ ⟩' ]') 50 | (⇒'-eta : ∀ {R P Q : Ty'} (φ : R →̇ P ⇒' Q) → φ ≈̇ lam' (app' (φ [ π₁'[ P ] ]') π₂'[ R ])) 51 | (lam'-nat : ∀ {R' R P Q : Ty'} (φ : R ×' P →̇ Q) (ψ : R' →̇ R) → lam' φ ∘ ψ ≈̇ lam' (φ ∘ ψ ×'-map id'[ P ])) 52 | (app'-nat : ∀ {R' R P Q : Ty'} (φ : R →̇ P ⇒' Q) (ψ : R →̇ P) (ω : R' →̇ R) → app' φ ψ ∘ ω ≈̇ app' (φ ∘ ω) (ψ ∘ ω)) 53 | 54 | (✦'_ : (P : Ctx') → Ctx') 55 | (✦'-map_ : {P Q : Ctx'} → (φ : P →̇ Q) → ✦' P →̇ ✦' Q) 56 | (✦'-map-pres-≈̇ : {P Q : Ctx'} {φ φ' : P →̇ Q} (φ≈̇φ' : φ ≈̇ φ') → ✦'-map φ ≈̇ ✦'-map φ') 57 | (✦'-map-pres-id' : {P : Ctx'} → ✦'-map id'[ P ] ≈̇ id'[ ✦' P ]) 58 | (✦'-map-pres-∘ : {P Q R : Ctx'} (ψ : Q →̇ R) (φ : P →̇ Q) → ✦'-map (ψ ∘ φ) ≈̇ ✦'-map ψ ∘ ✦'-map φ) 59 | 60 | (□'_ : (P : Ty') → Ty') 61 | (□'-map_ : {P Q : Ctx'} → (φ : P →̇ Q) → □' P →̇ □' Q) 62 | (box' : {P Q : Ty'} → (φ : ✦' P →̇ Q) → P →̇ □' Q) 63 | (box'-pres-≈̇ : ∀ {P : Ctx'} {Q : Ty'} {φ φ' : ✦' P →̇ Q} (φ≈̇φ' : φ ≈̇ φ') → box' φ ≈̇ box' φ') 64 | (λ' : {P Q : Ty'} → (φ : P →̇ □' Q) → ✦' P →̇ Q) 65 | (λ'-pres-≈̇ : ∀ {P : Ctx'} {Q : Ty'} {φ φ' : P →̇ □' Q} (φ≈̇φ' : φ ≈̇ φ') → λ' φ ≈̇ λ' φ') 66 | (□'-beta : ∀ {P : Ctx'} {Q : Ty'} (φ : ✦' P →̇ Q) → λ' (box' φ) ≈̇ φ) 67 | (□'-eta : ∀ {P : Ctx'} {Q : Ty'} (φ : P →̇ □' Q) → φ ≈̇ box' (λ' φ)) 68 | (box'-nat-dom : ∀ {P' P : Ctx'} {Q : Ty'} (φ : ✦' P →̇ Q) (φ' : P' →̇ P) → box' (φ ∘ ✦'-map φ') ≈̇ box' φ ∘ φ') 69 | (λ'-nat-dom : ∀ {P' P : Ctx'} {Q : Ty'} (φ : P →̇ □' Q) (φ' : P' →̇ P) → λ' (φ ∘ φ') ≈̇ λ' φ ∘ ✦'-map φ') 70 | where 71 | 72 | import Semantics.Clouston.Evaluation.IML.Base 73 | Ctx' _→̇_ _≈̇_ ≈̇-refl ≈̇-sym ≈̇-trans _∘_ id'[_] 74 | []' unit' _×'_ ⟨_,_⟩' π₁'[_] π₂'[_] 75 | _⇒'_ lam' app' 76 | ✦'_ ✦'-map_ 77 | □'_ box' λ' 78 | as CloustonEvaluationIMLBase 79 | 80 | open CloustonEvaluationIMLBase public 81 | 82 | module EvalProperties (N : Ty') where 83 | import Semantics.Clouston.Evaluation.IML.Properties 84 | Ctx' _→̇_ _≈̇_ ≈̇-refl ≈̇-sym ≈̇-trans _∘_ ∘-pres-≈̇ ∘-assoc id'[_] id'-unit-left id'-unit-right 85 | []' unit' []'-eta _×'_ ⟨_,_⟩' ⟨,⟩'-pres-≈̇ π₁'[_] π₂'[_] ×'-beta-left ×'-beta-right ×'-eta ⟨,⟩'-nat 86 | _⇒'_ lam' lam'-pres-≈̇ app' app'-pres-≈̇ ⇒'-beta ⇒'-eta lam'-nat app'-nat 87 | ✦'_ ✦'-map_ ✦'-map-pres-≈̇ ✦'-map-pres-id' ✦'-map-pres-∘ 88 | □'_ □'-map_ box' box'-pres-≈̇ λ' λ'-pres-≈̇ □'-beta □'-eta box'-nat-dom λ'-nat-dom N 89 | as CloustonEvaluationIMLProperties 90 | 91 | open CloustonEvaluationIMLProperties public 92 | -------------------------------------------------------------------------------- /src/Semantics/Clouston/Evaluation/IML/Base.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | open import Data.Product using (∃; _,_; -,_) renaming (_×_ to _∧_; proj₁ to fst; proj₂ to snd) 3 | 4 | open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst) 5 | 6 | module Semantics.Clouston.Evaluation.IML.Base 7 | (Ctx' : Set₁) 8 | 9 | (_→̇_ : (P Q : Ctx') → Set) (let infixr 19 _→̇_; _→̇_ = _→̇_) 10 | 11 | (_≈̇_ : {P Q : Ctx'} → (φ ψ : P →̇ Q) → Set) (let infix 18 _≈̇_; _≈̇_ = _≈̇_) 12 | (≈̇-refl : ∀ {P Q : Ctx'} {φ : P →̇ Q} → φ ≈̇ φ) 13 | (≈̇-sym : ∀ {P Q : Ctx'} {φ ψ : P →̇ Q} → (φ≈̇ψ : φ ≈̇ ψ) → ψ ≈̇ φ) 14 | (≈̇-trans : ∀ {P Q : Ctx'} {φ ψ ω : P →̇ Q} → (φ≈̇ψ : φ ≈̇ ψ) → (ψ≈̇ω : ψ ≈̇ ω) → φ ≈̇ ω) 15 | 16 | (_∘_ : {P Q R : Ctx'} → (ψ : Q →̇ R) → (φ : P →̇ Q) → (P →̇ R)) (let infixr 19 _∘_; _∘_ = _∘_) 17 | (let _[_]' = _∘_) 18 | 19 | (id'[_] : (P : Ctx') → P →̇ P) 20 | 21 | ([]' : Ctx') 22 | (unit' : {P : Ctx'} → P →̇ []') 23 | 24 | (_×'_ : (P Q : Ctx') → Ctx') 25 | (⟨_,_⟩' : {R P Q : Ctx'} → (φ : R →̇ P) → (ψ : R →̇ Q) → R →̇ P ×' Q) 26 | (π₁'[_] : {P : Ctx'} → (Q : Ctx') → P ×' Q →̇ P) 27 | (π₂'[_] : (P : Ctx') → {Q : Ctx'} → P ×' Q →̇ Q) 28 | (let fst'[_]_ = λ {R} {P} Q φ → _∘_ {R} {P ×' Q} {P} π₁'[ Q ] φ) 29 | (let snd'[_]_ = λ {R} P {Q} φ → _∘_ {R} {P ×' Q} {Q} π₂'[ P ] φ) 30 | (let _×'-map_ = λ {P} {P'} {Q} {Q'} φ ψ → ⟨_,_⟩' {P ×' Q} {P'} {Q'} (φ ∘ π₁'[ Q ]) (ψ ∘ π₂'[ P ])) 31 | 32 | (let Ty' = Ctx') 33 | 34 | (_⇒'_ : (P Q : Ty') → Ty') 35 | (lam' : {R P Q : Ty'} → (φ : R ×' P →̇ Q) → R →̇ P ⇒' Q) 36 | (app' : {R P Q : Ty'} → (φ : R →̇ P ⇒' Q) → (ψ : R →̇ P) → R →̇ Q) 37 | 38 | (✦'_ : (P : Ctx') → Ctx') 39 | (✦'-map_ : {P Q : Ctx'} → (φ : P →̇ Q) → ✦' P →̇ ✦' Q) 40 | 41 | (□'_ : (P : Ty') → Ty') 42 | (box' : {P Q : Ty'} → (φ : ✦' P →̇ Q) → P →̇ □' Q) 43 | (λ' : {P Q : Ty'} → (φ : P →̇ □' Q) → ✦' P →̇ Q) 44 | where 45 | 46 | open import Level using (0ℓ) 47 | 48 | open import Relation.Binary using (Reflexive; Symmetric; Transitive; IsEquivalence; Setoid) 49 | 50 | import Relation.Binary.Reasoning.Setoid as EqReasoning 51 | 52 | open import Type 53 | open import Context Ty Ty-Decidable 54 | 55 | -- XXX: make parameters 56 | ≈̇-equiv : ∀ (P Q : Ctx') → IsEquivalence (_≈̇_ {P} {Q}) 57 | ≈̇-equiv P Q = record { refl = ≈̇-refl {P} {Q} ; sym = ≈̇-sym {P} {Q} ; trans = ≈̇-trans {P} {Q} } 58 | 59 | →̇-setoid : (P Q : Ctx') → Setoid 0ℓ 0ℓ 60 | →̇-setoid P Q = record { Carrier = P →̇ Q ; _≈_ = _≈̇_ ; isEquivalence = ≈̇-equiv P Q } 61 | 62 | id' = λ {P} → id'[ P ] 63 | 64 | π₁' = λ {P} {Q} → π₁'[_] {P} Q 65 | π₁'[_][_] = λ P Q → π₁'[_] {P} Q 66 | 67 | π₂' = λ {P} {Q} → π₂'[_] P {Q} 68 | π₂'[_][_] = λ P Q → π₂'[_] P {Q} 69 | 70 | -- Δ' : {P P : Ctx'} → P →̇ P ×' P 71 | 72 | unbox' : {R P Q : Ty'} → (φ : P →̇ □' Q) → (ψ : R →̇ ✦' P) → R →̇ Q 73 | unbox' φ ψ = λ' φ ∘ ψ 74 | 75 | module Eval (N : Ty') where 76 | evalTy : (a : Ty) → Ty' 77 | evalTy ι = N 78 | evalTy (a ⇒ b) = evalTy a ⇒' evalTy b 79 | evalTy (□ a) = □' evalTy a 80 | 81 | evalCtx : (Γ : Ctx) → Ty' 82 | evalCtx [] = []' 83 | evalCtx (Γ `, a) = evalCtx Γ ×' evalTy a 84 | evalCtx (Γ #) = ✦' evalCtx Γ 85 | 86 | evalWk : (w : Γ ⊆ Δ) → evalCtx Δ →̇ evalCtx Γ 87 | evalWk base = unit' 88 | evalWk (drop {a = a} w) = evalWk w ∘ π₁'[ evalTy a ] 89 | evalWk (keep {a = a} w) = evalWk w ×'-map id'[ evalTy a ] 90 | evalWk (keep# w) = ✦'-map (evalWk w) 91 | 92 | evalVar : (v : Var Γ a) → evalCtx Γ →̇ evalTy a 93 | evalVar (zero {Γ}) = π₂'[ evalCtx Γ ] 94 | evalVar (succ {b = b} v) = evalVar v ∘ π₁'[ evalTy b ] 95 | 96 | Sub' = λ Δ Γ → evalCtx Δ →̇ evalCtx Γ 97 | 98 | Sub'-setoid = λ Δ Γ → →̇-setoid (evalCtx Δ) (evalCtx Γ) 99 | 100 | Tm' = λ Γ a → evalCtx Γ →̇ evalTy a 101 | 102 | Tm'-setoid = λ Γ a → →̇-setoid (evalCtx Γ) (evalTy a) 103 | -------------------------------------------------------------------------------- /src/Semantics/Clouston/Evaluation/IML/Properties.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | open import Data.Product using (∃; _,_; -,_) renaming (_×_ to _∧_; proj₁ to fst; proj₂ to snd) 3 | 4 | open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst) 5 | 6 | module Semantics.Clouston.Evaluation.IML.Properties 7 | (Ctx' : Set₁) 8 | 9 | (_→̇_ : (P Q : Ctx') → Set) (let infixr 19 _→̇_; _→̇_ = _→̇_) 10 | 11 | (_≈̇_ : {P Q : Ctx'} → (φ ψ : P →̇ Q) → Set) (let infix 18 _≈̇_; _≈̇_ = _≈̇_) 12 | (≈̇-refl : ∀ {P Q : Ctx'} {φ : P →̇ Q} → φ ≈̇ φ) 13 | (≈̇-sym : ∀ {P Q : Ctx'} {φ ψ : P →̇ Q} → (φ≈̇ψ : φ ≈̇ ψ) → ψ ≈̇ φ) 14 | (≈̇-trans : ∀ {P Q : Ctx'} {φ ψ ω : P →̇ Q} → (φ≈̇ψ : φ ≈̇ ψ) → (ψ≈̇ω : ψ ≈̇ ω) → φ ≈̇ ω) 15 | 16 | (_∘_ : {P Q R : Ctx'} → (ψ : Q →̇ R) → (φ : P →̇ Q) → (P →̇ R)) (let infixr 19 _∘_; _∘_ = _∘_) 17 | (∘-pres-≈̇ : ∀ {P Q R : Ctx'} {ψ ψ' : Q →̇ R} {φ φ' : P →̇ Q} (ψ≈̇ψ' : ψ ≈̇ ψ') (φ≈̇φ' : φ ≈̇ φ') → ψ ∘ φ ≈̇ ψ' ∘ φ') 18 | (∘-assoc : {P Q R S : Ctx'} → (ω : R →̇ S) → (ψ : Q →̇ R) → (φ : P →̇ Q) → (ω ∘ ψ) ∘ φ ≈̇ ω ∘ ψ ∘ φ) 19 | (let _[_]' = _∘_) 20 | 21 | (id'[_] : (P : Ctx') → P →̇ P) 22 | (id'-unit-left : ∀ {P : Ctx'} (Q : Ctx') (φ : P →̇ Q) → id'[ Q ] ∘ φ ≈̇ φ) 23 | (id'-unit-right : ∀ (P : Ctx') {Q : Ctx'} (φ : P →̇ Q) → φ ∘ id'[ P ] ≈̇ φ) 24 | 25 | ([]' : Ctx') 26 | (unit' : {P : Ctx'} → P →̇ []') 27 | ([]'-eta : ∀ {P : Ctx'} {φ : P →̇ []'} → φ ≈̇ unit') 28 | 29 | (_×'_ : (P Q : Ctx') → Ctx') 30 | (⟨_,_⟩' : {R P Q : Ctx'} → (φ : R →̇ P) → (ψ : R →̇ Q) → R →̇ P ×' Q) 31 | (⟨,⟩'-pres-≈̇ : ∀ {R P Q : Ctx'} {φ φ' : R →̇ P} {ψ ψ' : R →̇ Q} (φ≈̇φ' : φ ≈̇ φ') (ψ≈̇ψ' : ψ ≈̇ ψ') → ⟨ φ , ψ ⟩' ≈̇ ⟨ φ' , ψ' ⟩') 32 | (π₁'[_] : {P : Ctx'} → (Q : Ctx') → P ×' Q →̇ P) 33 | (π₂'[_] : (P : Ctx') → {Q : Ctx'} → P ×' Q →̇ Q) 34 | (let fst'[_]_ = λ {R} {P} Q φ → _∘_ {R} {P ×' Q} {P} π₁'[ Q ] φ) 35 | (let snd'[_]_ = λ {R} P {Q} φ → _∘_ {R} {P ×' Q} {Q} π₂'[ P ] φ) 36 | (×'-beta-left : ∀ {R P Q : Ctx'} {φ : R →̇ P} (ψ : R →̇ Q) → π₁'[ Q ] ∘ ⟨ φ , ψ ⟩' ≈̇ φ) 37 | (×'-beta-right : ∀ {R P Q : Ctx'} (φ : R →̇ P) {ψ : R →̇ Q} → π₂'[ P ] ∘ ⟨ φ , ψ ⟩' ≈̇ ψ) 38 | (×'-eta : ∀ {R P Q : Ctx'} {φ : R →̇ P ×' Q} → φ ≈̇ ⟨ fst'[ Q ] φ , snd'[ P ] φ ⟩') 39 | (⟨,⟩'-nat : ∀ {R' R P Q : Ctx'} (φ : R →̇ P) (ψ : R →̇ Q) (ω : R' →̇ R) → ⟨ φ , ψ ⟩' ∘ ω ≈̇ ⟨ φ ∘ ω , ψ ∘ ω ⟩') 40 | (let _×'-map_ = λ {P} {P'} {Q} {Q'} φ ψ → ⟨_,_⟩' {P ×' Q} {P'} {Q'} (φ ∘ π₁'[ Q ]) (ψ ∘ π₂'[ P ])) 41 | 42 | (let Ty' = Ctx') 43 | 44 | (_⇒'_ : (P Q : Ty') → Ty') 45 | (lam' : {R P Q : Ty'} → (φ : R ×' P →̇ Q) → R →̇ P ⇒' Q) 46 | (lam'-pres-≈̇ : ∀ {R P Q : Ty'} {φ φ' : R ×' P →̇ Q} (φ≈̇φ' : φ ≈̇ φ') → lam' φ ≈̇ lam' φ') 47 | (app' : {R P Q : Ty'} → (φ : R →̇ P ⇒' Q) → (ψ : R →̇ P) → R →̇ Q) 48 | (app'-pres-≈̇ : ∀ {R P Q : Ty'} {φ φ' : R →̇ P ⇒' Q} {ψ ψ' : R →̇ P} (φ≈̇φ' : φ ≈̇ φ') (ψ≈̇ψ' : ψ ≈̇ ψ') → app' φ ψ ≈̇ app' φ' ψ') 49 | (⇒'-beta : ∀ {R P Q : Ty'} (φ : R ×' P →̇ Q) (ψ : R →̇ P) → app' (lam' φ) ψ ≈̇ φ [ ⟨ id'[ R ] , ψ ⟩' ]') 50 | (⇒'-eta : ∀ {R P Q : Ty'} (φ : R →̇ P ⇒' Q) → φ ≈̇ lam' (app' (φ [ π₁'[ P ] ]') π₂'[ R ])) 51 | (lam'-nat : ∀ {R' R P Q : Ty'} (φ : R ×' P →̇ Q) (ψ : R' →̇ R) → lam' φ ∘ ψ ≈̇ lam' (φ ∘ ψ ×'-map id'[ P ])) 52 | (app'-nat : ∀ {R' R P Q : Ty'} (φ : R →̇ P ⇒' Q) (ψ : R →̇ P) (ω : R' →̇ R) → app' φ ψ ∘ ω ≈̇ app' (φ ∘ ω) (ψ ∘ ω)) 53 | 54 | (✦'_ : (P : Ctx') → Ctx') 55 | (✦'-map_ : {P Q : Ctx'} → (φ : P →̇ Q) → ✦' P →̇ ✦' Q) 56 | (✦'-map-pres-≈̇ : {P Q : Ctx'} {φ φ' : P →̇ Q} (φ≈̇φ' : φ ≈̇ φ') → ✦'-map φ ≈̇ ✦'-map φ') 57 | (✦'-map-pres-id' : {P : Ctx'} → ✦'-map id'[ P ] ≈̇ id'[ ✦' P ]) 58 | (✦'-map-pres-∘ : {P Q R : Ctx'} (ψ : Q →̇ R) (φ : P →̇ Q) → ✦'-map (ψ ∘ φ) ≈̇ ✦'-map ψ ∘ ✦'-map φ) 59 | 60 | (□'_ : (P : Ty') → Ty') 61 | (□'-map_ : {P Q : Ctx'} → (φ : P →̇ Q) → □' P →̇ □' Q) 62 | (box' : {P Q : Ty'} → (φ : ✦' P →̇ Q) → P →̇ □' Q) 63 | (box'-pres-≈̇ : ∀ {P : Ctx'} {Q : Ty'} {φ φ' : ✦' P →̇ Q} (φ≈̇φ' : φ ≈̇ φ') → box' φ ≈̇ box' φ') 64 | (λ' : {P Q : Ty'} → (φ : P →̇ □' Q) → ✦' P →̇ Q) 65 | (λ'-pres-≈̇ : ∀ {P : Ctx'} {Q : Ty'} {φ φ' : P →̇ □' Q} (φ≈̇φ' : φ ≈̇ φ') → λ' φ ≈̇ λ' φ') 66 | (□'-beta : ∀ {P : Ctx'} {Q : Ty'} (φ : ✦' P →̇ Q) → λ' (box' φ) ≈̇ φ) 67 | (□'-eta : ∀ {P : Ctx'} {Q : Ty'} (φ : P →̇ □' Q) → φ ≈̇ box' (λ' φ)) 68 | (box'-nat-dom : ∀ {P' P : Ctx'} {Q : Ty'} (φ : ✦' P →̇ Q) (φ' : P' →̇ P) → box' (φ ∘ ✦'-map φ') ≈̇ box' φ ∘ φ') 69 | (λ'-nat-dom : ∀ {P' P : Ctx'} {Q : Ty'} (φ : P →̇ □' Q) (φ' : P' →̇ P) → λ' (φ ∘ φ') ≈̇ λ' φ ∘ ✦'-map φ') 70 | 71 | (N : Ty') 72 | where 73 | 74 | open import Level using (0ℓ) 75 | 76 | open import Relation.Binary using (IsEquivalence; Setoid) 77 | 78 | import Relation.Binary.Reasoning.Setoid as EqReasoning 79 | 80 | open import Type 81 | open import Context Ty Ty-Decidable 82 | 83 | open import Semantics.Clouston.Evaluation.IML.Base 84 | Ctx' _→̇_ _≈̇_ ≈̇-refl ≈̇-sym ≈̇-trans _∘_ id'[_] 85 | []' unit' _×'_ ⟨_,_⟩' π₁'[_] π₂'[_] 86 | _⇒'_ lam' app' 87 | ✦'_ ✦'-map_ 88 | □'_ box' λ' 89 | renaming (module Eval to CloustonEvaluationIMLBaseEval) 90 | 91 | open CloustonEvaluationIMLBaseEval N 92 | 93 | ∘-pres-≈̇-left : ∀ {P Q R : Ctx'} {ψ ψ' : Q →̇ R} (ψ≈̇ψ' : ψ ≈̇ ψ') (φ : P →̇ Q) → ψ ∘ φ ≈̇ ψ' ∘ φ 94 | ∘-pres-≈̇-left ψ≈̇ψ' φ = ∘-pres-≈̇ ψ≈̇ψ' (≈̇-refl {φ = φ}) 95 | 96 | ∘-pres-≈̇-right : ∀ {P Q R : Ctx'} (ψ : Q →̇ R) {φ φ' : P →̇ Q} (φ≈̇φ' : φ ≈̇ φ') → ψ ∘ φ ≈̇ ψ ∘ φ' 97 | ∘-pres-≈̇-right ψ φ≈̇φ' = ∘-pres-≈̇ (≈̇-refl {φ = ψ}) φ≈̇φ' 98 | 99 | abstract 100 | ⟨,⟩'-pres-≈̇-left : ∀ {R P Q : Ctx'} {φ φ' : R →̇ P} (φ≈̇φ' : φ ≈̇ φ') (ψ : R →̇ Q) → ⟨ φ , ψ ⟩' ≈̇ ⟨ φ' , ψ ⟩' 101 | ⟨,⟩'-pres-≈̇-left ψ≈̇ψ' φ = ⟨,⟩'-pres-≈̇ ψ≈̇ψ' (≈̇-refl {φ = φ}) 102 | 103 | ⟨,⟩'-pres-≈̇-right : ∀ {R P Q : Ctx'} (φ : R →̇ P) {ψ ψ' : R →̇ Q} (ψ≈̇ψ' : ψ ≈̇ ψ') → ⟨ φ , ψ ⟩' ≈̇ ⟨ φ , ψ' ⟩' 104 | ⟨,⟩'-pres-≈̇-right ψ φ≈̇φ' = ⟨,⟩'-pres-≈̇ (≈̇-refl {φ = ψ}) φ≈̇φ' 105 | 106 | abstract 107 | ×'-map-pres-≈̇ : {P Q P' Q' : Ctx'} {φ φ' : P →̇ P'} (φ≈̇φ' : φ ≈̇ φ') {ψ ψ' : Q →̇ Q'} (ψ≈̇ψ' : ψ ≈̇ ψ') → φ ×'-map ψ ≈̇ φ' ×'-map ψ' 108 | ×'-map-pres-≈̇ {φ = φ} {φ'} φ≈̇φ' {ψ} {ψ'} ψ≈̇ψ' = let open EqReasoning (→̇-setoid _ _) in begin 109 | φ ×'-map ψ ≡⟨⟩ 110 | ⟨ φ ∘ π₁' , ψ ∘ π₂' ⟩' ≈⟨ ⟨,⟩'-pres-≈̇ (∘-pres-≈̇-left φ≈̇φ' π₁') (∘-pres-≈̇-left ψ≈̇ψ' π₂') ⟩ 111 | ⟨ φ' ∘ π₁' , ψ' ∘ π₂' ⟩' ∎ 112 | 113 | ×'-map-pres-≈̇-left : {P Q P' : Ctx'} {φ φ' : P →̇ P'} (φ≈̇φ' : φ ≈̇ φ') (ψ : Q →̇ Q) → φ ×'-map ψ ≈̇ φ' ×'-map ψ 114 | ×'-map-pres-≈̇-left = λ φ≈̇φ' ψ → ×'-map-pres-≈̇ φ≈̇φ' (≈̇-refl {φ = ψ}) 115 | 116 | ×'-map-pres-≈̇-right : {P Q Q' : Ctx'} (φ : P →̇ P) {ψ ψ' : Q →̇ Q'} (ψ≈̇ψ' : ψ ≈̇ ψ') → φ ×'-map ψ ≈̇ φ ×'-map ψ' 117 | ×'-map-pres-≈̇-right = λ φ ψ≈̇ψ' → ×'-map-pres-≈̇ (≈̇-refl {φ = φ}) ψ≈̇ψ' 118 | 119 | ×'-map-pres-id' : {P Q : Ctx'} → id'[ P ] ×'-map id'[ Q ] ≈̇ id'[ P ×' Q ] 120 | ×'-map-pres-id' {P} {Q} = let open EqReasoning (→̇-setoid _ _) in begin 121 | id' ×'-map id' ≡⟨⟩ 122 | ⟨ id' ∘ π₁' , id' ∘ π₂' ⟩' ≈⟨ ⟨,⟩'-pres-≈̇ (id'-unit-left P π₁') (id'-unit-left Q π₂') ⟩ 123 | ⟨ π₁' , π₂' ⟩' ≈˘⟨ ⟨,⟩'-pres-≈̇ (id'-unit-right (P ×' Q) π₁') (id'-unit-right (P ×' Q) π₂') ⟩ 124 | ⟨ π₁' ∘ id' , π₂' ∘ id' ⟩' ≈˘⟨ ×'-eta ⟩ 125 | id' ∎ 126 | 127 | abstract 128 | app'-pres-≈̇-left : ∀ {R : Ctx'} {P Q : Ty'} {φ φ' : R →̇ P ⇒' Q} (φ≈̇φ' : φ ≈̇ φ') (ψ : R →̇ P) → app' φ ψ ≈̇ app' φ' ψ 129 | app'-pres-≈̇-left φ≈̇φ' ψ = app'-pres-≈̇ φ≈̇φ' (≈̇-refl {φ = ψ}) 130 | 131 | app'-pres-≈̇-right : ∀ {R : Ctx'} {P Q : Ty'} (φ : R →̇ P ⇒' Q) {ψ ψ' : R →̇ P} (ψ≈̇ψ' : ψ ≈̇ ψ') → app' φ ψ ≈̇ app' φ ψ' 132 | app'-pres-≈̇-right φ ψ≈̇ψ' = app'-pres-≈̇ (≈̇-refl {φ = φ}) ψ≈̇ψ' 133 | 134 | abstract 135 | unbox'-pres-≈̇ : ∀ {R P : Ctx'} {Q : Ty'} {φ φ' : P →̇ □' Q} (φ≈̇φ' : φ ≈̇ φ') {ψ ψ' : R →̇ ✦' P} (ψ≈̇ψ' : ψ ≈̇ ψ') → unbox' φ ψ ≈̇ unbox' φ' ψ' 136 | unbox'-pres-≈̇ φ≈̇φ' ψ≈̇ψ' = ∘-pres-≈̇ (λ'-pres-≈̇ φ≈̇φ') ψ≈̇ψ' 137 | 138 | unbox'-pres-≈̇-left : ∀ {R P : Ctx'} {Q : Ty'} {φ φ' : P →̇ □' Q} (φ≈̇φ' : φ ≈̇ φ') (ψ : R →̇ ✦' P) → unbox' φ ψ ≈̇ unbox' φ' ψ 139 | unbox'-pres-≈̇-left φ≈̇φ' ψ = unbox'-pres-≈̇ φ≈̇φ' (≈̇-refl {φ = ψ}) 140 | 141 | unbox'-pres-≈̇-right : ∀ {R P : Ctx'} {Q : Ty'} (φ : P →̇ □' Q) {ψ ψ' : R →̇ ✦' P} (ψ≈̇ψ' : ψ ≈̇ ψ') → unbox' φ ψ ≈̇ unbox' φ ψ' 142 | unbox'-pres-≈̇-right φ ψ≈̇ψ' = unbox'-pres-≈̇ (≈̇-refl {φ = φ}) ψ≈̇ψ' 143 | 144 | unbox'-nat-dom : ∀ {R P' P : Ctx'} {Q : Ty'} (φ : P →̇ □' Q) (φ' : P' →̇ P) (ψ : R →̇ ✦' P') → unbox' (φ ∘ φ') ψ ≈̇ unbox' φ (✦'-map φ' ∘ ψ) 145 | unbox'-nat-dom {R} {P'} {P} {Q} φ φ' ψ = let open EqReasoning (→̇-setoid R Q) in begin 146 | unbox' (φ ∘ φ') ψ ≡⟨⟩ 147 | λ' (φ ∘ φ') ∘ ψ ≈⟨ ∘-pres-≈̇-left (λ'-nat-dom φ φ') ψ ⟩ 148 | (λ' φ ∘ ✦'-map φ') ∘ ψ ≈⟨ ∘-assoc (λ' φ) (✦'-map φ') ψ ⟩ 149 | λ' φ ∘ ✦'-map φ' ∘ ψ ∎ 150 | 151 | abstract 152 | evalWk-pres-id : ∀ (Γ : Ctx) → evalWk idWk[ Γ ] ≈̇ id' 153 | evalWk-pres-id [] = ≈̇-sym []'-eta 154 | evalWk-pres-id Γ@(Γ' `, a) = let open EqReasoning (Sub'-setoid Γ Γ) in begin 155 | evalWk (keep[ a ] idWk[ Γ' ]) ≈⟨ ×'-map-pres-≈̇-left (evalWk-pres-id Γ') id'[ evalTy a ] ⟩ 156 | id'[ evalCtx Γ' ] ×'-map id'[ evalTy a ] ≈⟨ ×'-map-pres-id' ⟩ 157 | id'[ evalCtx Γ ] ∎ 158 | evalWk-pres-id Γ@(Γ' #) = let open EqReasoning (Sub'-setoid Γ Γ) in begin 159 | evalWk (keep# idWk[ Γ' ]) ≈⟨ ✦'-map-pres-≈̇ (evalWk-pres-id Γ') ⟩ 160 | ✦'-map id'[ evalCtx Γ' ] ≈⟨ ✦'-map-pres-id' ⟩ 161 | id'[ evalCtx Γ ] ∎ 162 | 163 | evalWk-pres-∘-π₁ : evalWk (drop[ a ] w) ≈̇ evalWk w ∘ π₁'[ evalTy a ] 164 | evalWk-pres-∘-π₁ = ≈̇-refl 165 | 166 | evalWk-pres-×-map-id : evalWk (keep[ a ] w) ≈̇ evalWk w ×'-map id'[ evalTy a ] 167 | evalWk-pres-×-map-id = ≈̇-refl 168 | 169 | evalWk-pres-π₁ : ∀ (Γ : Ctx) (a : Ty) → evalWk (fresh {Γ} {a}) ≈̇ π₁'[ evalTy a ] 170 | evalWk-pres-π₁ Γ a = let open EqReasoning (Sub'-setoid (Γ `, a) Γ) in begin 171 | evalWk (fresh {Γ} {a}) ≈⟨ ∘-pres-≈̇-left (evalWk-pres-id Γ) π₁'[ evalTy a ] ⟩ 172 | id'[ evalCtx Γ ] ∘ π₁'[ evalTy a ] ≈⟨ id'-unit-left (evalCtx Γ) π₁'[ evalTy a ] ⟩ 173 | π₁'[ evalTy a ] ∎ 174 | 175 | evalWk-pres-✦-map : evalWk (keep# w) ≈̇ ✦'-map (evalWk w) 176 | evalWk-pres-✦-map = ≈̇-refl 177 | 178 | module _ {a : Ty} where 179 | abstract 180 | evalVar-pres-∘ : ∀ (w : Γ ⊆ Δ) (n : Var Γ a) → evalVar (wkVar w n) ≈̇ evalVar n ∘ evalWk w 181 | evalVar-pres-∘ (drop {Δ = Δ} {b} w) v = let open EqReasoning (Tm'-setoid (Δ `, b) a) in begin 182 | evalVar (wkVar (drop[ b ] w) v) ≈⟨ ∘-pres-≈̇-left (evalVar-pres-∘ w v) π₁'[ evalTy b ] ⟩ 183 | (evalVar v ∘ evalWk w) ∘ π₁'[ evalTy b ] ≈⟨ ∘-assoc (evalVar v) (evalWk w) π₁'[ evalTy b ] ⟩ 184 | evalVar v ∘ evalWk (drop[ b ] w) ∎ 185 | evalVar-pres-∘ (keep {Δ = Δ} {a} w) (zero {Γ}) = let open EqReasoning (Tm'-setoid (Δ `, a) a) in begin 186 | evalVar (wkVar (keep[ a ] w) (zero {Γ})) ≈˘⟨ id'-unit-left (evalTy a) π₂'[ evalCtx Δ ] ⟩ 187 | id'[ evalTy a ] ∘ π₂'[ evalCtx Δ ] ≈˘⟨ ×'-beta-right (evalWk w ∘ π₁'[ evalTy a ]) ⟩ 188 | evalVar (zero {Γ} {a}) ∘ evalWk (keep[ a ] w) ∎ 189 | evalVar-pres-∘ (keep {Δ = Δ} {b} w) (succ {Γ} {a} {b} n) = let open EqReasoning (Tm'-setoid (Δ `, b) a) in begin 190 | evalVar (wkVar (keep[ b ] w) (succ {Γ} {a} {b} n)) ≈⟨ ∘-pres-≈̇-left (evalVar-pres-∘ w n) π₁'[ evalTy b ] ⟩ 191 | (evalVar n ∘ evalWk w) ∘ π₁'[ evalTy b ] ≈⟨ ∘-assoc (evalVar n) (evalWk w) π₁'[ evalTy b ] ⟩ 192 | evalVar n ∘ evalWk w ∘ π₁'[ evalTy b ] ≈˘⟨ ∘-pres-≈̇-right (evalVar n) (×'-beta-left (id' ∘ π₂')) ⟩ 193 | evalVar n ∘ π₁'[ evalTy b ] ∘ evalWk (keep[ b ] w) ≈˘⟨ ∘-assoc (evalVar n) π₁'[ evalTy b ] (evalWk (keep[ b ] w)) ⟩ 194 | evalVar (succ {Γ} {a} {b} n) ∘ evalWk (keep[ b ] w) ∎ 195 | -------------------------------------------------------------------------------- /src/Semantics/Clouston/Evaluation/IS4.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | open import Data.Product using (∃; _,_; -,_) renaming (_×_ to _∧_; proj₁ to fst; proj₂ to snd) 3 | 4 | open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst) 5 | 6 | module Semantics.Clouston.Evaluation.IS4 7 | (Ctx' : Set₁) 8 | 9 | (_→̇_ : (P Q : Ctx') → Set) (let infixr 19 _→̇_; _→̇_ = _→̇_) 10 | 11 | (_≈̇_ : {P Q : Ctx'} → (φ ψ : P →̇ Q) → Set) (let infix 18 _≈̇_; _≈̇_ = _≈̇_) 12 | (≈̇-refl : ∀ {P Q : Ctx'} {φ : P →̇ Q} → φ ≈̇ φ) 13 | (≈̇-sym : ∀ {P Q : Ctx'} {φ ψ : P →̇ Q} → (φ≈̇ψ : φ ≈̇ ψ) → ψ ≈̇ φ) 14 | (≈̇-trans : ∀ {P Q : Ctx'} {φ ψ ω : P →̇ Q} → (φ≈̇ψ : φ ≈̇ ψ) → (ψ≈̇ω : ψ ≈̇ ω) → φ ≈̇ ω) 15 | 16 | (_∘_ : {P Q R : Ctx'} → (ψ : Q →̇ R) → (φ : P →̇ Q) → (P →̇ R)) (let infixr 19 _∘_; _∘_ = _∘_) 17 | (∘-pres-≈̇ : ∀ {P Q R : Ctx'} {ψ ψ' : Q →̇ R} {φ φ' : P →̇ Q} (ψ≈̇ψ' : ψ ≈̇ ψ') (φ≈̇φ' : φ ≈̇ φ') → ψ ∘ φ ≈̇ ψ' ∘ φ') 18 | (∘-assoc : {P Q R S : Ctx'} → (ω : R →̇ S) → (ψ : Q →̇ R) → (φ : P →̇ Q) → (ω ∘ ψ) ∘ φ ≈̇ ω ∘ ψ ∘ φ) 19 | (let _[_]' = _∘_) 20 | 21 | (id'[_] : (P : Ctx') → P →̇ P) 22 | (id'-unit-left : ∀ {P : Ctx'} (Q : Ctx') (φ : P →̇ Q) → id'[ Q ] ∘ φ ≈̇ φ) 23 | (id'-unit-right : ∀ (P : Ctx') {Q : Ctx'} (φ : P →̇ Q) → φ ∘ id'[ P ] ≈̇ φ) 24 | 25 | ([]' : Ctx') 26 | (unit' : {P : Ctx'} → P →̇ []') 27 | ([]'-eta : ∀ {P : Ctx'} {φ : P →̇ []'} → φ ≈̇ unit') 28 | 29 | (_×'_ : (P Q : Ctx') → Ctx') 30 | (⟨_,_⟩' : {R P Q : Ctx'} → (φ : R →̇ P) → (ψ : R →̇ Q) → R →̇ P ×' Q) 31 | (⟨,⟩'-pres-≈̇ : ∀ {R P Q : Ctx'} {φ φ' : R →̇ P} {ψ ψ' : R →̇ Q} (φ≈̇φ' : φ ≈̇ φ') (ψ≈̇ψ' : ψ ≈̇ ψ') → ⟨ φ , ψ ⟩' ≈̇ ⟨ φ' , ψ' ⟩') 32 | (π₁'[_] : {P : Ctx'} → (Q : Ctx') → P ×' Q →̇ P) 33 | (π₂'[_] : (P : Ctx') → {Q : Ctx'} → P ×' Q →̇ Q) 34 | (let fst'[_]_ = λ {R} {P} Q φ → _∘_ {R} {P ×' Q} {P} π₁'[ Q ] φ) 35 | (let snd'[_]_ = λ {R} P {Q} φ → _∘_ {R} {P ×' Q} {Q} π₂'[ P ] φ) 36 | (×'-beta-left : ∀ {R P Q : Ctx'} {φ : R →̇ P} (ψ : R →̇ Q) → π₁'[ Q ] ∘ ⟨ φ , ψ ⟩' ≈̇ φ) 37 | (×'-beta-right : ∀ {R P Q : Ctx'} (φ : R →̇ P) {ψ : R →̇ Q} → π₂'[ P ] ∘ ⟨ φ , ψ ⟩' ≈̇ ψ) 38 | (×'-eta : ∀ {R P Q : Ctx'} {φ : R →̇ P ×' Q} → φ ≈̇ ⟨ fst'[ Q ] φ , snd'[ P ] φ ⟩') 39 | (⟨,⟩'-nat : ∀ {R' R P Q : Ctx'} (φ : R →̇ P) (ψ : R →̇ Q) (ω : R' →̇ R) → ⟨ φ , ψ ⟩' ∘ ω ≈̇ ⟨ φ ∘ ω , ψ ∘ ω ⟩') 40 | (let _×'-map_ = λ {P} {P'} {Q} {Q'} φ ψ → ⟨_,_⟩' {P ×' Q} {P'} {Q'} (φ ∘ π₁'[ Q ]) (ψ ∘ π₂'[ P ])) 41 | 42 | (let Ty' = Ctx') 43 | 44 | (_⇒'_ : (P Q : Ty') → Ty') 45 | (lam' : {R P Q : Ty'} → (φ : R ×' P →̇ Q) → R →̇ P ⇒' Q) 46 | (lam'-pres-≈̇ : ∀ {R P Q : Ty'} {φ φ' : R ×' P →̇ Q} (φ≈̇φ' : φ ≈̇ φ') → lam' φ ≈̇ lam' φ') 47 | (app' : {R P Q : Ty'} → (φ : R →̇ P ⇒' Q) → (ψ : R →̇ P) → R →̇ Q) 48 | (app'-pres-≈̇ : ∀ {R P Q : Ty'} {φ φ' : R →̇ P ⇒' Q} {ψ ψ' : R →̇ P} (φ≈̇φ' : φ ≈̇ φ') (ψ≈̇ψ' : ψ ≈̇ ψ') → app' φ ψ ≈̇ app' φ' ψ') 49 | (⇒'-beta : ∀ {R P Q : Ty'} (φ : R ×' P →̇ Q) (ψ : R →̇ P) → app' (lam' φ) ψ ≈̇ φ [ ⟨ id'[ R ] , ψ ⟩' ]') 50 | (⇒'-eta : ∀ {R P Q : Ty'} (φ : R →̇ P ⇒' Q) → φ ≈̇ lam' (app' (φ [ π₁'[ P ] ]') π₂'[ R ])) 51 | (lam'-nat : ∀ {R' R P Q : Ty'} (φ : R ×' P →̇ Q) (ψ : R' →̇ R) → lam' φ ∘ ψ ≈̇ lam' (φ ∘ ψ ×'-map id'[ P ])) 52 | (app'-nat : ∀ {R' R P Q : Ty'} (φ : R →̇ P ⇒' Q) (ψ : R →̇ P) (ω : R' →̇ R) → app' φ ψ ∘ ω ≈̇ app' (φ ∘ ω) (ψ ∘ ω)) 53 | 54 | (✦'_ : (P : Ctx') → Ctx') 55 | (✦'-map_ : {P Q : Ctx'} → (φ : P →̇ Q) → ✦' P →̇ ✦' Q) 56 | (✦'-map-pres-≈̇ : {P Q : Ctx'} {φ φ' : P →̇ Q} (φ≈̇φ' : φ ≈̇ φ') → ✦'-map φ ≈̇ ✦'-map φ') 57 | (✦'-map-pres-id' : {P : Ctx'} → ✦'-map id'[ P ] ≈̇ id'[ ✦' P ]) 58 | (✦'-map-pres-∘ : {P Q R : Ctx'} (ψ : Q →̇ R) (φ : P →̇ Q) → ✦'-map (ψ ∘ φ) ≈̇ ✦'-map ψ ∘ ✦'-map φ) 59 | (μ'[_] : (P : Ctx') → ✦' ✦' P →̇ ✦' P) 60 | (μ'-nat : ∀ {P Q : Ctx'} (φ : P →̇ Q) → ✦'-map φ ∘ μ'[ P ] ≈̇ μ'[ Q ] ∘ ✦'-map ✦'-map φ) 61 | (μ'-assoc[_] : ∀ (P : Ctx') → μ'[ P ] ∘ μ'[ ✦' P ] ≈̇ μ'[ P ] ∘ ✦'-map μ'[ P ]) 62 | (η'[_] : (P : Ctx') → P →̇ ✦' P) 63 | (η'-nat : ∀ {P Q : Ctx'} (φ : P →̇ Q) → ✦'-map φ ∘ η'[ P ] ≈̇ η'[ Q ] ∘ φ) 64 | (η'-unit-left[_] : ∀ (P : Ctx') → μ'[ P ] ∘ η'[ ✦' P ] ≈̇ id'[ ✦' P ]) 65 | (η'-unit-right[_] : ∀ (P : Ctx') → μ'[ P ] ∘ ✦'-map η'[ P ] ≈̇ id'[ ✦' P ]) 66 | 67 | (□'_ : (P : Ty') → Ty') 68 | (□'-map_ : {P Q : Ctx'} → (φ : P →̇ Q) → □' P →̇ □' Q) 69 | (box' : {P Q : Ty'} → (φ : ✦' P →̇ Q) → P →̇ □' Q) 70 | (box'-pres-≈̇ : ∀ {P : Ctx'} {Q : Ty'} {φ φ' : ✦' P →̇ Q} (φ≈̇φ' : φ ≈̇ φ') → box' φ ≈̇ box' φ') 71 | (λ' : {P Q : Ty'} → (φ : P →̇ □' Q) → ✦' P →̇ Q) 72 | (λ'-pres-≈̇ : ∀ {P : Ctx'} {Q : Ty'} {φ φ' : P →̇ □' Q} (φ≈̇φ' : φ ≈̇ φ') → λ' φ ≈̇ λ' φ') 73 | (□'-beta : ∀ {P : Ctx'} {Q : Ty'} (φ : ✦' P →̇ Q) → λ' (box' φ) ≈̇ φ) 74 | (□'-eta : ∀ {P : Ctx'} {Q : Ty'} (φ : P →̇ □' Q) → φ ≈̇ box' (λ' φ)) 75 | (box'-nat-dom : ∀ {P' P : Ctx'} {Q : Ty'} (φ : ✦' P →̇ Q) (φ' : P' →̇ P) → box' (φ ∘ ✦'-map φ') ≈̇ box' φ ∘ φ') 76 | (λ'-nat-dom : ∀ {P' P : Ctx'} {Q : Ty'} (φ : P →̇ □' Q) (φ' : P' →̇ P) → λ' (φ ∘ φ') ≈̇ λ' φ ∘ ✦'-map φ') 77 | where 78 | 79 | import Semantics.Clouston.Evaluation.IS4.Base 80 | Ctx' _→̇_ _≈̇_ ≈̇-refl ≈̇-sym ≈̇-trans _∘_ id'[_] 81 | []' unit' _×'_ ⟨_,_⟩' π₁'[_] π₂'[_] 82 | _⇒'_ lam' app' 83 | ✦'_ ✦'-map_ μ'[_] η'[_] 84 | □'_ box' λ' 85 | as CloustonEvaluationIS4Base 86 | 87 | open CloustonEvaluationIS4Base public 88 | 89 | module EvalProperties (N : Ty') where 90 | import Semantics.Clouston.Evaluation.IS4.Properties 91 | Ctx' _→̇_ _≈̇_ ≈̇-refl ≈̇-sym ≈̇-trans _∘_ ∘-pres-≈̇ ∘-assoc id'[_] id'-unit-left id'-unit-right 92 | []' unit' []'-eta _×'_ ⟨_,_⟩' ⟨,⟩'-pres-≈̇ π₁'[_] π₂'[_] ×'-beta-left ×'-beta-right ×'-eta ⟨,⟩'-nat 93 | _⇒'_ lam' lam'-pres-≈̇ app' app'-pres-≈̇ ⇒'-beta ⇒'-eta lam'-nat app'-nat 94 | ✦'_ ✦'-map_ ✦'-map-pres-≈̇ ✦'-map-pres-id' ✦'-map-pres-∘ μ'[_] μ'-nat μ'-assoc[_] η'[_] η'-nat η'-unit-left[_] η'-unit-right[_] 95 | □'_ □'-map_ box' box'-pres-≈̇ λ' λ'-pres-≈̇ □'-beta □'-eta box'-nat-dom λ'-nat-dom N 96 | as CloustonEvaluationIS4Properties 97 | 98 | open CloustonEvaluationIS4Properties public 99 | -------------------------------------------------------------------------------- /src/Semantics/Clouston/Evaluation/IS4/Base.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | open import Data.Product using (∃; _,_; -,_) renaming (_×_ to _∧_; proj₁ to fst; proj₂ to snd) 3 | 4 | open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst) 5 | 6 | module Semantics.Clouston.Evaluation.IS4.Base 7 | (Ctx' : Set₁) 8 | (let Ty' = Ctx') 9 | 10 | (_→̇_ : (P Q : Ctx') → Set) (let infixr 19 _→̇_; _→̇_ = _→̇_) 11 | 12 | (_≈̇_ : {P Q : Ctx'} → (φ ψ : P →̇ Q) → Set) (let infix 18 _≈̇_; _≈̇_ = _≈̇_) 13 | (≈̇-refl : ∀ {P Q : Ctx'} {φ : P →̇ Q} → φ ≈̇ φ) 14 | (≈̇-sym : ∀ {P Q : Ctx'} {φ ψ : P →̇ Q} → (φ≈̇ψ : φ ≈̇ ψ) → ψ ≈̇ φ) 15 | (≈̇-trans : ∀ {P Q : Ctx'} {φ ψ ω : P →̇ Q} → (φ≈̇ψ : φ ≈̇ ψ) → (ψ≈̇ω : ψ ≈̇ ω) → φ ≈̇ ω) 16 | 17 | (_∘_ : {P Q R : Ctx'} → (ψ : Q →̇ R) → (φ : P →̇ Q) → (P →̇ R)) (let infixr 19 _∘_; _∘_ = _∘_) 18 | 19 | (id'[_] : (P : Ctx') → P →̇ P) 20 | 21 | ([]' : Ctx') 22 | (unit' : {P : Ctx'} → P →̇ []') 23 | 24 | (_×'_ : (P Q : Ctx') → Ctx') 25 | (⟨_,_⟩' : {R P Q : Ctx'} → (φ : R →̇ P) → (ψ : R →̇ Q) → R →̇ P ×' Q) 26 | (π₁'[_] : {P : Ctx'} → (Q : Ctx') → P ×' Q →̇ P) 27 | (π₂'[_] : (P : Ctx') → {Q : Ctx'} → P ×' Q →̇ Q) 28 | (let fst'[_]_ = λ {R} {P} Q φ → _∘_ {R} {P ×' Q} {P} π₁'[ Q ] φ) 29 | (let snd'[_]_ = λ {R} P {Q} φ → _∘_ {R} {P ×' Q} {Q} π₂'[ P ] φ) 30 | 31 | (_⇒'_ : (P Q : Ty') → Ty') 32 | (lam' : {R P Q : Ty'} → (φ : R ×' P →̇ Q) → R →̇ P ⇒' Q) 33 | (app' : {R P Q : Ty'} → (φ : R →̇ P ⇒' Q) → (ψ : R →̇ P) → R →̇ Q) 34 | 35 | (✦'_ : (P : Ctx') → Ctx') 36 | (✦'-map_ : {P Q : Ctx'} → (φ : P →̇ Q) → ✦' P →̇ ✦' Q) 37 | (μ'[_] : (P : Ctx') → ✦' ✦' P →̇ ✦' P) 38 | (η'[_] : (P : Ctx') → P →̇ ✦' P) 39 | 40 | (□'_ : (P : Ty') → Ty') 41 | (box' : {P Q : Ty'} → (φ : ✦' P →̇ Q) → P →̇ □' Q) 42 | (λ' : {P Q : Ty'} → (φ : P →̇ □' Q) → ✦' P →̇ Q) 43 | where 44 | 45 | open import IS4.Term.Base 46 | 47 | import Semantics.Clouston.Evaluation.IML.Base 48 | Ctx' _→̇_ _≈̇_ ≈̇-refl ≈̇-sym ≈̇-trans _∘_ id'[_] 49 | []' unit' _×'_ ⟨_,_⟩' π₁'[_] π₂'[_] 50 | _⇒'_ lam' app' 51 | ✦'_ ✦'-map_ 52 | □'_ box' λ' 53 | as CloustonEvaluationIMLBase 54 | 55 | open CloustonEvaluationIMLBase public hiding (module Eval) 56 | 57 | -- XXX: make parameters 58 | η' = λ {P} → η'[ P ] 59 | 60 | μ' = λ {P} → μ'[ P ] 61 | 62 | module Eval (N : Ty') where 63 | module CloustonEvaluationIMLEval = CloustonEvaluationIMLBase.Eval N 64 | 65 | open CloustonEvaluationIMLEval public 66 | 67 | evalAcc : (e : CExt Γ ΓL ΓR) → evalCtx Γ →̇ ✦' evalCtx ΓL 68 | evalAcc nil = η' 69 | evalAcc (ext {a = a} e) = evalAcc e ∘ π₁'[ evalTy a ] 70 | evalAcc (ext#- e) = μ' ∘ ✦'-map (evalAcc e) 71 | 72 | evalTm : (t : Tm Γ a) → evalCtx Γ →̇ evalTy a 73 | evalTm (var v) = evalVar v 74 | evalTm (lam t) = lam' (evalTm t) 75 | evalTm (app t u) = app' (evalTm t) (evalTm u) 76 | evalTm (box t) = box' (evalTm t) 77 | evalTm (unbox t e) = unbox' (evalTm t) (evalAcc e) 78 | 79 | evalSub : (σ : Sub Δ Γ) → evalCtx Δ →̇ evalCtx Γ 80 | evalSub [] = unit' 81 | evalSub (σ `, t) = ⟨ evalSub σ , evalTm t ⟩' 82 | evalSub (lock σ e) = ✦'-map (evalSub σ) ∘ evalAcc e 83 | -------------------------------------------------------------------------------- /src/Semantics/Presheaf/Base.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module Semantics.Presheaf.Base 3 | (C : Set) 4 | (_⊆_ : (Γ Γ' : C) → Set) 5 | (⊆-refl : ∀ {Γ : C} → Γ ⊆ Γ) 6 | (⊆-trans : ∀ {Γ Γ' Γ'' : C} → (_w : Γ ⊆ Γ') → (_w' : Γ' ⊆ Γ'') → Γ ⊆ Γ'') 7 | where 8 | 9 | open import Level using (0ℓ) 10 | 11 | open import Relation.Binary using (Reflexive; Symmetric; Transitive; IsEquivalence; Setoid) 12 | import Relation.Binary.Reasoning.Setoid as EqReasoning 13 | open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; subst; cong) 14 | 15 | infixr 19 _∘_ 16 | infix 18 _→̇_ _≈̇_ 17 | 18 | private 19 | variable 20 | Γ Γ' Γ'' : C 21 | Δ Δ' Δ'' : C 22 | Θ Θ' Θ'' : C 23 | w w' w'' : Γ ⊆ Δ 24 | 25 | record Psh : Set₁ where 26 | no-eta-equality 27 | field 28 | -- setoids 29 | Fam : (Γ : C) → Set 30 | _≋_ : (x y : Fam Γ) → Set -- type \~~~ 31 | ≋-equiv : ∀ (Γ : C) → IsEquivalence {A = Fam Γ} _≋_ 32 | 33 | -- setoid morphisms 34 | wk : (w : Γ ⊆ Δ) → (x : Fam Γ) → Fam Δ 35 | wk-pres-≋ : ∀ (w : Γ ⊆ Δ) {x y : Fam Γ} (x≋y : x ≋ y) → wk w x ≋ wk w y 36 | 37 | -- functoriality 38 | wk-pres-refl : ∀ (x : Fam Γ) → wk ⊆-refl x ≋ x 39 | wk-pres-trans : ∀ (w : Γ ⊆ Γ') (w' : Γ' ⊆ Γ'') (x : Fam Γ) → wk (⊆-trans w w') x ≋ wk w' (wk w x) 40 | 41 | infix 19 Fam 42 | 43 | Fam-setoid : {Γ : C} → Setoid _ _ 44 | Fam-setoid {Γ} = record 45 | { Carrier = Fam Γ 46 | ; _≈_ = _≋_ 47 | ; isEquivalence = ≋-equiv Γ 48 | } 49 | 50 | wk-pres-≡-≋ : ∀ {w w' : Γ ⊆ Δ} (w≡w' : w ≡ w') {x y : Fam Γ} (x≋y : x ≋ y) → wk w x ≋ wk w' y 51 | wk-pres-≡-≋ {w = w} {.w} refl = wk-pres-≋ w 52 | 53 | module _ {Γ : C} where 54 | open IsEquivalence (≋-equiv Γ) public 55 | using () 56 | renaming 57 | ( refl to ≋-refl 58 | ; sym to ≋-sym 59 | ; trans to ≋-trans 60 | ; reflexive to ≋-reflexive 61 | ) 62 | 63 | ≋-reflexive˘ : ∀ {x y : Fam Γ} → y ≡ x → x ≋ y 64 | ≋-reflexive˘ refl = ≋-refl 65 | 66 | -- open Psh {{...}} using (_≋_; ≋-refl; ≋-sym; ≋-trans; wk) public 67 | -- ≋-refl = λ {𝒫} {Γ} {p} → 𝒫 .Psh.≋-refl {Γ} {p} 68 | -- ≋-sym = λ {𝒫} {Γ} {p} {q} → 𝒫 .Psh.≋-sym {Γ} {p} {q} 69 | -- ≋-trans = λ {𝒫} {Γ} {p} {q} {r} → 𝒫 .Psh.≋-trans {Γ} {p} {q} {r} 70 | open Psh public 71 | using () 72 | renaming 73 | ( Fam to _₀_ 74 | ; Fam-setoid to ≋[_]-setoid 75 | ; ≋-refl to ≋[_]-refl 76 | ; ≋-sym to ≋[_]-sym 77 | ; ≋-trans to ≋[_]-trans 78 | ; ≋-reflexive to ≋[_]-reflexive 79 | ; ≋-reflexive˘ to ≋[_]-reflexive˘ 80 | ; wk to wk[_] 81 | ; wk-pres-≋ to wk[_]-pres-≋ 82 | ; wk-pres-refl to wk[_]-pres-refl 83 | ; wk-pres-trans to wk[_]-pres-trans 84 | ) 85 | 86 | private 87 | variable 88 | 𝒫 𝒫' : Psh -- type \McP 89 | 𝒬 𝒬' : Psh -- type \McQ 90 | ℛ ℛ' : Psh -- type \McR 91 | 𝒮 𝒮' : Psh -- type \McS 92 | 93 | ≋[]-syntax : (𝒫 : Psh) → (x y : 𝒫 ₀ Γ) → Set 94 | ≋[]-syntax 𝒫 = 𝒫 .Psh._≋_ 95 | 96 | syntax ≋[]-syntax 𝒫 x y = x ≋[ 𝒫 ] y 97 | 98 | record _→̇_ (𝒫 𝒬 : Psh) : Set where -- type \-> \^. 99 | no-eta-equality 100 | field 101 | fun : (p : 𝒫 ₀ Γ) → 𝒬 ₀ Γ 102 | pres-≋ : ∀ {p p' : 𝒫 ₀ Γ} (p≋p' : p ≋[ 𝒫 ] p') → fun p ≋[ 𝒬 ] fun p' 103 | natural : ∀ (w : Γ ⊆ Δ) (p : 𝒫 ₀ Γ) → wk[ 𝒬 ] w (fun p) ≋[ 𝒬 ] fun (wk[ 𝒫 ] w p) 104 | 105 | open _→̇_ using (natural) renaming (fun to apply; pres-≋ to apply-≋) public 106 | 107 | record _≈̇_ (φ ψ : 𝒫 →̇ 𝒬) : Set where -- type \~~ \^. 108 | no-eta-equality 109 | field 110 | proof : ∀ (p : 𝒫 ₀ Γ) → φ .apply p ≋[ 𝒬 ] ψ .apply p 111 | 112 | apply-sq : ∀ {p p' : 𝒫 ₀ Γ} → p ≋[ 𝒫 ] p' → φ .apply p ≋[ 𝒬 ] ψ .apply p' -- XXX: rename 113 | apply-sq {p = p} {p'} p≋p' = let open EqReasoning ≋[ 𝒬 ]-setoid in begin 114 | φ .apply p ≈⟨ φ .apply-≋ p≋p' ⟩ 115 | φ .apply p' ≈⟨ proof p' ⟩ 116 | ψ .apply p' ∎ 117 | 118 | open _≈̇_ using (apply-sq) renaming (proof to apply-≋) public 119 | 120 | private 121 | variable 122 | φ φ' : 𝒫 →̇ 𝒬 123 | ψ ψ' : 𝒫 →̇ 𝒬 124 | ω ω' : 𝒫 →̇ 𝒬 125 | 126 | module _ {𝒫 𝒬 : Psh} where 127 | abstract 128 | ≈̇-refl : Reflexive {A = 𝒫 →̇ 𝒬} _≈̇_ 129 | ≈̇-refl = record { proof = λ {_} _ → ≋[ 𝒬 ]-refl } 130 | 131 | ≈̇-sym : Symmetric {A = 𝒫 →̇ 𝒬} _≈̇_ 132 | ≈̇-sym φ≋φ' = record { proof = λ {_} p → ≋[ 𝒬 ]-sym (φ≋φ' ._≈̇_.proof p) } 133 | 134 | ≈̇-trans : Transitive {A = 𝒫 →̇ 𝒬} _≈̇_ 135 | ≈̇-trans φ≋ψ ψ≋ω = record { proof = λ {_} p → ≋[ 𝒬 ]-trans (φ≋ψ ._≈̇_.proof p) (ψ≋ω ._≈̇_.proof p) } 136 | 137 | ≈̇-equiv : IsEquivalence {A = 𝒫 →̇ 𝒬} _≈̇_ 138 | ≈̇-equiv = record 139 | { refl = ≈̇-refl 140 | ; sym = ≈̇-sym 141 | ; trans = ≈̇-trans 142 | } 143 | 144 | module _ (𝒫 𝒬 : Psh) where 145 | →̇-setoid : Setoid 0ℓ 0ℓ 146 | →̇-setoid = record 147 | { Carrier = 𝒫 →̇ 𝒬 148 | ; _≈_ = _≈̇_ 149 | ; isEquivalence = ≈̇-equiv 150 | } 151 | 152 | _∘_ : (ψ : 𝒬 →̇ ℛ) → (φ : 𝒫 →̇ 𝒬) → 𝒫 →̇ ℛ 153 | _∘_ {𝒬} {ℛ} {𝒫} ψ φ = record 154 | { fun = λ p → ψ .apply (φ .apply p) 155 | ; pres-≋ = λ p≋p' → ψ .apply-≋ (φ .apply-≋ p≋p') 156 | ; natural = λ w p → let open EqReasoning ≋[ ℛ ]-setoid in begin 157 | wk[ ℛ ] w (ψ .apply (φ .apply p)) ≈⟨ ψ .natural _ _ ⟩ 158 | ψ .apply (wk[ 𝒬 ] w (φ .apply p)) ≈⟨ ψ .apply-≋ (φ .natural _ _) ⟩ 159 | ψ .apply (φ .apply (wk[ 𝒫 ] w p)) ∎ 160 | } 161 | 162 | _[_]' = _∘_ 163 | 164 | abstract 165 | ∘-pres-≈̇ : ψ ≈̇ ψ' → φ ≈̇ φ' → ψ ∘ φ ≈̇ ψ' ∘ φ' 166 | ∘-pres-≈̇ ψ≈̇ψ' φ≈̇φ' = record { proof = λ p → apply-sq ψ≈̇ψ' (φ≈̇φ' .apply-≋ p) } 167 | 168 | ∘-pres-≈̇-left : ∀ (_ : ψ ≈̇ ψ') (φ : 𝒫 →̇ 𝒬) → ψ ∘ φ ≈̇ ψ' ∘ φ 169 | ∘-pres-≈̇-left ψ≈̇ψ' φ = ∘-pres-≈̇ ψ≈̇ψ' (≈̇-refl {x = φ}) 170 | 171 | ∘-pres-≈̇-right : ∀ (ψ : 𝒬 →̇ ℛ) (_ : φ ≈̇ φ') → ψ ∘ φ ≈̇ ψ ∘ φ' 172 | ∘-pres-≈̇-right ψ φ≈̇φ' = ∘-pres-≈̇ (≈̇-refl {x = ψ}) φ≈̇φ' 173 | 174 | ∘-assoc : ∀ (ω : ℛ →̇ 𝒮) (ψ : 𝒬 →̇ ℛ) (φ : 𝒫 →̇ 𝒬) → (ω ∘ ψ) ∘ φ ≈̇ ω ∘ ψ ∘ φ 175 | ∘-assoc {_} {ℛ} ω ψ φ = record { proof = λ p → ≋[ ℛ ]-refl } 176 | 177 | id'[_] : (𝒫 : Psh) → 𝒫 →̇ 𝒫 178 | id'[_] 𝒫 = record 179 | { fun = λ p → p 180 | ; pres-≋ = λ p≋p' → p≋p' 181 | ; natural = λ _ _ → ≋[ 𝒫 ]-refl 182 | } 183 | 184 | id' = λ {𝒫} → id'[ 𝒫 ] 185 | 186 | abstract 187 | id'-unit-left : ∀ {𝒫 : Psh} (𝒬 : Psh) (φ : 𝒫 →̇ 𝒬) → id'[ 𝒬 ] ∘ φ ≈̇ φ 188 | id'-unit-left 𝒬 _ = record { proof = λ p → ≋[ 𝒬 ]-refl } 189 | 190 | id'-unit-right : ∀ (𝒫 : Psh) {𝒬 : Psh} (φ : 𝒫 →̇ 𝒬) → φ ∘ id'[ 𝒫 ] ≈̇ φ 191 | id'-unit-right _ {𝒬} _ = record { proof = λ p → ≋[ 𝒬 ]-refl } 192 | -------------------------------------------------------------------------------- /src/Semantics/Presheaf/CartesianClosure.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | open import Relation.Binary.PropositionalEquality using (_≡_; subst; cong; cong₂) renaming (refl to ≡-refl; sym to ≡-sym; trans to ≡-trans) 3 | 4 | module Semantics.Presheaf.CartesianClosure 5 | (C : Set) 6 | (_⊆_ : (Γ Γ' : C) → Set) 7 | (⊆-trans : ∀ {Γ Γ' Γ'' : C} → (w : Γ ⊆ Γ') → (w' : Γ' ⊆ Γ'') → Γ ⊆ Γ'') 8 | (⊆-trans-assoc : ∀ {Γ Γ' Γ'' Γ''' : C} (w : Γ ⊆ Γ') (w' : Γ' ⊆ Γ'') (w'' : Γ'' ⊆ Γ''') → ⊆-trans w (⊆-trans w' w'') ≡ ⊆-trans (⊆-trans w w') w'') 9 | (⊆-refl : ∀ {Γ : C} → Γ ⊆ Γ) 10 | (⊆-refl-unit-left : ∀ {Γ Γ' : C} (w : Γ ⊆ Γ') → ⊆-trans w ⊆-refl ≡ w) 11 | (⊆-refl-unit-right : ∀ {Γ Γ' : C} (w : Γ ⊆ Γ') → ⊆-trans ⊆-refl w ≡ w) 12 | where 13 | 14 | open import Data.Unit using (⊤; tt) 15 | open import Data.Unit.Properties using () renaming (⊤-irrelevant to ⊤-eta) 16 | 17 | open import Data.Product using (Σ; _×_; _,_) renaming (proj₁ to fst; proj₂ to snd) 18 | open import Data.Product using () renaming (_×_ to _∧_) 19 | 20 | open import Function using (id) 21 | 22 | open import Relation.Binary using (IsEquivalence) 23 | open import Relation.Binary.PropositionalEquality.Properties using () renaming (isEquivalence to ≡-equiv) 24 | import Relation.Binary.Reasoning.Setoid as EqReasoning 25 | 26 | open import Semantics.Presheaf.Base C _⊆_ ⊆-refl ⊆-trans 27 | 28 | private 29 | variable 30 | Γ Δ Θ : C 31 | w w' w'' : Γ ⊆ Δ 32 | 𝒫 𝒫' : Psh 33 | 𝒬 𝒬' : Psh 34 | ℛ ℛ' : Psh 35 | s s' : 𝒫 →̇ 𝒬 36 | t t' : 𝒫 →̇ 𝒬 37 | u u' : 𝒫 →̇ 𝒬 38 | 39 | Unit' : Psh 40 | Unit' = record 41 | { Fam = λ _Γ → ⊤ 42 | ; _≋_ = _≡_ 43 | ; ≋-equiv = λ _Γ → ≡-equiv 44 | ; wk = λ _w → id 45 | ; wk-pres-≋ = λ _w → cong id 46 | ; wk-pres-refl = λ _x → ≡-refl 47 | ; wk-pres-trans = λ _x _w _w' → ≡-refl 48 | } 49 | 50 | []' = Unit' 51 | 52 | unit' : ℛ →̇ Unit' 53 | unit' = record 54 | { fun = λ _r → tt 55 | ; pres-≋ = λ {Γ} _p≋p' → ≋[ Unit' ]-refl {Γ} 56 | ; natural = λ {_Γ} {Δ} _w _r → ≋[ Unit' ]-refl {Δ} 57 | } 58 | 59 | unit'[_] = λ ℛ → unit' {ℛ} 60 | 61 | Unit'-eta : t ≈̇ unit' 62 | Unit'-eta {ℛ} {t} = record { proof = λ r → ⊤-eta (t .apply r) (unit'[ ℛ ] .apply r) } 63 | 64 | []'-eta = Unit'-eta 65 | 66 | module _ (𝒫 𝒬 : Psh) where 67 | open Psh 𝒫 using () renaming (Fam to P) 68 | open Psh 𝒬 using () renaming (Fam to Q) 69 | 70 | record Fam (Γ : C) : Set where 71 | constructor elem 72 | field 73 | elem : P Γ × Q Γ 74 | 75 | record _≋_ {Γ : C} (x y : Fam Γ) : Set where 76 | constructor proof 77 | field 78 | proof : let elem (p , q) = x; elem (p' , q') = y in p ≋[ 𝒫 ] p' ∧ q ≋[ 𝒬 ] q' 79 | 80 | private 81 | ≋-equiv : ∀ (Γ : C) → IsEquivalence (_≋_ {Γ}) 82 | ≋-equiv _Γ = record 83 | { refl = proof (≋[ 𝒫 ]-refl , ≋[ 𝒬 ]-refl) 84 | ; sym = λ (proof (p≋p' , q≋q')) → proof (≋[ 𝒫 ]-sym p≋p' , ≋[ 𝒬 ]-sym q≋q') 85 | ; trans = λ (proof (p≋p' , q≋q')) (proof (p'≋p'' , q'≋q'')) → proof (≋[ 𝒫 ]-trans p≋p' p'≋p'' , ≋[ 𝒬 ]-trans q≋q' q'≋q'') 86 | } 87 | 88 | _×'_ : Psh 89 | _×'_ = record 90 | { Fam = Fam 91 | ; _≋_ = _≋_ 92 | ; ≋-equiv = ≋-equiv 93 | ; wk = λ w (elem (p , q)) → elem (wk[ 𝒫 ] w p , wk[ 𝒬 ] w q) 94 | ; wk-pres-≋ = λ w (proof (p≋p' , q≋q')) → proof (wk[ 𝒫 ]-pres-≋ w p≋p' , wk[ 𝒬 ]-pres-≋ w q≋q') 95 | ; wk-pres-refl = λ (elem (p , q)) → proof (wk[ 𝒫 ]-pres-refl p , wk[ 𝒬 ]-pres-refl q) 96 | ; wk-pres-trans = λ w w' (elem (p , q)) → proof (wk[ 𝒫 ]-pres-trans w w' p , wk[ 𝒬 ]-pres-trans w w' q) 97 | } 98 | 99 | module _ {𝒫 𝒬 : Psh} where 100 | π₁' : 𝒫 ×' 𝒬 →̇ 𝒫 101 | π₁' = record 102 | { fun = λ x → let elem (p , _q) = x in p 103 | ; pres-≋ = λ x≋y → let proof (p≋p' , _q≋q') = x≋y in p≋p' 104 | ; natural = λ _w x → let elem (_p , _q) = x in ≋[ 𝒫 ]-refl 105 | } 106 | 107 | π₂' : 𝒫 ×' 𝒬 →̇ 𝒬 108 | π₂' = record 109 | { fun = λ x → let elem (_p , q) = x in q 110 | ; pres-≋ = λ x≋y → let proof (_p≋p' , q≋q') = x≋y in q≋q' 111 | ; natural = λ _w x → let elem (_p , _q) = x in ≋[ 𝒬 ]-refl 112 | } 113 | 114 | fst' : (t : ℛ →̇ 𝒫 ×' 𝒬) → ℛ →̇ 𝒫 115 | fst' = π₁' ∘_ 116 | 117 | snd' : (t : ℛ →̇ 𝒫 ×' 𝒬) → ℛ →̇ 𝒬 118 | snd' = π₂' ∘_ 119 | 120 | pr' : (t : ℛ →̇ 𝒫) → (u : ℛ →̇ 𝒬) → ℛ →̇ 𝒫 ×' 𝒬 121 | pr' t u = record 122 | { fun = λ r → elem (t .apply r , u .apply r) 123 | ; pres-≋ = λ r≋r' → proof (t .apply-≋ r≋r' , u .apply-≋ r≋r') 124 | ; natural = λ w r → proof (t .natural w r , u .natural w r) 125 | } 126 | 127 | ⟨_,_⟩' = pr' 128 | 129 | abstract 130 | pr'-pres-≈̇ : t ≈̇ t' → u ≈̇ u' → pr' t u ≈̇ pr' t' u' 131 | pr'-pres-≈̇ t≈̇t' u≈̇u' = record { proof = λ r → proof (t≈̇t' .apply-≋ r , u≈̇u' .apply-≋ r) } 132 | 133 | ⟨,⟩'-pres-≈̇ : t ≈̇ t' → u ≈̇ u' → ⟨ t , u ⟩' ≈̇ ⟨ t' , u' ⟩' 134 | ⟨,⟩'-pres-≈̇ = pr'-pres-≈̇ 135 | 136 | pr'-pres-≈̇-left : t ≈̇ t' → pr' t u ≈̇ pr' t' u 137 | pr'-pres-≈̇-left {u = u} t≈̇t' = pr'-pres-≈̇ t≈̇t' (≈̇-refl {x = u}) 138 | 139 | pr'-pres-≈̇-right : u ≈̇ u' → pr' t u ≈̇ pr' t u' 140 | pr'-pres-≈̇-right {t = t} u≈̇u' = pr'-pres-≈̇ (≈̇-refl {x = t}) u≈̇u' 141 | 142 | pr'-nat : ∀ (t : ℛ →̇ 𝒫) (u : ℛ →̇ 𝒬) (s : ℛ' →̇ ℛ) → pr' t u ∘ s ≈̇ pr' (t ∘ s) (u ∘ s) 143 | pr'-nat _t _u _s = ≈̇-refl 144 | 145 | ⟨,⟩'-nat : ∀ (t : ℛ →̇ 𝒫) (u : ℛ →̇ 𝒬) (s : ℛ' →̇ ℛ) → ⟨ t , u ⟩' ∘ s ≈̇ ⟨ t ∘ s , u ∘ s ⟩' 146 | ⟨,⟩'-nat _t _u _s = ≈̇-refl 147 | 148 | ×'-beta-left : ∀ {t : ℛ →̇ 𝒫} (u : ℛ →̇ 𝒬) → fst' (pr' t u) ≈̇ t 149 | ×'-beta-left {_t} _u = record { proof = λ _r → ≋[ 𝒫 ]-refl } 150 | 151 | ×'-beta-right : ∀ (t : ℛ →̇ 𝒫) {u : ℛ →̇ 𝒬} → snd' (pr' t u) ≈̇ u 152 | ×'-beta-right t {_u} = record { proof = λ _r → ≋[ 𝒬 ]-refl } 153 | 154 | ×'-eta : t ≈̇ pr' (fst' t) (snd' t) 155 | ×'-eta = record { proof = λ _r → ≋[ 𝒫 ×' 𝒬 ]-refl } 156 | 157 | π₁'[_] = λ {𝒫} 𝒬 → π₁' {𝒫} {𝒬} 158 | 159 | π₁'[_][_] = λ 𝒫 𝒬 → π₁' {𝒫} {𝒬} 160 | 161 | π₂'[_] = λ 𝒫 {𝒬} → π₂' {𝒫} {𝒬} 162 | 163 | π₂'[_][_] = λ 𝒫 𝒬 → π₂' {𝒫} {𝒬} 164 | 165 | _×'-map_ : (t : 𝒫 →̇ 𝒫') → (u : 𝒬 →̇ 𝒬') → 𝒫 ×' 𝒬 →̇ 𝒫' ×' 𝒬' 166 | _×'-map_ {𝒫 = 𝒫} {𝒬 = 𝒬} t u = pr' (t ∘ π₁'[ 𝒬 ]) (u ∘ π₂'[ 𝒫 ]) 167 | 168 | abstract 169 | ×'-map-pres-≈̇ : t ≈̇ t' → u ≈̇ u' → t ×'-map u ≈̇ t' ×'-map u' 170 | ×'-map-pres-≈̇ t≈̇t' u≈̇u' = record { proof = λ x → let elem (p , q) = x in proof (t≈̇t' .apply-≋ p , u≈̇u' .apply-≋ q) } 171 | 172 | ×'-map-pres-≈̇-left : ∀ (_ : t ≈̇ t') (u : 𝒬 →̇ 𝒬') → t ×'-map u ≈̇ t' ×'-map u 173 | ×'-map-pres-≈̇-left t≈̇t' u = ×'-map-pres-≈̇ t≈̇t' (≈̇-refl {x = u}) 174 | 175 | ×'-map-pres-≈̇-right : ∀ (t : 𝒫 →̇ 𝒫') (_ : u ≈̇ u') → t ×'-map u ≈̇ t ×'-map u' 176 | ×'-map-pres-≈̇-right t u≈̇u' = ×'-map-pres-≈̇ (≈̇-refl {x = t}) u≈̇u' 177 | 178 | ×'-map-pres-id : ∀ {𝒫 𝒬 : Psh} → id'[ 𝒫 ] ×'-map id'[ 𝒬 ] ≈̇ id'[ 𝒫 ×' 𝒬 ] 179 | ×'-map-pres-id {𝒫} {𝒬} = record { proof = λ _x → ≋[ 𝒫 ×' 𝒬 ]-refl } 180 | 181 | module _ (𝒫 𝒬 : Psh) where 182 | open Psh 𝒫 using () renaming (Fam to P) 183 | open Psh 𝒬 using () renaming (Fam to Q) 184 | 185 | record ⇒'-Fam (Γ : C) : Set where 186 | constructor elem 187 | field 188 | fun : {Γ' : C} → (w : Γ ⊆ Γ') → P Γ' → Q Γ' 189 | pres-≋ : ∀ {Γ' : C} → (w : Γ ⊆ Γ') {p p' : P Γ'} → (p≋p' : p ≋[ 𝒫 ] p') → fun w p ≋[ 𝒬 ] fun w p' 190 | natural : ∀ {Γ' Γ'' : C} (w : Γ ⊆ Γ') (w' : Γ' ⊆ Γ'') (p : P Γ') → wk[ 𝒬 ] w' (fun w p) ≋[ 𝒬 ] fun (⊆-trans w w') (wk[ 𝒫 ] w' p) 191 | 192 | open ⇒'-Fam using (natural) renaming (fun to apply; pres-≋ to apply-≋) public 193 | 194 | record _⇒'-≋_ {Γ : C} (f g : ⇒'-Fam Γ) : Set where 195 | constructor proof 196 | field 197 | pw : ∀ {Δ : C} (w : Γ ⊆ Δ) (p : P Δ) → f .apply w p ≋[ 𝒬 ] g .apply w p 198 | 199 | open _⇒'-≋_ using (pw) public 200 | 201 | private 202 | ⇒'-≋-equiv : ∀ (_Γ : C) → IsEquivalence (_⇒'-≋_ {_Γ}) 203 | ⇒'-≋-equiv _Γ = record 204 | { refl = proof (λ _w _p → ≋[ 𝒬 ]-refl) 205 | ; sym = λ {f} {g} f≋g → proof (λ w p → ≋[ 𝒬 ]-sym (f≋g .pw w p)) 206 | ; trans = λ {f} {g} {h} f≋g g≋h → proof (λ w p → ≋[ 𝒬 ]-trans (f≋g .pw w p) (g≋h .pw w p)) 207 | } 208 | 209 | _⇒'_ : Psh 210 | _⇒'_ = record 211 | { Fam = ⇒'-Fam 212 | ; _≋_ = _⇒'-≋_ 213 | ; wk = λ w f → elem (λ w' p → f .apply (⊆-trans w w') p) 214 | (λ w' p≋p' → f .apply-≋ (⊆-trans w w') p≋p') 215 | (λ w' w'' p → subst (λ hole → wk[ 𝒬 ] w'' (f .apply (⊆-trans w w') p) ≋[ 𝒬 ] f .apply hole (wk[ 𝒫 ] w'' p)) (≡-sym (⊆-trans-assoc w w' w'')) (f .natural (⊆-trans w w') w'' p)) 216 | ; ≋-equiv = ⇒'-≋-equiv 217 | ; wk-pres-≋ = λ w f≋g → proof (λ w' → f≋g .pw (⊆-trans w w')) 218 | ; wk-pres-refl = λ f → proof (λ w p → ≋[ 𝒬 ]-reflexive (cong (λ hole → f .apply hole p) (⊆-refl-unit-right w))) 219 | ; wk-pres-trans = λ w w' f → proof (λ w'' p → ≋[ 𝒬 ]-reflexive˘ (cong (λ hole → f .apply hole p) (⊆-trans-assoc w w' w''))) 220 | } 221 | 222 | module _ {𝒫 𝒬 : Psh} where 223 | private 224 | ⇒'-≋-apply-sq : ∀ {f g : 𝒫 ⇒' 𝒬 ₀ Γ} (_f≋g : f ≋[ 𝒫 ⇒' 𝒬 ] g) (w : Γ ⊆ Δ) {p p' : 𝒫 ₀ Δ} → (_p≋p' : p ≋[ 𝒫 ] p') → f .apply w p ≋[ 𝒬 ] g .apply w p' 225 | ⇒'-≋-apply-sq {_Γ} {_Δ} {f} {g} f≋g w {p} {p'} p≋p' = let open EqReasoning ≋[ 𝒬 ]-setoid in begin 226 | f .apply w p ≈⟨ f .apply-≋ w p≋p' ⟩ 227 | f .apply w p' ≈⟨ f≋g .pw w p' ⟩ 228 | g .apply w p' ∎ 229 | 230 | app' : (t : ℛ →̇ 𝒫 ⇒' 𝒬) → (u : ℛ →̇ 𝒫) → ℛ →̇ 𝒬 231 | app' {ℛ} t u = record 232 | { fun = λ r → t .apply r .apply ⊆-refl (u .apply r) 233 | ; pres-≋ = λ r≋r' → ⇒'-≋-apply-sq (t .apply-≋ r≋r') ⊆-refl (u .apply-≋ r≋r') 234 | ; natural = λ w r → let open EqReasoning ≋[ 𝒬 ]-setoid in begin 235 | wk[ 𝒬 ] w (t .apply r .apply ⊆-refl (u .apply r)) ≈⟨ t .apply r .natural ⊆-refl w (u .apply r) ⟩ 236 | t .apply r .apply (⊆-trans ⊆-refl w) (wk[ 𝒫 ] w (u .apply r)) ≈⟨ t .apply r .apply-≋ (⊆-trans ⊆-refl w) (u .natural w r) ⟩ 237 | t .apply r .apply (⊆-trans ⊆-refl w) (u .apply (wk[ ℛ ] w r)) ≡⟨ cong (λ hole → t .apply r .apply hole (u .apply (wk[ ℛ ] w r))) (⊆-refl-unit-right w) ⟩ 238 | t .apply r .apply w (u .apply (wk[ ℛ ] w r)) ≡˘⟨ cong (λ hole → t .apply r .apply hole (u .apply (wk[ ℛ ] w r))) (⊆-refl-unit-left w) ⟩ 239 | t .apply r .apply (⊆-trans w ⊆-refl) (u .apply (wk[ ℛ ] w r)) ≡⟨⟩ 240 | wk[ 𝒫 ⇒' 𝒬 ] w (t .apply r) .apply ⊆-refl (u .apply (wk[ ℛ ] w r)) ≈⟨ t .natural w r .pw ⊆-refl (u .apply (wk[ ℛ ] w r)) ⟩ 241 | t .apply (wk[ ℛ ] w r) .apply ⊆-refl (u .apply (wk[ ℛ ] w r)) ∎ 242 | } 243 | 244 | abstract 245 | app'-pres-≈̇ : t ≈̇ t' → u ≈̇ u' → app' t u ≈̇ app' t' u' 246 | app'-pres-≈̇ t≈̇t' u≈̇u' = record { proof = λ r → ⇒'-≋-apply-sq (t≈̇t' .apply-≋ r) ⊆-refl (u≈̇u' .apply-≋ r) } 247 | 248 | app'-pres-≈̇-left : ∀ (_ : t ≈̇ t') (u : ℛ →̇ 𝒫) → app' t u ≈̇ app' t' u 249 | app'-pres-≈̇-left t≈̇t' u = app'-pres-≈̇ t≈̇t' (≈̇-refl {x = u}) 250 | 251 | app'-pres-≈̇-right : ∀ (t : ℛ →̇ 𝒫 ⇒' 𝒬) (_ : u ≈̇ u') → app' t u ≈̇ app' t u' 252 | app'-pres-≈̇-right t u≈̇u' = app'-pres-≈̇ (≈̇-refl {x = t}) u≈̇u' 253 | 254 | app'-nat : ∀ (t : ℛ →̇ 𝒫 ⇒' 𝒬) (u : ℛ →̇ 𝒫) (s : ℛ' →̇ ℛ) → app' t u ∘ s ≈̇ app' (t ∘ s) (u ∘ s) 255 | app'-nat _t _u _s = record { proof = λ _r' → ≋[ 𝒬 ]-refl } 256 | 257 | lam' : (t : ℛ ×' 𝒫 →̇ 𝒬) → ℛ →̇ 𝒫 ⇒' 𝒬 258 | lam' {ℛ} {𝒫} {𝒬} t = record 259 | { fun = λ r → record 260 | { fun = λ w p → t .apply (elem (wk[ ℛ ] w r , p)) 261 | ; pres-≋ = λ w p≋p' → t .apply-≋ (proof (≋[ ℛ ]-refl , p≋p')) 262 | ; natural = λ w w' p → let open EqReasoning ≋[ 𝒬 ]-setoid in begin 263 | wk[ 𝒬 ] w' (t .apply (elem (wk[ ℛ ] w r , p))) ≈⟨ t .natural w' (elem (wk[ ℛ ] w r , p)) ⟩ 264 | t .apply (elem (wk[ ℛ ] w' (wk[ ℛ ] w r) , wk[ 𝒫 ] w' p)) ≈˘⟨ t .apply-≋ (proof (wk[ ℛ ]-pres-trans w w' r , ≋[ 𝒫 ]-refl)) ⟩ 265 | t .apply (elem (wk[ ℛ ] (⊆-trans w w') r , wk[ 𝒫 ] w' p)) ∎ 266 | } 267 | ; pres-≋ = λ r≋r' → proof λ w p → t .apply-≋ (proof (wk[ ℛ ]-pres-≋ w r≋r' , ≋[ 𝒫 ]-refl)) 268 | ; natural = λ w r → proof λ w' p → t .apply-≋ (proof ((wk[ ℛ ]-pres-trans w w' r) , ≋[ 𝒫 ]-refl)) 269 | } 270 | 271 | abstract 272 | lam'-pres-≈̇ : t ≈̇ t' → lam' t ≈̇ lam' t' 273 | lam'-pres-≈̇ {_𝒬} {ℛ} {𝒫} t≈̇t' = record { proof = λ r → proof (λ w p → t≈̇t' .apply-≋ (elem (wk[ ℛ ] w r , p))) } 274 | 275 | lam'-nat : ∀ (t : ℛ ×' 𝒫 →̇ 𝒬) (s : ℛ' →̇ ℛ) → lam' t ∘ s ≈̇ lam' (t ∘ s ×'-map id'[ 𝒫 ]) 276 | lam'-nat {_ℛ} {𝒫} {_𝒬} {_ℛ'} t s = record { proof = λ r' → proof (λ w p → t .apply-≋ (proof ((s .natural w r') , ≋[ 𝒫 ]-refl))) } 277 | 278 | ⇒'-beta : ∀ (t : ℛ ×' 𝒫 →̇ 𝒬) (u : ℛ →̇ 𝒫) → app' (lam' t) u ≈̇ t [ pr' id' u ]' 279 | ⇒'-beta {ℛ} {𝒫} t u = record { proof = λ r → t .apply-≋ (proof (wk[ ℛ ]-pres-refl r , ≋[ 𝒫 ]-refl)) } 280 | 281 | ⇒'-eta : ∀ (t : ℛ →̇ 𝒫 ⇒' 𝒬) → t ≈̇ lam' {𝒬 = 𝒬} (app' (t [ π₁'[ 𝒫 ] ]') π₂'[ ℛ ]) 282 | ⇒'-eta {ℛ} {𝒫} {𝒬} t = record 283 | { proof = λ r → proof (λ w p → let open EqReasoning ≋[ 𝒬 ]-setoid in begin 284 | t .apply r .apply w p ≡˘⟨ cong (λ hole → t .apply r .apply hole p) (⊆-refl-unit-left w) ⟩ 285 | t .apply r .apply (⊆-trans w ⊆-refl) p ≡⟨⟩ 286 | wk[ 𝒫 ⇒' 𝒬 ] w (t .apply r) .apply ⊆-refl p ≈⟨ t .natural w r .pw ⊆-refl p ⟩ 287 | t .apply (wk[ ℛ ] w r) .apply ⊆-refl p ∎ 288 | ) 289 | } 290 | -------------------------------------------------------------------------------- /src/Semantics/Presheaf/Evaluation/IML.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | open import Data.Product using (∃; _,_; -,_) renaming (_×_ to _∧_; proj₁ to fst; proj₂ to snd) 3 | 4 | open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst) 5 | 6 | module Semantics.Presheaf.Evaluation.IML 7 | (C : Set) 8 | (_⩽_ : (X Y : C) → Set) 9 | (⩽-trans : ∀ {X X' X'' : C} (f : X ⩽ X') (g : X' ⩽ X'') → X ⩽ X'') 10 | (⩽-trans-assoc : ∀ {X X' X'' X''' : C} (f : X ⩽ X') (g : X' ⩽ X'') (h : X'' ⩽ X''') → ⩽-trans f (⩽-trans g h) ≡ ⩽-trans (⩽-trans f g) h) 11 | (⩽-refl : ∀ {X : C} → X ⩽ X) 12 | (⩽-refl-unit-left : ∀ {X X' : C} (f : X ⩽ X') → ⩽-trans ⩽-refl f ≡ f) 13 | (⩽-refl-unit-right : ∀ {X X' : C} (f : X ⩽ X') → ⩽-trans f ⩽-refl ≡ f) 14 | (_R_ : (X Y : C) → Set) 15 | (factor : ∀ {X Y Y' : C} → (r : X R Y) → (w : Y ⩽ Y') → ∃ λ X' → X ⩽ X' ∧ X' R Y') 16 | (let lCtx : {Γ Δ Δ' : C} → (r : Γ R Δ) → (w : Δ ⩽ Δ') → C ; lCtx = λ r w → factor r w .fst) 17 | (let factorWk : ∀ {Γ Δ Δ' : C} (r : Γ R Δ) (w : Δ ⩽ Δ') → Γ ⩽ _ ; factorWk = λ r w → factor r w .snd .fst) 18 | (let factorR : ∀ {Γ Δ Δ' : C} (r : Γ R Δ) (w : Δ ⩽ Δ') → _ R Δ' ; factorR = λ r w → factor r w .snd .snd) 19 | (factor-pres-id : ∀ {X Y : C} (r : X R Y) → factor r ⩽-refl ≡ (-, ⩽-refl , r)) 20 | (factor-pres-∘ : ∀ {X Y Y' Y'' : C} (r : X R Y) (w : Y ⩽ Y') (w' : Y' ⩽ Y'') → factor r (⩽-trans w w') ≡ (-, ⩽-trans (factorWk r w) (factorWk (factorR r w) w') , factorR (factorR r w) w')) 21 | where 22 | 23 | open import Level using (0ℓ) 24 | 25 | open import Relation.Binary using (Reflexive; Symmetric; Transitive; IsEquivalence; Setoid) 26 | 27 | import Relation.Binary.Reasoning.Setoid as EqReasoning 28 | 29 | open import Type 30 | 31 | open import Context (Ty) 32 | 33 | import Semantics.Presheaf.Base 34 | C _⩽_ ⩽-refl ⩽-trans 35 | as PresheafBase 36 | import Semantics.Presheaf.CartesianClosure 37 | C _⩽_ ⩽-trans ⩽-trans-assoc ⩽-refl ⩽-refl-unit-right ⩽-refl-unit-left 38 | as PresheafCartesianClosure 39 | import Semantics.Presheaf.Necessity 40 | C _⩽_ ⩽-trans ⩽-trans-assoc ⩽-refl ⩽-refl-unit-right ⩽-refl-unit-left _R_ factor factor-pres-id factor-pres-∘ 41 | as PresheafNecessity 42 | 43 | open PresheafBase public 44 | open PresheafCartesianClosure public 45 | open PresheafNecessity public 46 | 47 | import Semantics.Clouston.Evaluation.IML 48 | Psh _→̇_ _≈̇_ ≈̇-refl ≈̇-sym ≈̇-trans _∘_ ∘-pres-≈̇ ∘-assoc id'[_] id'-unit-left id'-unit-right 49 | []' unit' []'-eta _×'_ ⟨_,_⟩' ⟨,⟩'-pres-≈̇ π₁'[_] π₂'[_] ×'-beta-left ×'-beta-right ×'-eta ⟨,⟩'-nat 50 | _⇒'_ lam' lam'-pres-≈̇ app' app'-pres-≈̇ ⇒'-beta ⇒'-eta lam'-nat app'-nat 51 | ✦'_ ✦'-map_ ✦'-map-pres-≈̇ ✦'-map-pres-id' ✦'-map-pres-∘ 52 | □'_ □'-map_ box' box'-pres-≈̇ λ' λ'-pres-≈̇ □'-beta □'-eta box'-nat-dom λ'-nat-dom 53 | as CloustonEvaluationIML 54 | 55 | module Eval (N : Psh) where 56 | module CloustonEvaluationIMLEval = CloustonEvaluationIML.Eval N 57 | 58 | open CloustonEvaluationIMLEval public 59 | -------------------------------------------------------------------------------- /src/Semantics/Presheaf/Evaluation/IS4.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | open import Data.Product using (∃; _,_; -,_) renaming (_×_ to _∧_; proj₁ to fst; proj₂ to snd) 3 | 4 | open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst) 5 | 6 | module Semantics.Presheaf.Evaluation.IS4 7 | (C : Set) 8 | 9 | (_⩽_ : (X Y : C) → Set) 10 | 11 | (⩽-trans : ∀ {X X' X'' : C} (f : X ⩽ X') (g : X' ⩽ X'') → X ⩽ X'') 12 | (⩽-trans-assoc : ∀ {X X' X'' X''' : C} (f : X ⩽ X') (g : X' ⩽ X'') (h : X'' ⩽ X''') → ⩽-trans f (⩽-trans g h) ≡ ⩽-trans (⩽-trans f g) h) 13 | 14 | (⩽-refl : ∀ {X : C} → X ⩽ X) 15 | (⩽-refl-unit-left : ∀ {X X' : C} (f : X ⩽ X') → ⩽-trans f ⩽-refl ≡ f) 16 | (⩽-refl-unit-right : ∀ {X X' : C} (f : X ⩽ X') → ⩽-trans ⩽-refl f ≡ f) 17 | 18 | (_R_ : (X Y : C) → Set) 19 | 20 | (R-trans : ∀ {X Y Z : C} (r : X R Y) (r' : Y R Z) → X R Z) 21 | (R-trans-assoc : ∀ {X Y Z Z' : C} (r : X R Y) (r' : Y R Z) (r'' : Z R Z') → R-trans r (R-trans r' r'') ≡ R-trans (R-trans r r') r'') 22 | 23 | (R-refl : ∀ {X : C} → X R X) 24 | (R-refl-unit-left : ∀ {X Y : C} (r : X R Y) → R-trans r R-refl ≡ r) 25 | (R-refl-unit-right : ∀ {X Y : C} (r : X R Y) → R-trans R-refl r ≡ r) 26 | 27 | (factor : ∀ {X Y Y' : C} (r : X R Y) (w : Y ⩽ Y') → ∃ λ X' → X ⩽ X' ∧ X' R Y') 28 | (let lCtx : ∀ {X Y Y' : C} (r : X R Y) (w : Y ⩽ Y') → C ; lCtx = λ r w → factor r w .fst) 29 | (let factorWk : ∀ {X Y Y' : C} (r : X R Y) (w : Y ⩽ Y') → X ⩽ _ ; factorWk = λ r w → factor r w .snd .fst) 30 | (let factorR : ∀ {X Y Y' : C} (r : X R Y) (w : Y ⩽ Y') → _ R Y' ; factorR = λ r w → factor r w .snd .snd) 31 | (factor-pres-id : ∀ {X Y : C} (r : X R Y) → factor r ⩽-refl ≡ (-, ⩽-refl , r)) 32 | (factor-pres-∘ : ∀ {X Y Y' Y'' : C} (r : X R Y) (w : Y ⩽ Y') (w' : Y' ⩽ Y'') → factor r (⩽-trans w w') ≡ (-, ⩽-trans (factorWk r w) (factorWk (factorR r w) w') , factorR (factorR r w) w')) 33 | (factor-pres-refl : ∀ {X X' : C} (w : X ⩽ X') → factor R-refl w ≡ (X' , w , R-refl)) 34 | (factor-pres-trans : ∀ {X Y Z Z' : C} (r : X R Y) (r' : Y R Z) (w : Z ⩽ Z') → factor (R-trans r r') w ≡ (lCtx r (factorWk r' w) , factorWk r _ , R-trans (factorR r _) (factorR r' _))) 35 | where 36 | 37 | import Semantics.Presheaf.Base C _⩽_ ⩽-refl ⩽-trans as PresheafBase 38 | import Semantics.Presheaf.CartesianClosure C _⩽_ ⩽-trans ⩽-trans-assoc ⩽-refl ⩽-refl-unit-left ⩽-refl-unit-right as PresheafCartesianClosure 39 | import Semantics.Presheaf.Necessity C _⩽_ ⩽-trans ⩽-trans-assoc ⩽-refl ⩽-refl-unit-left ⩽-refl-unit-right _R_ factor factor-pres-id factor-pres-∘ as PresheafNecessity 40 | 41 | module PresheafNecessityIS4 = PresheafNecessity.IS4 R-trans R-trans-assoc R-refl R-refl-unit-left R-refl-unit-right factor-pres-refl factor-pres-trans 42 | 43 | open PresheafBase public 44 | open PresheafCartesianClosure public 45 | open PresheafNecessity public 46 | open PresheafNecessityIS4 public 47 | 48 | import Semantics.Clouston.Evaluation.IS4.Base 49 | Psh _→̇_ _≈̇_ ≈̇-refl ≈̇-sym ≈̇-trans _∘_ id'[_] 50 | []' unit' _×'_ ⟨_,_⟩' π₁'[_] π₂'[_] 51 | _⇒'_ lam' app' 52 | ✦'_ ✦'-map_ μ'[_] η'[_] 53 | □'_ box' λ' 54 | as CloustonEvaluationIS4Base 55 | 56 | open CloustonEvaluationIS4Base public using (module Eval) 57 | 58 | module EvalProperties (N : Psh) where 59 | import Semantics.Clouston.Evaluation.IS4.Properties 60 | Psh _→̇_ _≈̇_ ≈̇-refl ≈̇-sym ≈̇-trans _∘_ ∘-pres-≈̇ ∘-assoc id'[_] id'-unit-left id'-unit-right 61 | []' unit' []'-eta _×'_ ⟨_,_⟩' ⟨,⟩'-pres-≈̇ π₁'[_] π₂'[_] ×'-beta-left ×'-beta-right ×'-eta ⟨,⟩'-nat 62 | _⇒'_ lam' lam'-pres-≈̇ app' app'-pres-≈̇ ⇒'-beta ⇒'-eta lam'-nat app'-nat 63 | ✦'_ ✦'-map_ ✦'-map-pres-≈̇ ✦'-map-pres-id' ✦'-map-pres-∘ μ'[_] μ'-nat μ'-assoc[_] η'[_] η'-nat η'-unit-left[_] η'-unit-right[_] 64 | □'_ □'-map_ box' box'-pres-≈̇ λ' λ'-pres-≈̇ □'-beta □'-eta box'-nat-dom λ'-nat-dom 65 | N 66 | as CloustonEvaluationIS4Properties 67 | 68 | open CloustonEvaluationIS4Properties public 69 | -------------------------------------------------------------------------------- /src/Type.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module Type where 3 | 4 | open import Type.Base public 5 | open import Type.Properties public 6 | -------------------------------------------------------------------------------- /src/Type/Base.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module Type.Base where 3 | 4 | infixr 7 _⇒_ 5 | 6 | data Ty : Set where 7 | ι : Ty 8 | _⇒_ : (a : Ty) → (b : Ty) → Ty 9 | □_ : (a : Ty) → Ty 10 | 11 | variable 12 | a b c d : Ty 13 | -------------------------------------------------------------------------------- /src/Type/Properties.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --safe --without-K #-} 2 | module Type.Properties where 3 | 4 | open import Relation.Nullary using (_because_; yes; no) 5 | 6 | open import Relation.Binary.Definitions using (Decidable) 7 | open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; cong ; cong₂) 8 | 9 | open import Type.Base 10 | 11 | Ty-Decidable : Decidable (_≡_ {A = Ty}) 12 | Ty-Decidable ι ι = yes refl 13 | Ty-Decidable ι (a ⇒ b) = no λ () 14 | Ty-Decidable ι (□ a) = no λ () 15 | Ty-Decidable (a ⇒ b) ι = no λ () 16 | Ty-Decidable (a ⇒ b) (c ⇒ d) with Ty-Decidable a c | Ty-Decidable b d 17 | ... | yes a≡c | yes b≡d = yes (cong₂ _⇒_ a≡c b≡d) 18 | ... | yes a≡c | no ¬b≡d = no λ { refl → ¬b≡d refl } 19 | ... | no ¬a≡c | yes b≡d = no λ { refl → ¬a≡c refl } 20 | ... | no ¬a≡c | no ¬b≡d = no λ { refl → ¬a≡c refl } 21 | Ty-Decidable (a ⇒ b) (□ c) = no λ () 22 | Ty-Decidable (□ a) ι = no λ () 23 | Ty-Decidable (□ a) (b ⇒ c) = no λ () 24 | Ty-Decidable (□ a) (□ b) with Ty-Decidable a b 25 | ... | yes a≡b = yes (cong □_ a≡b) 26 | ... | no ¬a≡b = no λ { refl → ¬a≡b refl } 27 | --------------------------------------------------------------------------------