在`Set`（以及其他有約束的容器）上構造高效monad實例使用continuation monad

Question

Set，與[]類似，具有完美定義的monadic操作。問題在於它們要求值滿足Ord約束條件，因此不可能在沒有任何約束的情況下定義return和>>=。同樣的問題也適用於需要對可能值進行某種約束的其他數據結構。

標準把戲（在haskell-cafe post中向我推薦）是將Set換成繼續monad。 ContT並不關心底層類型仿函數是否有任何約束。成爲唯一所需的限制包裝時/從延續展開Set s轉換/：

import Control.Monad.Cont 
import Data.Foldable (foldrM) 
import Data.Set 

setReturn :: a -> Set a 
setReturn = singleton 

setBind :: (Ord b) => Set a -> (a -> Set b) -> Set b 
setBind set f = foldl' (\s -> union s . f) empty set 

type SetM r a = ContT r Set a 

fromSet :: (Ord r) => Set a -> SetM r a 
fromSet = ContT . setBind 

toSet :: SetM r r -> Set r 
toSet c = runContT c setReturn 

需要這個工作。例如，我們可以模擬非確定性的函數，要麼增加1，它的參數或離開它的完整：

step :: (Ord r) => Int -> SetM r Int 
step i = fromSet $ fromList [i, i + 1] 

-- repeated application of step: 
stepN :: Int -> Int -> Set Int 
stepN times start = toSet $ foldrM ($) start (replicate times step) 

事實上，stepN 5 0產生fromList [0,1,2,3,4,5]。如果我們用[] monad代替，我們會得到

[0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4,1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5] 

改爲。

---

問題是效率。如果我們撥打stepN 20 0，則輸出需要幾秒鐘，並且stepN 30 0未在合理的時間內完成。事實證明，所有的Set.union操作都是在最後執行的，而不是在每次單計算之後執行它們。其結果是僅僅在最後才構造了許多指數級的Set，並且union僅僅是在大多數任務中不可接受的。

有沒有辦法繞過它，使這種建築效率？我試過但沒有成功。

（我甚至懷疑，有可能是某些類型的從咖喱霍華德同構和Glivenko's theorem以下的理論極限。Glivenko定理說，任何命題同義反復φ公式¬¬φ可以在直覺邏輯證明然而，我懷疑證據的長度（以正常形式）可以成倍長。所以，也許，有可能包裝計算入延續單子時，會使其成倍不再是個案？）

Answer 1

單子結構和排序計算的一個特定的方式。單子的綁定不能神奇地重構你的計算，以便以更有效的方式發生。計算結構的方式有兩個問題。

1. 當評估stepN 20 0，的step 0結果將被計算的20倍。這是因爲計算的每一步產生0作爲一個替代方案，然後將其饋送到下一步，這也產生0作爲替代方案，等等......

   也許這裏有一些記憶可以幫助。

