diff --git a/formalizations/guarded-cubical/ErrorDomains.agda b/formalizations/guarded-cubical/ErrorDomains.agda index 92e8d882ed11eaecdf7d0a839f7984fd4524aaa7..a02826aaa3923887dea0239b0804d122eb28b7eb 100644 --- a/formalizations/guarded-cubical/ErrorDomains.agda +++ b/formalizations/guarded-cubical/ErrorDomains.agda @@ -228,6 +228,136 @@ monad-assoc = fix lem + + + +-- Dyn as a predomain +data Dyn' (D : â–¹ Type) : Type where + nat : â„• -> Dyn' D + arr : (â–¸ D -> L℧ (â–¸ D)) -> Dyn' D + +Dyn : Type +Dyn = fix Dyn' + +-- Embedding-projection pairs +record EP (A B : Set) : Set where + field + emb : A -> B + proj : B -> L℧ A + retract : + proj ∘ emb ≡ ret + + +-- E-P Pair for nat + +e-nat : â„• -> Dyn +e-nat n = transport (sym (fix-eq Dyn')) (nat n) + +p-nat' : Dyn' (next Dyn) -> L℧ â„• +p-nat' (nat n) = ret n +p-nat' (arr f) = ℧ + +p-nat : Dyn -> L℧ â„• +p-nat d = p-nat' (transport (fix-eq Dyn') d) + +retraction-nat : (n : â„•) -> p-nat (e-nat n) ≡ ret n +retraction-nat n = + λ i → p-nat' + (transportâ»Transport (sym (fix-eq Dyn')) (nat n) i) + +EP-nat : EP â„• Dyn +EP-nat = record { + emb = e-nat; + proj = p-nat; + retract = funExt retraction-nat } + +-- E-P Pair for function types + +e-fun : (Dyn -> L℧ Dyn) -> Dyn +e-fun f = transport + (sym (fix-eq Dyn')) + (arr λ (x : â–¹ Dyn) → + θ (λ t -> mapL next (f (x t)))) + +apply : Tick k -> â–¹ Dyn -> Dyn +apply t l_dyn = l_dyn t + +p-fun' : Dyn' (next Dyn) -> L℧ (Dyn -> L℧ Dyn) +p-fun' (nat n) = ℧ +p-fun' (arr f) = ret λ d -> + θ (λ t → + mapL (apply t) (f (next d)) + -- doesn't work: + -- mapL (\ (l_dyn : â–¹ Dyn) -> l_dyn t) (f (next d)) + ) + +-- f : â–¸ next Dyn → L℧ (â–¸ next Dyn) +-- which is equal to +-- â–¹ Dyn -> L℧ (â–¹ Dyn) + + +p-fun : Dyn -> L℧ (Dyn -> L℧ Dyn) +p-fun d = p-fun' (transport (fix-eq Dyn') d) + + +theta-lem : (t : Tick k) (la : L℧ A) -> + θ (λ t -> la) ≡ θ (next la) +theta-lem t la = refl + + +retraction-fun : (h : Dyn -> L℧ Dyn) -> + p-fun (e-fun h) ≡ {!!} +retraction-fun h = {!!} + + +EP-fun : EP (Dyn -> L℧ Dyn) Dyn +EP-fun = record { + emb = e-fun; + proj = p-fun; + retract = {!!} } + + +-- Lifting retractions to functions + +module LiftRetraction + (A A' B B' : Set) + (epAA' : EP A A') + (epBB' : EP B B') where + + e-lift : + (A → L℧ B) → (A' → L℧ B') + e-lift h a' = + bind (EP.proj {!!} a') λ a -> mapL (EP.emb {!!}) (h a) + -- or equivalently: + -- mapL (EP.emb epBB') (bind (EP.proj epAA' a') h) + + p-lift : + (A' -> L℧ B') -> L℧ (A -> L℧ B) + p-lift f = + ret (λ a → bind (f (EP.emb epAA' a)) (EP.proj epBB')) + + + + + +{- +L℧ : Predomain → ErrorDomain +L℧ X = record { X = L℧X ; ℧ = ℧ ; ℧⊥ = {!!} ; θ = record { f = θ₀ ; isMon = {!!} } } + where + L℧X : Predomain + L℧X = L℧₀ (X .fst) , {!!} +-} + + -- Plan: + -- 1. Define denotational semantics for gradual STLC and show soundness of term precision + -- 1a. Define interpretation of terms of gradual CBV cast calculus (STLC + casts) + -- i) Semantic domains + -- ii) Term syntax (intrinsically typed, de Bruijn) + -- iii) Denotation function + -- 1b. Soundness of term precision with equational theory only (no ordering) + + -- The language supports Dyn, CBV functions, nat + -- | TODO: -- | 1. monotone monad structure -- | 2. strict functions