diff --git a/AUTHORS b/AUTHORS
new file mode 100644
--- /dev/null
+++ b/AUTHORS
@@ -0,0 +1,1 @@
+leon at melding-monads dot com
diff --git a/Control/Monad/Queue/Allison.hs b/Control/Monad/Queue/Allison.hs
new file mode 100644
--- /dev/null
+++ b/Control/Monad/Queue/Allison.hs
@@ -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
+--
+--
+--
+-- 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
diff --git a/Control/Monad/Queue/Class.hs b/Control/Monad/Queue/Class.hs
new file mode 100644
--- /dev/null
+++ b/Control/Monad/Queue/Class.hs
@@ -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))
diff --git a/Control/Monad/Queue/Corec.hs b/Control/Monad/Queue/Corec.hs
new file mode 100644
--- /dev/null
+++ b/Control/Monad/Queue/Corec.hs
@@ -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
diff --git a/Control/Monad/Queue/ST.hs b/Control/Monad/Queue/ST.hs
new file mode 100644
--- /dev/null
+++ b/Control/Monad/Queue/ST.hs
@@ -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
diff --git a/Control/Monad/Queue/Util.hs b/Control/Monad/Queue/Util.hs
new file mode 100644
--- /dev/null
+++ b/Control/Monad/Queue/Util.hs
@@ -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
diff --git a/Data/Queue/Class.hs b/Data/Queue/Class.hs
new file mode 100644
--- /dev/null
+++ b/Data/Queue/Class.hs
@@ -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)
diff --git a/Data/Queue/Okasaki.hs b/Data/Queue/Okasaki.hs
new file mode 100644
--- /dev/null
+++ b/Data/Queue/Okasaki.hs
@@ -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
diff --git a/Data/Queue/TwoStack.hs b/Data/Queue/TwoStack.hs
new file mode 100644
--- /dev/null
+++ b/Data/Queue/TwoStack.hs
@@ -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
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -0,0 +1,3 @@
+To compile the timing program, change to the tests/ directory, and then run
+
+ghc --make -O2 Time.hs -i..
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+import Distribution.Simple
+main = defaultMain
diff --git a/control-monad-queue.cabal b/control-monad-queue.cabal
new file mode 100644
--- /dev/null
+++ b/control-monad-queue.cabal
@@ -0,0 +1,17 @@
+Name: control-monad-queue
+Version: 0.0.9
+Description: Corecursive Queues
+License: BSD3
+License-file: LICENSE
+Author: Leon P Smith
+Maintainer: Leon P Smith
+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
diff --git a/tests/BinaryTree.hs b/tests/BinaryTree.hs
new file mode 100644
--- /dev/null
+++ b/tests/BinaryTree.hs
@@ -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) ++ "}$"
diff --git a/tests/BreadthFirstSearch.hs b/tests/BreadthFirstSearch.hs
new file mode 100644
--- /dev/null
+++ b/tests/BreadthFirstSearch.hs
@@ -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)))
diff --git a/tests/CpSt.hs b/tests/CpSt.hs
new file mode 100644
--- /dev/null
+++ b/tests/CpSt.hs
@@ -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
diff --git a/tests/SideChannelQ.hs b/tests/SideChannelQ.hs
new file mode 100644
--- /dev/null
+++ b/tests/SideChannelQ.hs
@@ -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
diff --git a/tests/Time.hs b/tests/Time.hs
new file mode 100644
--- /dev/null
+++ b/tests/Time.hs
@@ -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 "
+ putStr "\n 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"