Does a Powerset-over-Reader monad exist?

▼魔方 西西 提交于 2019-12-05 03:39:55

Fun question. Here is my take -- let's see if I didn't goof anywhere!

To begin with, I will spell your signatures in (slightly less pseudo) Haskell:

return :: a -> PSet (r -> a)
(>>=) :: PSet (r -> a) -> (a -> PSet (r -> b)) -> PSet (r -> b))

Before continuing, it is worth mentioning two practical complications. Firstly, as you have already observed, thanks to Eq and/or Ord constraints it is non-trivial to give sets Functor or Monad instances; in any case, there are ways around it. Secondly, and more worryingly, with the type you propose for (>>=) it is necessary to extract as from PSet (r -> a) without having any obvious supply of rs -- or, in other words, your (>>=) demands a traversal of the function functor (->) r. That, of course, is not possible in the general case, and tends to be impractical even when possible -- at least as far as Haskell is concerned. In any case, for our speculative purposes it is fine to suppose we can traverse (->) r by applying the function to all possible r values. I will indicate this through a hand-wavy universe :: PSet r set, named in tribute to this package. I will also make use of an universe :: PSet (r -> b), and assume we can tell whether two r -> b functions agree on a certain r even without requiring an Eq constraint. (The pseudo-Haskell is getting quite fake indeed!)

Preliminary remarks made, here are my pseudo-Haskell versions of your methods:

return :: a -> PSet (r -> a)
return x = singleton (const x)

(>>=) :: PSet (r -> a) -> (a -> PSet (r -> b)) -> PSet (r -> b))
m >>= f = unionMap (\x ->
    intersectionMap (\r ->
        filter (\rb -> 
            any (\rb' -> rb' r == rb r) (f (x r)))
            (universe :: PSet (r -> b)))
        (universe :: PSet r)) m
    where
    unionMap f = unions . map f
    intersectionMap f = intersections . map f

Next, the monad laws:

m >>= return = m
return y >>= f = f y
m >>= f >>= g = m >>= \y -> f y >>= g

(By the way, when doing this sort of thing it is good to keep in mind the other presentations of the class we are working with -- in this case, we have join and (>=>) as alternatives to (>>=) -- as switching presentations might make working with your instance of choice more pleasant. Here I will stick with the (>>=) presentation of Monad.)

Onwards to the first law...

m >>= return = m
m >>= return -- LHS
unionMap (\x ->
    intersectionMap (\r ->
        filter (\rb -> 
            any (\rb' -> rb' r == rb r) (singleton (const (x r))))
            (universe :: PSet (r -> b)))
        (universe :: PSet r)) m
unionMap (\x ->
    intersectionMap (\r ->
        filter (\rb -> 
            const (x r) r == rb r)
            (universe :: PSet (r -> b)))
        (universe :: PSet r)) m
unionMap (\x ->
    intersectionMap (\r ->
        filter (\rb -> 
            x r == rb r)
            (universe :: PSet (r -> b)))
        (universe :: PSet r)) m
-- In other words, rb has to agree with x for all r. 
unionMap (\x -> singleton x) m
m -- RHS

One down, two to go.

return y >>= f = f y
return y -- LHS
unionMap (\x ->
    intersectionMap (\r ->
        filter (\rb -> 
            any (\rb' -> rb' r == rb r) (f (x r)))
            (universe :: PSet (r -> b)))
        (universe :: PSet r)) (singleton (const y))
(\x ->
    intersectionMap (\r ->
        filter (\rb -> 
            any (\rb' -> rb' r == rb r) (f (x r)))
            (universe :: PSet (r -> b)))
        (universe :: PSet r)) (const y)
intersectionMap (\r ->
    filter (\rb -> 
        any (\rb' -> rb' r == rb r) (f (const y r)))
        (universe :: PSet (r -> b)))
    (universe :: PSet r)
intersectionMap (\r ->
    filter (\rb -> 
        any (\rb' -> rb' r == rb r) (f y)))
        (universe :: PSet (r -> b)))
    (universe :: PSet r)
-- This set includes all functions that agree with at least one function
-- from (f y) at each r.

return y >>= f, therefore, might possibly be a much larger set than f y. We have a violation of the second law; therefore, we don't have a monad -- at least not with the instance proposed here.


Appendix: here is an actual, runnable implementation of your functions, which is usable enough at least for playing with small types. It takes advantage of the aforementioned universe package.

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
module FunSet where