2. 一個更大的問題是ContT對計算結構的影響。帶着幾分等式推理，拓展出結果的replicate 20 step的foldrM的定義和簡化多次有必要，我們可以看到，stepN 20 0等同於：

   (...(return 0 >>= step) >>= step) >>= step) >>= ...) 
   

   這種表達關聯的所有括號到剩下。這很好，因爲這意味着(>>=)每次出現的RHS是一個基本計算，即step，而不是一個合成的。然而，拉近的(>>=)定義爲ContT，

   m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c) 
   

   我們看到，評估(>>=)關聯向左鏈時，每個綁定將推動新的計算到當前的延續c。爲了說明到底是怎麼回事，我們可以再次使用了一下等式推理，擴大了這個定義(>>=)和定義runContT，並簡化，得到以下特性：

   setReturn 0 `setBind` 
       (\x1 -> step x1 `setBind` 
        (\x2 -> step x2 `setBind` (\x3 -> ...)...) 
   

   現在，爲setBind每次出現，讓我們問自己什麼是RHS的觀點。對於最左邊的事件，RHS參數是setReturn 0之後的整個計算的其餘部分。對於第二次出現，這是step x1後一切，等我們放大到setBind定義：

   setBind set f = foldl' (\s -> union s . f) empty set 
   

   這裏f代表計算的所有其餘部分，上的出現的右邊的一切setBind。這意味着在每個步驟中，我們都將其餘計算捕獲爲f，並且應用f的次數與set中的元素一樣多。這些計算不像以前那樣是基本的，而是組成的，並且這些計算將被重複許多次。

問題的關鍵在於ContT單子變壓器變換的計算，你意味着作爲的setBind的一個左結合鏈的初始結構，成計算與不同的結構，即一個正確的聯想鏈。畢竟這是完全正常的，因爲單子法律人說，對於每一個m，f和g我們

(m >>= f) >>= g = m >>= (\x -> f x >>= g) 

然而，單子法律並沒有強加的複雜性保持在每一側的相同每個法則的方程。事實上，在這種情況下，構造這種計算的左邊聯想方式更有效率。 setBind的左邊關聯鏈很快就會評估，因爲只有基本子計算被複制。

事實證明，將其他解決方案鎖在一個monad中也遭受同樣的問題。特別是，set-monad包產生類似的運行時間。原因是，它也將左聯想表達式重寫爲正確的聯想表達式。

我想你已經把手指放在一個非常重要而又相當微妙的問題與堅持Set服從Monad接口。我不認爲這是可以解決的。的問題是，一個單子的綁定的類型需要是

(>>=) :: m a -> (a -> m b) -> m b 

即允許在任a或b沒有類約束。這意味着我們不能在左邊嵌套綁定，沒有先調用單子法來重寫成正確的關聯鏈。原因如下：給定(m >>= f) >>= g，計算的類型(m >>= f)的形式爲m b。計算值(m >>= f)的類型爲b。但是因爲我們不能將任何類約束掛到類型變量b上，所以我們不能知道我們得到的值滿足Ord約束，因此不能使用這個值作爲我們想要的集合中的元素計算union's。

Answer 2

我不在這種情況下，你認爲你的性能問題是由於使用了Cont

step' :: Int -> Set Int 
step' i = fromList [i,i + 1] 

foldrM' f z0 xs = Prelude.foldl f' setReturn xs z0 
    where f' k x z = f x z `setBind` k 

stepN' :: Int -> Int -> Set Int 
stepN' times start = foldrM' ($) start (replicate times step') 

得到類似的性能的Cont基於實現，但完全是我不知道如果我相信你對Glivenko定理導致指數增加（標準化）證明大小要求發生在Set「限制單子」

- 至少在「按需呼叫」環境中。這是因爲我們可以任意重複使用子證書（而我們的邏輯是二階的，我們只需要一個證明forall a. ~~(a \/ ~a)）。證明不是樹，而是圖（共享）。

一般情況下，你可能會看到性能的成本從Cont包裝Set，但他們通常可以通過避免

smash :: (Ord r, Ord k) => SetM r r -> SetM k r 
smash = fromSet . toSet 

Answer 3

最近關於Haskell Cafe Oleg gave an example如何有效地實現Set monad。引用：

...然而，高效的正版套裝單子是可能的。

... 封閉的是高效的真正的集monad。我以直接的方式編寫它（無論如何，它似乎更快）。關鍵是我們可以使用優化的選擇功能。

{-# LANGUAGE GADTs, TypeSynonymInstances, FlexibleInstances #-} 

    module SetMonadOpt where 

    import qualified Data.Set as S 
    import Control.Monad 

    data SetMonad a where 
     SMOrd :: Ord a => S.Set a -> SetMonad a 
     SMAny :: [a] -> SetMonad a 

    instance Monad SetMonad where 
     return x = SMAny [x] 

     m >>= f = collect . map f $ toList m 

    toList :: SetMonad a -> [a] 
    toList (SMOrd x) = S.toList x 
    toList (SMAny x) = x 

    collect :: [SetMonad a] -> SetMonad a 
    collect [] = SMAny [] 
    collect [x] = x 
    collect ((SMOrd x):t) = case collect t of 
          SMOrd y -> SMOrd (S.union x y) 
          SMAny y -> SMOrd (S.union x (S.fromList y)) 
    collect ((SMAny x):t) = case collect t of 
          SMOrd y -> SMOrd (S.union y (S.fromList x)) 
          SMAny y -> SMAny (x ++ y) 

    runSet :: Ord a => SetMonad a -> S.Set a 
    runSet (SMOrd x) = x 
    runSet (SMAny x) = S.fromList x 

    instance MonadPlus SetMonad where 
     mzero = SMAny [] 
     mplus (SMAny x) (SMAny y) = SMAny (x ++ y) 
     mplus (SMAny x) (SMOrd y) = SMOrd (S.union y (S.fromList x)) 
     mplus (SMOrd x) (SMAny y) = SMOrd (S.union x (S.fromList y)) 
     mplus (SMOrd x) (SMOrd y) = SMOrd (S.union x y) 

    choose :: MonadPlus m => [a] -> m a 
    choose = msum . map return 


    test1 = runSet (do 
    n1 <- choose [1..5] 
    n2 <- choose [1..5] 
    let n = n1 + n2 
    guard $ n < 7 
    return n) 
    -- fromList [2,3,4,5,6] 

    -- Values to choose from might be higher-order or actions 
    test1' = runSet (do 
    n1 <- choose . map return $ [1..5] 
    n2 <- choose . map return $ [1..5] 
    n <- liftM2 (+) n1 n2 
    guard $ n < 7 
    return n) 
    -- fromList [2,3,4,5,6] 

    test2 = runSet (do 
    i <- choose [1..10] 
    j <- choose [1..10] 
    k <- choose [1..10] 
    guard $ i*i + j*j == k * k 
    return (i,j,k)) 
    -- fromList [(3,4,5),(4,3,5),(6,8,10),(8,6,10)] 

    test3 = runSet (do 
    i <- choose [1..10] 
    j <- choose [1..10] 
    k <- choose [1..10] 
    guard $ i*i + j*j == k * k 
    return k) 
    -- fromList [5,10] 

    -- Test by Petr Pudlak 

    -- First, general, unoptimal case 
    step :: (MonadPlus m) => Int -> m Int 
    step i = choose [i, i + 1] 

    -- repeated application of step on 0: 
    stepN :: Int -> S.Set Int 
    stepN = runSet . f 
    where 
    f 0 = return 0 
    f n = f (n-1) >>= step 

    -- it works, but clearly exponential 
    {- 
    *SetMonad> stepN 14 
    fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14] 
    (0.09 secs, 31465384 bytes) 
    *SetMonad> stepN 15 
    fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] 
    (0.18 secs, 62421208 bytes) 
    *SetMonad> stepN 16 
    fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16] 
    (0.35 secs, 124876704 bytes) 
    -} 

    -- And now the optimization 
    chooseOrd :: Ord a => [a] -> SetMonad a 
    chooseOrd x = SMOrd (S.fromList x) 

    stepOpt :: Int -> SetMonad Int 
    stepOpt i = chooseOrd [i, i + 1] 

    -- repeated application of step on 0: 
    stepNOpt :: Int -> S.Set Int 
    stepNOpt = runSet . f 
    where 
    f 0 = return 0 
    f n = f (n-1) >>= stepOpt 

    {- 
    stepNOpt 14 
    fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14] 
    (0.00 secs, 515792 bytes) 
    stepNOpt 15 
    fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] 
    (0.00 secs, 515680 bytes) 
    stepNOpt 16 
    fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16] 
    (0.00 secs, 515656 bytes) 

    stepNOpt 30 
    fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30] 
    (0.00 secs, 1068856 bytes) 
    -} 

