packages feed

control-monad-queue (empty) → 0.0.9

raw patch · 18 files changed

+1091/−0 lines, 18 filesdep +basesetup-changed

Dependencies added: base

Files

+ AUTHORS view
@@ -0,0 +1,1 @@+leon at melding-monads dot com
+ Control/Monad/Queue/Allison.hs view
@@ -0,0 +1,130 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Queue.Allison+-- Copyright   :  (c) Leon P Smith 2009+-- License     :  BSD3+--+-- Maintainer  :  leon at melding-monads dot com+-- Stability   :  experimental+-- Portability :  portable+--+-- A library implementation of corecursive queues,  see+-- /Circular Programs and Self-Referential Structures/ by Lloyd Allison,+-- /Software Practice and Experience/, 19(2), pp.99-109, Feb 1989+--+-- <http://www.csse.monash.edu.au/~lloyd/tildeFP/1989SPE/>+--+-- For an explanation of the library implementation, see+-- /Lloyd Allison's Corecursive Queue:  Why Continuations Matter/+-- by Leon P Smith,  in /The Monad Reader/ issue 14.+--+-----------------------------------------------------------------------------++{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE RankNTypes                 #-}++module  Control.Monad.Queue.Allison+     (  Q()+     ,  LenType+     ,  enQ+     ,  peekQ+     ,  peekQn+     ,  peekQs+     ,  deQ+     ,  deQs+     ,  deQ_break+     ,  lenQ+     ,  lenQ_+     ,  runQueue+     ,  callCC+     )  where++import qualified Control.Monad.Queue.Class as Class+import Control.Monad.Queue.Util+import Data.List(genericIndex, genericTake, genericSplitAt)++type QSt e = LenType -> [e] -> [e]++newtype Q e a = Q { unQ :: (a -> QSt e) -> QSt e }++instance Monad (Q e) where+  return a  = Q (\k -> k a)+  m >>= f   = Q (\k -> unQ m (\a -> unQ (f a) k))++callCC :: ((a -> forall b. Q e b) -> Q e a) -> Q e a+callCC f = Q (\k -> unQ (f (\a -> Q (\_ -> k a))) k)++enQ :: e -> Q e ()+enQ e = Q (\k n q -> e : (k () $! n+1) q)++deQ :: Q e (Maybe e)+deQ   = Q delta+  where+    delta k n q+       | n <= 0    = k Nothing n q+       | otherwise = case q of+                      [] -> error "Control.Monad.Queue.Allison.deQ: empty list"+                      (e:q') -> (k (Just e) $! n-1) q'++deQ_break :: Q e e+deQ_break =  Q delta+  where+    delta k n q+       | n <= 0    = []+       | otherwise = case q of+                      [] -> error "Control.Monad.Queue.Allison.deQ_break: empty list"+                      (e:q') -> (k e $! n-1) q'++deQs :: Integral len => len -> Q e [e]+deQs i = Q delta+  where+    delta k n q+       = let i' = min (fromIntegral i) n+             (res,q') = genericSplitAt i' q+          in (k res $! n-i') q'++peekQ :: Q e (Maybe e)+peekQ = Q delta+  where+    delta k n q+       | n <= 0    = k Nothing n q+       | otherwise = case q of+                      [] -> error "Control.Monad.Queue.Allison.peekQ: empty list"+                      (e:_q') -> k (Just e) n q++peekQn :: (Integral index) => index -> Q e (Maybe e)+peekQn i_ = Q delta+  where+    i = fromIntegral i_++    delta k n q+       | n < i     = k Nothing n q+       | otherwise = k (Just (genericIndex q i)) n q++peekQs :: (Integral len) => len -> Q e [e]+peekQs i_ = Q delta+  where+    i = fromIntegral i_+    delta k n q = k (genericTake (min i n) q) n q++lenQ_ :: Q e LenType+lenQ_ = Q (\k n q -> k n n q)++lenQ  :: Integral len => Q e len+lenQ  = Q (\k n q -> k (fromIntegral n) n q)++runQueue :: Q e a -> [e]+runQueue m = q+  where+    q = unQ m (\_ _ _ -> []) 0 q++instance Class.MonadQueue e (Q e) where+  enQ     = enQ+  peekQ   = peekQ+  peekQs  = peekQs+  peekQn  = peekQn+  deQ     = deQ+  deQs    = deQs+  lenQ    = lenQ
+ Control/Monad/Queue/Class.hs view
@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Queue.Class+-- Copyright   :  (c) Leon P Smith 2009+-- License     :  BSD3+--+-- Maintainer  :  leon at melding-monads dot com+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------++{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FunctionalDependencies     #-}++module Control.Monad.Queue.Class where++import Control.Monad.Queue.Util++class Monad q => MonadQueue e q | q -> e where+  enQ     :: e -> q ()+  peekQ   :: q (Maybe e)+  peekQs  :: Integral maxlen  => maxlen -> q [e]+  peekQn  :: Integral index   => index  -> q (Maybe e)+  deQ     :: q (Maybe e)+  deQs    :: Integral maxlen => maxlen -> q [e]+  lenQ    :: Integral len => q len++  deQ = do+          es <- deQs (1 :: LenType)+          case es of+           []    -> return Nothing+           (e:_) -> return (Just e)++  deQs n+     | n <= 0    = return []+     | otherwise = deQ >>=  maybe (return [])+                            (\e ->  do+                                    es <- deQs (n-1)+                                    return (e:es))
+ Control/Monad/Queue/Corec.hs view
@@ -0,0 +1,138 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Queue.Corec+-- Copyright   :  (c) Leon P Smith 2009+-- License     :  BSD3+--+-- Maintainer  :  leon at melding-monads dot com+-- Stability   :  experimental+-- Portability :  portable+--+-- Corecursive queues with return values.  This is a straightforward+-- generalization of Control.Monad.Queue.Allison.+--+-----------------------------------------------------------------------------++{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE RankNTypes                 #-}++module  Control.Monad.Queue.Corec +     (  Q()+     ,  LenType+     ,  enQ+     ,  peekQ+     ,  peekQn+     ,  peekQs+     ,  deQ+     ,  deQ_break+     ,  deQs+     ,  lenQ+     ,  lenQ_+     ,  runQueue+     ,  runResult+     ,  runResultQueue+     ,  mapQW+     ,  callCC+     )  where++import qualified Control.Monad.Queue.Class as Class+import Control.Monad.Queue.Util+import Data.List(genericIndex, genericTake, genericSplitAt)++type QSt w e = LenType -> [e] -> (w,[e])++newtype Q w e a = Q { unQ :: (a -> QSt w e) -> QSt w e }++instance Monad (Q w e) where+  return a  = Q (\k -> k a)+  m >>= f   = Q (\k -> unQ m (\a -> unQ (f a) k))++callCC :: ((a -> forall b. Q w e b) -> Q w e a) -> Q w e a+callCC f = Q $ \c -> unQ (f (\a -> Q $ \_ -> c a)) c++enQ :: e -> Q w e ()+enQ e = Q (\k n q -> let (w,es) = (k () $! n+1) q+                      in (w,e:es))++deQ  ::  Q w e (Maybe e)+deQ  =   Q delta+  where+    delta k n q+       | n <= 0     = k Nothing n q+       | otherwise  = case q of+                       [] -> error "Control.Monad.Queue.Corec.deQ: empty list"+                       (e:q') -> (k (Just e) $! n-1) q'++deQ_break :: w -> Q w e e+deQ_break w =   Q delta+  where+    delta k n q+       | n <= 0    = (w,[])+       | otherwise = case q of+                      [] -> error "Control.Monad.Queue.Corec.deQ_break: empty list"+                      (e:q') -> (k e $! n-1) q'++deQs :: Integral len => len -> Q w e [e]+deQs i = Q delta+  where+    delta k n q+       = let i' = min (fromIntegral i) n+             (res,q') = genericSplitAt i' q+          in (k res $! n-i') q'++peekQ :: Q w e (Maybe e)+peekQ = Q delta+  where+    delta k n q+       | n <= 0    = k Nothing n q+       | otherwise = case q of+                      [] -> error "Control.Monad.Queue.Corec.peekQ: empty list"+                      (e:q') -> k (Just e) n q++peekQn :: (Integral index) => index -> Q w e (Maybe e)+peekQn i_ = Q delta+  where+    i = fromIntegral i_++    delta k n q+       | n < i = k Nothing n q+       | otherwise = k (Just (genericIndex q i)) n q++peekQs :: (Integral len) => len -> Q w e [e]+peekQs i_ = Q delta+  where+    i = fromIntegral i_+    delta k n q = k (genericTake (min i n) q) n q++lenQ_ :: Q w e LenType+lenQ_ = Q (\k n q -> k n n q)++lenQ  :: Integral len => Q w e len+lenQ  = Q (\k n q -> k (fromIntegral n) n q)+++mapQW :: (w -> w) -> Q w e a -> Q w e a+mapQW f m = Q (\k n q ->  let (w,es) = unQ m k n q+                          in  (f w, es))++runResultQueue :: Q a e a -> (a,[e])+runResultQueue m = st+  where+    st@(_a,q) = unQ m (\a _ _ -> (a,[])) 0 q++runResult :: Q a e a -> a+runResult = fst . runResultQueue++runQueue :: Q a e a -> [e]+runQueue  = snd . runResultQueue++instance Class.MonadQueue e (Q w e) where+  enQ     = enQ+  peekQ   = peekQ+  peekQs  = peekQs+  peekQn  = peekQn+  deQ     = deQ+  deQs    = deQs+  lenQ    = lenQ
+ Control/Monad/Queue/ST.hs view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Queue.ST+-- Copyright   :  (c) Leon P Smith 2009+-- License     :  BSD3+--+-- Maintainer  :  leon at melding-monads dot com+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------++{-# LANGUAGE RankNTypes #-}++module Control.Monad.Queue.ST+     ( Q()+     , enQ+     , deQ+     , lenQ_+     , runResult+     ) where++import qualified Control.Monad.Queue.Class+import Control.Monad.Queue.Util+import Control.Monad.ST.Strict+import Data.STRef.Strict++type  ListPtr st a = STRef st (List st a)+data  List st a+   =  Null+   |  Cons a {-# UNPACK #-} !(ListPtr st a)++type  QSt st res elt = LenType -> ListPtr st elt -> ListPtr st elt -> ST st res+newtype Q elt a+      = Q { unQ :: forall res st. ((a -> QSt st res elt) -> QSt st res elt) }++instance Monad (Q st) where+    return a = Q (\k -> k a)+    m >>= f  = Q (\k -> unQ m (\a -> unQ (f a) k))++enQ :: e -> Q e ()+enQ e  = Q $ \k n a z -> do+                 z' <- newSTRef Null+                 writeSTRef z (Cons e z')+                 (k () $! n+1) a z'++deQ :: Q e (Maybe e)+deQ    = Q $ \k n a z -> do+                 list <- readSTRef a+                 case list of+                   Null+                     -> (k Nothing  $! n-1) a  z+                   (Cons e a')+                     -> (k (Just e) $! n-1) a' z++lenQ_ :: Q e LenType+lenQ_ = Q (\k n a z -> k n n a z)++runResult m = runST $ do+  ref <- newSTRef Null+  unQ m (\a n front back -> return a) 0 ref ref
+ Control/Monad/Queue/Util.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Queue.Util+-- Copyright   :  (c) Leon P Smith 2009+-- License     :  BSD3+--+-- Maintainer  :  leon at melding-monads dot com+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Control.Monad.Queue.Util where++import Data.Word++type LenType = Word32
+ Data/Queue/Class.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Queue.Class+-- Copyright   :  (c) Leon P Smith 2009+-- License     :  BSD3+--+-- Maintainer  :  leon at melding-monads dot com+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------+++module Data.Queue.Class+     ( Queue(empty, enque, deque)+     ) where++class Queue q where+   empty :: q a+   enque :: a   -> q a -> q a+   deque :: q a -> (Maybe a, q a)
+ Data/Queue/Okasaki.hs view
@@ -0,0 +1,94 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Queue.Okasaki+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  leon at melding-monads dot com+-- Stability   :  experimental+-- Portability :  portable+--+-- Queues with constant time operations, from+-- /Simple and efficient purely functional queues and deques/,+-- by Chris Okasaki, /JFP/ 5(4):583-592, October 1995.+--+-- Based on the incremental reversals of lazy lists.+--+-----------------------------------------------------------------------------++module  Data.Queue.Okasaki+     (  Q+        -- * Primitive operations+        -- | Each of these requires /O(1)/ time in the worst case.+     ,  empty, enque, deque+        -- * Queues and lists+     ,  listToQueue, queueToList+     )  where++import Prelude -- necessary to get dependencies right+import qualified Data.Queue.Class as Class++-- import Data.Typeable++-- | The type of FIFO queues.+data Q a = Q [a] [a] [a]+++-- #include "Typeable.h"+-- `INSTANCE_TYPEABLE1(Queue,queueTc,"Queue")++-- Invariants for Q xs ys xs':+--	length xs = length ys + length xs'+--	xs' = drop (length ys) xs	-- in fact, shared (except after fmap)+-- The queue then represents the list xs ++ reverse ys+++instance Functor Q where+	fmap f (Q xs ys xs') = Q (map f xs) (map f ys) (map f xs')+	-- The new xs' does not share the tail of the new xs, but it does+	-- share the tail of the old xs, so it still forces the rotations.+	-- Note that elements of xs' are ignored.++-- | The empty queue.+empty :: Q a+empty = Q [] [] []++-- | Add an element to the back of a queue.+enque :: a -> Q a  -> Q a+enque y (Q xs ys xs') = makeQ xs (y:ys) xs'++-- | Attempt to extract the front element from a queue.+-- If the queue is empty,  return 'Nothing' paired with the original queue+-- otherwise return 'Just' the first element paired with the modified queue++deque :: Q a -> (Maybe a, Q a)+deque q@(Q [] _ _) = (Nothing,  q)+deque q@(Q (x:xs) ys xs') = (Just x, makeQ xs ys xs')++-- Assuming+--	length ys <= length xs + 1+--	xs' = drop (length ys - 1) xs+-- construct a queue respecting the invariant.+makeQ :: [a] -> [a] -> [a] -> Q a+makeQ xs ys [] = listToQueue (rotate xs ys [])+makeQ xs ys (_:xs') = Q xs ys xs'++-- Assuming length ys = length xs + 1,+--	rotate xs ys zs = xs ++ reverse ys ++ zs+rotate :: [a] -> [a] -> [a] -> [a]+rotate [] (y:_) zs = y : zs		-- the _ here must be []+rotate (x:xs) (y:ys) zs = x : rotate xs ys (y:zs)++-- | A queue with the same elements as the list.+listToQueue :: [a] -> Q a+listToQueue xs = Q xs [] xs++-- | The elements of a queue, front first.+queueToList :: Q a -> [a]+queueToList (Q xs ys _) = xs ++ reverse ys+++instance Class.Queue Q where+   empty = empty+   deque = deque+   enque = enque
+ Data/Queue/TwoStack.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Queue.TwoStack+-- Copyright   :  (c) Leon P Smith 2009+-- License     :  BSD3+--+-- Maintainer  :  leon at melding-monads dot com+-- Stability   :  experimental+-- Portability :  portable+--+-- Two-Stack Queues of functional programming folklore.+-- Notably mentioned inside Chris Okasaki's thesis, with+-- relevant citations.+--+-- /Purely Functional Data Structures/ by Chris Okasaki,+-- /Cambridge University Press/,  1998+--+-- http://www.cs.cmu.edu/~rwh/theses/okasaki.pdf+--+-----------------------------------------------------------------------------++module Data.Queue.TwoStack+     ( Q()+     , empty+     , enque+     , deque+     , listToQueue+     , queueToList+     , len+     ) where++import qualified Data.Queue.Class as Class+import Data.List++import Control.Monad.Queue.Util++data Q e = Q !LenType [e] [e]++instance Functor Q where+  fmap f (Q n as zs) = Q n (map f as ++ map f (reverse zs)) []++instance (Eq e) => Eq (Q e) where+  (Q ln as ys) == (Q mn bs zs)   =  ln == mn  &&  loop   as bs ys zs+    where+      loop as bs (y:ys) (z:zs)   =  y == z    &&  loop   as bs ys zs+      loop as bs ys     zs       =                loop2  as bs ys zs++      loop2 (a:as) (b:bs) ys zs  =  a == b    &&  loop2  as bs ys zs+      loop2 as     []     [] zs  =  as == reverse zs+      loop2 []     bs     ys []  =  bs == reverse ys++instance (Ord e) => Ord (Q e) where+  compare (Q _ as ys) (Q _ bs zs) = loop as bs ys zs+     where+       loop (a:as) (b:bs) ys zs+          = case compare a b of+             LT -> LT+             EQ -> loop as bs ys zs+             GT -> GT+       loop [] [] [] [] = EQ+       loop [] bs [] zs = LT+       loop [] bs ys zs = loop (reverse ys) bs [] zs+       loop as [] ys [] = GT+       loop as [] ys zs = loop as (reverse zs) ys []++empty :: Q e+empty =  Q 0 [] []++enque :: e -> Q e -> Q e+enque z  (Q 0 []     [])  = Q 1     [z]     []+enque z  (Q n (a:as) zs)  = Q (n+1) (a:as)  (z:zs)++deque :: Q e -> (Maybe e, Q e)+deque    (Q 0 []     [])  =   ( Nothing  ,  Q 0     []   []  )+deque    (Q n (a:as) zs)+         |  null as       =   ( Just a   ,  Q (n-1) as'  []  )+         |  otherwise     =   ( Just a   ,  Q (n-1) as   zs  )+            where as'     = reverse zs++listToQueue :: [e] -> Q e+listToQueue as = Q (genericLength as) as []++queueToList :: Q e -> [e]+queueToList (Q _ as zs) = as ++ reverse zs++len :: Q e -> LenType+len (Q l _ _) = l+++instance Class.Queue Q where+  empty = empty+  enque = enque+  deque = deque
+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2009, Melding Monads+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+    * Neither the name of Melding Monads nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,3 @@+To compile the timing program,  change to the tests/ directory, and then run++ghc --make -O2 Time.hs -i..
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ control-monad-queue.cabal view
@@ -0,0 +1,17 @@+Name:                control-monad-queue+Version:             0.0.9+Description:         Corecursive Queues+License:             BSD3+License-file:        LICENSE+Author:              Leon P Smith <leon@melding-monads.com>+Maintainer:          Leon P Smith <leon@melding-monads.com>+Build-Type:          Simple+Category:            Control+Synopsis:            Resuable corecursive queues, via continuations.+Cabal-Version:       >=1.2++Library+  Build-Depends:     base >= 2 && < 5+  Exposed-Modules:   Control.Monad.Queue.Class+                     Control.Monad.Queue.Allison+                     Control.Monad.Queue.Corec
+ tests/BinaryTree.hs view
@@ -0,0 +1,57 @@+{-# OPTIONS_GHC -O2 -fasm #-}++module BinaryTree where++import Data.Ratio(Ratio, (%), numerator, denominator)+++data  Tree a b+   =  Leaf    a+   |  Branch  b (Tree a b) (Tree a b)+      deriving (Eq,Show)++childrenOf :: Tree a b ->  [Tree a b]+childrenOf (Leaf    _      )  =   []+childrenOf (Branch  _ l r  )  =   [l,r]++fold :: (a -> c) -> (b -> c -> c -> c) -> Tree a b -> c+fold leaf branch = loop+    where+       loop (Leaf    a      ) = leaf a+       loop (Branch  b l r  ) = branch b (loop l) (loop r)++labelDisj :: (a -> c) -> (b -> c) -> Tree a b -> c+labelDisj leaf branch (Leaf    a      ) = leaf    a+labelDisj leaf branch (Branch  b _ _  ) = branch  b++++fib n = fibs !! (n - 1)+  where+    fibs = Leaf 0 : Leaf 0 : zipWith3 Branch [1..] fibs (tail fibs)++sternBrocot :: Tree a (Ratio Integer)+sternBrocot = loop 0 1 1 0+   where+     loop a b x y+         = Branch (m%n) (loop a b m n) (loop m n x y)+           where+             m  = a + x+             n  = b + y++toTikzString maxdepth branch leaf t = "  \\" ++ loop 0 t ";\n"+  where+    loop n t str+      | n < maxdepth+      = case t of+         (Leaf a) -> "node {" ++ leaf a ++ "}" ++ str+         (Branch b l r) -> "node {" ++ branch b ++ "}\n"+                        ++ replicate (7*n+3) ' ' ++ "child {"+                        ++ loop (n+1) l ("}\n" ++ replicate (7*n+3) ' '+                                         ++ "child {" ++ (loop (n+1) r ("}" ++ str)))+      | otherwise+      = case t of+          (Leaf a) -> "node {" ++ leaf a ++ "}" ++ str+          (Branch b _l _r) -> "node {" ++ branch b ++ "} child {} child {}" ++ str++toFrac x = "$\\frac{" ++ show (numerator x) ++ "}{" ++ show (denominator x) ++ "}$"
+ tests/BreadthFirstSearch.hs view
@@ -0,0 +1,203 @@+{-# OPTIONS_GHC -O2 -fasm              #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module BreadthFirstSearch where++import BinaryTree+import qualified Control.Monad.Queue.Allison  as A+import qualified Control.Monad.Queue.Corec    as C+import qualified Control.Monad.Queue.ST       as STQ+import qualified CpSt+import qualified SideChannelQ                 as SCQ+import qualified Data.Queue.TwoStack          as Two+import qualified Data.Queue.Okasaki           as Oka+import Data.Sequence+import qualified Data.Sequence as Seq++isBranch = labelDisj (const False) (const True)++direct ::  Tree a b  ->  [Tree a b]+direct     tree      =   queue+  where+    queue  | isBranch tree   = tree :  explore 1 queue+           | otherwise       =         explore 0 queue++    explore :: Int -> [Tree a b] -> [Tree a b]+    explore  0 _ = []+    explore  (n+1) (Branch _ l r : head')+      =  if (isBranch  l)+         then   if (isBranch r)+                then   l :  r :  explore  (  n+2)  head'+                else   l :       explore  (  n+1)  head'+         else   if (isBranch r)+                then        r :  explore  (  n+1)  head'+                else             explore     n     head'++allison tree = A.runQueue (handle tree >> explore)+  where+    handle t@(Leaf   _      ) = return ()+    handle t@(Branch _ _ _  ) = A.enQ t++    explore = do+      branch <- A.deQ+      case branch of+        Nothing -> return ()+        (Just (Branch _ !l !r)) -> handle l >> handle r >> explore+++allison2  tree = A.runQueue (handle tree >> explore)+  where+    handle t@(Leaf   _      ) = return ()+    handle t@(Branch _ _ _  ) = A.enQ t++    explore = do+      (Branch _ !l !r) <- A.deQ_break+      handle l+      handle r+      explore+++stq tree = STQ.runResult (handle tree >> explore)+  where+    handle t@(Leaf   _      ) = return ()+    handle t@(Branch _ _ _  ) = STQ.enQ t++    explore = do+      branch <- STQ.deQ+      case branch of+        Nothing -> return ()+        (Just (Branch _ !l !r)) -> handle l >> handle r >> explore++corec1   tree = case C.runResultQueue (handle tree >> explore) of+                 (_,q) -> q+  where++    handle t@(Leaf   _      ) = return ()+    handle t@(Branch _ _ _  ) = C.enQ t++    explore = do+      branch <- C.deQ+      case branch of+        Nothing -> return ()+        (Just (Branch _ !l !r)) -> handle l >> handle r >> explore++++corec2   tree = case C.runResultQueue (handle tree >> explore) of+                  ((),q) -> q+  where+    handle t@(Leaf   _      ) = return ()+    handle t@(Branch _ _ _  ) = C.enQ t++    explore = do+      branch <- C.deQ+      case branch of+        Nothing -> return ()+        (Just (Branch _ !l !r)) -> handle l >> handle r >> explore++sidechan1 tree+    = case SCQ.runResultQueue (handle tree >> explore) of+        (_,q) -> q+  where+    handle t@(Leaf   _      ) = return ()+    handle t@(Branch _ _ _  ) = SCQ.enQ t++    explore = do+      branch <- SCQ.deQ+      case branch of+        Nothing -> return ()+        (Just (Branch _ !l !r)) -> handle l >> handle r >> explore++++sidechan2 tree+    = case SCQ.runResultQueue (handle tree >> explore) of+       ((),q) -> q+  where+    handle t@(Leaf   _      ) = return ()+    handle t@(Branch _ _ _  ) = SCQ.enQ t++    explore = do+      branch <- SCQ.deQ+      case branch of+        Nothing -> return ()+        (Just (Branch _ !l !r)) -> handle l >> handle r >> explore++++twostack t = loop (handle t Two.empty)+  where+    handle t@(Leaf   _    ) q = q+    handle t@(Branch _ _ _) q = Two.enque t q++    loop q = case Two.deque q of+               (Nothing, q') ->  ()+               (Just (Branch _ !l !r), q') -> loop (handle r (handle l q'))+++twostack_cpst tree = CpSt.runResult (handle tree >> explore)+  where+    handle t@(Leaf   _      ) = return ()+    handle t@(Branch _ _ _  ) = CpSt.enQ t++    explore = do+      branch <- CpSt.deQ+      case branch of+        Nothing -> return ()+        (Just (Branch _ !l !r)) -> handle l >> handle r >> explore+++twostack_list t = loop (handle t Two.empty)+  where+    handle t@(Leaf   _    ) q = q+    handle t@(Branch _ _ _) q = Two.enque t q++    loop q = case Two.deque q of+               (Nothing, q') ->  []+               (Just t@(Branch _ !l !r), q') -> t : loop (handle r (handle l q'))++okasaki t = loop (handle t Oka.empty)+  where+    handle t@(Leaf   _    ) q = q+    handle t@(Branch _ _ _) q = Oka.enque t q++    loop q = case Oka.deque q of+               (Nothing, q') ->  ()+               (Just (Branch _ !l !r), q') -> loop (handle r (handle l q'))+++okasaki_list t = loop (handle t Oka.empty)+  where+    handle t@(Leaf   _    ) q = q+    handle t@(Branch _ _ _) q = Oka.enque t q++    loop q = case Oka.deque q of+               (Nothing, q') ->  []+               (Just t@(Branch _ !l !r), q') -> t:loop (handle r (handle l q'))++sequence t = loop (handle t empty)+  where+    handle t@(Leaf   _    ) q = q+    handle t@(Branch _ _ _) q = q |> t++    loop q = case viewl q of+               EmptyL -> ()+               (Branch _ !l !r) :< q' -> loop (handle r (handle l q'))++sequence_list t = loop (handle t empty)+  where+    handle t@(Leaf   _    ) q = q+    handle t@(Branch _ _ _) q = q |> t++    loop q = case viewl q of+               EmptyL -> []+               t@(Branch _ !l !r) :< q' -> t:loop (handle r (handle l q'))++sequence2 t = loop (Seq.singleton t)+   where+   handle t@(Leaf   _     ) q = q+   handle t@(Branch _ _ _ ) q = q |> t++   loop q | Seq.null q = ()+          | otherwise  = case Seq.index q 0 of+                           x@(Branch _ l r) -> loop (handle r (handle l (Seq.drop 1 q)))
+ tests/CpSt.hs view
@@ -0,0 +1,23 @@+module CpSt (CpSt(..), get, put, enQ, deQ, runResult, runCpSt)  where++import Data.Queue.TwoStack++newtype CpSt r s a+      = CpSt { unCpSt :: (a -> s -> r) -> s -> r }++instance Monad (CpSt r s) where+   return a  = CpSt (\k -> k a)+   m >>= f   = CpSt (\k -> unCpSt m (\a -> unCpSt (f a) k))++get     = CpSt (\k s -> k s   s   )+put s'  = CpSt (\k _ -> k ()  s'  )++--runCpSt :: CpSt a s a -> s -> (a,s)+runCpSt m s0 = unCpSt m (\a s -> (a,s)) s0++enQ e = CpSt (\k q -> k () (enque e q))++deQ   = CpSt (\k q -> case deque q of+                        (e,q') -> k e q')++runResult m = unCpSt m (\a s -> a) empty
+ tests/SideChannelQ.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -O2 -fno-full-laziness  #-}+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+-- Argh... for whatever reason this file cannot be compiled with optimization+-- -fno-full-laziness fixes this+-- Todo: check ghc-core to find out why++module SideChannelQ (Q(), enQ, deQ, runResultQueue) where++--import Control.Monad.Queue.Class+import Control.Monad.Cont.Class+import Data.IORef+import System.IO.Unsafe+import qualified Debug.Trace++-- trace   = Debug.Trace.trace+-- traceIO = putStr++trace   _ = id+traceIO _ = return ()++type QSt r' r  = IORef r' -> IORef [r] -> Int -> [r] -> [r]++newtype Q r' r a = Q { unQ :: ((a -> QSt r' r) -> QSt r' r) }++instance Monad (Q r' r) where+    return a = Q ($a)+    m >>= f  = Q (\k -> unQ m (\a -> unQ (f a) k))++instance MonadCont (Q r' r) where+  callCC f = Q (\k -> unQ (f (\a -> Q (\_ -> k a))) k)+++unsafeRead  ref   = unsafePerformIO (readIORef  ref  )+unsafeWrite ref a = unsafePerformIO (writeIORef ref a)+unsafeNew   a     = unsafePerformIO (newIORef   a    )+++enQ x = Q (\k rr' rr !n xs -> let !n' = n+1+                                  xs'  = k () rr' rr n' xs+                               in trace ("enQ $ " ++ show x)+                                   (unsafeWrite rr xs' `seq` (x:xs')))++deQ = Q delta+  where+    delta k rr' rr 0        xs  = trace ("deQ failed")     (k Nothing  rr' rr 0 xs)+    delta k rr' rr (n+1) (x:xs) = trace ("deQ " ++ show x) (k (Just x) rr' rr n xs)+++breakK a rr' rr n xs = trace ("setting return value: " ++ show a)+                         (unsafeWrite rr' (\() -> a) `seq` [])+++force [] = return ()+force (_:_) = return ()++demand [] = ()+demand (_:_) = ()++runResultQueue m+     = (trace "reading return value" `seq` unsafeRead rr' (), queue)+   where+     rr' = unsafeNew init+     init () = unsafePerformIO $ do+                 traceIO "forcing computation\n"+                 xs <- readIORef rr+                 force xs+                 traceIO "reading return value\n"+                 f <- readIORef rr'+                 return (f ())+     rr  = unsafeNew queue+     queue = unQ m breakK rr' rr 0 queue
+ tests/Time.hs view
@@ -0,0 +1,108 @@++{-# LANGUAGE BangPatterns #-}++module Main where++import qualified BinaryTree as T+import qualified BreadthFirstSearch as BFS+import qualified Data.Char as Char+import Data.List+import Data.Bits+import System.CPUTime+import System.Environment++stats = foldl' (\(!s0,!s1,!s2) x -> (s0+1,s1+x,s2+x*x)) (0,0,0)++stddev (s0,s1,s2) = sqrt (s0 * s2 - s1 * s1) / s0++avg (s0,s1,s2) = s1 / s0++fib :: Int -> Int+fib n = snd . foldl' fib' (1, 0) $ dropWhile not $+            [testBit n k | k <- let s = bitSize n in [s-1,s-2..0]]+    where+        fib' (f, g) p+            | p         = (f*(f+2*g), ss)+            | otherwise = (ss, g*(2*f-g))+            where ss = f*f+g*g++test string val = do+  start <- getCPUTime+  if val then return () else error ("Failed test: " ++ string)+  end <- getCPUTime+  return $! (end - start) `div` cpuTimePrecision++test' string f i n = do+  ts <- mapM (test string . f) (replicate n i)+  putStr string+  putStr "\nTimings: "+  print ts+  putStr "Sum:     "+  print (sum ts)+  putStr "Minimum: "+  print (minimum ts)+  putStr "Maximum: "+  print (maximum ts)+  let s = stats (map fromIntegral ts)+  putStr "Mean:    "+  print (avg s)+  putStr "Stddev:  "+  print (stddev s)+++fromQueue f n = length (f (T.fib n)) == fib n - 1++fromUnit  f n = (f (T.fib n)) == ()++main = do+  xs <- getArgs+  case xs of+    (a1:a2:a3:_)+        | all Char.isDigit a2 && all Char.isDigit a3+        -> do_test a1 (read a2) (read a3)+    _ -> help_message++do_test a1 i n+ = case a1 of+   "direct"         -> test' a1 (fromQueue BFS.direct        ) i n+   "allison"        -> test' a1 (fromQueue BFS.allison       ) i n+   "allison2"       -> test' a1 (fromQueue BFS.allison2      ) i n+   "corec1"         -> test' a1 (fromQueue BFS.corec1        ) i n+   "corec2"         -> test' a1 (fromQueue BFS.corec2        ) i n+   "st"             -> test' a1 (fromUnit  BFS.stq           ) i n+   "sidechan1"      -> test' a1 (fromQueue BFS.sidechan1     ) i n+   "sidechan2"      -> test' a1 (fromQueue BFS.sidechan2     ) i n+   "twostack"       -> test' a1 (fromUnit  BFS.twostack      ) i n+   "two_cpst"       -> test' a1 (fromUnit  BFS.twostack_cpst ) i n+   "two_list"       -> test' a1 (fromQueue BFS.twostack_list ) i n+   "okasaki"        -> test' a1 (fromUnit  BFS.okasaki       ) i n+   "okasaki_list"   -> test' a1 (fromQueue BFS.okasaki_list  ) i n+   "sequence"       -> test' a1 (fromUnit  BFS.sequence      ) i n+   "sequence_list"  -> test' a1 (fromQueue BFS.sequence_list ) i n+   "sequence2"      -> test' a1 (fromUnit  BFS.sequence2     ) i n+   _ -> help_message++help_message = do+  putStr   "Usage:  Time <test> <input> <number_of_trials>"+  putStr "\n<test> is one of:"+  putStr "\n   direct     for a corecursive traversal without using a monad"+  putStr "\n   allison    Control.Monad.Queue.Allison"+  putStr "\n   allison2     as above, but uses deQ_break instead of deQ"+  putStr "\n   corec1       Control.Monad.Queue.Corec, does not demand result of ()"+  putStr "\n   corec2       as above, but demands ()"+  putStr "\n   sidechan1    SideChannelQ, like corec1"+  putStr "\n   sidechan2    like corec2"+  putStr "\n   twostack     Two-Stack queues without a monad"+  putStr "\n   two_cpst     uses Two-Stack queues inside a CpSt monad"+  putStr "\n   two_list     produces a list of elements enqueued"+  putStr "\n   okasaki      Data.Queue.Okasaki"+  putStr "\n   okasaki_list"+  putStr "\n   sequence     Data.Sequence"+  putStr "\n   sequence_list"+  putStr "\n   sequence2    The wrong way to use sequence as a queue"+  putStr "\n"+  putStr "\ne.g.  Test direct 30 10"+  putStr "\n        runs direct on the 30th fibbonacci tree 10 times"+  putStr "\n      Test direct 30 10 +RTS -H500M -sstderr"+  putStr "\n        as above, but uses a 500MB heap,  and prints runtime stats"+  putStr "\n"