import Data.Universe
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import Data.Int
import Data.Bool

-- FunSet and its would-be monad instance

newtype FunSet r a = FunSet { runFunSet :: Set (Fun r a) }
    deriving (Eq, Ord, Show)

fsreturn :: (Finite a, Finite r, Ord r) => a -> FunSet r a
fsreturn x = FunSet (S.singleton (toFun (const x)))

-- Perhaps we should think of a better name for this...
fsbind :: forall r a b.
    (Ord r, Finite r, Ord a, Ord b, Finite b, Eq b)
    => FunSet r a -> (a -> FunSet r b) -> FunSet r b
fsbind (FunSet s) f = FunSet $
    unionMap (\x ->
        intersectionMap (\r ->
            S.filter (\rb ->
                any (\rb' -> funApply rb' r == funApply rb r)
                    ((runFunSet . f) (funApply x r)))
                (universeF' :: Set (Fun r b)))
            (universeF' :: Set r)) s

toFunSet :: (Finite r, Finite a, Ord r, Ord a) => [r -> a] -> FunSet r a
toFunSet = FunSet . S.fromList . fmap toFun

-- Materialised functions

newtype Fun r a = Fun { unFun :: Map r a }
    deriving (Eq, Ord, Show, Functor)

instance (Finite r, Ord r, Universe a) => Universe (Fun r a) where
    universe = fmap (Fun . (\f ->
        foldr (\x m ->
            M.insert x (f x) m) M.empty universe))
        universe

instance (Finite r, Ord r, Finite a) => Finite (Fun r a) where
    universeF = universe

funApply :: Ord r => Fun r a -> r -> a
funApply f r = maybe
    (error "funApply: Partial functions are not fun")
    id (M.lookup r (unFun f))

toFun :: (Finite r, Finite a, Ord r) => (r -> a) -> Fun r a
toFun f = Fun (M.fromList (fmap ((,) <$> id <*> f) universeF))

-- Set utilities

unionMap :: (Ord a, Ord b) => (a -> Set b) -> (Set a -> Set b)
unionMap f = S.foldl S.union S.empty . S.map f

-- Note that this is partial. Since for our immediate purposes the only
-- consequence is that r in FunSet r a cannot be Void, I didn't bother
-- with making it cleaner.
intersectionMap :: (Ord a, Ord b) => (a -> Set b) -> (Set a -> Set b)
intersectionMap f s = case ss of
    [] -> error "intersectionMap: Intersection of empty set of sets"
    _ -> foldl1 S.intersection ss
    where
    ss = S.toList (S.map f s)

universeF' :: (Finite a, Ord a) => Set a
universeF' = S.fromList universeF

-- Demo

main :: IO ()
main = do
    let andor = toFunSet [uncurry (&&), uncurry (||)]
    print andor -- Two truth tables
    print $ funApply (toFun (2+)) (3 :: Int8) -- 5
    print $ (S.map (flip funApply (7 :: Int8)) . runFunSet)
        (fsreturn (Just True)) -- fromList [Just True]
    -- First monad law demo
    print $ fsbind andor fsreturn == andor -- True
    -- Second monad law demo
    let twoToFour = [ bool (Left False) (Left True)
                    , bool (Left False) (Right False)]
        decider b = toFunSet
            (fmap (. bool (uncurry (&&)) (uncurry (||)) b) twoToFour)
    print $ fsbind (fsreturn True) decider == decider True -- False (!)

It is somewhat easier to verify the laws in Kleisli notation.

kleisli' :: (a -> {r -> b}) -> (b -> {r -> c}) -> (a -> {r -> c})
g `kleisli'` f = \z -> {rb | x <- g z, ∀r: ∃rb' ∈ f (x r): rb r == rb' r}

Let's try to verify return `kleisli'` f = f.

(\a -> {\r->a}) `kleisli'` f = 
\z -> {rb | x <- {\r->z}, ∀r: ∃rb' ∈ f (x r): rb r == rb' r} = 
\z -> {rb | ∀r: ∃rb' ∈ f z: rb r == rb' r}

Say all of our types a, b, c and r are Integer and f x = {const x, const -x}. What functions are in (return `kleisli'` f) 5? This set should be f 5, that is, {const 5, const -5}.

Is it? Naturally const 5 and const -5 are both in, but not only. For example, \r->if even r then 5 else -5 is also in.

易学教程内所有资源均来自网络或用户发布的内容,如有违反法律规定的内容欢迎反馈
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!