Answer 4

我發現了另一種可能性，根據GHC的ConstraintKinds擴展。我們的想法是重新定義Monad以便它包括允許的數據的參數約束：

{-# LANGUAGE ConstraintKinds #-} 
{-# LANGUAGE TypeFamilies #-} 
{-# LANGUAGE RebindableSyntax #-} 

import qualified Data.Foldable as F 
import qualified Data.Set as S 
import Prelude hiding (Monad(..), Functor(..)) 

class CFunctor m where 
    -- Each instance defines a constraint it valust must satisfy: 
    type Constraint m a 
    -- The default is no constraints. 
    type Constraint m a =() 
    fmap :: (Constraint m a, Constraint m b) => (a -> b) -> (m a -> m b) 
class CFunctor m => CMonad (m :: * -> *) where 
    return :: (Constraint m a) => a -> m a 
    (>>=) :: (Constraint m a, Constraint m b) => m a -> (a -> m b) -> m b 
    fail :: String -> m a 
    fail = error 

-- [] instance 
instance CFunctor [] where 
    fmap = map 
instance CMonad [] where 
    return = (: []) 
    (>>=) = flip concatMap 

-- Set instance 
instance CFunctor S.Set where 
    -- Sets need Ord. 
    type Constraint S.Set a = Ord a 
    fmap = S.map 
instance CMonad S.Set where 
    return = S.singleton 
    (>>=) = flip F.foldMap 

-- Example: 

-- prints fromList [3,4,5] 
main = print $ do 
    x <- S.fromList [1,2] 
    y <- S.fromList [2,3] 
    return $ x + y 

（這種方法的問題是在一元值的功能的情況下，如m (a -> b)，因爲它們不能滿足限制像Ord (a -> b)，因此不能使用組合子像<*>（或ap）此約束Set單子。）