Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

218 lines (166 sloc) 8.38 kb
{-# LANGUAGE GADTs, ExistentialQuantification, TypeSynonymInstances, ScopedTypeVariables #-}
import Control.Monad
import Data.List
import Data.Ord
import Debug.Trace
newtype ContT r m a = ContT { unContT :: (a -> m r) -> m r }
runContT :: Monad m => ContT r m r -> m r
runContT x = unContT x return
instance Functor (ContT r m) where
fmap f m = ContT $ \c -> unContT m (c . f)
instance Monad (ContT r m) where
return x = ContT ($ x)
m >>= fm = ContT (\c -> unContT m (\x -> unContT (fm x) c))
newtype ScpM' a = ScpM' { unScpM' :: Int -> (Int, a) }
instance Functor ScpM' where
fmap = liftM
instance Monad ScpM' where
return x = ScpM' (\s -> (s, x))
mx >>= fxmy = ScpM' (\s -> case unScpM' mx s of (s, x) -> unScpM' (fxmy x) s)
data ApplicativeTree f a where
Lifted :: f a -> ApplicativeTree f a
Pure :: a -> ApplicativeTree f a -- ??
Deepen :: ApplicativeTree f a -> ApplicativeTree f a
Star :: ApplicativeTree f (b -> a) -> ApplicativeTree f b -> ApplicativeTree f a
instance Functor f => Functor (ApplicativeTree f) where
fmap f (Lifted x) = Lifted (fmap f x)
fmap f (Star mg mx) = Star (fmap (\g -> f . g) mg) mx
type ScpM = ContT (Res Res') ScpM'
data Res a = forall b. Res (ApplicativeTree ScpM b) (b -> ScpM' (Res a))
| Done a
type Res' = Tree Int
runScpM :: ScpM Res' -> Res'
runScpM = runScpM' . go0
where
go0 :: ScpM Res' -> ScpM' Res'
go0 mx = unContT mx (return . Done) >>= go1
go1 :: Res Res' -> ScpM' Res'
go1 (Done x) = return x
--go1 (Res at cont) = dfs at cont
go1 (Res at cont) = bfs at cont
dfs :: forall a. ApplicativeTree ScpM a -> (a -> ScpM' (Res Res')) -> ScpM' Res'
--dfs (Lifted mx) cont = go0 mx >>= \a -> cont a >>= \r -> go1 r
--dfs (Lifted mx) cont = unContT mx (\(x :: a) -> undefined :: ScpM' (Res Res')) >>= \(r :: Res Res') -> undefined :: ScpM' Res'
dfs (Lifted mx) cont = unContT mx cont >>= go1
dfs (Deepen t) cont = dfs t cont
dfs (Pure x) cont = cont x >>= go1
dfs (Star mf mx) cont = dfs mf (\f -> return (Res (fmap f mx) cont))
{-
bfs at cont = bfs'' 0 at cont
bfs'' d at cont = trace (show (length cands)) $ snd $ minimumBy (comparing fst) cands
where cands = bfs' d at cont
bfs' :: Int -> ApplicativeTree ScpM a -> (a -> ScpM' (Res Res')) -> [(Int, ScpM' Res')]
--bfs' d (Lifted mx) cont = [(d, unContT mx cont >>= go1)]
bfs' d (Lifted mx) cont = do
r <- unContT mx cont
case r of Done x -> return x
Res at cont -> bfs' (d + 1) at cont
bfs' d (Star mf mx) cont = bfs' (d + 1) mf (\f -> return (Res (fmap f mx) cont)) ++
bfs' (d + 1) mx (\x -> return (Res (fmap ($ x) mf) cont))
-}
{-
bfs at cont = bfs' [Candidate 0 at cont]
bfs' :: [Candidate] -> ScpM' Res'
--bfs' (Candidate (Lifted mx) cont:cs) = unContT mx cont >>= go1
bfs' (Candidate (Lifted mx) cont:cs) = do
r <- unContT mx cont
case r of Done x -> return x
Res at cont ->
--bfs' (Candidate (Deepen t) cont:cs) = bfs' (cs ++ [Candidate t cont])
--bfs' (Candidate (Pure x) cont:cs) = cont x >>= go1
--bfs' (Candidate (Star mf mx) cont:cs) = bfs' (cs ++ [Candidate mf (\f -> return (Res (fmap f mx) cont)), Candidate mx (\x -> return (Res (fmap ($ x) mf) cont))])
--bfs' (Candidate (Star mf mx) cont:cs) = bfs' (cs ++ [Candidate mf (\f -> return (Res (Pure f `Star` mx) cont)), Candidate mx (\x -> return (Res (mf `Star` Pure x) cont))])
bfs' (Candidate (Star mf mx) cont:cs) = bfs' (cs ++ [Candidate mf (\f -> return (Res (Deepen (fmap f mx)) cont)), Candidate mx (\x -> return (Res (Deepen (fmap ($ x) mf)) cont))])
-}
{-
bfs :: forall a r.
ApplicativeTree ScpM a
-> (ApplicativeTree ScpM a -> r)
-> (a -> ScpM' (Res Res'))
-> ScpM' Res'
-}
bfs at k = bfs' [Candidate at k (\at' -> bfs at' k)]
bfs' :: [Candidate] -> ScpM' Res'
bfs' (Candidate (Lifted (mx :: ScpM a)) k rb:cands) = do
r <- unContT mx k
case r of
Done x -> return x
Res at' k' -> bfs' (cands ++ [Candidate at' k' (\at' -> bfs at' k')])
bfs' (Candidate (Pure x) k rb:cands) = do
r <- k x
case r of
Done x -> return x
Res at' k' -> bfs' (cands ++ [Candidate at' k' (\at' -> bfs at' k')])
bfs' (Candidate (Star (Pure f) (Pure x)) k rb:cands) = do
r <- k (f x)
case r of
Done x -> return x
Res at' k' -> bfs' (cands ++ [Candidate at' k' (\at' -> bfs at' k')])
bfs' (Candidate (Star fat xat) k rb:cands) = do
bfs' (cands ++ [Candidate xat (\x -> rb (Star fat (Pure x))) (\xat -> rb (Star fat xat)),
Candidate fat (\f -> rb (Star (Pure f) xat)) (\fat -> rb (Star fat xat))])
{-
bfs' :: [Candidate' b] -> (b -> ScpM' (Res Res')) -> ScpM' Res'
bfs' (Candidate' (Lifted mx) rb cont:cs) contt = do
r <- unContT mx cont
case r of Done x -> bfs (rb (Pure x)) contt
Res at cont -> undefined
--bfs' (Candidate' (Pure x) rb cont:cs) contt = s
bfs' (Candidate' (Star mf mx) rb cont:cs) contt = bfs' (cs ++ [Candidate' mf (\f -> cont (f `Star` mx)) (\f -> return (Res (fmap f mx) cont)),
Candidate' mx (\x -> cont (mf `Star`x)) (\x -> return (Res (fmap ($ x) mf) cont))]) contt
-}
data Candidate = forall a. Candidate {
focus :: ApplicativeTree ScpM a,
finished :: a -> ScpM' (Res Res'), -- If focus reduced to pure value
rebuild :: ApplicativeTree ScpM a -> ScpM' (Res Res') -- If focus still a tree of some sort
}
--data Candidate = forall a. Candidate Int (ApplicativeTree ScpM a) (a -> ScpM' (Res Res'))
--data Candidate' b = forall a. Candidate' (ApplicativeTree ScpM a) (ApplicativeTree ScpM a -> ApplicativeTree ScpM b) (a -> ScpM' (Res Res'))
--data Candidate2 = forall a. Candidate2 (ScpM a) (a -> ScpM' (Res Res'))
{-
runScpM :: ScpM Res' -> Res'
runScpM mx = runScpM' $ unContT mx (\b -> return (Res (Pure b) return)) >>= combine
where
combine :: Res -> ScpM' Res'
combine (Res comps cont) = combineChoice comps cont
combineChoice :: ApplicativeTree ScpM a -> (a -> ScpM' Res) -> ScpM' Res'
combineChoice (Pure x) cont = cont x >>= combine
combineChoice (Star compf compx) cont = combineChoice compf $ \f -> do
combineChoice compx $ \x -> do
return (f x)
-- combineChoice (Star compf compx) cont = do
-- r <- unContT compf (return . flip Res return)
-- case r of
-- Res (Pure f) cont' -> combineChoice compx (\x -> cont (f x))
--
--
-- -- Effects in breadth-first order:
-- --Choice comps' cont' -> combine (Choice (comps ++ comps') (\bs -> case comps `splitBy` bs of (bs, bs') -> cont' bs' >>= \r -> combine r >>= \b -> cont (b : bs)))
-- -- Effects in depth-first order:
-- Choice comps' cont' -> combineChoice (comps' ++ comps) (\bs -> case comps' `splitBy` bs of (bs', bs) -> cont' bs' >>= \r -> combine r >>= \b -> cont (b : bs))
-}
runScpM' :: ScpM' a -> a
runScpM' mx = snd (unScpM' mx 0)
class Monad m => MonadNext m where
next :: m Int
instance MonadNext ScpM' where
next = ScpM' (\s -> (s + 1, s))
instance MonadNext m => MonadNext (ContT r m) where
next = ContT (\c -> next >>= c)
class Monad m => MonadChoice m where
choice :: m (a -> b) -> m a -> m b
instance MonadChoice ScpM where
choice mf mx = ContT $ \c -> return (Res (Lifted mf `Star` Lifted mx) c)
choicePair :: MonadChoice m => m a -> m b -> m (a, b)
choicePair ma mb = return (,) `choice` ma `choice` mb
bitsToNumber :: [Bool] -> Int
bitsToNumber = foldr (\b acc -> acc * 2 + if b then 1 else 0) 0
tHRESHOLD :: Int
tHRESHOLD = 3
data Tree a = Tree a [Tree a]
deriving (Show)
tree :: [()] -> ScpM Res'
tree n | length n > tHRESHOLD = next >>= \i -> return (Tree i [])
| otherwise = next >>= \i -> choicePair (tree (() : n)) (tree (() : n)) >>= \(xs, ys) -> return (Tree i [xs, ys])
main :: IO ()
main = print (runScpM (tree [()]))
Jump to Line
Something went wrong with that request. Please try again.