This commit is contained in:
Frederik Hanghøj Iversen 2018-03-06 11:25:29 +01:00
parent 485703c85e
commit 4d528a7077

View file

@ -488,45 +488,47 @@ module _ {a b : Level} { : Category a b} where
fortheq m = K.Monad≡ (forthRawEq m) fortheq m = K.Monad≡ (forthRawEq m)
module _ (m : M.Monad) where module _ (m : M.Monad) where
open M.RawMonad (M.Monad.raw m) open M.RawMonad (M.Monad.raw m) using (R ; Romap ; Rfmap ; pureNT ; joinNT)
rawEq* : Functor.func* (K.Monad.R (forth m)) Functor.func* R
rawEq* = refl
left = Functor.raw (K.Monad.R (forth m))
right = Functor.raw R
P : (omap : Omap )
(eq : RawFunctor.func* left omap)
(fmap' : Fmap omap)
Set _
P _ eq fmap' = (λ i Fmap (eq i))
[ RawFunctor.func→ left fmap' ]
module KM = K.Monad (forth m) module KM = K.Monad (forth m)
rawEq→ : (λ i Fmap (refl i)) [ Functor.func→ (K.Monad.R (forth m)) Functor.func→ R ] omapEq : KM.omap Romap
-- aka: omapEq = refl
D : (omap : Omap ) Romap omap Set _
D omap eq = (fmap' : Fmap omap)
(λ i Fmap (eq i))
[ (λ f KM.fmap f) fmap' ]
-- The "base-case" for path induction on the family `D`.
d : D Romap λ _ Romap
d = res
where
-- aka:
res
: (fmap : Fmap Romap)
(λ _ Fmap Romap) [ KM.fmap fmap ]
res fmap = begin
(λ f KM.fmap f) ≡⟨⟩
(λ f KM.bind (f >>> KM.pure)) ≡⟨ {!!}
(λ f fmap f)
-- This is sort of equivalent to `d` though the the order of
-- quantification is different. `KM.fmap` is defined in terms of `Rfmap`
-- (via `forth`) whereas in `d` above `fmap` is universally quantified.
-- --
-- rawEq→ : P (RawFunctor.func* right) refl (RawFunctor.func→ right) -- I'm not sure `d` is provable. I believe `d'` should be, but I can also
rawEq→ = begin -- not prove it.
(λ f RawFunctor.func→ left f) ≡⟨⟩ d' : (λ i Fmap Romap) [ KM.fmap Rfmap ]
d' = begin
(λ f KM.fmap f) ≡⟨⟩ (λ f KM.fmap f) ≡⟨⟩
(λ f KM.bind (f >>> KM.pure)) ≡⟨ {!!} (λ f KM.bind (f >>> KM.pure)) ≡⟨ {!!}
(λ f Rfmap f) ≡⟨⟩ (λ f Rfmap f)
(λ f RawFunctor.func→ right f)
-- This goal is more general than the above goal which I also don't know fmapEq : (λ i Fmap (omapEq i)) [ KM.fmap Rfmap ]
-- how to close. fmapEq = pathJ D d Romap refl Rfmap
p : (fmap' : Fmap (RawFunctor.func* left))
(λ i Fmap Romap) [ RawFunctor.func→ left fmap' ]
-- aka:
--
-- p : P (RawFunctor.func* left) refl
p fmap' = begin
(λ f RawFunctor.func→ left f) ≡⟨⟩
(λ f KM.fmap f) ≡⟨⟩
(λ f KM.bind (f >>> KM.pure)) ≡⟨ {!!}
(λ f fmap' f)
rawEq : Functor.raw (K.Monad.R (forth m)) Functor.raw R rawEq : Functor.raw KM.R Functor.raw R
rawEq = RawFunctor≡ {x = left} {right} (λ _ Romap) p RawFunctor.func* (rawEq i) = omapEq i
RawFunctor.func→ (rawEq i) = fmapEq i
Req : M.RawMonad.R (backRaw (forth m)) R Req : M.RawMonad.R (backRaw (forth m)) R
Req = Functor≡ rawEq Req = Functor≡ rawEq